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

/-!
# A model of ZFC

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

## The model

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

## Other definitions

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

## Notes

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

## TODO

Prove `Set.map_definable_aux` computably.
-/

universes u v

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

namespace arity

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

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

end arity

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

namespace pSet

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

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

theorem mk_type_func : Π (x : pSet), mk x.type x.func = x
| ⟨α, A⟩ := rfl

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

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

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

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

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

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

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

/-- A pre-set is a subset of another pre-set if every element of the first family is extensionally
equivalent to some element of the second family.-/
protected def subset : pSet → pSet → Prop
| ⟨α, A⟩ ⟨β, B⟩ := ∀ a, ∃ b, equiv (A a) (B b)

instance : has_subset pSet := ⟨pSet.subset⟩

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

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

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

/-- `x ∈ y` as pre-sets if `x` is extensionally equivalent to a member of the family `y`. -/
def mem : pSet → pSet → Prop
| x ⟨β, B⟩ := ∃ b, equiv x (B b)
instance : has_mem pSet.{u} pSet.{u} := ⟨mem⟩

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

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

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

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

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

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

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

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

/-- The empty pre-set -/
protected def empty : pSet := ⟨ulift empty, λ e, match e with end⟩

instance : has_emptyc pSet := ⟨pSet.empty⟩

instance : inhabited pSet := ⟨∅⟩

theorem mem_empty (x : pSet.{u}) : x ∉ (∅ : pSet.{u}) := λ e, match e with end

/-- Insert an element into a pre-set -/
protected def insert : pSet → pSet → pSet
| u ⟨α, A⟩ := ⟨option α, λ o, option.rec u A o⟩

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

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

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

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

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

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

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

/-- The pre-set powerset operator -/
def powerset : pSet → pSet
| ⟨α, A⟩ := ⟨set α, λ p, ⟨{a // p a}, λ x, A x.1⟩⟩

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

/-- The pre-set union operator -/
def Union : pSet → pSet
| ⟨α, A⟩ := ⟨Σx, (A x).type, λ ⟨x, y⟩, (A x).func y⟩

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

/-- The image of a function from pre-sets to pre-sets. -/
def image (f : pSet.{u} → pSet.{u}) : pSet.{u} → pSet
| ⟨α, A⟩ := ⟨α, λ a, f (A a)⟩

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

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

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

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

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

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

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

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

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

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

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

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

instance resp.setoid {n} : setoid (resp n) :=
⟨resp.equiv, resp.refl, λ x y h, resp.euc (resp.refl y) h,
  λ x y z h1 h2, resp.euc h1 $ resp.euc (resp.refl z) h2⟩

end pSet

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

namespace pSet

namespace resp

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

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

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

end resp

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

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

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

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

end pSet

namespace classical
open pSet

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

end classical

namespace Set
open pSet

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

@[simp] theorem mk_eq (x : pSet) : @eq Set ⟦x⟧ (mk x) := rfl

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

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

instance : has_mem Set Set := ⟨mem⟩

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

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

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

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

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

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

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

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

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

theorem eq_empty (x : Set.{u}) : x = ∅ ↔ ∀ y : Set.{u}, y ∉ x :=
⟨λ h y, (h.symm ▸ mem_empty y),
λ h, ext (λ y, ⟨λ yx, absurd yx (h y), λ y0, absurd y0 (mem_empty _)⟩)⟩

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

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

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

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

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

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

@[simp] theorem mem_pair {x y z : Set.{u}} : x ∈ ({y, z} : Set) ↔ 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 omega

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

@[simp] theorem omega_succ {n} : n ∈ omega.{u} → insert n n ∈ omega.{u} :=
quotient.induction_on n (λ x ⟨⟨n⟩, h⟩, ⟨⟨n+1⟩,
  have Set.insert ⟦x⟧ ⟦x⟧ = Set.insert ⟦of_nat n⟧ ⟦of_nat n⟧, by rw (@quotient.sound pSet _ _ _ h),
  quotient.exact this⟩)

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

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

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

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

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

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

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

notation `⋃` := Union

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

@[simp] theorem Union_singleton {x : Set.{u}} : Union {x} = x :=
ext $ λ y, by simp_rw [mem_Union, exists_prop, mem_singleton, exists_eq_left]

theorem singleton_inj {x y : Set.{u}} (H : ({x} : Set) = {y}) : x = y :=
let this := congr_arg Union H in by rwa [Union_singleton, Union_singleton] at this

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

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

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

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

@[simp] theorem mem_union {x y z : Set.{u}} : z ∈ x ∪ y ↔ z ∈ x ∨ z ∈ y :=
iff.trans mem_Union
 ⟨λ ⟨w, wxy, zw⟩, match mem_pair.1 wxy with
  | or.inl wx := or.inl (by rwa ←wx)
  | or.inr wy := or.inr (by rwa ←wy)
  end, λ zxy, match zxy with
  | or.inl zx := ⟨x, mem_pair.2 (or.inl rfl), zx⟩
  | or.inr zy := ⟨y, mem_pair.2 (or.inr rfl), zy⟩
  end⟩

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

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

theorem induction_on {p : Set → Prop} (x) (h : ∀ x, (∀ y ∈ x, p y) → p x) : p x :=
quotient.induction_on x $ λ u, pSet.rec_on u $ λ α A IH, h _ $ λ y,
show @has_mem.mem _ _ Set.has_mem y ⟦⟨α, A⟩⟧ → p y, from
quotient.induction_on y (λ v ⟨a, ha⟩, by { rw (@quotient.sound pSet _ _ _ ha), exact IH a })

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

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

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

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

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

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

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

theorem pair_inj {x y x' y' : Set.{u}} (H : pair x y = pair x' y') : x = x' ∧ y = y' := begin
  have ae := ext_iff.2 H,
  simp [pair] at ae,
  have : x = x',
  { cases (ae {x}).1 (by simp) with h h,
    { exact singleton_inj h },
    { have m : x' ∈ ({x} : Set),
      { rw h, simp },
      simp at m, simp [*] } },
  subst x',
  have he : y = x → y = y',
  { intro yx, subst y,
    cases (ae {x, y'}).2 (by simp only [eq_self_iff_true, or_true]) with xy'x xy'xx,
    { rw [eq_comm, ←mem_singleton, ←xy'x, mem_pair],
      exact or.inr rfl },
    { have yxx := (ext_iff.2 xy'xx y').1 (by simp),
      simp at yxx, subst y' } },
  have xyxy' := (ae {x, y}).1 (by simp),
  cases xyxy' with xyx xyy',
  { have yx := (ext_iff.2 xyx y).1 (by simp),
    simp at yx, simp [he yx] },
  { have yxy' := (ext_iff.2 xyy' y).1 (by simp),
    simp at yxy',
    cases yxy' with yx yy',
    { simp [he yx] },
    { simp [yy'] } }
end

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

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

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

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

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

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

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

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

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

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

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

end Set

/-- The collection of all classes. A class is defined as a `set` of ZFC sets. -/
def Class := set Set

namespace Class

instance : has_subset Class     := ⟨set.subset⟩
instance : has_sep Set Class    := ⟨set.sep⟩
instance : has_emptyc Class     := ⟨λ a, false⟩
instance : inhabited Class      := ⟨∅⟩
instance : has_insert Set Class := ⟨set.insert⟩
instance : has_union Class      := ⟨set.union⟩
instance : has_inter Class      := ⟨set.inter⟩
instance : has_neg Class        := ⟨set.compl⟩
instance : has_sdiff Class      := ⟨set.diff⟩

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@[simp] theorem insert_hom (x y : Set.{u}) : (@insert Set.{u} Class.{u} _ x y) = ↑(insert x y) :=
set.ext $ λ z, iff.symm Set.mem_insert

@[simp] theorem union_hom (x y : Set.{u}) : (x : Class.{u}) ∪ y = (x ∪ y : Set.{u}) :=
set.ext $ λ z, iff.symm Set.mem_union

@[simp] theorem inter_hom (x y : Set.{u}) : (x : Class.{u}) ∩ y = (x ∩ y : Set.{u}) :=
set.ext $ λ z, iff.symm Set.mem_inter

@[simp] theorem diff_hom (x y : Set.{u}) : (x : Class.{u}) \ y = (x \ y : Set.{u}) :=
set.ext $ λ z, iff.symm Set.mem_diff

@[simp] theorem powerset_hom (x : Set.{u}) : powerset.{u} x = Set.powerset x :=
set.ext $ λ z, iff.symm Set.mem_powerset

@[simp] theorem Union_hom (x : Set.{u}) : Union.{u} x = Set.Union x :=
set.ext $ λ z, by { refine iff.trans _ Set.mem_Union.symm, exact
⟨λ ⟨._, ⟨a, rfl, ax⟩, za⟩, ⟨a, ax, za⟩, λ ⟨a, ax, za⟩, ⟨_, ⟨a, rfl, ax⟩, za⟩⟩ }

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

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

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

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

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

end Class

namespace Set

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

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

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

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

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

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

end Set


import topology.local_at_target

variables {α β : Type*} [topological_space α] [topological_space β] (s t : set α)

def is_locally_closed : Prop := is_open ((coe : closure s → α) ⁻¹' s)

variables {s t}

lemma is_locally_closed_iff_exists_inter_closure :
  is_locally_closed s ↔ ∃ {U : set α}, is_open U ∧ s = U ∩ (closure s) :=
by simp_rw [is_locally_closed, embedding_subtype_coe.is_open_iff,
    ← (set.image_injective.mpr subtype.coe_injective).eq_iff, set.image_preimage_eq_inter_range,
    subtype.range_coe, set.inter_eq_left_iff_subset.mpr subset_closure, eq_comm]

lemma is_locally_closed_iff :
  is_locally_closed s ↔ ∃ {U Z : set α}, is_open U ∧ is_closed Z ∧ s = U ∩ Z :=
begin
  rw is_locally_closed_iff_exists_inter_closure,
  split,
  { rintro ⟨U, h₁, h₂⟩, exact ⟨U, _, h₁, is_closed_closure, h₂⟩ },
  { rintro ⟨U, Z, hU, hZ, rfl⟩, refine ⟨U, hU, _⟩,
    apply subset_antisymm,
    { simpa using subset_closure },
    { conv_rhs { rw [← hZ.closure_eq] },
      exact set.inter_subset_inter (refl _) (closure_mono $ set.inter_subset_right _ _) } }
end

lemma is_open.is_locally_closed (hs : is_open s) : is_locally_closed s :=
continuous_subtype_coe.1 _ hs

lemma is_closed.is_locally_closed (hs : is_closed s) : is_locally_closed s :=
begin
  delta is_locally_closed,
  convert is_open_univ,
  rw [hs.closure_eq, set.eq_univ_iff_forall],
  exact λ x, x.2
end

lemma is_locally_closed.inter (hs : is_locally_closed s) (ht : is_locally_closed t) :
  is_locally_closed (s ∩ t) :=
begin
  rw is_locally_closed_iff at hs ht ⊢,
  obtain ⟨U₁, Z₁, hU₁, hZ₁, rfl⟩ := hs,
  obtain ⟨U₂, Z₂, hU₂, hZ₂, rfl⟩ := ht,
  refine ⟨_, _, hU₁.inter hU₂, hZ₁.inter hZ₂, set.inter_inter_inter_comm U₁ Z₁ U₂ Z₂⟩,
end

lemma is_locally_closed.preimage {s : set β} (hs : is_locally_closed s)
  {f : α → β} (hf : continuous f) :
  is_locally_closed (f ⁻¹' s) :=
begin
  rw is_locally_closed_iff at hs ⊢,
  obtain ⟨U, Z, hU, hZ, rfl⟩ := hs,
  exact ⟨_, _, hU.preimage hf, hZ.preimage hf, set.preimage_inter⟩,
end

lemma inducing.is_locally_closed_iff {s : set α}
  {f : α → β} (hf : inducing f) :
  is_locally_closed s ↔ ∃ s' : set β, is_locally_closed s' ∧ f ⁻¹' s' = s :=
begin
  simp_rw [is_locally_closed_iff, hf.is_open_iff, hf.is_closed_iff],
  split,
  { rintros ⟨_, _, ⟨U, hU, rfl⟩, ⟨Z, hZ, rfl⟩, rfl⟩,
    exact ⟨_, ⟨U, Z, hU, hZ, rfl⟩, rfl⟩ },
  { rintros ⟨_, ⟨U, Z, hU, hZ, rfl⟩, rfl⟩,
    exact ⟨_, _, ⟨U, hU, rfl⟩, ⟨Z, hZ, rfl⟩, rfl⟩ },
end

lemma embedding.is_locally_closed_iff {s : set α}
  {f : α → β} (hf : embedding f) :
  is_locally_closed s ↔ ∃ s' : set β, is_locally_closed s' ∧ s' ∩ set.range f = f '' s :=
begin
  simp_rw [hf.to_inducing.is_locally_closed_iff,
    ← (set.image_injective.mpr hf.inj).eq_iff, set.image_preimage_eq_inter_range],
end

lemma is_locally_closed.image {s : set α} (hs : is_locally_closed s)
  {f : α → β} (hf : inducing f) (hf' : is_locally_closed (set.range f)) :
  is_locally_closed (f '' s) :=
begin
  obtain ⟨t, ht, rfl⟩ := hf.is_locally_closed_iff.mp hs,
  rw set.image_preimage_eq_inter_range,
  exact ht.inter hf'
end

lemma is_locally_closed.is_closed_closure_diff (hs : is_locally_closed s) :
  is_closed (closure s \ s) :=
begin
  convert (closed_embedding_subtype_coe is_closed_closure).is_closed_map _ hs.is_closed_compl,
  rw [← set.preimage_compl, set.image_preimage_eq_inter_range, @subtype.range_coe _ (closure s),
    set.diff_eq_compl_inter],
end

def coboundary (s : set α) : set α :=
(closure s \ s)ᶜ

lemma subset_coboundary :
  s ⊆ coboundary s :=
by { rw [coboundary, set.subset_compl_iff_disjoint_right], exact set.disjoint_diff }

lemma coboundary_inter_closure :
  coboundary s ∩ closure s = s :=
begin
  rw [coboundary, ← set.diff_eq_compl_inter, set.diff_diff_right_self,
    set.inter_eq_right_iff_subset],
  exact subset_closure
end

lemma closure_inter_coboundary :
  closure s ∩ coboundary s = s :=
by rw [set.inter_comm, coboundary_inter_closure]

lemma is_open_map.coboundary_preimage_subset {f : α → β} (hf : is_open_map f) (s : set β) :
  coboundary (f ⁻¹' s) ⊆ f ⁻¹' (coboundary s) :=
begin
  rw [coboundary, coboundary, set.preimage_compl, set.preimage_diff, set.compl_subset_compl],
  apply set.diff_subset_diff_left,
  exact hf.preimage_closure_subset_closure_preimage
end

lemma continuous.preimage_coboundary_subset {f : α → β} (hf : continuous f) (s : set β) :
  f ⁻¹' (coboundary s) ⊆ coboundary (f ⁻¹' s) :=
begin
  rw [coboundary, coboundary, set.preimage_compl, set.preimage_diff, set.compl_subset_compl],
  apply set.diff_subset_diff_left,
  exact hf.closure_preimage_subset s
end

lemma coboundary_preimage {f : α → β} (hf : is_open_map f) (hf' : continuous f) (s : set β) :
  coboundary (f ⁻¹' s) = f ⁻¹' (coboundary s) :=
(hf.coboundary_preimage_subset s).antisymm (hf'.preimage_coboundary_subset s)

lemma is_locally_closed.is_open_coboundary (hs : is_locally_closed s) :
  is_open (coboundary s) :=
hs.is_closed_closure_diff.is_open_compl

lemma is_locally_closed_iff_is_open_coboundary :
  is_locally_closed s ↔ is_open (coboundary s) :=
⟨is_locally_closed.is_open_coboundary, λ h, by { rw ← @coboundary_inter_closure _ _ s,
  exact h.is_locally_closed.inter is_closed_closure.is_locally_closed }⟩

lemma is_closed_preimage_coe_coboundary :
  is_closed ((coe : coboundary s → α) ⁻¹' s) :=
begin
  rw embedding_subtype_coe.to_inducing.is_closed_iff,
  refine ⟨closure s, is_closed_closure, _⟩,
  rw [← (set.image_injective.mpr subtype.coe_injective).eq_iff, set.image_preimage_eq_inter_range,
    set.image_preimage_eq_inter_range, subtype.range_coe, closure_inter_coboundary,
    set.inter_eq_left_iff_subset.mpr subset_coboundary],
end

open topological_space

variables {ι : Type*} {U : ι → opens β} (hU : supr U = ⊤)

include hU

lemma is_locally_closed_iff_coe_preimage_of_supr_eq_top (s : set β) :
  is_locally_closed s ↔ ∀ i, is_locally_closed (coe ⁻¹' s : set (U i)) :=
begin
  simp_rw [is_locally_closed_iff_is_open_coboundary],
  rw is_open_iff_coe_preimage_of_supr_eq_top hU,
  refine forall_congr (λ i, _),
  rw coboundary_preimage (U i).2.open_embedding_subtype_coe.is_open_map
    (U i).2.open_embedding_subtype_coe.continuous,
end


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Jens Wagemaker, Aaron Anderson
-/

import algebra.big_operators.associated
import algebra.gcd_monoid.basic
import data.finsupp.multiset
import ring_theory.noetherian
import ring_theory.multiplicity

/-!

# Unique factorization

## Main Definitions
* `wf_dvd_monoid` holds for `monoid`s for which a strict divisibility relation is
  well-founded.
* `unique_factorization_monoid` holds for `wf_dvd_monoid`s where
  `irreducible` is equivalent to `prime`

## To do
* set up the complete lattice structure on `factor_set`.

-/

variables {α : Type*}
local infix ` ~ᵤ ` : 50 := associated

/-- Well-foundedness of the strict version of |, which is equivalent to the descending chain
condition on divisibility and to the ascending chain condition on
principal ideals in an integral domain.
  -/
class wf_dvd_monoid (α : Type*) [comm_monoid_with_zero α] : Prop :=
(well_founded_dvd_not_unit : well_founded (@dvd_not_unit α _))

export wf_dvd_monoid (well_founded_dvd_not_unit)

@[priority 100]  -- see Note [lower instance priority]
instance is_noetherian_ring.wf_dvd_monoid [comm_ring α] [is_domain α] [is_noetherian_ring α] :
  wf_dvd_monoid α :=
⟨by { convert inv_image.wf (λ a, ideal.span ({a} : set α)) (well_founded_submodule_gt _ _),
      ext,
      exact ideal.span_singleton_lt_span_singleton.symm }⟩

namespace wf_dvd_monoid

variables [comm_monoid_with_zero α]
open associates nat

theorem of_wf_dvd_monoid_associates (h : wf_dvd_monoid (associates α)): wf_dvd_monoid α :=
⟨begin
  haveI := h,
  refine (surjective.well_founded_iff mk_surjective _).2 wf_dvd_monoid.well_founded_dvd_not_unit,
  intros, rw mk_dvd_not_unit_mk_iff
end⟩

variables [wf_dvd_monoid α]

instance wf_dvd_monoid_associates : wf_dvd_monoid (associates α) :=
⟨begin
  refine (surjective.well_founded_iff mk_surjective _).1 wf_dvd_monoid.well_founded_dvd_not_unit,
  intros, rw mk_dvd_not_unit_mk_iff
end⟩

theorem well_founded_associates : well_founded ((<) : associates α → associates α → Prop) :=
subrelation.wf (λ x y, dvd_not_unit_of_lt) wf_dvd_monoid.well_founded_dvd_not_unit

local attribute [elab_as_eliminator] well_founded.fix

lemma exists_irreducible_factor {a : α} (ha : ¬ is_unit a) (ha0 : a ≠ 0) :
  ∃ i, irreducible i ∧ i ∣ a :=
(irreducible_or_factor a ha).elim (λ hai, ⟨a, hai, dvd_rfl⟩)
  (well_founded.fix
    wf_dvd_monoid.well_founded_dvd_not_unit
    (λ a ih ha ha0 ⟨x, y, hx, hy, hxy⟩,
      have hx0 : x ≠ 0, from λ hx0, ha0 (by rw [← hxy, hx0, zero_mul]),
      (irreducible_or_factor x hx).elim
        (λ hxi, ⟨x, hxi, hxy ▸ by simp⟩)
        (λ hxf, let ⟨i, hi⟩ := ih x ⟨hx0, y, hy, hxy.symm⟩ hx hx0 hxf in
          ⟨i, hi.1, hi.2.trans (hxy ▸ by simp)⟩)) a ha ha0)

@[elab_as_eliminator] lemma induction_on_irreducible {P : α → Prop} (a : α)
  (h0 : P 0) (hu : ∀ u : α, is_unit u → P u)
  (hi : ∀ a i : α, a ≠ 0 → irreducible i → P a → P (i * a)) :
  P a :=
by haveI := classical.dec; exact
well_founded.fix wf_dvd_monoid.well_founded_dvd_not_unit
  (λ a ih, if ha0 : a = 0 then ha0.symm ▸ h0
    else if hau : is_unit a then hu a hau
    else let ⟨i, hii, ⟨b, hb⟩⟩ := exists_irreducible_factor hau ha0 in
      have hb0 : b ≠ 0, from λ hb0, by simp * at *,
      hb.symm ▸ hi _ _ hb0 hii (ih _ ⟨hb0, i,
        hii.1, by rw [hb, mul_comm]⟩))
  a

lemma exists_factors (a : α) : a ≠ 0 →
  ∃f : multiset α, (∀b ∈ f, irreducible b) ∧ associated f.prod a :=
wf_dvd_monoid.induction_on_irreducible a
  (λ h, (h rfl).elim)
  (λ u hu _, ⟨0, ⟨by simp [hu], associated.symm (by simp [hu, associated_one_iff_is_unit])⟩⟩)
  (λ a i ha0 hii ih hia0,
    let ⟨s, hs⟩ := ih ha0 in
    ⟨i ::ₘ s, ⟨by clear _let_match;
    { intros b H, cases (multiset.mem_cons.mp H), { convert hii }, { exact hs.1 b h } },
      by { rw multiset.prod_cons,
           exact hs.2.mul_left _ }⟩⟩)

end wf_dvd_monoid

theorem wf_dvd_monoid.of_well_founded_associates [cancel_comm_monoid_with_zero α]
  (h : well_founded ((<) : associates α → associates α → Prop)) : wf_dvd_monoid α :=
wf_dvd_monoid.of_wf_dvd_monoid_associates
  ⟨by { convert h, ext, exact associates.dvd_not_unit_iff_lt }⟩

theorem wf_dvd_monoid.iff_well_founded_associates [cancel_comm_monoid_with_zero α] :
  wf_dvd_monoid α ↔ well_founded ((<) : associates α → associates α → Prop) :=
⟨by apply wf_dvd_monoid.well_founded_associates, wf_dvd_monoid.of_well_founded_associates⟩
section prio
set_option default_priority 100 -- see Note [default priority]
/-- unique factorization monoids.

These are defined as `cancel_comm_monoid_with_zero`s with well-founded strict divisibility
relations, but this is equivalent to more familiar definitions:

Each element (except zero) is uniquely represented as a multiset of irreducible factors.
Uniqueness is only up to associated elements.

Each element (except zero) is non-uniquely represented as a multiset
of prime factors.

To define a UFD using the definition in terms of multisets
of irreducible factors, use the definition `of_exists_unique_irreducible_factors`

To define a UFD using the definition in terms of multisets
of prime factors, use the definition `of_exists_prime_factors`

-/
class unique_factorization_monoid (α : Type*) [cancel_comm_monoid_with_zero α]
  extends wf_dvd_monoid α : Prop :=
(irreducible_iff_prime : ∀ {a : α}, irreducible a ↔ prime a)

/-- Can't be an instance because it would cause a loop `ufm → wf_dvd_monoid → ufm → ...`. -/
@[reducible] lemma ufm_of_gcd_of_wf_dvd_monoid [cancel_comm_monoid_with_zero α]
  [wf_dvd_monoid α] [gcd_monoid α] : unique_factorization_monoid α :=
{ irreducible_iff_prime := λ _, gcd_monoid.irreducible_iff_prime
  .. ‹wf_dvd_monoid α› }

instance associates.ufm [cancel_comm_monoid_with_zero α]
  [unique_factorization_monoid α] : unique_factorization_monoid (associates α) :=
{ irreducible_iff_prime := by { rw ← associates.irreducible_iff_prime_iff,
    apply unique_factorization_monoid.irreducible_iff_prime, }
  .. (wf_dvd_monoid.wf_dvd_monoid_associates : wf_dvd_monoid (associates α)) }

end prio

namespace unique_factorization_monoid
variables [cancel_comm_monoid_with_zero α] [unique_factorization_monoid α]

theorem exists_prime_factors (a : α) : a ≠ 0 →
  ∃ f : multiset α, (∀b ∈ f, prime b) ∧ f.prod ~ᵤ a :=
by { simp_rw ← unique_factorization_monoid.irreducible_iff_prime,
     apply wf_dvd_monoid.exists_factors a }

@[elab_as_eliminator] lemma induction_on_prime {P : α → Prop}
  (a : α) (h₁ : P 0) (h₂ : ∀ x : α, is_unit x → P x)
  (h₃ : ∀ a p : α, a ≠ 0 → prime p → P a → P (p * a)) : P a :=
begin
  simp_rw ← unique_factorization_monoid.irreducible_iff_prime at h₃,
  exact wf_dvd_monoid.induction_on_irreducible a h₁ h₂ h₃,
end

lemma factors_unique : ∀{f g : multiset α},
  (∀x∈f, irreducible x) → (∀x∈g, irreducible x) → f.prod ~ᵤ g.prod →
  multiset.rel associated f g :=
by haveI := classical.dec_eq α; exact
λ f, multiset.induction_on f
  (λ g _ hg h,
    multiset.rel_zero_left.2 $
      multiset.eq_zero_of_forall_not_mem (λ x hx,
        have is_unit g.prod, by simpa [associated_one_iff_is_unit] using h.symm,
        (hg x hx).not_unit (is_unit_iff_dvd_one.2 ((multiset.dvd_prod hx).trans
          (is_unit_iff_dvd_one.1 this)))))
  (λ p f ih g hf hg hfg,
    let ⟨b, hbg, hb⟩ := exists_associated_mem_of_dvd_prod
      (irreducible_iff_prime.1 (hf p (by simp)))
      (λ q hq, irreducible_iff_prime.1 (hg _ hq)) $
        hfg.dvd_iff_dvd_right.1
          (show p ∣ (p ::ₘ f).prod, by simp) in
    begin
      rw ← multiset.cons_erase hbg,
      exact multiset.rel.cons hb (ih (λ q hq, hf _ (by simp [hq]))
        (λ q (hq : q ∈ g.erase b), hg q (multiset.mem_of_mem_erase hq))
        (associated.of_mul_left
          (by rwa [← multiset.prod_cons, ← multiset.prod_cons, multiset.cons_erase hbg]) hb
        (hf p (by simp)).ne_zero))
    end)

end unique_factorization_monoid

lemma prime_factors_unique [cancel_comm_monoid_with_zero α] : ∀ {f g : multiset α},
  (∀ x ∈ f, prime x) → (∀ x ∈ g, prime x) → f.prod ~ᵤ g.prod →
  multiset.rel associated f g :=
by haveI := classical.dec_eq α; exact
λ f, multiset.induction_on f
  (λ g _ hg h,
    multiset.rel_zero_left.2 $
    multiset.eq_zero_of_forall_not_mem $ λ x hx,
    have is_unit g.prod, by simpa [associated_one_iff_is_unit] using h.symm,
    (hg x hx).not_unit $ is_unit_iff_dvd_one.2 $
    (multiset.dvd_prod hx).trans (is_unit_iff_dvd_one.1 this))
  (λ p f ih g hf hg hfg,
    let ⟨b, hbg, hb⟩ := exists_associated_mem_of_dvd_prod
      (hf p (by simp)) (λ q hq, hg _ hq) $
        hfg.dvd_iff_dvd_right.1
          (show p ∣ (p ::ₘ f).prod, by simp) in
    begin
      rw ← multiset.cons_erase hbg,
      exact multiset.rel.cons hb (ih (λ q hq, hf _ (by simp [hq]))
        (λ q (hq : q ∈ g.erase b), hg q (multiset.mem_of_mem_erase hq))
        (associated.of_mul_left
          (by rwa [← multiset.prod_cons, ← multiset.prod_cons, multiset.cons_erase hbg]) hb
        (hf p (by simp)).ne_zero)),
    end)

/-- If an irreducible has a prime factorization,
  then it is an associate of one of its prime factors. -/
lemma prime_factors_irreducible [cancel_comm_monoid_with_zero α] {a : α} {f : multiset α}
  (ha : irreducible a) (pfa : (∀b ∈ f, prime b) ∧ f.prod ~ᵤ a) :
  ∃ p, a ~ᵤ p ∧ f = {p} :=
begin
  haveI := classical.dec_eq α,
  refine multiset.induction_on f (λ h, (ha.not_unit
    (associated_one_iff_is_unit.1 (associated.symm h))).elim) _ pfa.2 pfa.1,
  rintros p s _ ⟨u, hu⟩ hs,
  use p,
  have hs0 : s = 0,
  { by_contra hs0,
    obtain ⟨q, hq⟩ := multiset.exists_mem_of_ne_zero hs0,
    apply (hs q (by simp [hq])).2.1,
    refine (ha.is_unit_or_is_unit (_ : _ = ((p * ↑u) * (s.erase q).prod) * _)).resolve_left _,
    { rw [mul_right_comm _ _ q, mul_assoc, ← multiset.prod_cons, multiset.cons_erase hq, ← hu,
        mul_comm, mul_comm p _, mul_assoc],
      simp, },
    apply mt is_unit_of_mul_is_unit_left (mt is_unit_of_mul_is_unit_left _),
    apply (hs p (multiset.mem_cons_self _ _)).2.1 },
  simp only [mul_one, multiset.prod_cons, multiset.prod_zero, hs0] at *,
  exact ⟨associated.symm ⟨u, hu⟩, rfl⟩,
end

section exists_prime_factors

variables [cancel_comm_monoid_with_zero α]
variables (pf : ∀ (a : α), a ≠ 0 → ∃ f : multiset α, (∀b ∈ f, prime b) ∧ f.prod ~ᵤ a)

include pf

lemma wf_dvd_monoid.of_exists_prime_factors : wf_dvd_monoid α :=
⟨begin
  classical,
  refine rel_hom_class.well_founded
    (rel_hom.mk _ _ : (dvd_not_unit : α → α → Prop) →r ((<) : with_top ℕ → with_top ℕ → Prop))
    (with_top.well_founded_lt nat.lt_wf),
  { intro a,
    by_cases h : a = 0, { exact ⊤ },
    exact (classical.some (pf a h)).card },

  rintros a b ⟨ane0, ⟨c, hc, b_eq⟩⟩,
  rw dif_neg ane0,
  by_cases h : b = 0, { simp [h, lt_top_iff_ne_top] },
  rw [dif_neg h, with_top.coe_lt_coe],
  have cne0 : c ≠ 0, { refine mt (λ con, _) h, rw [b_eq, con, mul_zero] },
  calc multiset.card (classical.some (pf a ane0))
      < _ + multiset.card (classical.some (pf c cne0)) :
    lt_add_of_pos_right _ (multiset.card_pos.mpr (λ con, hc (associated_one_iff_is_unit.mp _)))
  ... = multiset.card (classical.some (pf a ane0) + classical.some (pf c cne0)) :
    (multiset.card_add _ _).symm
  ... = multiset.card (classical.some (pf b h)) :
    multiset.card_eq_card_of_rel (prime_factors_unique _ (classical.some_spec (pf _ h)).1 _),
  { convert (classical.some_spec (pf c cne0)).2.symm,
    rw [con, multiset.prod_zero] },
  { intros x hadd,
    rw multiset.mem_add at hadd,
    cases hadd; apply (classical.some_spec (pf _ _)).1 _ hadd },
  { rw multiset.prod_add,
    transitivity a * c,
    { apply associated.mul_mul; apply (classical.some_spec (pf _ _)).2 },
    { rw ← b_eq,
      apply (classical.some_spec (pf _ _)).2.symm, } }
end⟩

lemma irreducible_iff_prime_of_exists_prime_factors {p : α} : irreducible p ↔ prime p :=
begin
  by_cases hp0 : p = 0,
  { simp [hp0] },
  refine ⟨λ h, _, prime.irreducible⟩,
  obtain ⟨f, hf⟩ := pf p hp0,
  obtain ⟨q, hq, rfl⟩ := prime_factors_irreducible h hf,
  rw hq.prime_iff,
  exact hf.1 q (multiset.mem_singleton_self _)
end

theorem unique_factorization_monoid.of_exists_prime_factors :
  unique_factorization_monoid α :=
{ irreducible_iff_prime := λ _, irreducible_iff_prime_of_exists_prime_factors pf,
  .. wf_dvd_monoid.of_exists_prime_factors pf }

end exists_prime_factors

theorem unique_factorization_monoid.iff_exists_prime_factors [cancel_comm_monoid_with_zero α] :
  unique_factorization_monoid α ↔
    (∀ (a : α), a ≠ 0 → ∃ f : multiset α, (∀b ∈ f, prime b) ∧ f.prod ~ᵤ a) :=
⟨λ h, @unique_factorization_monoid.exists_prime_factors _ _ h,
  unique_factorization_monoid.of_exists_prime_factors⟩

theorem irreducible_iff_prime_of_exists_unique_irreducible_factors [cancel_comm_monoid_with_zero α]
  (eif : ∀ (a : α), a ≠ 0 → ∃ f : multiset α, (∀b ∈ f, irreducible b) ∧ f.prod ~ᵤ a)
  (uif : ∀ (f g : multiset α),
  (∀ x ∈ f, irreducible x) → (∀ x ∈ g, irreducible x) → f.prod ~ᵤ g.prod →
    multiset.rel associated f g)
  (p : α) : irreducible p ↔ prime p :=
⟨by letI := classical.dec_eq α; exact λ hpi,
    ⟨hpi.ne_zero, hpi.1,
      λ a b ⟨x, hx⟩,
      if hab0 : a * b = 0
      then (eq_zero_or_eq_zero_of_mul_eq_zero hab0).elim
        (λ ha0, by simp [ha0])
        (λ hb0, by simp [hb0])
      else
        have hx0 : x ≠ 0, from λ hx0, by simp * at *,
        have ha0 : a ≠ 0, from left_ne_zero_of_mul hab0,
        have hb0 : b ≠ 0, from right_ne_zero_of_mul hab0,
        begin
          cases eif x hx0 with fx hfx,
          cases eif a ha0 with fa hfa,
          cases eif b hb0 with fb hfb,
          have h : multiset.rel associated (p ::ₘ fx) (fa + fb),
          { apply uif,
            { exact λ i hi, (multiset.mem_cons.1 hi).elim (λ hip, hip.symm ▸ hpi) (hfx.1 _), },
            { exact λ i hi, (multiset.mem_add.1 hi).elim (hfa.1 _) (hfb.1 _), },
            calc multiset.prod (p ::ₘ fx)
                  ~ᵤ a * b : by rw [hx, multiset.prod_cons];
                    exact hfx.2.mul_left _
              ... ~ᵤ (fa).prod * (fb).prod :
                hfa.2.symm.mul_mul hfb.2.symm
              ... = _ : by rw multiset.prod_add, },
          exact let ⟨q, hqf, hq⟩ := multiset.exists_mem_of_rel_of_mem h
          (multiset.mem_cons_self p _) in
        (multiset.mem_add.1 hqf).elim
          (λ hqa, or.inl $ hq.dvd_iff_dvd_left.2 $
            hfa.2.dvd_iff_dvd_right.1
              (multiset.dvd_prod hqa))
          (λ hqb, or.inr $ hq.dvd_iff_dvd_left.2 $
            hfb.2.dvd_iff_dvd_right.1
              (multiset.dvd_prod hqb))
        end⟩, prime.irreducible⟩

theorem unique_factorization_monoid.of_exists_unique_irreducible_factors
  [cancel_comm_monoid_with_zero α]
  (eif : ∀ (a : α), a ≠ 0 → ∃ f : multiset α, (∀b ∈ f, irreducible b) ∧ f.prod ~ᵤ a)
  (uif : ∀ (f g : multiset α),
  (∀ x ∈ f, irreducible x) → (∀ x ∈ g, irreducible x) → f.prod ~ᵤ g.prod →
    multiset.rel associated f g) :
  unique_factorization_monoid α :=
unique_factorization_monoid.of_exists_prime_factors (by
  { convert eif,
    simp_rw irreducible_iff_prime_of_exists_unique_irreducible_factors eif uif })

namespace unique_factorization_monoid
variables [cancel_comm_monoid_with_zero α] [decidable_eq α]
variables [unique_factorization_monoid α]
/-- Noncomputably determines the multiset of prime factors. -/
noncomputable def factors (a : α) : multiset α := if h : a = 0 then 0 else
classical.some (unique_factorization_monoid.exists_prime_factors a h)

theorem factors_prod {a : α} (ane0 : a ≠ 0) : associated (factors a).prod a :=
begin
  rw [factors, dif_neg ane0],
  exact (classical.some_spec (exists_prime_factors a ane0)).2
end

theorem prime_of_factor {a : α} : ∀ (x : α), x ∈ factors a → prime x :=
begin
  rw [factors],
  split_ifs with ane0, { simp only [multiset.not_mem_zero, forall_false_left, forall_const] },
  intros x hx,
  exact (classical.some_spec (unique_factorization_monoid.exists_prime_factors a ane0)).1 x hx,
end

theorem irreducible_of_factor {a : α} : ∀ (x : α), x ∈ factors a → irreducible x :=
λ x h, (prime_of_factor x h).irreducible

lemma exists_mem_factors_of_dvd {a p : α} (ha0 : a ≠ 0) (hp : irreducible p) : p ∣ a →
  ∃ q ∈ factors a, p ~ᵤ q :=
λ ⟨b, hb⟩,
have hb0 : b ≠ 0, from λ hb0, by simp * at *,
have multiset.rel associated (p ::ₘ factors b) (factors a),
  from factors_unique
    (λ x hx, (multiset.mem_cons.1 hx).elim (λ h, h.symm ▸ hp) (irreducible_of_factor _))
    irreducible_of_factor
    (associated.symm $ calc multiset.prod (factors a) ~ᵤ a : factors_prod ha0
      ... = p * b : hb
      ... ~ᵤ multiset.prod (p ::ₘ factors b) :
        by rw multiset.prod_cons; exact (factors_prod hb0).symm.mul_left _),
multiset.exists_mem_of_rel_of_mem this (by simp)

end unique_factorization_monoid

namespace unique_factorization_monoid
variables [cancel_comm_monoid_with_zero α] [decidable_eq α] [normalization_monoid α]
variables [unique_factorization_monoid α]

/-- Noncomputably determines the multiset of prime factors. -/
noncomputable def normalized_factors (a : α) : multiset α :=
multiset.map normalize $ factors a

theorem normalized_factors_prod {a : α} (ane0 : a ≠ 0) : associated (normalized_factors a).prod a :=
begin
  rw [normalized_factors, factors, dif_neg ane0],
  refine associated.trans _ (classical.some_spec (exists_prime_factors a ane0)).2,
  rw [← associates.mk_eq_mk_iff_associated, ← associates.prod_mk, ← associates.prod_mk,
      multiset.map_map],
  congr' 2,
  ext,
  rw [function.comp_apply, associates.mk_normalize],
end

theorem prime_of_normalized_factor {a : α} : ∀ (x : α), x ∈ normalized_factors a → prime x :=
begin
  rw [normalized_factors, factors],
  split_ifs with ane0, { simp },
  intros x hx, rcases multiset.mem_map.1 hx with ⟨y, ⟨hy, rfl⟩⟩,
  rw (normalize_associated _).prime_iff,
  exact (classical.some_spec (unique_factorization_monoid.exists_prime_factors a ane0)).1 y hy,
end

theorem irreducible_of_normalized_factor {a : α} :
  ∀ (x : α), x ∈ normalized_factors a → irreducible x :=
λ x h, (prime_of_normalized_factor x h).irreducible

theorem normalize_normalized_factor {a : α} :
  ∀ (x : α), x ∈ normalized_factors a → normalize x = x :=
begin
  rw [normalized_factors, factors],
  split_ifs with h, { simp },
  intros x hx,
  obtain ⟨y, hy, rfl⟩ := multiset.mem_map.1 hx,
  apply normalize_idem
end

lemma normalized_factors_irreducible {a : α} (ha : irreducible a) :
  normalized_factors a = {normalize a} :=
begin
  obtain ⟨p, a_assoc, hp⟩ := prime_factors_irreducible ha
    ⟨prime_of_normalized_factor, normalized_factors_prod ha.ne_zero⟩,
  have p_mem : p ∈ normalized_factors a,
  { rw hp, exact multiset.mem_singleton_self _ },
  convert hp,
  rwa [← normalize_normalized_factor p p_mem, normalize_eq_normalize_iff, dvd_dvd_iff_associated]
end

lemma exists_mem_normalized_factors_of_dvd {a p : α} (ha0 : a ≠ 0) (hp : irreducible p) : p ∣ a →
  ∃ q ∈ normalized_factors a, p ~ᵤ q :=
λ ⟨b, hb⟩,
have hb0 : b ≠ 0, from λ hb0, by simp * at *,
have multiset.rel associated (p ::ₘ normalized_factors b) (normalized_factors a),
  from factors_unique
    (λ x hx, (multiset.mem_cons.1 hx).elim (λ h, h.symm ▸ hp)
      (irreducible_of_normalized_factor _))
    irreducible_of_normalized_factor
    (associated.symm $ calc multiset.prod (normalized_factors a) ~ᵤ a : normalized_factors_prod ha0
      ... = p * b : hb
      ... ~ᵤ multiset.prod (p ::ₘ normalized_factors b) :
        by rw multiset.prod_cons; exact (normalized_factors_prod hb0).symm.mul_left _),
multiset.exists_mem_of_rel_of_mem this (by simp)

@[simp] lemma normalized_factors_zero : normalized_factors (0 : α) = 0 :=
by simp [normalized_factors, factors]

@[simp] lemma normalized_factors_one : normalized_factors (1 : α) = 0 :=
begin
  nontriviality α using [normalized_factors, factors],
  rw ← multiset.rel_zero_right,
  apply factors_unique irreducible_of_normalized_factor,
  { intros x hx,
    exfalso,
    apply multiset.not_mem_zero x hx },
  { simp [normalized_factors_prod (@one_ne_zero α _ _)] },
  apply_instance
end

@[simp] lemma normalized_factors_mul {x y : α} (hx : x ≠ 0) (hy : y ≠ 0) :
  normalized_factors (x * y) = normalized_factors x + normalized_factors y :=
begin
  have h : (normalize : α → α) = associates.out ∘ associates.mk,
  { ext, rw [function.comp_apply, associates.out_mk], },
  rw [← multiset.map_id' (normalized_factors (x * y)), ← multiset.map_id' (normalized_factors x),
    ← multiset.map_id' (normalized_factors y), ← multiset.map_congr rfl normalize_normalized_factor,
    ← multiset.map_congr rfl normalize_normalized_factor,
    ← multiset.map_congr rfl normalize_normalized_factor,
    ← multiset.map_add, h, ← multiset.map_map associates.out, eq_comm,
    ← multiset.map_map associates.out],
  refine congr rfl _,
  apply multiset.map_mk_eq_map_mk_of_rel,
  apply factors_unique,
  { intros x hx,
    rcases multiset.mem_add.1 hx with hx | hx;
    exact irreducible_of_normalized_factor x hx },
  { exact irreducible_of_normalized_factor },
  { rw multiset.prod_add,
    exact ((normalized_factors_prod hx).mul_mul (normalized_factors_prod hy)).trans
      (normalized_factors_prod (mul_ne_zero hx hy)).symm }
end

@[simp] lemma normalized_factors_pow {x : α} (n : ℕ) :
  normalized_factors (x ^ n) = n • normalized_factors x :=
begin
  induction n with n ih,
  { simp },
  by_cases h0 : x = 0,
  { simp [h0, zero_pow n.succ_pos, smul_zero] },
  rw [pow_succ, succ_nsmul, normalized_factors_mul h0 (pow_ne_zero _ h0), ih],
end

lemma dvd_iff_normalized_factors_le_normalized_factors {x y : α} (hx : x ≠ 0) (hy : y ≠ 0) :
  x ∣ y ↔ normalized_factors x ≤ normalized_factors y :=
begin
  split,
  { rintro ⟨c, rfl⟩,
    simp [hx, right_ne_zero_of_mul hy] },
  { rw [← (normalized_factors_prod hx).dvd_iff_dvd_left,
      ← (normalized_factors_prod hy).dvd_iff_dvd_right],
    apply multiset.prod_dvd_prod_of_le }
end

lemma zero_not_mem_normalized_factors (x : α) : (0 : α) ∉ normalized_factors x :=
λ h, prime.ne_zero (prime_of_normalized_factor _ h) rfl

lemma dvd_of_mem_normalized_factors {a p : α} (H : p ∈ normalized_factors a) : p ∣ a :=
begin
  by_cases hcases : a = 0,
  { rw hcases,
    exact dvd_zero p },
  { exact dvd_trans (multiset.dvd_prod H) (associated.dvd (normalized_factors_prod hcases)) },
end

end unique_factorization_monoid

namespace unique_factorization_monoid

open_locale classical
open multiset associates
noncomputable theory

variables [cancel_comm_monoid_with_zero α] [nontrivial α] [unique_factorization_monoid α]

/-- Noncomputably defines a `normalization_monoid` structure on a `unique_factorization_monoid`. -/
protected def normalization_monoid : normalization_monoid α :=
normalization_monoid_of_monoid_hom_right_inverse
{ to_fun := λ a : associates α, if a = 0 then 0 else ((normalized_factors a).map
    (classical.some mk_surjective.has_right_inverse : associates α → α)).prod,
  map_one' := by simp,
  map_mul' := λ x y, by
  { by_cases hx : x = 0, { simp [hx] },
    by_cases hy : y = 0, { simp [hy] },
    simp [hx, hy] } } begin
  intro x,
  dsimp,
  by_cases hx : x = 0, { simp [hx] },
  have h : associates.mk_monoid_hom ∘ (classical.some mk_surjective.has_right_inverse) =
           (id : associates α → associates α),
  { ext x,
    rw [function.comp_apply, mk_monoid_hom_apply,
      classical.some_spec mk_surjective.has_right_inverse x],
    refl },
  rw [if_neg hx, ← mk_monoid_hom_apply, monoid_hom.map_multiset_prod, map_map, h, map_id,
      ← associated_iff_eq],
  apply normalized_factors_prod hx
end

instance : inhabited (normalization_monoid α) := ⟨unique_factorization_monoid.normalization_monoid⟩

end unique_factorization_monoid

namespace unique_factorization_monoid

variables {R : Type*} [cancel_comm_monoid_with_zero R] [unique_factorization_monoid R]

lemma no_factors_of_no_prime_factors {a b : R} (ha : a ≠ 0)
  (h : (∀ {d}, d ∣ a → d ∣ b → ¬ prime d)) : ∀ {d}, d ∣ a → d ∣ b → is_unit d :=
λ d, induction_on_prime d
  (by { simp only [zero_dvd_iff], intros, contradiction })
  (λ x hx _ _, hx)
  (λ d q hp hq ih dvd_a dvd_b,
    absurd hq (h (dvd_of_mul_right_dvd dvd_a) (dvd_of_mul_right_dvd dvd_b)))

/-- Euclid's lemma: if `a ∣ b * c` and `a` and `c` have no common prime factors, `a ∣ b`.
Compare `is_coprime.dvd_of_dvd_mul_left`. -/
lemma dvd_of_dvd_mul_left_of_no_prime_factors {a b c : R} (ha : a ≠ 0) :
  (∀ {d}, d ∣ a → d ∣ c → ¬ prime d) → a ∣ b * c → a ∣ b :=
begin
  refine induction_on_prime c _ _ _,
  { intro no_factors,
    simp only [dvd_zero, mul_zero, forall_prop_of_true],
    haveI := classical.prop_decidable,
    exact is_unit_iff_forall_dvd.mp
      (no_factors_of_no_prime_factors ha @no_factors (dvd_refl a) (dvd_zero a)) _ },
  { rintros _ ⟨x, rfl⟩ _ a_dvd_bx,
    apply units.dvd_mul_right.mp a_dvd_bx },
  { intros c p hc hp ih no_factors a_dvd_bpc,
    apply ih (λ q dvd_a dvd_c hq, no_factors dvd_a (dvd_c.mul_left _) hq),
    rw mul_left_comm at a_dvd_bpc,
    refine or.resolve_left (hp.left_dvd_or_dvd_right_of_dvd_mul a_dvd_bpc) (λ h, _),
    exact no_factors h (dvd_mul_right p c) hp }
end

/-- Euclid's lemma: if `a ∣ b * c` and `a` and `b` have no common prime factors, `a ∣ c`.
Compare `is_coprime.dvd_of_dvd_mul_right`. -/
lemma dvd_of_dvd_mul_right_of_no_prime_factors {a b c : R} (ha : a ≠ 0)
  (no_factors : ∀ {d}, d ∣ a → d ∣ b → ¬ prime d) : a ∣ b * c → a ∣ c :=
by simpa [mul_comm b c] using dvd_of_dvd_mul_left_of_no_prime_factors ha @no_factors

/-- If `a ≠ 0, b` are elements of a unique factorization domain, then dividing
out their common factor `c'` gives `a'` and `b'` with no factors in common. -/
lemma exists_reduced_factors : ∀ (a ≠ (0 : R)) b,
  ∃ a' b' c', (∀ {d}, d ∣ a' → d ∣ b' → is_unit d) ∧ c' * a' = a ∧ c' * b' = b :=
begin
  haveI := classical.prop_decidable,
  intros a,
  refine induction_on_prime a _ _ _,
  { intros, contradiction },
  { intros a a_unit a_ne_zero b,
    use [a, b, 1],
    split,
    { intros p p_dvd_a _,
      exact is_unit_of_dvd_unit p_dvd_a a_unit },
    { simp } },
  { intros a p a_ne_zero p_prime ih_a pa_ne_zero b,
    by_cases p ∣ b,
    { rcases h with ⟨b, rfl⟩,
      obtain ⟨a', b', c', no_factor, ha', hb'⟩ := ih_a a_ne_zero b,
      refine ⟨a', b', p * c', @no_factor, _, _⟩,
      { rw [mul_assoc, ha'] },
      { rw [mul_assoc, hb'] } },
    { obtain ⟨a', b', c', coprime, rfl, rfl⟩ := ih_a a_ne_zero b,
      refine ⟨p * a', b', c', _, mul_left_comm _ _ _, rfl⟩,
      intros q q_dvd_pa' q_dvd_b',
      cases p_prime.left_dvd_or_dvd_right_of_dvd_mul q_dvd_pa' with p_dvd_q q_dvd_a',
      { have : p ∣ c' * b' := dvd_mul_of_dvd_right (p_dvd_q.trans q_dvd_b') _,
        contradiction },
      exact coprime q_dvd_a' q_dvd_b' } }
end

lemma exists_reduced_factors' (a b : R) (hb : b ≠ 0) :
  ∃ a' b' c', (∀ {d}, d ∣ a' → d ∣ b' → is_unit d) ∧ c' * a' = a ∧ c' * b' = b :=
let ⟨b', a', c', no_factor, hb, ha⟩ := exists_reduced_factors b hb a
in ⟨a', b', c', λ _ hpb hpa, no_factor hpa hpb, ha, hb⟩

section multiplicity
variables [nontrivial R] [normalization_monoid R] [decidable_eq R]
variables [decidable_rel (has_dvd.dvd : R → R → Prop)]
open multiplicity multiset

lemma le_multiplicity_iff_repeat_le_normalized_factors {a b : R} {n : ℕ}
  (ha : irreducible a) (hb : b ≠ 0) :
  ↑n ≤ multiplicity a b ↔ repeat (normalize a) n ≤ normalized_factors b :=
begin
  rw ← pow_dvd_iff_le_multiplicity,
  revert b,
  induction n with n ih, { simp },
  intros b hb,
  split,
  { rintro ⟨c, rfl⟩,
    rw [ne.def, pow_succ, mul_assoc, mul_eq_zero, decidable.not_or_iff_and_not] at hb,
    rw [pow_succ, mul_assoc, normalized_factors_mul hb.1 hb.2, repeat_succ,
      normalized_factors_irreducible ha, singleton_add, cons_le_cons_iff, ← ih hb.2],
    apply dvd.intro _ rfl },
  { rw [multiset.le_iff_exists_add],
    rintro ⟨u, hu⟩,
    rw [← (normalized_factors_prod hb).dvd_iff_dvd_right, hu, prod_add, prod_repeat],
    exact (associated.pow_pow $ associated_normalize a).dvd.trans (dvd.intro u.prod rfl) }
end

lemma multiplicity_eq_count_normalized_factors {a b : R} (ha : irreducible a) (hb : b ≠ 0) :
  multiplicity a b = (normalized_factors b).count (normalize a) :=
begin
  apply le_antisymm,
  { apply enat.le_of_lt_add_one,
    rw [← nat.cast_one, ← nat.cast_add, lt_iff_not_ge, ge_iff_le,
      le_multiplicity_iff_repeat_le_normalized_factors ha hb, ← le_count_iff_repeat_le],
    simp },
  rw [le_multiplicity_iff_repeat_le_normalized_factors ha hb, ← le_count_iff_repeat_le],
end

end multiplicity

end unique_factorization_monoid

namespace associates
open unique_factorization_monoid associated multiset
variables [cancel_comm_monoid_with_zero α]

/-- `factor_set α` representation elements of unique factorization domain as multisets.
`multiset α` produced by `normalized_factors` are only unique up to associated elements, while the
multisets in `factor_set α` are unique by equality and restricted to irreducible elements. This
gives us a representation of each element as a unique multisets (or the added ⊤ for 0), which has a
complete lattice struture. Infimum is the greatest common divisor and supremum is the least common
multiple.
-/
@[reducible] def {u} factor_set (α : Type u) [cancel_comm_monoid_with_zero α] :
  Type u :=
with_top (multiset { a : associates α // irreducible a })

local attribute [instance] associated.setoid

theorem factor_set.coe_add {a b : multiset { a : associates α // irreducible a }} :
  (↑(a + b) : factor_set α) = a + b :=
by norm_cast

lemma factor_set.sup_add_inf_eq_add [decidable_eq (associates α)] :
  ∀(a b : factor_set α), a ⊔ b + a ⊓ b = a + b
| none     b        := show ⊤ ⊔ b + ⊤ ⊓ b = ⊤ + b, by simp
| a        none     := show a ⊔ ⊤ + a ⊓ ⊤ = a + ⊤, by simp
| (some a) (some b) := show (a : factor_set α) ⊔ b + a ⊓ b = a + b, from
  begin
    rw [← with_top.coe_sup, ← with_top.coe_inf, ← with_top.coe_add, ← with_top.coe_add,
      with_top.coe_eq_coe],
    exact multiset.union_add_inter _ _
  end

/-- Evaluates the product of a `factor_set` to be the product of the corresponding multiset,
  or `0` if there is none. -/
def factor_set.prod : factor_set α → associates α
| none     := 0
| (some s) := (s.map coe).prod

@[simp] theorem prod_top : (⊤ : factor_set α).prod = 0 := rfl

@[simp] theorem prod_coe {s : multiset { a : associates α // irreducible a }} :
  (s : factor_set α).prod = (s.map coe).prod :=
rfl

@[simp] theorem prod_add : ∀(a b : factor_set α), (a + b).prod = a.prod * b.prod
| none b    := show (⊤ + b).prod = (⊤:factor_set α).prod * b.prod, by simp
| a    none := show (a + ⊤).prod = a.prod * (⊤:factor_set α).prod, by simp
| (some a) (some b) :=
  show (↑a + ↑b:factor_set α).prod = (↑a:factor_set α).prod * (↑b:factor_set α).prod,
    by rw [← factor_set.coe_add, prod_coe, prod_coe, prod_coe, multiset.map_add, multiset.prod_add]

theorem prod_mono : ∀{a b : factor_set α}, a ≤ b → a.prod ≤ b.prod
| none b h := have b = ⊤, from top_unique h, by rw [this, prod_top]; exact le_rfl
| a none h := show a.prod ≤ (⊤ : factor_set α).prod, by simp; exact le_top
| (some a) (some b) h := prod_le_prod $ multiset.map_le_map $ with_top.coe_le_coe.1 $ h

theorem factor_set.prod_eq_zero_iff [nontrivial α] (p : factor_set α) :
  p.prod = 0 ↔ p = ⊤ :=
begin
  induction p using with_top.rec_top_coe,
  { simp only [iff_self, eq_self_iff_true, associates.prod_top] },
  simp only [prod_coe, with_top.coe_ne_top, iff_false, prod_eq_zero_iff, multiset.mem_map],
  rintro ⟨⟨a, ha⟩, -, eq⟩,
  rw [subtype.coe_mk] at eq,
  exact ha.ne_zero eq,
end

/-- `bcount p s` is the multiplicity of `p` in the factor_set `s` (with bundled `p`)-/
def bcount [decidable_eq (associates α)] (p : {a : associates α // irreducible a}) :
  factor_set α → ℕ
| none := 0
| (some s) := s.count p

variables [dec_irr : Π (p : associates α), decidable (irreducible p)]
include dec_irr

/-- `count p s` is the multiplicity of the irreducible `p` in the factor_set `s`.

If `p` is not irreducible, `count p s` is defined to be `0`. -/
def count [decidable_eq (associates α)] (p : associates α) :
  factor_set α → ℕ :=
if hp : irreducible p then bcount ⟨p, hp⟩  else 0

@[simp] lemma count_some [decidable_eq (associates α)] {p : associates α} (hp : irreducible p)
  (s : multiset _) : count p (some s) = s.count ⟨p, hp⟩:=
by { dunfold count, split_ifs, refl }

@[simp] lemma count_zero [decidable_eq (associates α)] {p : associates α} (hp : irreducible p) :
  count p (0 : factor_set α) = 0 :=
by { dunfold count, split_ifs, refl }

lemma count_reducible [decidable_eq (associates α)] {p : associates α} (hp : ¬ irreducible p) :
  count p = 0 := dif_neg hp

omit dec_irr

/-- membership in a factor_set (bundled version) -/
def bfactor_set_mem : {a : associates α // irreducible a} → (factor_set α) → Prop
| _ ⊤ := true
| p (some l) := p ∈ l

include dec_irr

/-- `factor_set_mem p s` is the predicate that the irreducible `p` is a member of
`s : factor_set α`.

If `p` is not irreducible, `p` is not a member of any `factor_set`. -/
def factor_set_mem (p : associates α) (s : factor_set α) : Prop :=
if hp : irreducible p then bfactor_set_mem ⟨p, hp⟩ s else false

instance : has_mem (associates α) (factor_set α) := ⟨factor_set_mem⟩

@[simp] lemma factor_set_mem_eq_mem (p : associates α) (s : factor_set α) :
  factor_set_mem p s = (p ∈ s) := rfl

lemma mem_factor_set_top {p : associates α} {hp : irreducible p} :
  p ∈ (⊤ : factor_set α) :=
begin
  dunfold has_mem.mem, dunfold factor_set_mem, split_ifs, exact trivial
end

lemma mem_factor_set_some {p : associates α} {hp : irreducible p}
   {l : multiset {a : associates α // irreducible a }} :
  p ∈ (l : factor_set α) ↔ subtype.mk p hp ∈ l :=
begin
  dunfold has_mem.mem, dunfold factor_set_mem, split_ifs, refl
end

lemma reducible_not_mem_factor_set {p : associates α} (hp : ¬ irreducible p)
  (s : factor_set α) : ¬ p ∈ s :=
λ (h : if hp : irreducible p then bfactor_set_mem ⟨p, hp⟩ s else false),
  by rwa [dif_neg hp] at h

omit dec_irr

variable [unique_factorization_monoid α]

theorem unique' {p q : multiset (associates α)} :
  (∀a∈p, irreducible a) → (∀a∈q, irreducible a) → p.prod = q.prod → p = q :=
begin
  apply multiset.induction_on_multiset_quot p,
  apply multiset.induction_on_multiset_quot q,
  assume s t hs ht eq,
  refine multiset.map_mk_eq_map_mk_of_rel (unique_factorization_monoid.factors_unique _ _ _),
  { exact assume a ha, ((irreducible_mk _).1 $ hs _ $ multiset.mem_map_of_mem _ ha) },
  { exact assume a ha, ((irreducible_mk _).1 $ ht _ $ multiset.mem_map_of_mem _ ha) },
  simpa [quot_mk_eq_mk, prod_mk, mk_eq_mk_iff_associated] using eq
end

theorem factor_set.unique [nontrivial α] {p q : factor_set α} (h : p.prod = q.prod) : p = q :=
begin
  induction p using with_top.rec_top_coe;
  induction q using with_top.rec_top_coe,
  { refl },
  { rw [eq_comm, ←factor_set.prod_eq_zero_iff, ←h, associates.prod_top] },
  { rw [←factor_set.prod_eq_zero_iff, h, associates.prod_top] },
  { congr' 1,
    rw  ←multiset.map_eq_map subtype.coe_injective,
    apply unique' _ _ h;
    { intros a ha,
      obtain ⟨⟨a', irred⟩, -, rfl⟩ := multiset.mem_map.mp ha,
      rwa [subtype.coe_mk] } },
end

theorem prod_le_prod_iff_le [nontrivial α] {p q : multiset (associates α)}
  (hp : ∀a∈p, irreducible a) (hq : ∀a∈q, irreducible a) :
  p.prod ≤ q.prod ↔ p ≤ q :=
iff.intro
  begin
    classical,
    rintros ⟨c, eqc⟩,
    refine multiset.le_iff_exists_add.2 ⟨factors c, unique' hq (λ x hx, _) _⟩,
    { obtain h|h := multiset.mem_add.1 hx,
      { exact hp x h },
      { exact irreducible_of_factor _ h } },
    { rw [eqc, multiset.prod_add],
      congr,
      refine associated_iff_eq.mp (factors_prod (λ hc, _)).symm,
      refine not_irreducible_zero (hq _ _),
      rw [←prod_eq_zero_iff, eqc, hc, mul_zero] }
  end
  prod_le_prod

variables [dec : decidable_eq α] [dec' : decidable_eq (associates α)]
include dec

/-- This returns the multiset of irreducible factors as a `factor_set`,
  a multiset of irreducible associates `with_top`. -/
noncomputable def factors' (a : α) :
  multiset { a : associates α // irreducible a } :=
(factors a).pmap (λa ha, ⟨associates.mk a, (irreducible_mk _).2 ha⟩)
  (irreducible_of_factor)

@[simp] theorem map_subtype_coe_factors' {a : α} :
  (factors' a).map coe = (factors a).map associates.mk :=
by simp [factors', multiset.map_pmap, multiset.pmap_eq_map]

theorem factors'_cong {a b : α} (h : a ~ᵤ b) :
  factors' a = factors' b :=
begin
  obtain rfl|hb := eq_or_ne b 0,
  { rw associated_zero_iff_eq_zero at h, rw h },
  have ha : a ≠ 0,
  { contrapose! hb with ha,
    rw [←associated_zero_iff_eq_zero, ←ha],
    exact h.symm },
  rw [←multiset.map_eq_map subtype.coe_injective, map_subtype_coe_factors',
    map_subtype_coe_factors', ←rel_associated_iff_map_eq_map],
  exact factors_unique irreducible_of_factor irreducible_of_factor
    ((factors_prod ha).trans $ h.trans $ (factors_prod hb).symm),
end

include dec'

/-- This returns the multiset of irreducible factors of an associate as a `factor_set`,
  a multiset of irreducible associates `with_top`. -/
noncomputable def factors (a : associates α) :
  factor_set α :=
begin
  refine (if h : a = 0 then ⊤ else
    quotient.hrec_on a (λx h, some $ factors' x) _ h),
  assume a b hab,
  apply function.hfunext,
  { have : a ~ᵤ 0 ↔ b ~ᵤ 0, from
      iff.intro (assume ha0, hab.symm.trans ha0) (assume hb0, hab.trans hb0),
    simp only [associated_zero_iff_eq_zero] at this,
    simp only [quotient_mk_eq_mk, this, mk_eq_zero] },
  exact (assume ha hb eq, heq_of_eq $ congr_arg some $ factors'_cong hab)
end

@[simp] theorem factors_0 : (0 : associates α).factors = ⊤ :=
dif_pos rfl

@[simp] theorem factors_mk (a : α) (h : a ≠ 0) :
  (associates.mk a).factors = factors' a :=
by { classical, apply dif_neg, apply (mt mk_eq_zero.1 h) }

@[simp]
theorem factors_prod (a : associates α) : a.factors.prod = a :=
quotient.induction_on a $ assume a, decidable.by_cases
  (assume : associates.mk a = 0, by simp [quotient_mk_eq_mk, this])
  (assume : associates.mk a ≠ 0,
    have a ≠ 0, by simp * at *,
    by simp [this, quotient_mk_eq_mk, prod_mk,
      mk_eq_mk_iff_associated.2 (factors_prod this)])

theorem prod_factors [nontrivial α] (s : factor_set α) : s.prod.factors = s :=
factor_set.unique $ factors_prod _

@[nontriviality] lemma factors_subsingleton [subsingleton α] {a : associates α} :
  a.factors = option.none :=
by { convert factors_0; apply_instance }

lemma factors_eq_none_iff_zero {a : associates α} :
  a.factors = option.none ↔ a = 0 :=
begin
  nontriviality α,
  exact ⟨λ h, by rwa [← factors_prod a, factor_set.prod_eq_zero_iff], λ h, h.symm ▸ factors_0⟩
end

lemma factors_eq_some_iff_ne_zero {a : associates α} :
  (∃ (s : multiset {p : associates α // irreducible p}), a.factors = some s) ↔ a ≠ 0 :=
by rw [← option.is_some_iff_exists, ← option.ne_none_iff_is_some, ne.def, ne.def,
  factors_eq_none_iff_zero]

theorem eq_of_factors_eq_factors {a b : associates α} (h : a.factors = b.factors) : a = b :=
have a.factors.prod = b.factors.prod, by rw h,
by rwa [factors_prod, factors_prod] at this

omit dec dec'

theorem eq_of_prod_eq_prod [nontrivial α] {a b : factor_set α} (h : a.prod = b.prod) : a = b :=
begin
  classical,
  have : a.prod.factors = b.prod.factors, by rw h,
  rwa [prod_factors, prod_factors] at this
end

include dec dec' dec_irr

theorem eq_factors_of_eq_counts {a b : associates α} (ha : a ≠ 0) (hb : b ≠ 0)
  (h : ∀ (p : associates α) (hp : irreducible p), p.count a.factors = p.count b.factors) :
  a.factors = b.factors :=
begin
  obtain ⟨sa, h_sa⟩ := factors_eq_some_iff_ne_zero.mpr ha,
  obtain ⟨sb, h_sb⟩ := factors_eq_some_iff_ne_zero.mpr hb,
  rw [h_sa, h_sb] at h ⊢,
  rw option.some_inj,
  have h_count : ∀ (p : associates α) (hp : irreducible p), sa.count ⟨p, hp⟩ = sb.count ⟨p, hp⟩,
  { intros p hp, rw [← count_some, ← count_some, h p hp] },
  apply multiset.to_finsupp.injective,
  ext ⟨p, hp⟩,
  rw [multiset.to_finsupp_apply, multiset.to_finsupp_apply, h_count p hp]
end

theorem eq_of_eq_counts {a b : associates α} (ha : a ≠ 0) (hb  : b ≠ 0)
  (h : ∀ (p : associates α), irreducible p → p.count a.factors = p.count b.factors) : a = b :=
eq_of_factors_eq_factors (eq_factors_of_eq_counts ha hb h)

omit dec_irr

@[simp] theorem factors_mul [nontrivial α] (a b : associates α) :
  (a * b).factors = a.factors + b.factors :=
eq_of_prod_eq_prod $ eq_of_factors_eq_factors $
  by rw [prod_add, factors_prod, factors_prod, factors_prod]

theorem factors_mono [nontrivial α] : ∀{a b : associates α}, a ≤ b → a.factors ≤ b.factors
| s t ⟨d, rfl⟩ := by rw [factors_mul] ; exact le_add_of_nonneg_right bot_le

theorem factors_le [nontrivial α] {a b : associates α} : a.factors ≤ b.factors ↔ a ≤ b :=
iff.intro
  (assume h, have a.factors.prod ≤ b.factors.prod, from prod_mono h,
    by rwa [factors_prod, factors_prod] at this)
  factors_mono

omit dec dec'

theorem prod_le [nontrivial α] {a b : factor_set α} : a.prod ≤ b.prod ↔ a ≤ b :=
begin
  classical,
  exact iff.intro
  (assume h, have a.prod.factors ≤ b.prod.factors, from factors_mono h,
    by rwa [prod_factors, prod_factors] at this)
  prod_mono
end

include dec dec'

noncomputable instance : has_sup (associates α) := ⟨λa b, (a.factors ⊔ b.factors).prod⟩
noncomputable instance : has_inf (associates α) := ⟨λa b, (a.factors ⊓ b.factors).prod⟩

noncomputable instance [nontrivial α] : lattice (associates α) :=
{ sup          := (⊔),
  inf          := (⊓),
  sup_le       :=
    assume a b c hac hbc, factors_prod c ▸ prod_mono (sup_le (factors_mono hac) (factors_mono hbc)),
  le_sup_left  := assume a b,
    le_trans (le_of_eq (factors_prod a).symm) $ prod_mono $ le_sup_left,
  le_sup_right := assume a b,
    le_trans (le_of_eq (factors_prod b).symm) $ prod_mono $ le_sup_right,
  le_inf :=
    assume a b c hac hbc, factors_prod a ▸ prod_mono (le_inf (factors_mono hac) (factors_mono hbc)),
  inf_le_left  := assume a b,
    le_trans (prod_mono inf_le_left) (le_of_eq (factors_prod a)),
  inf_le_right := assume a b,
    le_trans (prod_mono inf_le_right) (le_of_eq (factors_prod b)),
  .. associates.partial_order }

lemma sup_mul_inf [nontrivial α] (a b : associates α) : (a ⊔ b) * (a ⊓ b) = a * b :=
show (a.factors ⊔ b.factors).prod * (a.factors ⊓ b.factors).prod = a * b,
begin
  refine eq_of_factors_eq_factors _,
  rw [← prod_add, prod_factors, factors_mul, factor_set.sup_add_inf_eq_add]
end

include dec_irr

lemma dvd_of_mem_factors {a p : associates α} {hp : irreducible p}
  (hm : p ∈ factors a) : p ∣ a :=
begin
  by_cases ha0 : a = 0, { rw ha0, exact dvd_zero p },
  obtain ⟨a0, nza, ha'⟩ := exists_non_zero_rep ha0,
  rw [← associates.factors_prod a],
  rw [← ha', factors_mk a0 nza] at hm ⊢,
  erw prod_coe,
  apply multiset.dvd_prod, apply multiset.mem_map.mpr,
  exact ⟨⟨p, hp⟩, mem_factor_set_some.mp hm, rfl⟩
end

omit dec'

lemma dvd_of_mem_factors' {a : α} {p : associates α} {hp : irreducible p} {hz : a ≠ 0}
  (h_mem : subtype.mk p hp ∈ factors' a) : p ∣ associates.mk a :=
by { haveI := classical.dec_eq (associates α),
  apply @dvd_of_mem_factors _ _ _ _ _ _ _ _ hp,
  rw factors_mk _ hz,
  apply mem_factor_set_some.2 h_mem }

omit dec_irr

lemma mem_factors'_of_dvd {a p : α} (ha0 : a ≠ 0) (hp : irreducible p) (hd : p ∣ a) :
  subtype.mk (associates.mk p) ((irreducible_mk _).2 hp) ∈ factors' a :=
begin
  obtain ⟨q, hq, hpq⟩ := exists_mem_factors_of_dvd ha0 hp hd,
  apply multiset.mem_pmap.mpr, use q, use hq,
  exact subtype.eq (eq.symm (mk_eq_mk_iff_associated.mpr hpq))
end

include dec_irr

lemma mem_factors'_iff_dvd {a p : α} (ha0 : a ≠ 0) (hp : irreducible p) :
  subtype.mk (associates.mk p) ((irreducible_mk _).2 hp) ∈ factors' a ↔ p ∣ a :=
begin
  split,
  { rw ← mk_dvd_mk, apply dvd_of_mem_factors', apply ha0 },
  { apply mem_factors'_of_dvd ha0 }
end

include dec'

lemma mem_factors_of_dvd {a p : α} (ha0 : a ≠ 0) (hp : irreducible p) (hd : p ∣ a) :
  (associates.mk p) ∈ factors (associates.mk a) :=
begin
  rw factors_mk _ ha0, exact mem_factor_set_some.mpr (mem_factors'_of_dvd ha0 hp hd)
end

lemma mem_factors_iff_dvd {a p : α} (ha0 : a ≠ 0) (hp : irreducible p) :
  (associates.mk p) ∈ factors (associates.mk a) ↔ p ∣ a :=
begin
  split,
  { rw ← mk_dvd_mk, apply dvd_of_mem_factors, exact (irreducible_mk p).mpr hp },
  { apply mem_factors_of_dvd ha0 hp }
end

lemma exists_prime_dvd_of_not_inf_one {a b : α}
  (ha : a ≠ 0) (hb : b ≠ 0) (h : (associates.mk a) ⊓ (associates.mk b) ≠ 1)  :
  ∃ (p : α), prime p ∧ p ∣ a ∧ p ∣ b :=
begin
  have hz : (factors (associates.mk a)) ⊓ (factors (associates.mk b)) ≠ 0,
  { contrapose! h with hf,
    change ((factors (associates.mk a)) ⊓ (factors (associates.mk b))).prod = 1,
    rw hf,
    exact multiset.prod_zero },
  rw [factors_mk a ha, factors_mk b hb, ← with_top.coe_inf] at hz,
  obtain ⟨⟨p0, p0_irr⟩, p0_mem⟩ := multiset.exists_mem_of_ne_zero ((mt with_top.coe_eq_coe.mpr) hz),
  rw multiset.inf_eq_inter at p0_mem,
  obtain ⟨p, rfl⟩ : ∃ p, associates.mk p = p0 := quot.exists_rep p0,
  refine ⟨p, _, _, _⟩,
  { rw [← irreducible_iff_prime, ← irreducible_mk],
    exact p0_irr },
  { apply dvd_of_mk_le_mk,
    apply dvd_of_mem_factors' (multiset.mem_inter.mp p0_mem).left,
    apply ha, },
  { apply dvd_of_mk_le_mk,
    apply dvd_of_mem_factors' (multiset.mem_inter.mp p0_mem).right,
    apply hb }
end

theorem coprime_iff_inf_one [nontrivial α] {a b : α} (ha0 : a ≠ 0) (hb0 : b ≠ 0) :
  (associates.mk a) ⊓ (associates.mk b) = 1 ↔ ∀ {d : α}, d ∣ a → d ∣ b → ¬ prime d :=
begin
  split,
  { intros hg p ha hb hp,
    refine ((associates.prime_mk _).mpr hp).not_unit (is_unit_of_dvd_one _ _),
    rw ← hg,
    exact le_inf (mk_le_mk_of_dvd ha) (mk_le_mk_of_dvd hb) },
  { contrapose,
    intros hg hc,
    obtain ⟨p, hp, hpa, hpb⟩ := exists_prime_dvd_of_not_inf_one ha0 hb0 hg,
    exact hc hpa hpb hp }
end

omit dec_irr

include dec_irr

theorem prime_pow_dvd_iff_le [nontrivial α] {m p : associates α} (h₁ : m ≠ 0)
  (h₂ : irreducible p) {k : ℕ} : p ^ k ≤ m ↔ k ≤ count p m.factors :=
begin
  obtain ⟨a, nz, rfl⟩ := associates.exists_non_zero_rep h₁,
  rw [factors_mk _ nz, ← with_top.some_eq_coe, count_some, multiset.le_count_iff_repeat_le,
      ← factors_le, factors_prime_pow h₂, factors_mk _ nz],
  exact with_top.coe_le_coe
end

theorem le_of_count_ne_zero [nontrivial α] {m p : associates α} (h0 : m ≠ 0)
  (hp : irreducible p) : count p m.factors ≠ 0 → p ≤ m :=
begin
  rw [← pos_iff_ne_zero],
  intro h,
  rw [← pow_one p],
  apply (prime_pow_dvd_iff_le h0 hp).2,
  simpa only
end

theorem count_ne_zero_iff_dvd {a p : α} (ha0 : a ≠ 0) (hp : irreducible p) :
  (associates.mk p).count (associates.mk a).factors ≠ 0 ↔ p ∣ a :=
begin
  nontriviality α,
  rw ← associates.mk_le_mk_iff_dvd_iff,
  refine ⟨λ h, associates.le_of_count_ne_zero (associates.mk_ne_zero.mpr ha0)
    ((associates.irreducible_mk p).mpr hp) h, λ h, _⟩,
  { rw [← pow_one (associates.mk p), associates.prime_pow_dvd_iff_le
      (associates.mk_ne_zero.mpr ha0) ((associates.irreducible_mk p).mpr hp)] at h,
    exact (zero_lt_one.trans_le h).ne' }
end

theorem count_mul [nontrivial α] {a : associates α} (ha : a ≠ 0) {b : associates α} (hb : b ≠ 0)
  {p : associates α} (hp : irreducible p) :
  count p (factors (a * b)) = count p a.factors + count p b.factors :=
begin
  obtain ⟨a0, nza, ha'⟩ := exists_non_zero_rep ha,
  obtain ⟨b0, nzb, hb'⟩ := exists_non_zero_rep hb,
  rw [factors_mul, ← ha', ← hb', factors_mk a0 nza, factors_mk b0 nzb, ← factor_set.coe_add,
      ← with_top.some_eq_coe, ← with_top.some_eq_coe, ← with_top.some_eq_coe, count_some hp,
      multiset.count_add, count_some hp, count_some hp]
end

theorem count_of_coprime [nontrivial α] {a : associates α} (ha : a ≠ 0) {b : associates α}
  (hb : b ≠ 0)
  (hab : ∀ d, d ∣ a → d ∣ b → ¬ prime d) {p : associates α} (hp : irreducible p) :
  count p a.factors = 0 ∨ count p b.factors = 0 :=
begin
  rw [or_iff_not_imp_left, ← ne.def],
  intro hca,
  contrapose! hab with hcb,
  exact ⟨p, le_of_count_ne_zero ha hp hca, le_of_count_ne_zero hb hp hcb,
    (irreducible_iff_prime.mp hp)⟩,
end

theorem count_mul_of_coprime [nontrivial α] {a : associates α} {b : associates α}
  (hb : b ≠ 0)
  {p : associates α} (hp : irreducible p) (hab : ∀ d, d ∣ a → d ∣ b → ¬ prime d) :
  count p a.factors = 0 ∨ count p a.factors = count p (a * b).factors :=
begin
  by_cases ha : a = 0,
  { simp [ha], },
  cases count_of_coprime ha hb hab hp with hz hb0, { tauto },
  apply or.intro_right,
  rw [count_mul ha hb hp, hb0, add_zero]
end

theorem count_mul_of_coprime' [nontrivial α] {a b : associates α}
  {p : associates α} (hp : irreducible p) (hab : ∀ d, d ∣ a → d ∣ b → ¬ prime d) :
  count p (a * b).factors = count p a.factors
  ∨ count p (a * b).factors = count p b.factors :=
begin
  by_cases ha : a = 0, { simp [ha], },
  by_cases hb : b = 0, { simp [hb], },
  rw [count_mul ha hb hp],
  cases count_of_coprime ha hb hab hp with ha0 hb0,
  { apply or.intro_right, rw [ha0, zero_add] },
  { apply or.intro_left, rw [hb0, add_zero] }
end

theorem dvd_count_of_dvd_count_mul [nontrivial α] {a b : associates α} (hb : b ≠ 0)
  {p : associates α} (hp : irreducible p) (hab : ∀ d, d ∣ a → d ∣ b → ¬ prime d)
  {k : ℕ} (habk : k ∣ count p (a * b).factors) : k ∣ count p a.factors :=
begin
  by_cases ha : a = 0, { simpa [*] using habk, },
  cases count_of_coprime ha hb hab hp with hz h,
  { rw hz, exact dvd_zero k },
  { rw [count_mul ha hb hp, h] at habk, exact habk }
end

omit dec_irr

@[simp] lemma factors_one [nontrivial α] : factors (1 : associates α) = 0 :=
begin
  apply eq_of_prod_eq_prod,
  rw associates.factors_prod,
  exact multiset.prod_zero,
end

@[simp] theorem pow_factors [nontrivial α] {a : associates α} {k : ℕ} :
  (a ^ k).factors = k • a.factors :=
begin
  induction k with n h,
  { rw [zero_nsmul, pow_zero], exact factors_one },
  { rw [pow_succ, succ_nsmul, factors_mul, h] }
end

include dec_irr

lemma count_pow [nontrivial α] {a : associates α} (ha : a ≠ 0) {p : associates α}
  (hp : irreducible p)
  (k : ℕ) : count p (a ^ k).factors = k * count p a.factors :=
begin
  induction k with n h,
  { rw [pow_zero, factors_one, zero_mul, count_zero hp] },
  { rw [pow_succ, count_mul ha (pow_ne_zero _ ha) hp, h, nat.succ_eq_add_one], ring }
end

theorem dvd_count_pow [nontrivial α] {a : associates α} (ha : a ≠ 0) {p : associates α}
  (hp : irreducible p)
  (k : ℕ) : k ∣ count p (a ^ k).factors := by { rw count_pow ha hp, apply dvd_mul_right }

theorem is_pow_of_dvd_count [nontrivial α] {a : associates α} (ha : a ≠ 0) {k : ℕ}
  (hk : ∀ (p : associates α) (hp : irreducible p), k ∣ count p a.factors) :
  ∃ (b : associates α), a = b ^ k :=
begin
  obtain ⟨a0, hz, rfl⟩ := exists_non_zero_rep ha,
  rw [factors_mk a0 hz] at hk,
  have hk' : ∀ p, p ∈ (factors' a0) → k ∣ (factors' a0).count p,
  { rintros p -,
    have pp : p = ⟨p.val, p.2⟩, { simp only [subtype.coe_eta, subtype.val_eq_coe] },
    rw [pp, ← count_some p.2], exact hk p.val p.2 },
  obtain ⟨u, hu⟩ := multiset.exists_smul_of_dvd_count _ hk',
  use (u : factor_set α).prod,
  apply eq_of_factors_eq_factors,
  rw [pow_factors, prod_factors, factors_mk a0 hz, ← with_top.some_eq_coe, hu],
  exact with_bot.coe_nsmul u k
end

omit dec
omit dec_irr
omit dec'

theorem eq_pow_of_mul_eq_pow [nontrivial α] {a b c : associates α} (ha : a ≠ 0) (hb : b ≠ 0)
  (hab : ∀ d, d ∣ a → d ∣ b → ¬ prime d) {k : ℕ} (h : a * b = c ^ k) :
  ∃ (d : associates α), a = d ^ k :=
begin
  classical,
  by_cases hk0 : k = 0,
  { use 1,
    rw [hk0, pow_zero] at h ⊢,
    apply (mul_eq_one_iff.1 h).1 },
  { refine is_pow_of_dvd_count ha _,
    intros p hp,
    apply dvd_count_of_dvd_count_mul hb hp hab,
    rw h,
    apply dvd_count_pow _ hp,
    rintros rfl,
    rw zero_pow' _ hk0 at h,
    cases mul_eq_zero.mp h; contradiction }
end

end associates

section
open associates unique_factorization_monoid

lemma associates.quot_out {α : Type*} [comm_monoid α] (a : associates α):
associates.mk (quot.out (a)) = a :=
by rw [←quot_mk_eq_mk, quot.out_eq]

/-- `to_gcd_monoid` constructs a GCD monoid out of a unique factorization domain. -/
noncomputable def unique_factorization_monoid.to_gcd_monoid
  (α : Type*) [cancel_comm_monoid_with_zero α] [nontrivial α] [unique_factorization_monoid α]
  [decidable_eq (associates α)] [decidable_eq α] : gcd_monoid α :=
{ gcd := λa b, quot.out (associates.mk a ⊓ associates.mk b : associates α),
  lcm := λa b, quot.out (associates.mk a ⊔ associates.mk b : associates α),
  gcd_dvd_left := λ a b, by
  { rw [←mk_dvd_mk, (associates.mk a ⊓ associates.mk b).quot_out, dvd_eq_le],
    exact inf_le_left },
  gcd_dvd_right := λ a b, by
  { rw [←mk_dvd_mk, (associates.mk a ⊓ associates.mk b).quot_out, dvd_eq_le],
    exact inf_le_right },
  dvd_gcd := λ a b c hac hab, by
  { rw [←mk_dvd_mk, (associates.mk c ⊓ associates.mk b).quot_out, dvd_eq_le,
      le_inf_iff, mk_le_mk_iff_dvd_iff, mk_le_mk_iff_dvd_iff],
    exact ⟨hac, hab⟩ },
  lcm_zero_left := λ a, by
  { have : associates.mk (0 : α) = ⊤ := rfl,
    rw [this, top_sup_eq, ←this, ←associated_zero_iff_eq_zero, ←mk_eq_mk_iff_associated,
      ←associated_iff_eq, associates.quot_out] },
  lcm_zero_right := λ a, by
  { have : associates.mk (0 : α) = ⊤ := rfl,
    rw [this, sup_top_eq, ←this, ←associated_zero_iff_eq_zero, ←mk_eq_mk_iff_associated,
      ←associated_iff_eq, associates.quot_out] },
  gcd_mul_lcm := λ a b, by
  { rw [←mk_eq_mk_iff_associated, ←associates.mk_mul_mk, ←associated_iff_eq, associates.quot_out,
      associates.quot_out, mul_comm, sup_mul_inf, associates.mk_mul_mk] } }

/-- `to_normalized_gcd_monoid` constructs a GCD monoid out of a normalization on a
  unique factorization domain. -/
noncomputable def unique_factorization_monoid.to_normalized_gcd_monoid
  (α : Type*) [cancel_comm_monoid_with_zero α] [nontrivial α] [unique_factorization_monoid α]
  [normalization_monoid α] [decidable_eq (associates α)] [decidable_eq α] :
  normalized_gcd_monoid α :=
{ gcd := λa b, (associates.mk a ⊓ associates.mk b).out,
  lcm := λa b, (associates.mk a ⊔ associates.mk b).out,
  gcd_dvd_left := assume a b, (out_dvd_iff a (associates.mk a ⊓ associates.mk b)).2 $ inf_le_left,
  gcd_dvd_right := assume a b, (out_dvd_iff b (associates.mk a ⊓ associates.mk b)).2 $ inf_le_right,
  dvd_gcd := assume a b c hac hab, show a ∣ (associates.mk c ⊓ associates.mk b).out,
    by rw [dvd_out_iff, le_inf_iff, mk_le_mk_iff_dvd_iff, mk_le_mk_iff_dvd_iff]; exact ⟨hac, hab⟩,
  lcm_zero_left := assume a, show (⊤ ⊔ associates.mk a).out = 0, by simp,
  lcm_zero_right := assume a, show (associates.mk a ⊔ ⊤).out = 0, by simp,
  gcd_mul_lcm := assume a b, by
  { rw [← out_mul, mul_comm, sup_mul_inf, mk_mul_mk, out_mk],
    exact normalize_associated (a * b) },
  normalize_gcd := assume a b, by convert normalize_out _,
  normalize_lcm := assume a b, by convert normalize_out _,
  .. ‹normalization_monoid α› }

end

namespace unique_factorization_monoid

/-- If `y` is a nonzero element of a unique factorization monoid with finitely
many units (e.g. `ℤ`, `ideal (ring_of_integers K)`), it has finitely many divisors. -/
noncomputable def fintype_subtype_dvd {M : Type*} [cancel_comm_monoid_with_zero M]
  [unique_factorization_monoid M] [fintype Mˣ]
  (y : M) (hy : y ≠ 0) :
  fintype {x // x ∣ y} :=
begin
  haveI : nontrivial M := ⟨⟨y, 0, hy⟩⟩,
  haveI : normalization_monoid M := unique_factorization_monoid.normalization_monoid,
  haveI := classical.dec_eq M,
  haveI := classical.dec_eq (associates M),
  -- We'll show `λ (u : Mˣ) (f ⊆ factors y) → u * Π f` is injective
  -- and has image exactly the divisors of `y`.
  refine fintype.of_finset
    (((normalized_factors y).powerset.to_finset.product (finset.univ : finset Mˣ)).image
      (λ s, (s.snd : M) * s.fst.prod))
    (λ x, _),
  simp only [exists_prop, finset.mem_image, finset.mem_product, finset.mem_univ, and_true,
    multiset.mem_to_finset, multiset.mem_powerset, exists_eq_right, multiset.mem_map],
  split,
  { rintros ⟨s, hs, rfl⟩,
    have prod_s_ne : s.fst.prod ≠ 0,
    { intro hz,
      apply hy (eq_zero_of_zero_dvd _),
      have hz := (@multiset.prod_eq_zero_iff M _ _ _ s.fst).mp hz,
      rw ← (normalized_factors_prod hy).dvd_iff_dvd_right,
      exact multiset.dvd_prod (multiset.mem_of_le hs hz) },
    show (s.snd : M) * s.fst.prod ∣ y,
    rw [(unit_associated_one.mul_right s.fst.prod).dvd_iff_dvd_left, one_mul,
        ← (normalized_factors_prod hy).dvd_iff_dvd_right],
    exact multiset.prod_dvd_prod_of_le hs },
  { rintro (h : x ∣ y),
    have hx : x ≠ 0, { refine mt (λ hx, _) hy, rwa [hx, zero_dvd_iff] at h },
    obtain ⟨u, hu⟩ := normalized_factors_prod hx,
    refine ⟨⟨normalized_factors x, u⟩, _, (mul_comm _ _).trans hu⟩,
    exact (dvd_iff_normalized_factors_le_normalized_factors hx hy).mp h }
end

end unique_factorization_monoid

section finsupp
variables [cancel_comm_monoid_with_zero α] [unique_factorization_monoid α]
variables [normalization_monoid α] [decidable_eq α]

open unique_factorization_monoid

/-- This returns the multiset of irreducible factors as a `finsupp` -/
noncomputable def factorization (n : α) : α →₀ ℕ := (normalized_factors n).to_finsupp

lemma factorization_eq_count {n p : α} :
  factorization n p = multiset.count p (normalized_factors n) :=
by simp [factorization]

@[simp] lemma factorization_zero : factorization (0 : α) = 0 := by simp [factorization]

@[simp] lemma factorization_one : factorization (1 : α) = 0 := by simp [factorization]

/-- The support of `factorization n` is exactly the finset of normalized factors -/
@[simp] lemma support_factorization {n : α} :
  (factorization n).support = (normalized_factors n).to_finset :=
by simp [factorization, multiset.to_finsupp_support]

/-- For nonzero `a` and `b`, the power of `p` in `a * b` is the sum of the powers in `a` and `b` -/
@[simp] lemma factorization_mul {a b : α} (ha : a ≠ 0) (hb : b ≠ 0) :
  factorization (a * b) = factorization a + factorization b :=
by simp [factorization, normalized_factors_mul ha hb]

/-- For any `p`, the power of `p` in `x^n` is `n` times the power in `x` -/
lemma factorization_pow {x : α} {n : ℕ} :
  factorization (x^n) = n • factorization x :=
by { ext, simp [factorization] }

lemma associated_of_factorization_eq (a b: α) (ha: a ≠ 0) (hb: b ≠ 0)
  (h: factorization a = factorization b) : associated a b :=
begin
  simp only [factorization, add_equiv.apply_eq_iff_eq] at h,
  have ha' := normalized_factors_prod ha,
  rw h at ha',
  exact associated.trans ha'.symm (normalized_factors_prod hb),
end

end finsupp


universe u

notation `exists!` binders `, ` r:(scoped P, exists_unique P) := r
infix ` != `:50 := ne

namespace set -- set extensionality
    variable {R : Type u}

    @[reducible]
    def eq (A : set R) (B : set R) := forall x : R, set.mem x A <-> set.mem x B

    theorem ext {A : set R} {B : set R} (a_eq_b : eq A B) : A = B := funext (fun x, propext (a_eq_b x))
end set


universe u

def f {α : Type u} [BEq α] (xs : List α) (y : α) : α := Id.run <| do
for x in xs do
  if x == y then
    return x
return y

structure S :=
(key val : Nat)

instance : BEq S :=
⟨fun a b => a.key == b.key⟩

theorem ex1 : f (α := S) [⟨1, 2⟩, ⟨3, 4⟩, ⟨5, 6⟩] ⟨3, 0⟩ = ⟨3, 4⟩ :=
rfl

theorem ex2 : f (α := S) [⟨1, 2⟩, ⟨3, 4⟩, ⟨5, 6⟩] ⟨4, 10⟩ = ⟨4, 10⟩ :=
rfl


import algebra.homology.homological_complex

open category_theory

namespace cochain_complex

variables {𝓐 : Type*} [category 𝓐] [preadditive 𝓐]

def cons.X (C : cochain_complex 𝓐 ℕ) (A : 𝓐) : ℕ → 𝓐
| 0     := A
| (n+1) := C.X n

def cons.d (C : cochain_complex 𝓐 ℕ) (A : 𝓐) (d : A ⟶ C.X 0) :
  Π (i j : ℕ), cons.X C A i ⟶ cons.X C A j
| 0 0     := 0
| 0 1     := d
| 0 (j+2) := 0
| (i+1) 0 := 0
| (i+1) (j+1) := C.d i j

lemma cons.shape (C : cochain_complex 𝓐 ℕ) (A : 𝓐) (d : A ⟶ C.X 0) :
  ∀ (i j : ℕ), ¬(complex_shape.up ℕ).rel i j → cons.d C A d i j = 0
| 0 0     h := rfl
| 0 1     h := (h rfl).elim
| 0 (j+2) h := rfl
| (i+1) 0 h := rfl
| (i+1) (j+1) h := C.shape i j $ mt (add_left_inj 1).mpr h

lemma cons.d_comp_d (C : cochain_complex 𝓐 ℕ) (A : 𝓐) (d : A ⟶ C.X 0) (h : d ≫ C.d 0 1 = 0) :
  ∀ i j k, (complex_shape.up ℕ).rel i j → (complex_shape.up ℕ).rel j k →
    cons.d C A d i j ≫ cons.d C A d j k = 0
| 0 1 2 rfl rfl := h
| (i+1) _ _ rfl rfl := C.d_comp_d _ _ _

def cons (C : cochain_complex 𝓐 ℕ) (A : 𝓐) (d : A ⟶ C.X 0) (h : d ≫ C.d 0 1 = 0) :
  cochain_complex 𝓐 ℕ :=
{ X := cons.X C A,
  d := cons.d C A d,
  shape' := cons.shape C A d,
  d_comp_d' := cons.d_comp_d C A d h }

section simp_lemmas

variables (C : cochain_complex 𝓐 ℕ) (A : 𝓐) (d : A ⟶ C.X 0) (h : d ≫ C.d 0 1 = 0)

@[simp] lemma cons_X_0 : (C.cons A d h).X 0 = A := rfl
@[simp] lemma cons_X_succ (n : ℕ) : (C.cons A d h).X (n+1) = C.X n := rfl
@[simp] lemma cons_d_01 : (C.cons A d h).d 0 1  = d := rfl
@[simp] lemma cons_d_succ (n : ℕ) : (C.cons A d h).d (n+1) (n+2) = C.d n (n+1) := rfl

end simp_lemmas

namespace hom

variables {C₁ C₂ : cochain_complex 𝓐 ℕ} {A₁ A₂ : 𝓐}
  {d₁ : A₁ ⟶ C₁.X 0} {d₂ : A₂ ⟶ C₂.X 0}
  (h₁ : d₁ ≫ C₁.d 0 1 = 0) (h₂ : d₂ ≫ C₂.d 0 1 = 0)
  (f : A₁ ⟶ A₂) (g : C₁ ⟶ C₂)

def cons.f : Π (i : ℕ), (C₁.cons A₁ d₁ h₁).X i ⟶ (C₂.cons A₂ d₂ h₂).X i
| 0 := f
| (i+1) := g.f i

lemma cons.comm (w : f ≫ d₂ = d₁ ≫ g.f 0) :
  ∀ (i j : ℕ), (complex_shape.up ℕ).rel i j →
    cons.f h₁ h₂ f g i ≫ (C₂.cons A₂ d₂ h₂).d i j = (C₁.cons A₁ d₁ h₁).d i j ≫ cons.f h₁ h₂ f g j
| 0 1 rfl := w
| (i+1) _ rfl := g.comm i (i+1)

def cons (w : f ≫ d₂ = d₁ ≫ g.f 0) : C₁.cons A₁ d₁ h₁ ⟶ C₂.cons A₂ d₂ h₂ :=
{ f := cons.f h₁ h₂ f g,
  comm' := cons.comm h₁ h₂ f g w }

section simp_lemmas

variables (w : f ≫ d₂ = d₁ ≫ g.f 0)

@[simp] lemma cons_f_0 : (cons h₁ h₂ f g w).f 0 = f := rfl
@[simp] lemma cons_f_succ (i : ℕ) : (cons h₁ h₂ f g w).f (i+1) = g.f i := rfl

end simp_lemmas

end hom

end cochain_complex