import set_theory.surreal
import tactic
open pgame
namespace pgame

universe u

/-- An explicit description of the moves for Left in `x * y`. -/
def left_moves_mul {x y : pgame.{u}} : (x * y).left_moves
  ≃ x.left_moves × y.left_moves ⊕ x.right_moves × y.right_moves :=
by { cases x, cases y, refl, }

/-- An explicit description of the moves for Right in `x * y`. -/
def right_moves_mul {x y : pgame.{u}} : (x * y).right_moves
  ≃ x.left_moves × y.right_moves ⊕ x.right_moves × y.left_moves :=
by { cases x, cases y, refl, }

@[simp] lemma mk_mul_move_left_inl {xl xr yl yr} {xL xR yL yR} {i j} :
  (mk xl xr xL xR * mk yl yr yL yR).move_left (sum.inl (i,j))
  = xL i * (mk yl yr yL yR) + (mk xl xr xL xR) * yL j - xL i * yL j
:= rfl

@[simp] lemma mul_move_left_inl {x y : pgame.{u}} {i j} :
   (x * y).move_left ((@left_moves_mul x y).symm (sum.inl (i,j)))
   = x.move_left i * y + x * y.move_left j - x.move_left i * y.move_left j
:= by {cases x, cases y, refl}

@[simp] lemma mk_mul_move_left_inr {xl xr yl yr} {xL xR yL yR} {i j} :
  (mk xl xr xL xR * mk yl yr yL yR).move_left (sum.inr (i,j))
  = xR i * (mk yl yr yL yR) + (mk xl xr xL xR) * yR j - xR i * yR j
:= rfl

@[simp] lemma mul_move_left_inr {x y : pgame.{u}} {i j} :
   (x * y).move_left ((@left_moves_mul x y).symm (sum.inr (i,j)))
   = x.move_right i * y + x * y.move_right j - x.move_right i * y.move_right j
:= by {cases x, cases y, refl}

@[simp] lemma mk_mul_move_right_inl {xl xr yl yr} {xL xR yL yR} {i j} :
  (mk xl xr xL xR * mk yl yr yL yR).move_right (sum.inl (i,j))
  = xL i * (mk yl yr yL yR) + (mk xl xr xL xR) * yR j - xL i * yR j
:= rfl

@[simp] lemma mul_move_right_inl {x y : pgame.{u}} {i j} :
   (x * y).move_right ((@right_moves_mul x y).symm (sum.inr (i, j)))
   = x.move_right i * y + x * y.move_left j - x.move_right i * y.move_left j
:= by {cases x, cases y, refl}

@[simp] lemma mk_mul_move_right_inr {xl xr yl yr} {xL xR yL yR} {i j} :
  (mk xl xr xL xR * mk yl yr yL yR).move_right (sum.inr (i,j))
  = xR i * (mk yl yr yL yR) + (mk xl xr xL xR) * yL j - xR i * yL j
:= rfl

@[simp] lemma mul_move_right_inr {x y : pgame.{u}} {i j} :
   (x * y).move_right ((@right_moves_mul x y).symm (sum.inr (i,j)))
   = x.move_right i * y + x * y.move_left j - x.move_right i * y.move_left j
:= by {cases x, cases y, refl}

/-- If `w` has the same moves as `x` and `y` has the same moves as `z`,
then `w + y` has the same moves as `x + z`. -/
def add_congr_relabelling : ∀ {w x y z : pgame.{u}},
w.relabelling x → y.relabelling z → (w + y).relabelling (x + z)
| (mk wl wr wL wR) (mk xl xr xL xR) (mk yl yr yL yR) (mk zl zr zL zR)
  ⟨L_equiv₁, R_equiv₁, L_relabelling₁, R_relabelling₁⟩
  ⟨L_equiv₂, R_equiv₂, L_relabelling₂, R_relabelling₂⟩ :=
begin
  refine ⟨equiv.sum_congr L_equiv₁ L_equiv₂, equiv.sum_congr R_equiv₁ R_equiv₂,_,_⟩,
  { rintro (i|j),
    { exact add_congr_relabelling
        (L_relabelling₁ i)
        (⟨L_equiv₂, R_equiv₂, L_relabelling₂, R_relabelling₂⟩) },
    { exact add_congr_relabelling
        (⟨L_equiv₁, R_equiv₁, L_relabelling₁, R_relabelling₁⟩)
        (L_relabelling₂ j) }},
  { rintro (i|j),
    { exact add_congr_relabelling
        (R_relabelling₁ i)
        (⟨L_equiv₂, R_equiv₂, L_relabelling₂, R_relabelling₂⟩) },
    { exact add_congr_relabelling
        (⟨L_equiv₁, R_equiv₁, L_relabelling₁, R_relabelling₁⟩)
        (R_relabelling₂ j) }},
end
using_well_founded { dec_tac := pgame_wf_tac }

/-- If `x` has the same moves as `y`, then `-x` has the sames moves as `-y`. -/
def neg_congr_relabelling : ∀ {x y : pgame}, x.relabelling y → (-x).relabelling (-y)
| (mk xl xr xL xR) (mk yl yr yL yR) ⟨L_equiv, R_equiv, L_relabelling, R_relabelling⟩ :=
  ⟨R_equiv, L_equiv,
    λ i, neg_congr_relabelling (by simpa using R_relabelling (R_equiv i)),
    λ i, neg_congr_relabelling (by simpa using L_relabelling (L_equiv.symm i))⟩

/-- If `w` has the same moves as `x` and `y` has the same moves as `z`,
then `w - y` has the same moves as `x - z`. -/
theorem sub_congr_relabelling {w x y z : pgame}
  (h₁ : w.relabelling x) (h₂ : y.relabelling z) : (w - y).relabelling (x - z) :=
add_congr_relabelling h₁ (neg_congr_relabelling h₂)

/-- If `a` has the same moves as `x`, `b` has the same moves as `y`,
and `c` has the same moves as `z`, then `a + b - c` has the same moves as `x + y - z`. -/
lemma add_sub_relabelling {a b c x y z : pgame.{u}}
  (h₁ : a.relabelling x) (h₂ : b.relabelling y) (h₃ : c.relabelling z) :
  (a + b - c).relabelling (x + y - z) :=
sub_congr_relabelling (add_congr_relabelling h₁ h₂) h₃

/-- If `a` has the same moves as `x`, `b` has the same moves as `y`,
and `c` has the same moves as `z`, then `a + b - c` has the same moves as `y + x - z`. -/
lemma add_comm_sub_relabelling {a b c x y z : pgame.{u}}
  (h₁ : a.relabelling x) (h₂ : b.relabelling y) (h₃ : c.relabelling z) :
  (a + b - c).relabelling (y + x - z) :=
sub_congr_relabelling
  (relabelling.trans (add_comm_relabelling a b) (add_congr_relabelling h₂ h₁)) h₃

/-- `x * y` has exactly the same moves as `y * x`. -/
theorem mul_comm_relabelling (x y : pgame.{u}) : (x * y).relabelling (y * x):=
begin
  induction x with xl xr xL xR IHxl IHxr generalizing y,
  induction y with yl yr yL yR IHyl IHyr,
  let x := mk xl xr xL xR,
  let y := mk yl yr yL yR,
  refine ⟨equiv.sum_congr (equiv.prod_comm _ _) (equiv.prod_comm _ _), _ ,_,_⟩,
  calc
   (x * y).right_moves
       ≃ xl × yr ⊕ xr × yl : by refl
   ... ≃ xr × yl ⊕ xl × yr : equiv.sum_comm _ _
   ... ≃ yl × xr ⊕ yr × xl : equiv.sum_congr (equiv.prod_comm _ _) (equiv.prod_comm _ _)
   ... ≃ (y * x).right_moves : by refl,
  { rintro (⟨i, j⟩ | ⟨i, j⟩),
    { exact add_comm_sub_relabelling (IHxl i y) (IHyl j) (IHxl i (yL j)) },
    { exact add_comm_sub_relabelling (IHxr i y) (IHyr j) (IHxr i (yR j)) }},
  { rintro (⟨i, j⟩ | ⟨i, j⟩),
    { exact add_comm_sub_relabelling (IHxr j y) (IHyl i) (IHxr j (yL i)) },
    { exact add_comm_sub_relabelling (IHxl j y) (IHyr i) (IHxl j (yR i)) }}
end

/-- `x * y` is equivalent to `y * x`. -/
theorem mul_comm_equiv (x y : pgame) : (x * y).equiv (y * x) :=
equiv_of_relabelling (mul_comm_relabelling x y)

/-- `x * 0` has exactly the same moves as `0`. -/
theorem mul_zero_relabelling : Π (x : pgame), relabelling (x * 0) 0
| (mk xl xr xL xR) :=
⟨by fsplit; rintro (⟨_,⟨⟩⟩ | ⟨_,⟨⟩⟩),
 by fsplit; rintro (⟨_,⟨⟩⟩ | ⟨_,⟨⟩⟩),
 by rintro (⟨_,⟨⟩⟩ | ⟨_,⟨⟩⟩),
 by rintro ⟨⟩⟩

/-- `x * 0` is equivalent to `0`. -/
theorem mul_zero_equiv (x : pgame) : (x * 0).equiv 0 :=
equiv_of_relabelling (mul_zero_relabelling x)

/-- `0 * x` has exactly the same moves as `0`. -/
theorem zero_mul_relabelling : Π (x : pgame), relabelling (0 * x) 0
| (mk xl xr xL xR) :=
⟨by fsplit; rintro (⟨⟨⟩,_⟩ | ⟨⟨⟩,_⟩),
 by fsplit; rintro (⟨⟨⟩,_⟩ | ⟨⟨⟩,_⟩),
 by rintro (⟨⟨⟩,_⟩ | ⟨⟨⟩,_⟩),
 by rintro ⟨⟩⟩

/-- `0 * x` is equivalent to `0`. -/
theorem zero_mul_equiv (x : pgame) : (0 * x).equiv 0 :=
equiv_of_relabelling (zero_mul_relabelling x)

#check add_assoc_relabelling

/-- `(x + y) + z` has exactly the same moves as `x + (y + z)`. -/
def mul_assoc_relabelling : Π (x y z : pgame.{u}), relabelling ((x * y) * z) (x * (y * z))
| (mk xl xr xL xR) (mk yl yr yL yR) (mk zl zr zL zR) :=
begin
  -- refine ⟨equiv.prod_assoc _ _ _, equiv.prod_assoc _ _ _, _, _⟩,
    refine ⟨_,_,_,_⟩,
    fsplit,
    rintros (⟨(⟨i,j⟩|⟨i,j⟩),k⟩|⟨(⟨i,j⟩|⟨i,j⟩),k⟩),
    exact sum.inl (i, sum.inl (j, k)),
    exact sum.inr (i, sum.inr (j, k)),
    exact sum.inl (i, sum.inr (j, k)),
    exact sum.inr (i, sum.inl (j, k)),

    rintros (⟨i, (⟨j,k⟩|⟨j,k⟩)⟩|⟨i,(⟨j,k⟩|⟨j,k⟩)⟩),
    exact sum.inl (sum.inl (i,j), k),
    exact sum.inr (sum.inl (i, j), k),
    exact sum.inr (sum.inr (i, j), k),
    exact sum.inl (sum.inr (i, j), k),

  {tidy},
  {tidy},

  fsplit,

    rintros (⟨(⟨i,j⟩|⟨i,j⟩),k⟩|⟨(⟨i,j⟩|⟨i,j⟩),k⟩),
    exact sum.inl (i, sum.inl (j, k)),
    exact sum.inr (i, sum.inr (j, k)),
    exact sum.inl (i, sum.inr (j, k)),
    exact sum.inr (i, sum.inl (j, k)),

    rintros (⟨i, (⟨j,k⟩|⟨j,k⟩)⟩|⟨i,(⟨j,k⟩|⟨j,k⟩)⟩),
    exact sum.inl (sum.inl (i, j), k),
    exact sum.inr (sum.inl (i, j), k),
    exact sum.inr (sum.inr (i, j), k),
    exact sum.inl (sum.inr (i, j), k),

  {tidy},
  {tidy},

    rintros (⟨(⟨i,j⟩|⟨i,j⟩),k⟩|⟨(⟨i,j⟩|⟨i,j⟩),k⟩),

  dsimp,
   -- have := mul_assoc_relabelling (xL i) (yL j) (zL k),

    -- calc
    --   (xl × yl ⊕ xr × yr) × zl ⊕ (xl × yr ⊕ xr × yl) × zr
    --     ≃ xl × (yl × zl ⊕ yr × zr) ⊕ xr × (yl × zr ⊕ yr × zl) : sorry,
end
-- instance : ring surreal := { add := _,
--   add_assoc := _,
--   zero := _,
--   zero_add := _,
--   add_zero := _,
--   neg := _,
--   sub := _,
--   sub_eq_add_neg := _,
--   add_left_neg := _,
--   add_comm := _,
--   mul := _,
--   mul_assoc := _,
--   one := _,
--   one_mul := _,
--   mul_one := _,
--   left_distrib := _,
--   right_distrib := _ }

end pgame


/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Jeremy Avigad, Floris van Doorn

Additional declarations/theorems about equality. See also init.datatypes and init.logic.
-/

open eq.ops

namespace eq
  variables {A B : Type} {a a' a₁ a₂ a₃ a₄ : A}

  theorem irrel (H₁ H₂ : a = a') : H₁ = H₂ :=
  !proof_irrel

  theorem id_refl (H₁ : a = a) : H₁ = (eq.refl a) :=
  rfl

  theorem rec_on_id {B : A → Type} (H : a = a) (b : B a) : eq.rec_on H b = b :=
  rfl

  theorem rec_on_constant (H : a = a') {B : Type} (b : B) : eq.rec_on H b = b :=
  eq.drec_on H rfl

  theorem rec_on_constant2 (H₁ : a₁ = a₂) (H₂ : a₃ = a₄) (b : B) : eq.rec_on H₁ b = eq.rec_on H₂ b :=
  rec_on_constant H₁ b ⬝ (rec_on_constant H₂ b)⁻¹

  theorem rec_on_irrel_arg {f : A → B} {D : B → Type} (H : a = a') (H' : f a = f a') (b : D (f a)) :
                       eq.rec_on H b = eq.rec_on H' b :=
  eq.drec_on H (λ(H' : f a = f a), !rec_on_id⁻¹) H'

  theorem rec_on_irrel {a a' : A} {D : A → Type} (H H' : a = a') (b : D a) :
      eq.drec_on H b = eq.drec_on H' b :=
  proof_irrel H H' ▸ rfl

  theorem rec_on_comp {a b c : A} {P : A → Type} (H₁ : a = b) (H₂ : b = c)
          (u : P a) : eq.rec_on H₂ (eq.rec_on H₁ u) = eq.rec_on (trans H₁ H₂) u :=
    (show ∀ H₂ : b = c, eq.rec_on H₂ (eq.rec_on H₁ u) = eq.rec_on (trans H₁ H₂) u,
      from eq.drec_on H₂ (take (H₂ : b = b), rec_on_id H₂ _))
    H₂
end eq

open eq

section
  variables {A B C D E F : Type}
  variables {a a' : A} {b b' : B} {c c' : C} {d d' : D} {e e' : E}

  theorem congr_arg2 (f : A → B → C) (Ha : a = a') (Hb : b = b') : f a b = f a' b' :=
  by substvars

  theorem congr_arg3 (f : A → B → C → D) (Ha : a = a') (Hb : b = b') (Hc : c = c')
      : f a b c = f a' b' c' :=
  by substvars

  theorem congr_arg4 (f : A → B → C → D → E) (Ha : a = a') (Hb : b = b') (Hc : c = c') (Hd : d = d')
      : f a b c d = f a' b' c' d' :=
  by substvars

  theorem congr_arg5 (f : A → B → C → D → E → F)
      (Ha : a = a') (Hb : b = b') (Hc : c = c') (Hd : d = d') (He : e = e')
        : f a b c d e = f a' b' c' d' e' :=
  by substvars

  theorem congr2 (f f' : A → B → C) (Hf : f = f') (Ha : a = a') (Hb : b = b') : f a b = f' a' b' :=
  by substvars

  theorem congr3 (f f' : A → B → C → D) (Hf : f = f') (Ha : a = a') (Hb : b = b') (Hc : c = c')
      : f a b c = f' a' b' c' :=
  by substvars

  theorem congr4 (f f' : A → B → C → D → E)
      (Hf : f = f') (Ha : a = a') (Hb : b = b') (Hc : c = c') (Hd : d = d')
        : f a b c d = f' a' b' c' d' :=
  by substvars

  theorem congr5 (f f' : A → B → C → D → E → F)
      (Hf : f = f') (Ha : a = a') (Hb : b = b') (Hc : c = c') (Hd : d = d') (He : e = e')
        : f a b c d e = f' a' b' c' d' e' :=
  by substvars
end

theorem equal_f {A : Type} {B : A → Type} {f g : Π x, B x} (H : f = g) : ∀x, f x = g x :=
take x, congr_fun H x

section
  variables {a b c : Prop}

  theorem eqmp (H₁ : a = b) (H₂ : a) : b :=
  H₁ ▸ H₂

  theorem eqmpr (H₁ : a = b) (H₂ : b) : a :=
  H₁⁻¹ ▸ H₂

  theorem imp_trans (H₁ : a → b) (H₂ : b → c) : a → c :=
  assume Ha, H₂ (H₁ Ha)

  theorem imp_eq_trans (H₁ : a → b) (H₂ : b = c) : a → c :=
  assume Ha, H₂ ▸ (H₁ Ha)

  theorem eq_imp_trans (H₁ : a = b) (H₂ : b → c) : a → c :=
  assume Ha, H₂ (H₁ ▸ Ha)
end


import Src.Prover.Set

namespace prover
noncomputable section

theorem empty_intro {a} (h : ∀ b, b ∉ a) : empty a :=
λ h₁ => exi_elim h₁ # λ b h₂ => h b h₂

theorem not_mem_of_empty {a b} (h : empty a) : b ∉ a :=
λ h₁ => h # exi_intro b h₁

theorem empty_iff {a} : empty a ↔ ∀ b, b ∉ a :=
iff_intro (λ h _ => not_mem_of_empty h) (λ h h₁ => exi_elim h₁ h)

theorem nonempty_intro {a} b (h : b ∈ a) : nonempty a :=
not_not_intro # exi_intro b h

theorem nonempty_elim {P : Prop} {a} (h₁ : nonempty a) (h₂ : ∀ b, b ∈ a → P) : P :=
exi_elim (not_not_elim h₁) h₂

theorem nonempty_iff {a} : nonempty a ↔ ∃ b, b ∈ a :=
iff_intro not_not_elim not_not_intro

theorem exi_empty : ∃ a, empty a :=
exi_elim ax_inf' # λ a h₁ => exi_elim h₁ # λ b h₂ => exi_intro b # and_left h₂

def emp : Set :=
some' exi_empty

notation (priority := high) "∅" => emp

theorem empty_emp : empty ∅ :=
some_spec exi_empty

theorem exi_nonempty : ∃ a, nonempty a :=
exi_elim ax_inf' # λ a h₁ => exi_elim h₁ # λ b h₂ => exi_intro a #
nonempty_intro b # and_left # and_right h₂

def filter (a : Set) (P : Set → Prop) : Set :=
some' # ax_spec a P

theorem mem_filter {P : Set → Prop} {a b} : b ∈ filter a P ↔ b ∈ a ∧ P b :=
some_spec (ax_spec a P) b

def pred_of_fun {α β : Type} (f : α → β) (x : α) (y : β) : Prop :=
f x = y

theorem pred_of_fun_iff {α β : Type} {f : α → β} {x : α} {y : β} :
  pred_of_fun f x y ↔ f x = y :=
iff_refl

theorem exiu_pred_of_fun {α β : Type} {f : α → β} {x : α} :
  ∃! (y : β), pred_of_fun f x y :=
exiu_intro (f x) rfl # λ y h => eq_symm h

def image_aux (a : Set) (f : Set → Set) : Set :=
some' # ax_rep a (pred_of_fun f) # λ b h => exiu_pred_of_fun

theorem mem_image_aux_of {f : Set → Set} {a b}
  (h : ∃ c, c ∈ a ∧ f c = b) : b ∈ image_aux a f :=
exi_elim h # λ c h₁ => and_elim h₁ # λ h₂ h₃ =>
exi_elim (some_spec (ax_rep a (pred_of_fun f) (λ b h => exiu_pred_of_fun)) c h₂) #
λ d h₄ => and_elim h₄ # λ h₅ h₆ =>
eq_rec' (λ x => x ∈ image_aux a f) (eq_trans (eq_symm h₃) h₆) h₅

def image (a : Set) (f : Set → Set) : Set :=
filter (image_aux a f) # λ b => ∃ c, c ∈ a ∧ f c = b

theorem mem_image {f : Set → Set} {a b} :
  b ∈ image a f ↔ ∃ c, c ∈ a ∧ f c = b :=
iff_intro
(λ h => and_right # mp mem_filter h)
(λ h => mpr mem_filter # and_intro (mem_image_aux_of h) h)

def singleton (a : Set) : Set :=
image (some' exi_nonempty) # λ b => a

theorem mem_singleton {a b} : b ∈ singleton a ↔ b = a :=
iff_intro
(λ h => exi_elim (mp mem_image h) # λ c h₁ => eq_symm # and_right h₁)
(λ h => mpr mem_image # exi_elim (mp nonempty_iff # some_spec exi_nonempty) #
  λ c h₁ => exi_intro c # and_intro h₁ # eq_symm h)

theorem mem_singleton_self {a} : a ∈ singleton a :=
mpr mem_singleton rfl

theorem nonempty_singleton {a} : nonempty (singleton a) :=
nonempty_intro a mem_singleton_self

theorem mem_irrefl {a} : a ∉ a :=
exi_elim (ax_reg nonempty_singleton) # λ b h => and_elim h # λ h₁ h₂ h₃ => h₂ #
exi_intro a # and_intro (eq_rec' (λ x => a ∈ x) (mp mem_singleton h₁) h₃)
mem_singleton_self

theorem nonempty_image {a} {f : Set → Set} : nonempty (image a f) ↔ nonempty a :=
iff_intro
(λ h => nonempty_elim h # λ b h₁ => exi_elim (mp mem_image h₁) #
  λ c h₂ => nonempty_intro c # and_left h₂)
(λ h => nonempty_elim h # λ b h₁ => nonempty_intro (f b) # mpr mem_image #
  exi_intro b # and_intro h₁ rfl)

theorem not_mem_emp {a} : a ∉ ∅ :=
not_mem_of_empty empty_emp

theorem empty_iff_eq_emp {a} : empty a ↔ a = ∅ :=
iff_intro
(λ h => ax_ext # λ b => iff_intro
  (λ h₁ => exfalso # not_mem_of_empty h h₁) (λ h₁ => exfalso # not_mem_emp h₁))
(λ h => eq_rec' empty h empty_emp)

def some_inf : Set :=
some' ax_inf'

theorem emp_mem_some_inf : ∅ ∈ some_inf :=
exi_elim (some_spec ax_inf') # λ d h =>
eq_rec (λ x => x ∈ some_inf) (mp empty_iff_eq_emp # and_left h) #
and_left # and_right h

theorem nonempty_some_inf : nonempty some_inf :=
nonempty_intro ∅ emp_mem_some_inf

theorem ne_singleton_self {a} : a ≠ singleton a :=
λ h => mem_irrefl # eq_symm h (λ x => a ∈ x) mem_singleton_self

def powerset (a : Set) : Set :=
filter (some' # ax_pow a) # λ b => b ⊆ a

theorem mem_powerset {a b} : b ∈ powerset a ↔ b ⊆ a :=
iff_intro
(λ h => and_right (!mp mem_filter h))
(λ h => mpr mem_filter # and_intro (some_spec (ax_pow a) b h) h)

theorem mem_powerset_self {a} : a ∈ powerset a :=
mpr mem_powerset subset_refl

theorem eq_iff_mem {a b} : a = b ↔ ∀ c, c ∈ a ↔ c ∈ b :=
iff_intro
(λ h c => mp eq_iff h (λ x => c ∈ x))
(λ h => ax_ext h)

theorem ne_powerset_self {a} : a ≠ powerset a :=
λ h => !mem_irrefl # mpr (mp eq_iff_mem h a) mem_powerset_self

section natural_numbers

def zero : Set := ∅

instance : OfNat Set (nat_lit 0) := ⟨zero⟩

theorem empty_zero : empty 0 :=
empty_emp

theorem not_mem_zero {a} : a ∉ 0 :=
not_mem_emp

def one : Set :=
powerset 0

instance : OfNat Set (nat_lit 1) := ⟨one⟩

theorem zero_mem_one : 0 ∈ 1 :=
mem_powerset_self

theorem nonempty_one : nonempty 1 :=
nonempty_intro 0 zero_mem_one

theorem subset_emp {a} : a ⊆ ∅ ↔ a = ∅ :=
iff_intro
(λ h => mp empty_iff_eq_emp # contra # λ h₁ => nonempty_elim (mp not_empty h₁) #
  λ b h₂ => not_mem_emp # h b h₂)
(λ h => eq_rec' (λ x => x ⊆ ∅) h subset_refl)

theorem mem_one {a} : a ∈ 1 ↔ a = 0 :=
iff_intro
(λ h => mp subset_emp # mp mem_powerset h)
(λ h => eq_rec' (λ x => x ∈ 1) h zero_mem_one)

def two : Set :=
powerset 1

instance : OfNat Set (nat_lit 2) := ⟨two⟩

theorem emp_subset {a} : ∅ ⊆ a :=
λ b h => exfalso # not_mem_emp h

theorem emp_mem_powerset {a} : emp ∈ powerset a :=
mpr mem_powerset emp_subset

theorem zero_mem_two : 0 ∈ 2 :=
emp_mem_powerset

theorem one_mem_two : 1 ∈ 2 :=
mpr mem_powerset subset_refl

theorem zero_ne_one : (0 : Set) ≠ 1 :=
λ h => mem_irrefl # mpr (mp eq_iff h (λ x => 0 ∈ x)) zero_mem_one

theorem zero_ne_two : (0 : Set) ≠ 2 :=
λ h => mem_irrefl # mpr (mp eq_iff h (λ x => 0 ∈ x)) zero_mem_two

theorem one_ne_two : (1 : Set) ≠ 2 :=
λ h => mem_irrefl # mpr (mp eq_iff h (λ x => 1 ∈ x)) one_mem_two

theorem one_eq_singleton_zero : 1 = singleton 0 :=
mpr eq_iff_mem # λ a => iff_rec' (λ x => x ↔ a ∈ singleton 0) mem_one #
iff_rec' (λ x => a = 0 ↔ x) mem_singleton iff_refl

def subsingleton (a : Set) : Prop :=
∀ (b c : Set), b ∈ a → c ∈ a → b = c

theorem subsingleton_emp : subsingleton ∅ :=
λ b c h => exfalso # not_mem_emp h

theorem subsingleton_singleton {a} : subsingleton (singleton a) :=
λ b c h₁ h₂ => eq_trans (mp mem_singleton h₁) (eq_symm # mp mem_singleton h₂)

theorem subsingleton_zero : subsingleton 0 :=
subsingleton_emp

theorem subsingleton_one : subsingleton 1 :=
eq_rec' subsingleton one_eq_singleton_zero subsingleton_singleton

theorem subsingleton_iff {a} : subsingleton a ↔ a = ∅ ∨ ∃ b, a = singleton b :=
iff_intro
(λ h => by_cases (empty a)
  (λ h₁ => or_inl # mp empty_iff_eq_emp h₁)
  (λ h₁ => or_inr # nonempty_elim (mp not_empty h₁) # λ b h₂ => exi_intro b #
    mpr eq_iff_mem # λ c => iff_rec' (λ x => c ∈ a ↔ x) mem_singleton # iff_intro
      (λ h₃ => h c b h₃ h₂) (λ h₃ => eq_rec' (λ x => x ∈ a) h₃ h₂)))
(λ h => or_elim h
  (λ h₁ => eq_rec' subsingleton h₁ subsingleton_emp)
  (λ h₁ => exi_elim h₁ # λ b h₂ => eq_rec' subsingleton h₂ subsingleton_singleton))

theorem subsingleton_elim (P : Set → Prop) {a}
  (h₁ : subsingleton a) (h₂ : P ∅) (h₃ : ∀ b, P (singleton b)) : P a :=
or_elim (mp subsingleton_iff h₁)
(λ h₄ => eq_rec' P h₄ h₂)
(λ h₄ => exi_elim h₄ # λ b h₅ => eq_rec' P h₅ # h₃ b)

theorem subset_singleton {a b} : b ⊆ singleton a ↔ b = ∅ ∨ b = singleton a :=
iff_intro
(λ h => by_cases (empty b)
  (λ h₂ => or_inl # mp empty_iff_eq_emp h₂)
  (λ h₂ => or_inr # nonempty_elim (mp not_empty h₂) # λ c h₃ => mpr eq_iff_mem # λ d =>
    iff_intro (h d) # λ h₄ => eq_rec' (λ x => x ∈ b)
      (eq_trans (mp mem_singleton h₄) (eq_symm # mp mem_singleton # h c h₃)) h₃))
(λ h => or_elim h
  (λ h₁ => eq_rec' (λ x => x ⊆ singleton a) h₁ emp_subset)
  (λ h₁ => eq_rec' (λ x => x ⊆ singleton a) h₁ subset_refl))

theorem subset_of_subsingleton {a b} (h : subsingleton a) : b ⊆ a ↔ b = ∅ ∨ b = a :=
iff_intro
(λ h₁ => subsingleton_elim (λ x => b ⊆ x → b = ∅ ∨ b = x) h
  (λ h₂ => or_inl # mp subset_emp h₂) (λ c h₂ => mp subset_singleton h₂) h₁)
(λ h₁ => or_elim h₁
  (λ h₂ => eq_rec' (λ x => x ⊆ a) h₂ emp_subset)
  (λ h₂ => eq_rec' (λ x => x ⊆ a) h₂ subset_refl))

theorem mem_powerset_of_subsingleton {a b} (h : subsingleton a) :
  b ∈ powerset a ↔ b = ∅ ∨ b = a :=
iff_rec' (λ x => x ↔ b = ∅ ∨ b = a) mem_powerset # subset_of_subsingleton h

theorem mem_two {a} : a ∈ 2 ↔ a = 0 ∨ a = 1 :=
mem_powerset_of_subsingleton subsingleton_one

end natural_numbers

section unordered_pair

def upair (a b : Set) : Set :=
image some_inf # λ c => ite (empty c) a b

theorem empty_elim (P : Set → Prop) {a} (h₁ : empty a) (h₂ : P ∅) : P a :=
eq_rec' P (mp empty_iff_eq_emp h₁) h₂

theorem nonempty_upair {a b : Set} : nonempty (upair a b) :=
mpr nonempty_image # nonempty_some_inf

theorem zero_mem_some_inf : 0 ∈ some_inf :=
emp_mem_some_inf

theorem one_is_succ_zero : is_succ 1 0 :=
λ a => iff_intro (λ h => or_inr # mp mem_one h)
(λ h => or_elim h (λ h₁ => exfalso # not_mem_zero h₁) (mpr mem_one))

theorem one_mem_some_inf : 1 ∈ some_inf :=
exi_elim (some_spec ax_inf') # λ a h => and_right (and_right h) 0
zero_mem_some_inf 1 one_is_succ_zero

theorem mem_upair {a b c} : c ∈ upair a b ↔ c = a ∨ c = b :=
iff_intro
(λ h => exi_elim (mp mem_image h) # λ d h₁ => split_ifs (λ x => x = c → c = a ∨ c = b)
  (λ h₂ h₃ => or_inl # eq_symm h₃) (λ h₂ h₃ => or_inr # eq_symm h₃) # and_right h₁)
(λ h => mpr mem_image # or_elim h
  (λ h₁ => exi_intro ∅ # and_intro emp_mem_some_inf #
    eq_trans (if_pos empty_emp) (eq_symm h₁))
  (λ h₁ => exi_intro 1 # and_intro one_mem_some_inf #
    eq_rec' (λ x => ite (empty 1) a b = x) h₁ # if_neg # mpr not_empty nonempty_one))

theorem upair_comm {a b} : upair a b = upair b a :=
mpr eq_iff_mem # λ c => iff_rec' (λ x => x ↔ _) mem_upair #
iff_rec' (λ x => _ ↔ x) mem_upair or_symm'

theorem upair_self_eq {a} : upair a a = singleton a :=
mpr eq_iff_mem # λ b => iff_rec' (λ x => x ↔ _) (iff_trans mem_upair or_self) #
iff_rec' (λ x => _ ↔ x) mem_singleton iff_refl

theorem subsingleton_upair_iff {a b} : subsingleton (upair a b) ↔ a = b :=
iff_intro
(λ h => or_elim (mp subsingleton_iff h)
  (λ h₁ => exfalso # mpr not_nonempty (mpr empty_iff_eq_emp h₁) nonempty_upair)
  (λ h₁ => exi_elim h₁ # λ c h₂ => eq_trans
    (mp mem_singleton # mp (mp eq_iff_mem h₂ a) # mpr mem_upair # or_inl rfl)
    (eq_symm # mp mem_singleton # mp (mp eq_iff_mem h₂ b) #
       mpr mem_upair # or_inr rfl)))
(λ h => eq_rec' (λ x => subsingleton (upair x b)) h #
  eq_rec' subsingleton upair_self_eq subsingleton_singleton)

theorem left_mem_upair {a b} : a ∈ upair a b :=
mpr mem_upair # or_inl rfl

theorem right_mem_upair {a b} : b ∈ upair a b :=
mpr mem_upair # or_inr rfl

theorem mem_asymm {a b} (h : a ∈ b) : b ∉ a :=
λ h₁ => exi_elim (ax_reg # nonempty_intro a left_mem_upair) # λ c h₂ =>
and_elim h₂ # λ h₃ h₄ => h₄ # or_elim (mp mem_upair h₃)
  (λ h₅ => exi_intro b # and_intro (eq_rec' (λ x => b ∈ x) h₅ h₁) right_mem_upair)
  (λ h₅ => exi_intro a # and_intro (eq_rec' (λ x => a ∈ x) h₅ h) left_mem_upair)

theorem mem_antisymm {a b} (h₁ : a ∈ b) (h₂ : b ∈ a) : a = b :=
false_elim # mem_asymm h₁ h₂

theorem ne_of_mem {a b} (h : a ∈ b) : a ≠ b :=
cpos_pn h # λ h₁ => eq_rec' (λ x => x ∉ b) h₁ mem_irrefl

end unordered_pair

section ordered_pair

def pair (a b : Set) : Set :=
upair a (upair a b)

theorem nonempty_pair {a b} : nonempty (pair a b) :=
nonempty_upair

theorem not_subsingleton_pair {a b} : ¬subsingleton (pair a b) :=
λ h => not_not_intro (mp subsingleton_upair_iff h) # ne_of_mem left_mem_upair

theorem left_eq_of_pair_eq_pair {a b c d} (h : pair a b = pair c d) : a = c :=
or_elim (mp mem_upair # mp (mp eq_iff_mem h a) left_mem_upair) id #
λ h₁ => exfalso #
or_elim (mp mem_upair # mp (mp eq_iff_mem h (upair a b)) right_mem_upair)
(λ h₂ => hv (eq_rec' (λ x => c ∈ x) h₁ left_mem_upair) # λ h₃ =>
  mem_asymm h₃ # eq_rec (λ x => a ∈ x) h₂ left_mem_upair)
(λ h₂ => hv (eq_trans h₁ # eq_symm h₂) # λ h₃ =>
  mem_irrefl # eq_rec' (λ x => a ∈ x) h₃ left_mem_upair)

theorem right_eq_of_pair_eq_pair {a b c d} (h : pair a b = pair c d) : b = d :=
hv (left_eq_of_pair_eq_pair h) # λ h₁ =>
or_elim (mp mem_upair # mp (mp eq_iff_mem h # upair a b) right_mem_upair)
(λ h₂ => exfalso # mem_irrefl #
  eq_rec' (λ x => a ∈ x) (eq_trans h₁ # eq_symm h₂) left_mem_upair)
(λ h₂ => hv (mp (iff_rec (λ x => x ↔ _) mem_upair # mp eq_iff_mem h₂ b) # or_inr rfl) #
  λ h₃ => or_elim (or_symm # mp mem_upair h₃) id #
  λ h₄ => hv (eq_rec (λ x => upair c x = _) h₄ # eq_rec (λ x => upair x b = _) h₁ h₂) #
  λ h₆ => hv (eq_rec (λ x => upair c d = x) upair_self_eq # eq_symm h₆) #
  λ h₇ => eq_trans h₄ # mp subsingleton_upair_iff #
  eq_rec' subsingleton h₇ subsingleton_singleton)

theorem eq_and_eq_of_pair_eq_pair {a b c d} (h : pair a b = pair c d) : a = c ∧ b = d :=
and_intro (left_eq_of_pair_eq_pair h) (right_eq_of_pair_eq_pair h)

theorem pair_ext {a b c d} : pair a b = pair c d ↔ a = c ∧ b = d :=
iff_intro eq_and_eq_of_pair_eq_pair #
λ h₁ => eq_rec' (λ x => pair x b = pair c d) (and_left h₁) #
eq_rec' (λ x => pair c x = pair c d) (and_right h₁) rfl

def fst (a : Set) : Set :=
some # λ b => ∃ c, a = pair b c

def snd (a : Set) : Set :=
some # λ b => ∃ c, a = pair c b

theorem fst_eq {a b} : fst (pair a b) = a :=
exi_elim (some_spec (exi_intro a # exi_intro b rfl : ∃ c d, pair a b = pair c d)) #
λ c h => eq_symm # left_eq_of_pair_eq_pair h

theorem snd_eq {a b} : snd (pair a b) = b :=
exi_elim (some_spec (exi_intro b # exi_intro a rfl : ∃ c d, pair a b = pair d c)) #
λ c h => eq_symm # right_eq_of_pair_eq_pair h

end ordered_pair