import data.set.basic
import data.num.lemmas
import util.meta.tactic

universes u v w

def arity (α : Type u) : nat → Type u
| 0     := α
| (n+1) := α → arity n

section definitions

variable β : Type v

inductive pObject : Type (max v (u+1))
| mk (α : Type u) (A : α → pObject) : pObject
| atom : β → pObject

variable {β}

inductive is_set : pObject β → Prop
| intro (α : Type u) (A : α → pObject β) : is_set (pObject.mk α A)

inductive is_atom : pObject β → Prop
| intro (x) : is_atom (pObject.atom x)

variable β

-- @[reducible]
def pSet := subtype (@is_set β)

@[reducible]
def pAtom := subtype (@is_atom β)

variable {β}

def pSet.mk (a : Type u) (A) : pSet β :=
⟨ pObject.mk a A, is_set.intro _ _ ⟩

def pAtom.mk (x : β) : pAtom β :=
⟨ pObject.atom x, is_atom.intro _ ⟩

@[recursor]
lemma {l} pSet.rec : Π {β : Type v} {C : pSet β → Sort l},
  (Π (α : Type u) (A : α → pObject β), C (pSet.mk α A)) →
  Π (n : pSet β), C n := sorry

@[recursor]
lemma {l} pSet.rec_on : Π {β : Type v} {C : pSet β → Sort l} (n : pSet β),
  (Π (α : Type u) (A : α → pObject β), C (pSet.mk α A)) →
  C n := sorry

-- inductive pSet : Type (max v (u+1))
-- | mk (α : Type u) (A : α → pObject.{u v} β) : pSet

-- def pAtom := β
-- DEFINE pAtom and pSet as subtypes of pObject

-- instance : has_coe (pAtom β) (pObject β) :=
-- ⟨ pObject.atom ⟩

-- def pSet_to_pObject : pSet β → pObject β
-- | ⟨a,A⟩ := pObject.mk a A

-- instance coe_pSet_pObject : has_coe (pSet β) (pObject β) :=
-- ⟨ pSet_to_pObject _ ⟩

end definitions

namespace pSet
  variables {β : Type v}

  -- #eval (show has_coe (pSet.{v} β) (pObject.{u+1} β), from _)
  local attribute [priority 0] coe_subtype
  def coe_set {p : pObject β → Prop} :=
   @coe (subtype p) (pObject β)
   (by { apply @coe_to_lift _ _ _, apply @coe_base _ _ _, apply coe_subtype })
  -- @[reducible] def lift_set : pSet.{u} β → pObject.{u} β := coe
  -- @[reducible] def lift_atom : pAtom β → pObject.{u} β := coe
  local prefix ↑ := coe_set

  -- def type : pSet β → Type u
  -- | ⟨α, A⟩ := α

  -- def func : Π (x : pSet), x.type → pSet
  -- | ⟨α, A⟩ := A

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

  def is_set.elim {α : Sort w} {x : β} (y : is_set (pObject.atom x)) : α :=
  by { exfalso, cases y }

  def type : pSet β → Type u
  | ⟨pObject.mk a A, _⟩ := a
  | ⟨pObject.atom _, x⟩ := is_set.elim x

  def func : Π (x : pSet β), x.type → pObject β
  | ⟨pObject.mk a A, _⟩ := A
  | ⟨pObject.atom _, x⟩ := is_set.elim x

  def mk_type_func : Π (x : pSet β), pSet.mk x.type x.func = x
  | ⟨pObject.mk a A, _⟩ := rfl
  | ⟨pObject.atom _, x⟩ := is_set.elim x

  def equiv : pObject β → pObject β → Prop
  | (pObject.atom x) (pObject.atom y) := x = y
  | (pObject.mk x f) (pObject.mk y g) :=
      (∀a, ∃b, equiv (f a) (g b))
    ∧ (∀b, ∃a, equiv (f a) (g b))
  | _ _ := false

  -- pSet.rec _ x y -- (λα z m ⟨β, B⟩, (∀a, ∃b, m a (B b)) ∧ (∀b, ∃a, m a (B b))) x y

  @[refl]
  lemma equiv.refl : ∀ x : pObject β, equiv x x
  | (pObject.atom x) := rfl
  | (pObject.mk x f) :=
    begin
      unfold equiv,
      split ; intro i ; existsi i ; apply equiv.refl,
    end

  def equiv.euc {x : pObject β} : Π {y z}, equiv x y → equiv z y → equiv x z :=
  begin
    induction x with x A₀
    ; introv h₀ h₁
    ; cases y with y A₁
    ; cases z with z A₂
    ; unfold equiv at *
    ; try { cases h₀ ; cases h₁ ; refl ; done },
    split,
    { intro,
      cases h₀.left a with b h₂,
      cases h₁.right b with b' h₃,
      existsi b',
      apply ih_1 _ h₂ h₃, },
    { intro,
      cases h₁.left b with a h₃,
      cases h₀.right a with a' h₂,
      existsi a',
      apply ih_1 _ h₂ h₃ },
  end
  -- pSet.rec_on x $ λα A IH y, pSet.rec_on y $ λβ B _ ⟨γ, Γ⟩ ⟨αβ, βα⟩ ⟨γβ, βγ⟩,
  -- ⟨λa, let ⟨b, ab⟩ := αβ a, ⟨c, bc⟩ := βγ b in ⟨c, IH a ab bc⟩,
  --  λc, let ⟨b, cb⟩ := γβ c, ⟨a, ba⟩ := βα b in ⟨a, IH a ba cb⟩⟩

  @[symm]
  def equiv.symm {x y : pObject β} : equiv x y → equiv y x :=
  equiv.euc (equiv.refl y)

  @[trans]
  lemma equiv.trans {x y z : pObject β} (h1 : equiv x y) (h2 : equiv y z) : equiv x z :=
  equiv.euc h1 (equiv.symm h2)

  instance setoid : setoid (pObject β) :=
  ⟨equiv, equiv.refl, λx y, equiv.symm, λx y z, equiv.trans⟩

  inductive subset : pSet β → pSet β → Prop
  | sets {x y : pSet β}
      : (∀ a,∃ b, equiv (x.func a) (y.func b)) →
        subset x y

  instance : has_subset (pSet β) := ⟨pSet.subset⟩

  section
  open interactive tactic.interactive interactive.types lean.parser

  meta def unfold_coes (l : parse location) : tactic unit :=
  unfold [`coe,`lift_t,`has_lift_t.lift,`coe_t,`has_coe_t.coe,`coe_b,`has_coe.coe] l

  meta def unfold_lift_set (xs : parse (many ident)) (l : parse location) : tactic unit :=
  do unfold (`coe_set::xs) l { fail_if_unchanged := ff },
     unfold_coes l,
     unfold xs l { fail_if_unchanged := ff }

  end

  run_cmd add_interactive [`unfold_lift_set]

  def equiv.ext : Π (x y : pSet β), equiv (↑ x) (↑ y) ↔ (x ⊆ y ∧ y ⊆ x) :=
  begin
    intros x y, split, cases x ; cases y ; try { intro h, cases h, done },
    cases property, cases property_1,
    unfold_lift_set equiv, simp, intros h₀ h₁,
    split ; apply subset.sets,
    { apply h₀,  },
    { revert h₁, introv_mono _, apply equiv.symm },
    { simp, intros h₀ h₁,
      rw [← mk_type_func x,← mk_type_func y],
      unfold_lift_set mk equiv,
      split ; [ cases h₀, cases h₁ ],
      { assumption },
      { revert a, introv_mono b, apply equiv.symm } },
  end

  @[trans]
  lemma subset.trans {x y z : pSet β} : x ⊆ y → y ⊆ z → x ⊆ z :=
  begin
    intros h₀ h₁,
    rw [← mk_type_func x,← mk_type_func y,← mk_type_func x,← mk_type_func y,← mk_type_func z] at *,
    cases h₀ with _ _ h₂,
    { cases h₁ with _ _ h₃,  constructor,
      intro i,
      cases h₂ i with j h₂,
      cases h₃ j with k h₃,
      existsi k, transitivity ; assumption },
  end

  def subset.congr_left : Π {x y z : pSet β}, equiv (↑ x) (↑ y) → (x ⊆ z ↔ y ⊆ z) :=
  begin
    introv h₀,
    cases (equiv.ext _ _).mp h₀ with h₁ h₂,
    split ; intros h₃ ; transitivity ; assumption,
  end

  def subset.congr_right : Π {x y z : pSet β}, equiv ↑x ↑y → (z ⊆ x ↔ z ⊆ y) :=
  begin
    introv h₀,
    cases (equiv.ext _ _).mp h₀ with h₁ h₂,
    split ; intros h₃ ; transitivity ; assumption,
  end

  inductive mem  : pObject β → pSet β → Prop
  | intro x (y : pSet β) (b : y.type) : equiv x (y.func b) → mem x y

  -- def mem : pSet β → pSet β → Prop
  -- | x (pSet.mk b B) := ∃b, equiv x (B b)
  -- | x (pSet.atom y) := false

  instance : has_mem (pObject.{u} β) (pSet.{v} β) := ⟨mem⟩

  def mem_def {α α': Type u} (A : α → pObject.{u} β) (A' : α' → pObject.{u} β)  (a' : α')
  : A' a' ∈ mk α A ↔ (∃ a, equiv (A' a') (A a)) :=
  begin
    split ; intro h,
    { cases h with x _ _ h, exact ⟨_,h⟩ },
    { cases h with x h, apply mem.intro, apply h }
  end

  def mem.mk {α: Type u} (A : α → pObject β) (a : α) : A a ∈ mk α A :=
  show mem (A a) (mk α A), by { apply mem.intro, refl }

  def mem.ext {x y : pSet.{v} β}
    (h : ∀w:pObject.{u} β, w ∈ x ↔ w ∈ y)
  : equiv ↑x ↑y :=
  begin
    revert x, apply @pSet.rec _ _ _,
    revert y, apply @pSet.rec _ _ _,
    intros a A b B h,
    unfold_lift_set mk subtype.val equiv,
    split,
    { intro c,
      rw [← mem_def,← h],
      apply mem.mk },
    { intro c,
      specialize h (A c),
      rw mem_def at h,
      apply exists_imp_exists _ (h.mpr _),
      { intro, apply equiv.symm },
      apply mem.mk }
  end

  def 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, equiv.trans ha hb⟩,
     λ⟨b, hb⟩, let ⟨a, ha⟩ := βα b in ⟨a, equiv.euc hb ha⟩⟩

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

  def to_set (u : pSet.{u}) : set pSet.{u} := {x | x ∈ u}

  def equiv.eq {x y : pSet} (h : equiv x y) : to_set x = to_set y :=
  set.ext (λz, mem.congr_right h)

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

  protected def empty : pSet := ⟨ulift empty, λe, match e with end⟩

  instance : has_emptyc pSet := ⟨pSet.empty⟩

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

  protected def insert : pSet → pSet → pSet
  | u ⟨α, A⟩ := ⟨option α, λo, option.rec u A o⟩

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

  def of_nat : ℕ → pSet
  | 0     := ∅
  | (n+1) := pSet.insert (of_nat n) (of_nat n)

  def omega : pSet := ⟨ulift ℕ, λn, of_nat n.down⟩

  protected def sep (p : set pSet) : pSet → pSet
  | ⟨α, A⟩ := ⟨{a // p (A a)}, λx, A x.1⟩

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

  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⟩⟩⟩

  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⟩, equiv.trans yb bc⟩⟩

  def image (f : pSet.{u} → pSet.{u}) : pSet.{u} → pSet
  | ⟨α, A⟩ := ⟨α, λa, f (A a)⟩

  def 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, equiv.trans yz (H za)⟩⟩

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

  prefix ⇑ := pSet.lift

  def embed : pSet.{max (u+1) v} := ⟨ulift.{v u+1} pSet, λ⟨x⟩, pSet.lift.{u (max (u+1) v)} x⟩

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

  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)

  def resp (n) := { x : arity pSet.{u} n // arity.equiv x x }

  def resp.f {n} (f : resp (n+1)) (x : pSet) : resp n :=
  ⟨f.1 x, f.2 _ _ $ equiv.refl x⟩

  def resp.equiv {n} (a b : resp n) : Prop := arity.equiv a.1 b.1

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

  def 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 := equiv.euc hab hcb
  | (n+1) a b c hab hcb := by delta resp.equiv; simp[arity.equiv]; exact λ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

def Set : Type (u+1) := quotient pSet.setoid.{u}

namespace pSet
  namespace resp
    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))⟩

    def eval (n) : resp n → arity Set.{u} n := eval_aux.1

    @[simp] def eval_val {n f x} : (@eval (n+1) f : Set → arity Set n) ⟦x⟧ = eval n (resp.f f x) := rfl
  end resp

  inductive definable (n) : arity Set.{u} n → Type (u+1)
  | mk (f) : definable (resp.eval _ f)
  attribute [class] definable
  attribute [instance] definable.mk

  def definable.eq_mk {n} (f) : Π {s : arity Set.{u} n} (H : resp.eval _ f = s), definable n s
  | ._ rfl := ⟨f⟩

  def definable.resp {n} : Π (s : arity Set.{u} n) [definable n s], resp n
  | ._ ⟨f⟩ := f

  def 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
  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.refl _⟩ (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],
        intros x y h,
        rw @quotient.sound pSet _ _ _ h,
        exact (definable.resp (F ⟦y⟧)).2 },
      exact funext (λq, quotient.induction_on q $ λx,
        by simp[resp.f]; exact @definable.eq _ (F ⟦x⟧) (I ⟦x⟧))
    end
    local attribute [instance] prop_decidable
end classical

namespace Set
  open pSet

  def mem : Set → Set → Prop :=
  quotient.lift₂ pSet.mem
    (λx y x' y' hx hy, propext (iff.trans (mem.congr_left hx) (mem.congr_right hy)))

  instance : has_mem Set Set := ⟨mem⟩

  def to_set (u : Set.{u}) : set Set.{u} := {x | x ∈ u}

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

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

  instance has_subset' : has_subset (quotient pSet.setoid) := Set.has_subset

  theorem subset_iff : Π (x y : pSet), ⟦x⟧ ⊆ ⟦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, equiv.trans za ab⟩)⟩

  def 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⟧)))

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

  def empty : Set := ⟦∅⟧
  instance : has_emptyc Set.{u} := ⟨empty⟩
  instance : inhabited Set := ⟨∅⟩

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

  def eq_empty (x : Set.{u}) : x = ∅ ↔ ∀y:Set.{u}, y ∉ x :=
  ⟨λh, by rw h; exact mem_empty,
  λh, ext (λy, ⟨λyx, absurd yx (h y), λy0, absurd y0 (mem_empty _)⟩)⟩

  protected def insert : Set.{u} → Set.{u} → Set.{u} :=
  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⟩

  @[simp] def 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 ∈ mk (option α) (λo, option.rec y A o) ↔ ⟦x⟧ = ⟦y⟧ ∨ x ∈ 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_singleton' {x y : Set.{u}} : x ∈ @insert Set.{u} Set.{u} _ y ∅ ↔ x = y := mem_singleton

  -- It looks better when you print it, but I can't get the {y, z} notation to typecheck
  @[simp] theorem mem_pair {x y z : Set.{u}} : x ∈ (insert z (@insert Set.{u} Set.{u} _ y ∅)) ↔ (x = y ∨ x = z) :=
  iff.trans mem_insert $ iff.trans or.comm $ let m := @mem_singleton x y in ⟨or.imp_left m.1, or.imp_left m.2⟩

  def omega : Set := ⟦omega⟧

  @[simp] theorem omega_zero : (∅:Set.{u}) ∈ omega.{u} :=
  show pSet.mem ∅ pSet.omega, from ⟨⟨0⟩, equiv.refl _⟩

  @[simp] theorem omega_succ {n : Set.{u}} : 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⟩)

  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⟩⟩)

  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} : y ∈ powerset x ↔ y ⊆ x :=
  quotient.induction_on₂ x y (λ⟨α, A⟩ ⟨β, B⟩,
    show (⟨β, B⟩ : pSet) ∈ (pSet.powerset ⟨α, A⟩) ↔ _,
      by rw [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
      ginduction A a with ea γ Γ,
      ginduction B b with eb δ Δ,
      rw [ea, eb] at hb,
      cases hb with γδ δγ,
      exact
      let c : type (A a) := c, ⟨d, hd⟩ := γδ (by rwa ea at c) in
      have 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

  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, equiv.symm hc⟩)) a) (λb hb, ⟨b, equiv.symm hb⟩)⟩⟩

  notation `⋃` := Union

  @[simp] theorem mem_Union {x y : Set.{u}} : y ∈ Union x ↔ ∃ z:Set.{u}, ∃_: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 (@insert Set.{u} _ _ x ∅) = x :=
  ext $ λy, by simp; exact ⟨λ⟨z, zx, yz⟩, by subst z; exact yz, λyx, ⟨x, by simp, yx⟩⟩

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

  protected def union (x y : Set.{u}) : Set.{u} := -- ⋃ {x, y}
  Set.Union (@insert Set _ _ y (insert x ∅))
  protected def inter (x y : Set.{u}) : Set.{u} := -- {z ∈ x | z ∈ y}
  Set.sep (λz, z ∈ y) x
  protected def diff (x y : Set.{u}) : Set.{u} := -- {z ∈ x | z ∉ y}
  Set.sep (λz, z ∉ y) x

  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

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

  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)⟩

  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)⟩

  def 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] def 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⟩

  def pair (x y : Set.{u}) : Set.{u} := -- {{x}, {x, y}}
  @insert Set.{u} _ _ (@insert Set.{u} _ _ y {x}) {insert x (∅ : Set.{u})}

  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 := by
  refine iff.trans mem_sep ⟨and.right, λe, ⟨_, e⟩⟩; exact
  let ⟨a, ax, b, bY, ze, pab⟩ := e in by rw ze; exact
  mem_powerset.2 (λu uz, mem_powerset.2 $ (mem_pair.1 uz).elim
    (λua, by rw ua; exact λv vu, by rw mem_singleton.1 vu; exact mem_union.2 (or.inl ax))
    (λuab, by rw uab; exact λv vu, (mem_pair.1 vu).elim
      (λva, by rw va; exact mem_union.2 (or.inl ax))
      (λvb, by rw vb; exact mem_union.2 (or.inr bY))))

  def 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',
    { have xx'y' := (ae (@insert Set.{u} _ _ x ∅)).1 (by simp),
      cases xx'y' with h h,
      exact singleton_inj h,
      { have m : x' ∈ insert x (∅:Set.{u}),
        { rw h, simp },
        simp at m, simp [*] } },
    refine ⟨this, _⟩,
    cases this,
    have he : y = x → y = y',
    { intro yx,
      cases yx,
      have xy'x := (ae (@insert Set.{u} _ _ y' {x})).2 (by simp),
      cases xy'x with xy'x xy'xx,
      { have y'x : y' ∈ @insert Set.{u} Set.{u} _ x ∅ := by rw ←xy'x; simp,
        simp at y'x, simp [*] },
      { have yxx := (ext_iff.2 xy'xx y').1 (by simp),
        simp at yxx, cases yxx; simp } },
    have xyxy' := (ae (@insert Set.{u} _ _ y {x})).1 (by simp),
    cases xyxy' with xyx xyy',
    { have yx := (ext_iff.2 xyx y).1 (by simp),
      simp at yx, exact he yx },
    { have yxy' := (ext_iff.2 xyy' y).1 (by simp),
      simp at yxy',
      cases yxy' with yx yy',
      exact he yx,
      assumption }
  end

  def prod : Set.{u} → Set.{u} → Set.{u} := pair_sep (λa b, true)

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

  @[simp] def 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⟩, by simp; exact ⟨a, ax, b, bY, rfl⟩⟩

  def is_func (x y f : Set.{u}) : Prop :=
  f ⊆ prod x y ∧ ∀z:Set.{u}, z ∈ x → ∃! w, pair z w ∈ f

  def funs (x y : Set.{u}) : Set.{u} :=
  {f ∈ powerset (prod x y) | is_func x y f}

  @[simp] def mem_funs {x y f : Set.{u}} : f ∈ funs x y ↔ is_func x y f :=
  by simp[funs]; exact ⟨and.left, λh, ⟨h, h.left⟩⟩

  -- 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 _

  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 by rw (t2 (f z) (image.mk _ _ zx)); exact (pair_mem_prod.1 (ss t1)).right,
  λh, ⟨λy yx, let ⟨z, zx, ze⟩ := mem_image.1 yx in by rw ←ze; exact pair_mem_prod.2 ⟨zx, h z zx⟩,
       λz, map_unique⟩⟩

end Set

def Class := set Set

namespace Class
  instance has_mem_Set_Class : has_mem Set Class := ⟨set.mem⟩
  instance : has_subset Class     := ⟨set.subset⟩
  instance : has_sep Set Class    := ⟨set.sep⟩
  instance : has_emptyc Class     := ⟨λ a, false⟩
  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⟩

  def of_Set (x : Set.{u}) : Class.{u} := {y | y ∈ x}
  instance : has_coe Set Class := ⟨of_Set⟩

  def univ : Class := set.univ

  def to_Set (p : Set.{u} → Prop) (A : Class.{u}) : Prop := ∃x, ↑x = A ∧ p x

  protected def mem (A B : Class.{u}) : Prop := to_Set.{u} (λx, x ∈ 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 _

  def Cong_to_Class (x : set Class.{u}) : Class.{u} := {y | ↑y ∈ x}
  def Class_to_Cong (x : Class.{u}) : set Class.{u} := {y | y ∈ x}

  def powerset (x : Class) : Class := Cong_to_Class (set.powerset x)
  notation `𝒫` := powerset

  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 z ∈ (x : Class.{u}) ↔ z ∈ (y : Class.{u}); simp [*]

  @[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 ↔ x ∈ A :=
  to_Set_of_Set _ _

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

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

  @[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, show _ ↔ false, by simp; exact 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 _ (iff.symm Set.mem_Union); exact
  ⟨λ⟨._, ⟨a, rfl, ax⟩, za⟩, ⟨a, ax, za⟩, λ⟨a, ax, za⟩, ⟨_, ⟨a, rfl, ax⟩, za⟩⟩

  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, ⟨∅, by simp; exact set.ext (λz, ⟨false.rec _, λ⟨._, ⟨x, rfl, H⟩, zA⟩, hn ⟨x, H⟩⟩)⟩)

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

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

namespace Set
  @[simp] def 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 simp; exact
    ⟨λ⟨w, wz, pr⟩, let ⟨wy, fw⟩ := Set.pair_inj pr in by rw[←fw, wy],
    λe, by cases e; exact ⟨_, h, rfl⟩⟩)

  variables (x : Set.{u}) (h : (∅:Set.{u}) ∉ x)
  noncomputable def choice : Set := @map (λy, classical.epsilon (λz, z ∈ y)) (classical.all_definable _) x

  include h
  def 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⟩)

  def choice_is_func : is_func x (Union x) (choice x) :=
  (@map_is_func _ (classical.all_definable _) _ _).2 $ λy yx, by simp; exact ⟨y, yx, choice_mem_aux x h y yx⟩

  def choice_mem (y : Set.{u}) (yx : y ∈ x) : (choice x ′ y : Class.{u}) ∈ (y : Class.{u}) :=
  by delta choice; rw map_fval yx; simp[choice_mem_aux x h y yx]
end Set


/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau

! This file was ported from Lean 3 source module linear_algebra.adic_completion
! leanprover-community/mathlib commit 2bbc7e3884ba234309d2a43b19144105a753292e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.GeomSum
import Mathbin.LinearAlgebra.Smodeq
import Mathbin.RingTheory.JacobsonIdeal

/-!
# Completion of a module with respect to an ideal.

In this file we define the notions of Hausdorff, precomplete, and complete for an `R`-module `M`
with respect to an ideal `I`:

## Main definitions

- `is_Hausdorff I M`: this says that the intersection of `I^n M` is `0`.
- `is_precomplete I M`: this says that every Cauchy sequence converges.
- `is_adic_complete I M`: this says that `M` is Hausdorff and precomplete.
- `Hausdorffification I M`: this is the universal Hausdorff module with a map from `M`.
- `completion I M`: if `I` is finitely generated, then this is the universal complete module (TODO)
  with a map from `M`. This map is injective iff `M` is Hausdorff and surjective iff `M` is
  precomplete.

-/

open Submodule

variable {R : Type _} [CommRing R] (I : Ideal R)

variable (M : Type _) [AddCommGroup M] [Module R M]

variable {N : Type _} [AddCommGroup N] [Module R N]

/-- A module `M` is Hausdorff with respect to an ideal `I` if `⋂ I^n M = 0`. -/
class IsHausdorff : Prop where
  haus' : ∀ x : M, (∀ n : ℕ, x ≡ 0 [SMOD (I ^ n • ⊤ : Submodule R M)]) → x = 0
#align is_Hausdorff IsHausdorff

/-- A module `M` is precomplete with respect to an ideal `I` if every Cauchy sequence converges. -/
class IsPrecomplete : Prop where
  prec' :
    ∀ f : ℕ → M,
      (∀ {m n}, m ≤ n → f m ≡ f n [SMOD (I ^ m • ⊤ : Submodule R M)]) →
        ∃ L : M, ∀ n, f n ≡ L [SMOD (I ^ n • ⊤ : Submodule R M)]
#align is_precomplete IsPrecomplete

/-- A module `M` is `I`-adically complete if it is Hausdorff and precomplete. -/
class IsAdicComplete extends IsHausdorff I M, IsPrecomplete I M : Prop
#align is_adic_complete IsAdicComplete

variable {I M}

theorem IsHausdorff.haus (h : IsHausdorff I M) :
    ∀ x : M, (∀ n : ℕ, x ≡ 0 [SMOD (I ^ n • ⊤ : Submodule R M)]) → x = 0 :=
  IsHausdorff.haus'
#align is_Hausdorff.haus IsHausdorff.haus

theorem isHausdorff_iff :
    IsHausdorff I M ↔ ∀ x : M, (∀ n : ℕ, x ≡ 0 [SMOD (I ^ n • ⊤ : Submodule R M)]) → x = 0 :=
  ⟨IsHausdorff.haus, fun h => ⟨h⟩⟩
#align is_Hausdorff_iff isHausdorff_iff

theorem IsPrecomplete.prec (h : IsPrecomplete I M) {f : ℕ → M} :
    (∀ {m n}, m ≤ n → f m ≡ f n [SMOD (I ^ m • ⊤ : Submodule R M)]) →
      ∃ L : M, ∀ n, f n ≡ L [SMOD (I ^ n • ⊤ : Submodule R M)] :=
  IsPrecomplete.prec' _
#align is_precomplete.prec IsPrecomplete.prec

theorem isPrecomplete_iff :
    IsPrecomplete I M ↔
      ∀ f : ℕ → M,
        (∀ {m n}, m ≤ n → f m ≡ f n [SMOD (I ^ m • ⊤ : Submodule R M)]) →
          ∃ L : M, ∀ n, f n ≡ L [SMOD (I ^ n • ⊤ : Submodule R M)] :=
  ⟨fun h => h.1, fun h => ⟨h⟩⟩
#align is_precomplete_iff isPrecomplete_iff

variable (I M)

/-- The Hausdorffification of a module with respect to an ideal. -/
@[reducible]
def Hausdorffification : Type _ :=
  M ⧸ (⨅ n : ℕ, I ^ n • ⊤ : Submodule R M)
#align Hausdorffification Hausdorffification

/-- The completion of a module with respect to an ideal. This is not necessarily Hausdorff.
In fact, this is only complete if the ideal is finitely generated. -/
def adicCompletion : Submodule R (∀ n : ℕ, M ⧸ (I ^ n • ⊤ : Submodule R M))
    where
  carrier :=
    { f |
      ∀ {m n} (h : m ≤ n),
        liftQ _ (mkQ _)
            (by
              rw [ker_mkq]
              exact smul_mono (Ideal.pow_le_pow h) le_rfl)
            (f n) =
          f m }
  zero_mem' m n hmn := by rw [Pi.zero_apply, Pi.zero_apply, LinearMap.map_zero]
  add_mem' f g hf hg m n hmn := by
    rw [Pi.add_apply, Pi.add_apply, LinearMap.map_add, hf hmn, hg hmn]
  smul_mem' c f hf m n hmn := by rw [Pi.smul_apply, Pi.smul_apply, LinearMap.map_smul, hf hmn]
#align adic_completion adicCompletion

namespace IsHausdorff

instance bot : IsHausdorff (⊥ : Ideal R) M :=
  ⟨fun x hx => by simpa only [pow_one ⊥, bot_smul, SModEq.bot] using hx 1⟩
#align is_Hausdorff.bot IsHausdorff.bot

variable {M}

protected theorem subsingleton (h : IsHausdorff (⊤ : Ideal R) M) : Subsingleton M :=
  ⟨fun x y =>
    eq_of_sub_eq_zero <|
      h.haus (x - y) fun n => by
        rw [Ideal.top_pow, top_smul]
        exact SModEq.top⟩
#align is_Hausdorff.subsingleton IsHausdorff.subsingleton

variable (M)

instance (priority := 100) of_subsingleton [Subsingleton M] : IsHausdorff I M :=
  ⟨fun x _ => Subsingleton.elim _ _⟩
#align is_Hausdorff.of_subsingleton IsHausdorff.of_subsingleton

variable {I M}

theorem infᵢ_pow_smul (h : IsHausdorff I M) : (⨅ n : ℕ, I ^ n • ⊤ : Submodule R M) = ⊥ :=
  eq_bot_iff.2 fun x hx =>
    (mem_bot _).2 <| h.haus x fun n => SModEq.zero.2 <| (mem_infᵢ fun n : ℕ => I ^ n • ⊤).1 hx n
#align is_Hausdorff.infi_pow_smul IsHausdorff.infᵢ_pow_smul

end IsHausdorff

namespace Hausdorffification

/-- The canonical linear map to the Hausdorffification. -/
def of : M →ₗ[R] Hausdorffification I M :=
  mkQ _
#align Hausdorffification.of Hausdorffification.of

variable {I M}

@[elab_as_elim]
theorem induction_on {C : Hausdorffification I M → Prop} (x : Hausdorffification I M)
    (ih : ∀ x, C (of I M x)) : C x :=
  Quotient.inductionOn' x ih
#align Hausdorffification.induction_on Hausdorffification.induction_on

variable (I M)

instance : IsHausdorff I (Hausdorffification I M) :=
  ⟨fun x =>
    Quotient.inductionOn' x fun x hx =>
      (Quotient.mk_eq_zero _).2 <|
        (mem_infᵢ _).2 fun n =>
          by
          have := comap_map_mkq (⨅ n : ℕ, I ^ n • ⊤ : Submodule R M) (I ^ n • ⊤)
          simp only [sup_of_le_right (infᵢ_le (fun n => (I ^ n • ⊤ : Submodule R M)) n)] at this
          rw [← this, map_smul'', mem_comap, Submodule.map_top, range_mkq, ← SModEq.zero];
          exact hx n⟩

variable {M} [h : IsHausdorff I N]

include h

/-- universal property of Hausdorffification: any linear map to a Hausdorff module extends to a
unique map from the Hausdorffification. -/
def lift (f : M →ₗ[R] N) : Hausdorffification I M →ₗ[R] N :=
  liftQ _ f <|
    map_le_iff_le_comap.1 <|
      h.infᵢ_pow_smul ▸
        le_infᵢ fun n =>
          le_trans (map_mono <| infᵢ_le _ n) <|
            by
            rw [map_smul'']
            exact smul_mono le_rfl le_top
#align Hausdorffification.lift Hausdorffification.lift

theorem lift_of (f : M →ₗ[R] N) (x : M) : lift I f (of I M x) = f x :=
  rfl
#align Hausdorffification.lift_of Hausdorffification.lift_of

theorem lift_comp_of (f : M →ₗ[R] N) : (lift I f).comp (of I M) = f :=
  LinearMap.ext fun _ => rfl
#align Hausdorffification.lift_comp_of Hausdorffification.lift_comp_of

/-- Uniqueness of lift. -/
theorem lift_eq (f : M →ₗ[R] N) (g : Hausdorffification I M →ₗ[R] N) (hg : g.comp (of I M) = f) :
    g = lift I f :=
  LinearMap.ext fun x => induction_on x fun x => by rw [lift_of, ← hg, LinearMap.comp_apply]
#align Hausdorffification.lift_eq Hausdorffification.lift_eq

end Hausdorffification

namespace IsPrecomplete

instance bot : IsPrecomplete (⊥ : Ideal R) M :=
  by
  refine' ⟨fun f hf => ⟨f 1, fun n => _⟩⟩; cases n
  · rw [pow_zero, Ideal.one_eq_top, top_smul]
    exact SModEq.top
  specialize hf (Nat.le_add_left 1 n)
  rw [pow_one, bot_smul, SModEq.bot] at hf; rw [hf]
#align is_precomplete.bot IsPrecomplete.bot

instance top : IsPrecomplete (⊤ : Ideal R) M :=
  ⟨fun f hf =>
    ⟨0, fun n => by
      rw [Ideal.top_pow, top_smul]
      exact SModEq.top⟩⟩
#align is_precomplete.top IsPrecomplete.top

instance (priority := 100) of_subsingleton [Subsingleton M] : IsPrecomplete I M :=
  ⟨fun f hf => ⟨0, fun n => by rw [Subsingleton.elim (f n) 0]⟩⟩
#align is_precomplete.of_subsingleton IsPrecomplete.of_subsingleton

end IsPrecomplete

namespace adicCompletion

/-- The canonical linear map to the completion. -/
def of : M →ₗ[R] adicCompletion I M
    where
  toFun x := ⟨fun n => mkQ _ x, fun m n hmn => rfl⟩
  map_add' x y := rfl
  map_smul' c x := rfl
#align adic_completion.of adicCompletion.of

@[simp]
theorem of_apply (x : M) (n : ℕ) : (of I M x).1 n = mkQ _ x :=
  rfl
#align adic_completion.of_apply adicCompletion.of_apply

/-- Linearly evaluating a sequence in the completion at a given input. -/
def eval (n : ℕ) : adicCompletion I M →ₗ[R] M ⧸ (I ^ n • ⊤ : Submodule R M)
    where
  toFun f := f.1 n
  map_add' f g := rfl
  map_smul' c f := rfl
#align adic_completion.eval adicCompletion.eval

@[simp]
theorem coe_eval (n : ℕ) :
    (eval I M n : adicCompletion I M → M ⧸ (I ^ n • ⊤ : Submodule R M)) = fun f => f.1 n :=
  rfl
#align adic_completion.coe_eval adicCompletion.coe_eval

theorem eval_apply (n : ℕ) (f : adicCompletion I M) : eval I M n f = f.1 n :=
  rfl
#align adic_completion.eval_apply adicCompletion.eval_apply

theorem eval_of (n : ℕ) (x : M) : eval I M n (of I M x) = mkQ _ x :=
  rfl
#align adic_completion.eval_of adicCompletion.eval_of

@[simp]
theorem eval_comp_of (n : ℕ) : (eval I M n).comp (of I M) = mkQ _ :=
  rfl
#align adic_completion.eval_comp_of adicCompletion.eval_comp_of

@[simp]
theorem range_eval (n : ℕ) : (eval I M n).range = ⊤ :=
  LinearMap.range_eq_top.2 fun x => Quotient.inductionOn' x fun x => ⟨of I M x, rfl⟩
#align adic_completion.range_eval adicCompletion.range_eval

variable {I M}

@[ext]
theorem ext {x y : adicCompletion I M} (h : ∀ n, eval I M n x = eval I M n y) : x = y :=
  Subtype.eq <| funext h
#align adic_completion.ext adicCompletion.ext

variable (I M)

instance : IsHausdorff I (adicCompletion I M) :=
  ⟨fun x hx =>
    ext fun n =>
      smul_induction_on (SModEq.zero.1 <| hx n)
        (fun r hr x _ =>
          ((eval I M n).map_smul r x).symm ▸
            Quotient.inductionOn' (eval I M n x) fun x => SModEq.zero.2 <| smul_mem_smul hr mem_top)
        fun _ _ ih1 ih2 => by rw [LinearMap.map_add, ih1, ih2, LinearMap.map_zero, add_zero]⟩

end adicCompletion

namespace IsAdicComplete

instance bot : IsAdicComplete (⊥ : Ideal R) M where
#align is_adic_complete.bot IsAdicComplete.bot

protected theorem subsingleton (h : IsAdicComplete (⊤ : Ideal R) M) : Subsingleton M :=
  h.1.Subsingleton
#align is_adic_complete.subsingleton IsAdicComplete.subsingleton

instance (priority := 100) of_subsingleton [Subsingleton M] : IsAdicComplete I M where
#align is_adic_complete.of_subsingleton IsAdicComplete.of_subsingleton

open BigOperators

open Finset

theorem le_jacobson_bot [IsAdicComplete I R] : I ≤ (⊥ : Ideal R).jacobson :=
  by
  intro x hx
  rw [← Ideal.neg_mem_iff, Ideal.mem_jacobson_bot]
  intro y
  rw [add_comm]
  let f : ℕ → R := fun n => ∑ i in range n, (x * y) ^ i
  have hf : ∀ m n, m ≤ n → f m ≡ f n [SMOD I ^ m • (⊤ : Submodule R R)] :=
    by
    intro m n h
    simp only [f, Algebra.id.smul_eq_mul, Ideal.mul_top, SModEq.sub_mem]
    rw [← add_tsub_cancel_of_le h, Finset.sum_range_add, ← sub_sub, sub_self, zero_sub, neg_mem_iff]
    apply Submodule.sum_mem
    intro n hn
    rw [mul_pow, pow_add, mul_assoc]
    exact Ideal.mul_mem_right _ (I ^ m) (Ideal.pow_mem_pow hx m)
  obtain ⟨L, hL⟩ := IsPrecomplete.prec to_is_precomplete hf
  · rw [isUnit_iff_exists_inv]
    use L
    rw [← sub_eq_zero, neg_mul]
    apply IsHausdorff.haus (to_is_Hausdorff : IsHausdorff I R)
    intro n
    specialize hL n
    rw [SModEq.sub_mem, Algebra.id.smul_eq_mul, Ideal.mul_top] at hL⊢
    rw [sub_zero]
    suffices (1 - x * y) * f n - 1 ∈ I ^ n
      by
      convert Ideal.sub_mem _ this (Ideal.mul_mem_left _ (1 + -(x * y)) hL) using 1
      ring
    cases n
    · simp only [Ideal.one_eq_top, pow_zero]
    · dsimp [f]
      rw [← neg_sub _ (1 : R), neg_mul, mul_geom_sum, neg_sub, sub_sub, add_comm, ← sub_sub,
        sub_self, zero_sub, neg_mem_iff, mul_pow]
      exact Ideal.mul_mem_right _ (I ^ _) (Ideal.pow_mem_pow hx _)
#align is_adic_complete.le_jacobson_bot IsAdicComplete.le_jacobson_bot

end IsAdicComplete


/-
Copyright (c) 2020 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.group_theory.perm.basic
import Mathlib.data.fintype.basic
import Mathlib.group_theory.subgroup
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# Lemmas about subgroups within the permutations (self-equivalences) of a type `α`

This file provides extra lemmas about some `subgroup`s that exist within `equiv.perm α`.
`group_theory.subgroup` depends on `group_theory.perm.basic`, so these need to be in a separate
file.
-/

namespace equiv

namespace perm

@[simp] theorem sum_congr_hom.card_range {α : Type u_1} {β : Type u_2}
    [fintype ↥(monoid_hom.range (sum_congr_hom α β))] [fintype (perm α × perm β)] :
    fintype.card ↥(monoid_hom.range (sum_congr_hom α β)) = fintype.card (perm α × perm β) :=
  iff.mpr fintype.card_eq
    (Nonempty.intro (equiv.symm (set.range (⇑(sum_congr_hom α β)) sum_congr_hom_injective)))

@[simp] theorem sigma_congr_right_hom.card_range {α : Type u_1} {β : α → Type u_2}
    [fintype ↥(monoid_hom.range (sigma_congr_right_hom β))] [fintype ((a : α) → perm (β a))] :
    fintype.card ↥(monoid_hom.range (sigma_congr_right_hom β)) =
        fintype.card ((a : α) → perm (β a)) :=
  iff.mpr fintype.card_eq
    (Nonempty.intro
      (equiv.symm (set.range (⇑(sigma_congr_right_hom β)) sigma_congr_right_hom_injective)))

end Mathlib


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import set_theory.game.short

/-!
# Games described via "the state of the board".

We provide a simple mechanism for constructing combinatorial (pre-)games, by describing
"the state of the board", and providing an upper bound on the number of turns remaining.

## Implementation notes

We're very careful to produce a computable definition, so small games can be evaluated
using `dec_trivial`. To achieve this, I've had to rely solely on induction on natural numbers:
relying on general well-foundedness seems to be poisonous to computation?

See `set_theory/game/domineering` for an example using this construction.
-/

universe u

namespace pgame

/--
`pgame_state S` describes how to interpret `s : S` as a state of a combinatorial game.
Use `pgame.of s` or `game.of s` to construct the game.

`pgame_state.L : S → finset S` and `pgame_state.R : S → finset S` describe the states reachable
by a move by Left or Right. `pgame_state.turn_bound : S → ℕ` gives an upper bound on the number of
possible turns remaining from this state.
-/
class state (S : Type u) :=
(turn_bound : S → ℕ)
(L : S → finset S)
(R : S → finset S)
(left_bound : ∀ {s t : S} (m : t ∈ L s), turn_bound t < turn_bound s)
(right_bound : ∀ {s t : S} (m : t ∈ R s), turn_bound t < turn_bound s)

open state

variables {S : Type u} [state S]

lemma turn_bound_ne_zero_of_left_move {s t : S} (m : t ∈ L s) : turn_bound s ≠ 0 :=
begin
  intro h,
  have t := state.left_bound m,
  rw h at t,
  exact nat.not_succ_le_zero _ t,
end
lemma turn_bound_ne_zero_of_right_move {s t : S} (m : t ∈ R s) : turn_bound s ≠ 0 :=
begin
  intro h,
  have t := state.right_bound m,
  rw h at t,
  exact nat.not_succ_le_zero _ t,
end

lemma turn_bound_of_left {s t : S} (m : t ∈ L s) (n : ℕ) (h : turn_bound s ≤ n + 1) :
  turn_bound t ≤ n :=
nat.le_of_lt_succ (nat.lt_of_lt_of_le (left_bound m) h)
lemma turn_bound_of_right {s t : S} (m : t ∈ R s) (n : ℕ) (h : turn_bound s ≤ n + 1) :
  turn_bound t ≤ n :=
nat.le_of_lt_succ (nat.lt_of_lt_of_le (right_bound m) h)

/--
Construct a `pgame` from a state and a (not necessarily optimal) bound on the number of
turns remaining.
-/
def of_aux : Π (n : ℕ) (s : S) (h : turn_bound s ≤ n), pgame
| 0 s h     := pgame.mk {t // t ∈ L s} {t // t ∈ R s}
    (λ t, begin exfalso, exact turn_bound_ne_zero_of_left_move t.2 (nonpos_iff_eq_zero.mp h) end)
    (λ t, begin exfalso, exact turn_bound_ne_zero_of_right_move t.2 (nonpos_iff_eq_zero.mp h) end)
| (n+1) s h :=
  pgame.mk {t // t ∈ L s} {t // t ∈ R s}
    (λ t, of_aux n t (turn_bound_of_left t.2 n h))
    (λ t, of_aux n t (turn_bound_of_right t.2 n h))

/-- Two different (valid) turn bounds give equivalent games. -/
def of_aux_relabelling : Π (s : S) (n m : ℕ) (hn : turn_bound s ≤ n) (hm : turn_bound s ≤ m),
  relabelling (of_aux n s hn) (of_aux m s hm)
| s 0 0 hn hm :=
  begin
    dsimp [pgame.of_aux],
    fsplit, refl, refl,
    { intro i, dsimp at i, exfalso,
      exact turn_bound_ne_zero_of_left_move i.2 (nonpos_iff_eq_zero.mp hn) },
    { intro j, dsimp at j, exfalso,
      exact turn_bound_ne_zero_of_right_move j.2 (nonpos_iff_eq_zero.mp hm) }
  end
| s 0 (m+1) hn hm :=
  begin
    dsimp [pgame.of_aux],
    fsplit, refl, refl,
    { intro i, dsimp at i, exfalso,
      exact turn_bound_ne_zero_of_left_move i.2 (nonpos_iff_eq_zero.mp hn) },
    { intro j, dsimp at j, exfalso,
      exact turn_bound_ne_zero_of_right_move j.2 (nonpos_iff_eq_zero.mp hn) }
  end
| s (n+1) 0 hn hm :=
  begin
    dsimp [pgame.of_aux],
    fsplit, refl, refl,
    { intro i, dsimp at i, exfalso,
      exact turn_bound_ne_zero_of_left_move i.2 (nonpos_iff_eq_zero.mp hm) },
    { intro j, dsimp at j, exfalso,
      exact turn_bound_ne_zero_of_right_move j.2 (nonpos_iff_eq_zero.mp hm) }
  end
| s (n+1) (m+1) hn hm :=
  begin
    dsimp [pgame.of_aux],
    fsplit, refl, refl,
    { intro i,
      apply of_aux_relabelling, },
    { intro j,
      apply of_aux_relabelling, }
  end

/-- Construct a combinatorial `pgame` from a state. -/
def of (s : S) : pgame := of_aux (turn_bound s) s (refl _)

/--
The equivalence between `left_moves` for a `pgame` constructed using `of_aux _ s _`, and `L s`.
-/
def left_moves_of_aux (n : ℕ) {s : S} (h : turn_bound s ≤ n) :
  left_moves (of_aux n s h) ≃ {t // t ∈ L s} :=
by induction n; refl
/--
The equivalence between `left_moves` for a `pgame` constructed using `of s`, and `L s`.
-/
def left_moves_of (s : S) : left_moves (of s) ≃ {t // t ∈ L s} :=
left_moves_of_aux _ _
/--
The equivalence between `right_moves` for a `pgame` constructed using `of_aux _ s _`, and `R s`.
-/
def right_moves_of_aux (n : ℕ) {s : S} (h : turn_bound s ≤ n) :
  right_moves (of_aux n s h) ≃ {t // t ∈ R s} :=
by induction n; refl
/-- The equivalence between `right_moves` for a `pgame` constructed using `of s`, and `R s`. -/
def right_moves_of (s : S) : right_moves (of s) ≃ {t // t ∈ R s} :=
right_moves_of_aux _ _

/--
The relabelling showing `move_left` applied to a game constructed using `of_aux`
has itself been constructed using `of_aux`.
-/
def relabelling_move_left_aux (n : ℕ) {s : S} (h : turn_bound s ≤ n)
  (t : left_moves (of_aux n s h)) :
  relabelling
    (move_left (of_aux n s h) t)
    (of_aux (n-1) (((left_moves_of_aux n h) t) : S)
      ((turn_bound_of_left ((left_moves_of_aux n h) t).2 (n-1)
        (nat.le_trans h (nat.le_sub_add n 1))))) :=
begin
  induction n,
  { have t' := (left_moves_of_aux 0 h) t,
    exfalso, exact turn_bound_ne_zero_of_left_move t'.2 (nonpos_iff_eq_zero.mp h), },
  { refl },
end
/--
The relabelling showing `move_left` applied to a game constructed using `of`
has itself been constructed using `of`.
-/
def relabelling_move_left (s : S) (t : left_moves (of s)) :
  relabelling
    (move_left (of s) t)
    (of (((left_moves_of s).to_fun t) : S)) :=
begin
  transitivity,
  apply relabelling_move_left_aux,
  apply of_aux_relabelling,
end
/--
The relabelling showing `move_right` applied to a game constructed using `of_aux`
has itself been constructed using `of_aux`.
-/
def relabelling_move_right_aux (n : ℕ) {s : S} (h : turn_bound s ≤ n)
  (t : right_moves (of_aux n s h)) :
  relabelling
    (move_right (of_aux n s h) t)
    (of_aux (n-1) (((right_moves_of_aux n h) t) : S)
      ((turn_bound_of_right ((right_moves_of_aux n h) t).2 (n-1)
        (nat.le_trans h (nat.le_sub_add n 1))))) :=
begin
  induction n,
  { have t' := (right_moves_of_aux 0 h) t,
    exfalso, exact turn_bound_ne_zero_of_right_move t'.2 (nonpos_iff_eq_zero.mp h), },
  { refl },
end
/--
The relabelling showing `move_right` applied to a game constructed using `of`
has itself been constructed using `of`.
-/
def relabelling_move_right (s : S) (t : right_moves (of s)) :
  relabelling
    (move_right (of s) t)
    (of (((right_moves_of s).to_fun t) : S)) :=
begin
  transitivity,
  apply relabelling_move_right_aux,
  apply of_aux_relabelling,
end

instance fintype_left_moves_of_aux (n : ℕ) (s : S) (h : turn_bound s ≤ n) :
  fintype (left_moves (of_aux n s h)) :=
begin
  apply fintype.of_equiv _ (left_moves_of_aux _ _).symm,
  apply_instance,
end
instance fintype_right_moves_of_aux (n : ℕ) (s : S) (h : turn_bound s ≤ n) :
  fintype (right_moves (of_aux n s h)) :=
begin
  apply fintype.of_equiv _ (right_moves_of_aux _ _).symm,
  apply_instance,
end

instance short_of_aux : Π (n : ℕ) {s : S} (h : turn_bound s ≤ n), short (of_aux n s h)
| 0 s h :=
  short.mk'
  (λ i, begin
    have i := (left_moves_of_aux _ _).to_fun i,
    exfalso,
    exact turn_bound_ne_zero_of_left_move i.2 (nonpos_iff_eq_zero.mp h),
  end)
  (λ j, begin
    have j := (right_moves_of_aux _ _).to_fun j,
    exfalso,
    exact turn_bound_ne_zero_of_right_move j.2 (nonpos_iff_eq_zero.mp h),
  end)
| (n+1) s h :=
  short.mk'
  (λ i, short_of_relabelling (relabelling_move_left_aux (n+1) h i).symm (short_of_aux n _))
  (λ j, short_of_relabelling (relabelling_move_right_aux (n+1) h j).symm (short_of_aux n _))

instance short_of (s : S) : short (of s) :=
begin
  dsimp [pgame.of],
  apply_instance
end

end pgame

namespace game

/-- Construct a combinatorial `game` from a state. -/
def of {S : Type u} [pgame.state S] (s : S) : game := ⟦pgame.of s⟧

end game