import tactic
import prefixes
import games

open list set

noncomputable theory
open_locale classical

-- We need to assume α is nonempty to construct the strategy
variables {α β : Type*} [inhabited α] {G : game α β} (σ : quasi_strategy G)

def choice_map (f : β → set α) : β → α :=
λ b, if h : (f b).nonempty then h.some else inhabited.default

lemma choice_map_def (f : β → set α) : ∀ b, (f  b).nonempty → choice_map f b ∈ f b :=
begin
  intros b hfb,
  simp [choice_map, hfb],
  exact hfb.some_mem,
end

def strategy_map_of_quasi_strategy : list α → α :=
  choice_map (λ t, {a | t.concat a ∈ σ.positions})

lemma strategy_map_of_quasi_strategy_def :
  ∀ t ∈ σ.positions, concat t (strategy_map_of_quasi_strategy σ t) ∈ σ.positions :=
begin
  intros t tpos,
  change strategy_map_of_quasi_strategy σ t ∈ {a | t.concat a ∈ σ.positions},
  unfold strategy_map_of_quasi_strategy,
  apply choice_map_def,
  by_cases G.turn t = σ.player,
  { exact (σ.is_quasi_strategy t tpos).1 h, },
  use inhabited.default,
  exact (σ.is_quasi_strategy t tpos).2 h inhabited.default,
end

def level_by_level_subtree_of_quasi_strategy :
  ℕ → set (list α)
| 0     := λ t, t ∈ σ.positions ∧ t = nil
| (n+1) := λ t, t ∈ σ.positions
                ∧ (t.init ∈ σ.positions
                    → t.init ∈ level_by_level_subtree_of_quasi_strategy n)
                ∧ (t.init ∈ σ.positions → G.turn t.init = σ.player
                    → t.ilast = strategy_map_of_quasi_strategy σ t.init)

def subtree_of_quasi_strategy : set (list α) :=
  ⋃ n, level_by_level_subtree_of_quasi_strategy σ n

lemma subtree_of_quasi_strategy_def {G : game α β} {σ : quasi_strategy G} {t : list α} :
  t ∈ subtree_of_quasi_strategy σ ↔ t ∈ level_by_level_subtree_of_quasi_strategy σ t.length :=
begin
  unfold subtree_of_quasi_strategy,
  rw mem_Union,
  refine ⟨_, λ h, ⟨t.length, h⟩⟩,
  induction h : t.length generalizing t,
  { rw eq_nil_of_length_eq_zero h,
    rintros ⟨k, hk⟩,
    cases k,
    exact hk,
    use [hk.1, rfl], },
  rintros ⟨k, hk⟩,
  cases k,
  { rw hk.2 at h, contradiction, },
  by_cases hinit : t.init ∈ σ.positions,
  { have : t.init.length = n,
    { change t.init.length = n.succ - 1,
      rw ← h,
      apply length_init, },
    use hk.1,
    split,
    { intros _, exact ih this ⟨k, (hk.2.1 hinit)⟩, },
    intros _ h, exact hk.2.2 hinit h, },
  use hk.1,
  split; intros contra; contradiction,
end

lemma position_of_position_subtree {t : list α} :
  t ∈ subtree_of_quasi_strategy σ → t ∈ σ.positions :=
begin
  rw subtree_of_quasi_strategy_def,
  cases t with h t,
  { exact λ h, h.1, },
  exact λ h, h.1,
end

lemma list.init_concat : ∀ (l : list α) (a : α), (l.concat a).init = l
| [] a := rfl
| [x] a := rfl
| (x :: y :: l) a := by simp [init]

lemma list.ilast_concat : ∀ (l : list α) (a : α), (l.concat a).ilast = a
| [] a := rfl
| [x] a := rfl
| [x, y] a := rfl
| [x, y, z] a := rfl
| (x :: y :: z :: l) a := by {  simp [ilast],
                                rw [← cons_append, ← concat_append, append_nil],
                                apply list.ilast_concat, }

lemma list.nil_of_prefix_init {l : list α} : l <+: l.init → l = nil :=
begin
  intros h,
  apply eq_nil_of_length_eq_zero,
  have := h.length_le,
  rw l.length_init at this,
  linarith,
end

instance strategy_of_quasi_strategy : quasi_strategy G :=
{ player := σ.player,
  positions := subtree_of_quasi_strategy σ,
  is_quasi_strategy :=
  begin
    intros t ht,
    rw subtree_of_quasi_strategy_def at ht,
    -- Didn't need induction, just two cases
    cases h : t,
    { rw h at ht,
      split,
      { intros turn,
        use strategy_map_of_quasi_strategy σ nil,
        rw subtree_of_quasi_strategy_def,
        use strategy_map_of_quasi_strategy_def σ nil ht.1,
        split,
        { intros _,
          change nil ∈ level_by_level_subtree_of_quasi_strategy σ 0,
          use [ht.1, rfl], },
        intros _ _,
        exact rfl, },
      intros turn a,
      rw subtree_of_quasi_strategy_def,
      use [(σ.is_quasi_strategy nil ht.1).2 turn a],
      split,
      { intros _,
        change nil ∈ level_by_level_subtree_of_quasi_strategy σ 0,
        use [ht.1, rfl], },
      intros _ contra,
      exfalso,
      change game.turn nil = _ at contra,
      exact turn contra, },
    have hn : t.length = tl.length + 1,
    { rw h, simp, },
    rw ← h,
    rw hn at ht,
    rcases ht with ⟨ht, ⟨tinit, tplay⟩⟩,
    split,
    { intros turn,
      use strategy_map_of_quasi_strategy σ t,
      rw subtree_of_quasi_strategy_def,
      simp only [length_concat],
      use strategy_map_of_quasi_strategy_def σ t ht,
      rw list.init_concat,
      split,
      { intros _,
        rw hn,
        unfold level_by_level_subtree_of_quasi_strategy,
        use [ht, tinit, tplay], },
      intros _ _,
      rw list.ilast_concat, },
    intros turn a,
    rw subtree_of_quasi_strategy_def,
    simp only [length_concat],
    unfold level_by_level_subtree_of_quasi_strategy,
    use [(σ.is_quasi_strategy t ht).2 turn a],
    rw list.init_concat,
    split,
    { intros _,
      rw hn,
      unfold level_by_level_subtree_of_quasi_strategy,
      use [ht, tinit, tplay], },
    intros _ contra,
    exfalso,
    exact turn contra,
  end }

theorem is_strategy_of_quasi_strategy :
  is_strategy (strategy_of_quasi_strategy σ) :=
begin
  intros t tpos tturn,
  use strategy_map_of_quasi_strategy σ t,
  split,
  { change t.concat (strategy_map_of_quasi_strategy σ t) ∈ (subtree_of_quasi_strategy σ),
    rw subtree_of_quasi_strategy_def,
    simp only [length_concat],
    split,
    { apply strategy_map_of_quasi_strategy_def,
      apply position_of_position_subtree,
      exact tpos, },
    split,
    { intros _,
      rw list.init_concat,
      rw ← subtree_of_quasi_strategy_def,
      exact tpos, },
    intros _ _,
    rw [list.ilast_concat, list.init_concat], },
  intros a tapos,
  change t.concat a ∈ subtree_of_quasi_strategy σ at tapos,
  rw [subtree_of_quasi_strategy_def, length_concat] at tapos,
  rcases tapos with ⟨_, ⟨_, h⟩⟩,
  rw [list.init_concat, list.ilast_concat] at h,
  exact h (position_of_position_subtree σ tpos) tturn,
end

lemma in_subtree_of_quasi_strategy (s : list α) :
  s ∈ σ.positions ∧ (s ≠ nil → s.init ∉ σ.positions) → s ∈ subtree_of_quasi_strategy σ :=
begin
  rintros ⟨hs, hsinit⟩,
  rw subtree_of_quasi_strategy_def,
  cases s,
  { use hs, },
  use hs,
  have : s_hd :: s_tl ≠ nil,
  { simp, },
  have hsinit := hsinit this,
  split,
  { intros contra, contradiction, },
  intros contra, contradiction,
end

lemma s_strategy_of_s_quasi_strategy (s : list α) :
  s_quasi_strategy σ s → s_quasi_strategy (strategy_of_quasi_strategy σ) s :=
begin
  intros hs,
  split,
  { apply in_subtree_of_quasi_strategy,
    use hs.1,
    contrapose!,
    intros hsinit,
    exact list.nil_of_prefix_init (hs.2 s.init hsinit), },
  intros t tpos,
  have : t ∈ σ.positions,
  { apply position_of_position_subtree σ tpos, },
  exact hs.2 t this,
end

variables (X : (ℕ → α) → β)

theorem winning_strategy_of_winning_quasi_strategy :
  winning σ X → winning (strategy_of_quasi_strategy σ) X :=
begin
  intros winning,
  intros f fplay,
  change X f = σ.player,
  apply winning f,
  cases fplay with N hN,
  use N,
  intros n hn,
  apply position_of_position_subtree,
  exact hN n hn,
end


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Gabriel Ebner

! This file was ported from Lean 3 source module data.int.cast.basic
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Int.Cast.Defs
import Mathbin.Algebra.Group.Basic

/-!
# Cast of integers (additional theorems)

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This file proves additional properties about the *canonical* homomorphism from
the integers into an additive group with a one (`int.cast`).

There is also `data.int.cast.lemmas`,
which includes lemmas stated in terms of algebraic homomorphisms,
and results involving the order structure of `ℤ`.

By contrast, this file's only import beyond `data.int.cast.defs` is `algebra.group.basic`.
-/

universe u

namespace Nat

variable {R : Type u} [AddGroupWithOne R]

@[simp, norm_cast]
theorem cast_sub {m n} (h : m ≤ n) : ((n - m : ℕ) : R) = n - m :=
  eq_sub_of_add_eq <| by rw [← cast_add, Nat.sub_add_cancel h]
#align nat.cast_sub Nat.cast_subₓ

/- warning: nat.cast_pred -> Nat.cast_pred is a dubious translation:
lean 3 declaration is
  forall {R : Type.{u1}} [_inst_1 : AddGroupWithOne.{u1} R] {n : Nat}, (LT.lt.{0} Nat Nat.hasLt (OfNat.ofNat.{0} Nat 0 (OfNat.mk.{0} Nat 0 (Zero.zero.{0} Nat Nat.hasZero))) n) -> (Eq.{succ u1} R ((fun (a : Type) (b : Type.{u1}) [self : HasLiftT.{1, succ u1} a b] => self.0) Nat R (HasLiftT.mk.{1, succ u1} Nat R (CoeTCₓ.coe.{1, succ u1} Nat R (Nat.castCoe.{u1} R (AddMonoidWithOne.toNatCast.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R _inst_1))))) (HSub.hSub.{0, 0, 0} Nat Nat Nat (instHSub.{0} Nat Nat.hasSub) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) (HSub.hSub.{u1, u1, u1} R R R (instHSub.{u1} R (SubNegMonoid.toHasSub.{u1} R (AddGroup.toSubNegMonoid.{u1} R (AddGroupWithOne.toAddGroup.{u1} R _inst_1)))) ((fun (a : Type) (b : Type.{u1}) [self : HasLiftT.{1, succ u1} a b] => self.0) Nat R (HasLiftT.mk.{1, succ u1} Nat R (CoeTCₓ.coe.{1, succ u1} Nat R (Nat.castCoe.{u1} R (AddMonoidWithOne.toNatCast.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R _inst_1))))) n) (OfNat.ofNat.{u1} R 1 (OfNat.mk.{u1} R 1 (One.one.{u1} R (AddMonoidWithOne.toOne.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R _inst_1)))))))
but is expected to have type
  forall {R : Type.{u1}} [_inst_1 : AddGroupWithOne.{u1} R] {n : Nat}, (LT.lt.{0} Nat instLTNat (OfNat.ofNat.{0} Nat 0 (instOfNatNat 0)) n) -> (Eq.{succ u1} R (Nat.cast.{u1} R (AddMonoidWithOne.toNatCast.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R _inst_1)) (HSub.hSub.{0, 0, 0} Nat Nat Nat (instHSub.{0} Nat instSubNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) (HSub.hSub.{u1, u1, u1} R R R (instHSub.{u1} R (AddGroupWithOne.toSub.{u1} R _inst_1)) (Nat.cast.{u1} R (AddMonoidWithOne.toNatCast.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R _inst_1)) n) (OfNat.ofNat.{u1} R 1 (One.toOfNat1.{u1} R (AddMonoidWithOne.toOne.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R _inst_1))))))
Case conversion may be inaccurate. Consider using '#align nat.cast_pred Nat.cast_predₓ'. -/
@[simp, norm_cast]
theorem cast_pred : ∀ {n}, 0 < n → ((n - 1 : ℕ) : R) = n - 1
  | 0, h => by cases h
  | n + 1, h => by rw [cast_succ, add_sub_cancel] <;> rfl
#align nat.cast_pred Nat.cast_pred

end Nat

open Nat

namespace Int

variable {R : Type u} [AddGroupWithOne R]

@[simp]
theorem cast_negSucc (n : ℕ) : (-[n+1] : R) = -(n + 1 : ℕ) :=
  AddGroupWithOne.intCast_negSucc n
#align int.cast_neg_succ_of_nat Int.cast_negSuccₓ

@[simp, norm_cast]
theorem cast_zero : ((0 : ℤ) : R) = 0 :=
  (cast_ofNat 0).trans Nat.cast_zero
#align int.cast_zero Int.cast_zeroₓ

@[simp, norm_cast]
theorem cast_ofNat (n : ℕ) : ((n : ℤ) : R) = n :=
  cast_ofNat _
#align int.cast_coe_nat Int.cast_ofNatₓ

@[simp, norm_cast]
theorem cast_one : ((1 : ℤ) : R) = 1 :=
  show (((1 : ℕ) : ℤ) : R) = 1 by simp
#align int.cast_one Int.cast_oneₓ

@[simp, norm_cast]
theorem cast_neg : ∀ n, ((-n : ℤ) : R) = -n
  | (0 : ℕ) => by erw [cast_zero, neg_zero]
  | (n + 1 : ℕ) => by erw [cast_of_nat, cast_neg_succ_of_nat] <;> rfl
  | -[n+1] => by erw [cast_of_nat, cast_neg_succ_of_nat, neg_neg]
#align int.cast_neg Int.cast_negₓ

@[simp]
theorem cast_subNatNat (m n) : ((Int.subNatNat m n : ℤ) : R) = m - n :=
  by
  unfold sub_nat_nat; cases e : n - m
  · simp only [sub_nat_nat, cast_of_nat]
    simp [e, Nat.le_of_sub_eq_zero e]
  ·
    rw [sub_nat_nat, cast_neg_succ_of_nat, Nat.add_one, ← e,
      Nat.cast_sub <| _root_.le_of_lt <| Nat.lt_of_sub_eq_succ e, neg_sub]
#align int.cast_sub_nat_nat Int.cast_subNatNatₓ

#print Int.negOfNat_eq /-
theorem negOfNat_eq (n : ℕ) : negOfNat n = -(n : ℤ) := by cases n <;> rfl
#align int.neg_of_nat_eq Int.negOfNat_eq
-/

/- warning: int.cast_neg_of_nat -> Int.cast_negOfNat is a dubious translation:
lean 3 declaration is
  forall {R : Type.{u1}} [_inst_1 : AddGroupWithOne.{u1} R] (n : Nat), Eq.{succ u1} R ((fun (a : Type) (b : Type.{u1}) [self : HasLiftT.{1, succ u1} a b] => self.0) Int R (HasLiftT.mk.{1, succ u1} Int R (CoeTCₓ.coe.{1, succ u1} Int R (Int.castCoe.{u1} R (AddGroupWithOne.toHasIntCast.{u1} R _inst_1)))) (Int.negOfNat n)) (Neg.neg.{u1} R (SubNegMonoid.toHasNeg.{u1} R (AddGroup.toSubNegMonoid.{u1} R (AddGroupWithOne.toAddGroup.{u1} R _inst_1))) ((fun (a : Type) (b : Type.{u1}) [self : HasLiftT.{1, succ u1} a b] => self.0) Nat R (HasLiftT.mk.{1, succ u1} Nat R (CoeTCₓ.coe.{1, succ u1} Nat R (Nat.castCoe.{u1} R (AddMonoidWithOne.toNatCast.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R _inst_1))))) n))
but is expected to have type
  forall {R : Type.{u1}} [_inst_1 : AddGroupWithOne.{u1} R] (n : Nat), Eq.{succ u1} R (Int.cast.{u1} R (AddGroupWithOne.toIntCast.{u1} R _inst_1) (Int.negOfNat n)) (Neg.neg.{u1} R (AddGroupWithOne.toNeg.{u1} R _inst_1) (Nat.cast.{u1} R (AddMonoidWithOne.toNatCast.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R _inst_1)) n))
Case conversion may be inaccurate. Consider using '#align int.cast_neg_of_nat Int.cast_negOfNatₓ'. -/
@[simp]
theorem cast_negOfNat (n : ℕ) : ((negOfNat n : ℤ) : R) = -n := by simp [neg_of_nat_eq]
#align int.cast_neg_of_nat Int.cast_negOfNat

@[simp, norm_cast]
theorem cast_add : ∀ m n, ((m + n : ℤ) : R) = m + n
  | (m : ℕ), (n : ℕ) => by simp [← Int.ofNat_add]
  | (m : ℕ), -[n+1] => by erw [cast_sub_nat_nat, cast_coe_nat, cast_neg_succ_of_nat, sub_eq_add_neg]
  | -[m+1], (n : ℕ) => by
    erw [cast_sub_nat_nat, cast_coe_nat, cast_neg_succ_of_nat, sub_eq_iff_eq_add, add_assoc,
      eq_neg_add_iff_add_eq, ← Nat.cast_add, ← Nat.cast_add, Nat.add_comm]
  | -[m+1], -[n+1] =>
    show (-[m + n + 1+1] : R) = _ by
      rw [cast_neg_succ_of_nat, cast_neg_succ_of_nat, cast_neg_succ_of_nat, ← neg_add_rev, ←
        Nat.cast_add, Nat.add_right_comm m n 1, Nat.add_assoc, Nat.add_comm]
#align int.cast_add Int.cast_addₓ

@[simp, norm_cast]
theorem cast_sub (m n) : ((m - n : ℤ) : R) = m - n := by simp [Int.sub_eq_add_neg, sub_eq_add_neg]
#align int.cast_sub Int.cast_subₓ

#print Int.ofNat_bit0 /-
@[simp, norm_cast]
theorem ofNat_bit0 (n : ℕ) : (↑(bit0 n) : ℤ) = bit0 ↑n :=
  rfl
#align int.coe_nat_bit0 Int.ofNat_bit0
-/

#print Int.ofNat_bit1 /-
@[simp, norm_cast]
theorem ofNat_bit1 (n : ℕ) : (↑(bit1 n) : ℤ) = bit1 ↑n :=
  rfl
#align int.coe_nat_bit1 Int.ofNat_bit1
-/

/- warning: int.cast_bit0 -> Int.cast_bit0 is a dubious translation:
lean 3 declaration is
  forall {R : Type.{u1}} [_inst_1 : AddGroupWithOne.{u1} R] (n : Int), Eq.{succ u1} R ((fun (a : Type) (b : Type.{u1}) [self : HasLiftT.{1, succ u1} a b] => self.0) Int R (HasLiftT.mk.{1, succ u1} Int R (CoeTCₓ.coe.{1, succ u1} Int R (Int.castCoe.{u1} R (AddGroupWithOne.toHasIntCast.{u1} R _inst_1)))) (bit0.{0} Int Int.hasAdd n)) (bit0.{u1} R (AddZeroClass.toHasAdd.{u1} R (AddMonoid.toAddZeroClass.{u1} R (AddMonoidWithOne.toAddMonoid.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R _inst_1)))) ((fun (a : Type) (b : Type.{u1}) [self : HasLiftT.{1, succ u1} a b] => self.0) Int R (HasLiftT.mk.{1, succ u1} Int R (CoeTCₓ.coe.{1, succ u1} Int R (Int.castCoe.{u1} R (AddGroupWithOne.toHasIntCast.{u1} R _inst_1)))) n))
but is expected to have type
  forall {R : Type.{u1}} [_inst_1 : AddGroupWithOne.{u1} R] (n : Int), Eq.{succ u1} R (Int.cast.{u1} R (AddGroupWithOne.toIntCast.{u1} R _inst_1) (bit0.{0} Int Int.instAddInt n)) (bit0.{u1} R (AddZeroClass.toAdd.{u1} R (AddMonoid.toAddZeroClass.{u1} R (AddMonoidWithOne.toAddMonoid.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R _inst_1)))) (Int.cast.{u1} R (AddGroupWithOne.toIntCast.{u1} R _inst_1) n))
Case conversion may be inaccurate. Consider using '#align int.cast_bit0 Int.cast_bit0ₓ'. -/
@[simp, norm_cast]
theorem cast_bit0 (n : ℤ) : ((bit0 n : ℤ) : R) = bit0 n :=
  cast_add _ _
#align int.cast_bit0 Int.cast_bit0

/- warning: int.cast_bit1 -> Int.cast_bit1 is a dubious translation:
lean 3 declaration is
  forall {R : Type.{u1}} [_inst_1 : AddGroupWithOne.{u1} R] (n : Int), Eq.{succ u1} R ((fun (a : Type) (b : Type.{u1}) [self : HasLiftT.{1, succ u1} a b] => self.0) Int R (HasLiftT.mk.{1, succ u1} Int R (CoeTCₓ.coe.{1, succ u1} Int R (Int.castCoe.{u1} R (AddGroupWithOne.toHasIntCast.{u1} R _inst_1)))) (bit1.{0} Int Int.hasOne Int.hasAdd n)) (bit1.{u1} R (AddMonoidWithOne.toOne.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R _inst_1)) (AddZeroClass.toHasAdd.{u1} R (AddMonoid.toAddZeroClass.{u1} R (AddMonoidWithOne.toAddMonoid.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R _inst_1)))) ((fun (a : Type) (b : Type.{u1}) [self : HasLiftT.{1, succ u1} a b] => self.0) Int R (HasLiftT.mk.{1, succ u1} Int R (CoeTCₓ.coe.{1, succ u1} Int R (Int.castCoe.{u1} R (AddGroupWithOne.toHasIntCast.{u1} R _inst_1)))) n))
but is expected to have type
  forall {R : Type.{u1}} [_inst_1 : AddGroupWithOne.{u1} R] (n : Int), Eq.{succ u1} R (Int.cast.{u1} R (AddGroupWithOne.toIntCast.{u1} R _inst_1) (bit1.{0} Int (One.ofOfNat1.{0} Int (instOfNatInt 1)) Int.instAddInt n)) (bit1.{u1} R (AddMonoidWithOne.toOne.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R _inst_1)) (AddZeroClass.toAdd.{u1} R (AddMonoid.toAddZeroClass.{u1} R (AddMonoidWithOne.toAddMonoid.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R _inst_1)))) (Int.cast.{u1} R (AddGroupWithOne.toIntCast.{u1} R _inst_1) n))
Case conversion may be inaccurate. Consider using '#align int.cast_bit1 Int.cast_bit1ₓ'. -/
@[simp, norm_cast]
theorem cast_bit1 (n : ℤ) : ((bit1 n : ℤ) : R) = bit1 n := by
  rw [bit1, cast_add, cast_one, cast_bit0] <;> rfl
#align int.cast_bit1 Int.cast_bit1

/- warning: int.cast_two -> Int.cast_two is a dubious translation:
lean 3 declaration is
  forall {R : Type.{u1}} [_inst_1 : AddGroupWithOne.{u1} R], Eq.{succ u1} R ((fun (a : Type) (b : Type.{u1}) [self : HasLiftT.{1, succ u1} a b] => self.0) Int R (HasLiftT.mk.{1, succ u1} Int R (CoeTCₓ.coe.{1, succ u1} Int R (Int.castCoe.{u1} R (AddGroupWithOne.toHasIntCast.{u1} R _inst_1)))) (OfNat.ofNat.{0} Int 2 (OfNat.mk.{0} Int 2 (bit0.{0} Int Int.hasAdd (One.one.{0} Int Int.hasOne))))) (OfNat.ofNat.{u1} R 2 (OfNat.mk.{u1} R 2 (bit0.{u1} R (AddZeroClass.toHasAdd.{u1} R (AddMonoid.toAddZeroClass.{u1} R (AddMonoidWithOne.toAddMonoid.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R _inst_1)))) (One.one.{u1} R (AddMonoidWithOne.toOne.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R _inst_1))))))
but is expected to have type
  forall {R : Type.{u1}} [_inst_1 : AddGroupWithOne.{u1} R], Eq.{succ u1} R (Int.cast.{u1} R (AddGroupWithOne.toIntCast.{u1} R _inst_1) (OfNat.ofNat.{0} Int 2 (instOfNatInt 2))) (OfNat.ofNat.{u1} R 2 (instOfNat.{u1} R 2 (AddMonoidWithOne.toNatCast.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R _inst_1)) (instAtLeastTwoHAddNatInstHAddInstAddNatOfNat (OfNat.ofNat.{0} Nat 0 (instOfNatNat 0)))))
Case conversion may be inaccurate. Consider using '#align int.cast_two Int.cast_twoₓ'. -/
theorem cast_two : ((2 : ℤ) : R) = 2 := by simp
#align int.cast_two Int.cast_two

/- warning: int.cast_three -> Int.cast_three is a dubious translation:
lean 3 declaration is
  forall {R : Type.{u1}} [_inst_1 : AddGroupWithOne.{u1} R], Eq.{succ u1} R ((fun (a : Type) (b : Type.{u1}) [self : HasLiftT.{1, succ u1} a b] => self.0) Int R (HasLiftT.mk.{1, succ u1} Int R (CoeTCₓ.coe.{1, succ u1} Int R (Int.castCoe.{u1} R (AddGroupWithOne.toHasIntCast.{u1} R _inst_1)))) (OfNat.ofNat.{0} Int 3 (OfNat.mk.{0} Int 3 (bit1.{0} Int Int.hasOne Int.hasAdd (One.one.{0} Int Int.hasOne))))) (OfNat.ofNat.{u1} R 3 (OfNat.mk.{u1} R 3 (bit1.{u1} R (AddMonoidWithOne.toOne.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R _inst_1)) (AddZeroClass.toHasAdd.{u1} R (AddMonoid.toAddZeroClass.{u1} R (AddMonoidWithOne.toAddMonoid.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R _inst_1)))) (One.one.{u1} R (AddMonoidWithOne.toOne.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R _inst_1))))))
but is expected to have type
  forall {R : Type.{u1}} [_inst_1 : AddGroupWithOne.{u1} R], Eq.{succ u1} R (Int.cast.{u1} R (AddGroupWithOne.toIntCast.{u1} R _inst_1) (OfNat.ofNat.{0} Int 3 (instOfNatInt 3))) (OfNat.ofNat.{u1} R 3 (instOfNat.{u1} R 3 (AddMonoidWithOne.toNatCast.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R _inst_1)) (instAtLeastTwoHAddNatInstHAddInstAddNatOfNat (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))))
Case conversion may be inaccurate. Consider using '#align int.cast_three Int.cast_threeₓ'. -/
theorem cast_three : ((3 : ℤ) : R) = 3 := by simp
#align int.cast_three Int.cast_three

/- warning: int.cast_four -> Int.cast_four is a dubious translation:
lean 3 declaration is
  forall {R : Type.{u1}} [_inst_1 : AddGroupWithOne.{u1} R], Eq.{succ u1} R ((fun (a : Type) (b : Type.{u1}) [self : HasLiftT.{1, succ u1} a b] => self.0) Int R (HasLiftT.mk.{1, succ u1} Int R (CoeTCₓ.coe.{1, succ u1} Int R (Int.castCoe.{u1} R (AddGroupWithOne.toHasIntCast.{u1} R _inst_1)))) (OfNat.ofNat.{0} Int 4 (OfNat.mk.{0} Int 4 (bit0.{0} Int Int.hasAdd (bit0.{0} Int Int.hasAdd (One.one.{0} Int Int.hasOne)))))) (OfNat.ofNat.{u1} R 4 (OfNat.mk.{u1} R 4 (bit0.{u1} R (AddZeroClass.toHasAdd.{u1} R (AddMonoid.toAddZeroClass.{u1} R (AddMonoidWithOne.toAddMonoid.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R _inst_1)))) (bit0.{u1} R (AddZeroClass.toHasAdd.{u1} R (AddMonoid.toAddZeroClass.{u1} R (AddMonoidWithOne.toAddMonoid.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R _inst_1)))) (One.one.{u1} R (AddMonoidWithOne.toOne.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R _inst_1)))))))
but is expected to have type
  forall {R : Type.{u1}} [_inst_1 : AddGroupWithOne.{u1} R], Eq.{succ u1} R (Int.cast.{u1} R (AddGroupWithOne.toIntCast.{u1} R _inst_1) (OfNat.ofNat.{0} Int 4 (instOfNatInt 4))) (OfNat.ofNat.{u1} R 4 (instOfNat.{u1} R 4 (AddMonoidWithOne.toNatCast.{u1} R (AddGroupWithOne.toAddMonoidWithOne.{u1} R _inst_1)) (instAtLeastTwoHAddNatInstHAddInstAddNatOfNat (OfNat.ofNat.{0} Nat 2 (instOfNatNat 2)))))
Case conversion may be inaccurate. Consider using '#align int.cast_four Int.cast_fourₓ'. -/
theorem cast_four : ((4 : ℤ) : R) = 4 := by simp
#align int.cast_four Int.cast_four

end Int


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

A model of ZFC in Lean.
-/
import data.set.basic

universes u v

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

/-- 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.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.euc (equiv.refl y)

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

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

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.trans (equiv.symm ba) 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, equiv.trans ca ab⟩,
    λγβ c, let ⟨b, cb⟩ := γβ c, ⟨a, ab⟩ := βα b in ⟨a, equiv.trans cb (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 :=
show mem (A a) ⟨α, A⟩, from ⟨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, equiv.symm ha⟩⟩

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

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⟩

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

/-- The image of a function -/
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, equiv.trans yz (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 -/
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.refl _⟩

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

/-- `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 }

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

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 := 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

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

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 Set function. -/
def eval (n) : resp n → arity Set.{u} n := eval_aux.1

@[simp] 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

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

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

noncomputable theorem 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],
      introsI 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

end classical

namespace Set
open pSet

def mk : pSet → Set := quotient.mk

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

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⟩

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

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

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

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, equiv.trans za 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 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, by rw h; exact mem_empty,
λ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⟩

@[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_singleton' {x y : Set.{u}} : x ∈ @insert Set.{u} Set.{u} _ y ∅ ↔ x = y := mem_singleton

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

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

@[simp] theorem omega_zero : ∅ ∈ omega :=
show pSet.mem ∅ pSet.omega, from ⟨⟨0⟩, equiv.refl _⟩

@[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 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} : y ∈ powerset x ↔ y ⊆ x :=
quotient.induction_on₂ x y (λ⟨α, A⟩ ⟨β, B⟩,
  show (⟨β, B⟩ : pSet) ∈ (pSet.powerset ⟨α, 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 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 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, equiv.symm hc⟩)) a) (λb hb, ⟨b, 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; exact ⟨λ⟨z, zx, yz⟩, by subst z; exact yz, λyx, ⟨x, by simp, yx⟩⟩

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) 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 := 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))))

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) with xy'x xy'xx,
    { have y'x : y' ∈ ({x} : Set) := by rw ← xy'x; simp,
      simp at y'x, simp [*] },
    { 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⟩, by simp; exact ⟨a, ax, b, bY, rfl⟩⟩

/-- `is_func x y f` is the assertion `f : x → y` where `f` is a ZFC function
  (a set of ordered pairs) -/
def is_func (x 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]; exact and_iff_right_of_imp and.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 _

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

/-- Coerce a 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 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 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 sets -/
def powerset (x : Class) : Class := Cong_to_Class (set.powerset x)

/-- The union of a class is the class of all members of 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; 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 ↔ A x :=
to_Set_of_Set _ _

@[simp] theorem mem_hom_right (x y : Set.{u}) : (y : Class.{u}) x ↔ 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⟩⟩

/-- 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, ⟨∅, by simp; exact set.ext (λz, ⟨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 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 : ∅ ∉ x)

/-- A choice function on the set of nonempty sets `x` -/
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, by simp; exact ⟨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}) :=
by delta choice; rw map_fval yx; simp [choice_mem_aux x h y yx]

end Set


/-
Copyright (c) 2019 The Flypitch Project. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.

Authors: Jesse Han, Floris van Doorn
-/
import .to_mathlib .pSet_ordinal data.pfun
-- local attribute [instance] classical.prop_decidable

/- The Cohen poset of finite partial functions (2^(2^ω)) × ω → 2 -/

/- The underlying type of the Cohen poset is the type of finite partial functions from (set $ set ω) × ω → Prop -/
variable {η : cardinal}

def cohen_poset := {f : ((pSet.ordinal.mk η.ord).type × ℕ) →. Prop | set.finite (pfun.dom f)}

-- TODO replace all instances of set $ set ℕ with a generic "B"
noncomputable instance B_decidable_eq : decidable_eq (set $ set ℕ) := λ _ _, classical.prop_decidable _

namespace pfun
/- Two partial functions are equal if their graphs are equal -/
lemma ext_graph {α β : Type*} (f g : α →. β) (h_graph : f.graph = g.graph) : f = g :=
  pfun.ext $ λ _ _, iff_of_eq (congr_fun h_graph (_,_))

lemma graph_empty_iff_dom_empty {α β : Type*} (f : α →. β) : f.graph = ∅ ↔ f.dom = ∅ :=
begin
  have := dom_iff_graph f,
  split; intro; ext; safe, apply this, tidy
end

/- A functional graph is a univalent graph -/
def functional {α β : Type*} (Γ : set (α × β)) : Prop :=
  ∀ a b₁ b₂, (a, b₁) ∈ Γ → (a, b₂) ∈ Γ → b₁ = b₂

lemma congr_arg {α β : Type*} (f : α →. β) : ∀ {x} {y} (h₁ : x ∈ f.dom) (h₂ : y ∈ f.dom)
  (h_eq : x = y), fn f x h₁ = fn f y h₂ :=
by intros; congr; assumption

lemma functional_subset {α β : Type*} (Γ Γ': set (α × β)) (h_Γ' : Γ' ⊆ Γ) (h_Γ : functional Γ) : functional Γ' :=
  λ _ _ _ _ _, by apply h_Γ; tidy

/-- The graph of a pfun is always functional -/
lemma graph_functional {α β : Type*} (f : α →. β) : functional f.graph := by tidy

/-- Given a partial functional relation, turn it into a pfun -/
noncomputable def of_graph {α β : Type*} (Γ : set (α × β)) (h_Γ : functional Γ) : α →. β :=
  λ a, ⟨∃ c ∈ Γ, (prod.fst c) = a, λ h, @prod.snd α β $ (classical.indefinite_description _ h).val⟩

lemma of_graph_property {α β : Type*} (Γ : set $ α × β) (h_Γ : functional Γ) (a : α) (h : ∃ c ∈ Γ, (prod.fst c) = a) : ∃ (H : Γ (classical.indefinite_description _ h)), (classical.indefinite_description _ h).val.fst = a :=
  by apply (classical.indefinite_description _ h).property

lemma of_graph_get {α β : Type*} (Γ : set $ α × β) (h_Γ : functional Γ) (a : α) : ∀ h,
(of_graph Γ h_Γ a).get h = (classical.indefinite_description _ h).val.snd :=
  by intro; refl

lemma of_graph_val {α β : Type*} (Γ : set $ α × β) (h_Γ : functional Γ) (a : α) (h : ∃ c ∈ Γ, (prod.fst c) = a) (c' ∈ Γ) (h' : c'.1 = a) :
  @prod.snd α β (classical.indefinite_description _ h).val = c'.snd :=
begin
  let c'', swap, change (prod.snd c'' = c'.snd),
  apply h_Γ a, swap, convert H, ext, rwa[h'], refl,
  have := (classical.indefinite_description _ h).property,
  cases this with this1 this2, rw[<-this2], convert this1, ext; refl
end

@[simp]lemma graph_of_graph {α β : Type*} (Γ : set $ α × β) (h_Γ : functional Γ) : (of_graph Γ h_Γ).graph = Γ :=
begin
  ext, rcases x with ⟨a,b⟩, dsimp[graph],
  split; intro H, {cases H, induction H_h, cases H_w, cases H_w_h, induction H_w_h_h,
  convert H_w_h_w, ext, refl, rw[of_graph_get], apply of_graph_val; try{assumption}; refl},
  fsplit, {tidy}, rw[of_graph_get], apply @of_graph_val _ _ Γ _ a _ (a,b) _;
  try{assumption}; refl
end

@[simp]lemma of_graph_graph {α β : Type*} {f : α →. β} : of_graph (f.graph) (graph_functional f) = f :=
  by apply ext_graph; rw[graph_of_graph]

@[simp]lemma dom_of_graph {α β : Type*} (Γ : set $ α × β) (h_Γ : functional Γ) : (of_graph Γ h_Γ).dom = (prod.fst '' Γ) :=
begin
 ext, split; intros, {tidy},
 {cases a, cases a_h, cases a_w, induction a_h_right, dsimp at *, fsplit,
 work_on_goal 0 { fsplit }, work_on_goal 2 {fsplit,
 work_on_goal 0 { assumption }, refl }}
end

@[simp]lemma dom_of_graph_union {α β : Type*} (Γ : set $ α × β) (p : α × β) (h_Γ : functional Γ) (h_Γ' : functional $ Γ ∪ {p}) : (of_graph (Γ ∪ {p}) h_Γ').dom = (of_graph Γ h_Γ).dom ∪ {p.fst} :=
  by simp[dom_of_graph, set.image_insert_eq]

lemma in_dom_of_in_graph {α β : Type*} {f : α →. β} : ∀ {a} {b}, (a,b) ∈ f.graph → a ∈ f.dom :=
  by {intros a b H, apply (pfun.dom_iff_graph _ a).mpr, exact ⟨b,H⟩}

lemma lift_graph' {α β : Type*} {f : α →. β} {a : α} {b : β} (h_a : a ∈ f.dom) : (a,b) ∈ f.graph ↔ pfun.fn f a h_a = b := by tidy

end pfun

/- Partial order structure on the Cohen poset -/
instance partial_order_cohen_poset : partial_order (@cohen_poset η) :=
{ le := λ f g, g.val.graph ⊆ f.val.graph,
  lt := λ f g, g.val.graph ⊆ f.val.graph ∧ ¬ f.val.graph ⊆ g.val.graph,
  le_refl := λ _, by unfold has_le.le,
  le_trans := by {intros, apply set.subset.trans, exact a_2, assumption},
  lt_iff_le_not_le := λ _ _, iff.refl _,
  le_antisymm := λ a b h1 h2, by {have := @set.subset.antisymm _ _ _ h2 h1, cases a, cases b,
                                       congr, apply pfun.ext_graph, exact this}}

def incompatible {α : Type*} [partial_order α] (a b : α) := ¬ ∃ c, c ≤ a ∧ c ≤ b

def antichain {α : Type*} [partial_order α] (s : set α) := ∀ x ∈ s, ∀ y ∈ s, (x ≠ y) → incompatible x y

lemma antichain_subset {α : Type*} [partial_order α] {s s' : set α} {h : s' ⊆ s} {hs : antichain s} : antichain s' :=
by {intros _ _ _ _, intro H, apply hs _ _ _ _, tidy}

def countable_chain_condition (α : Type*) [partial_order α] := ∀ s : set α, antichain s → set.countable s

@[simp]lemma univ_singletons {α : Type*} :  set.Union (λ a, {a}) = (set.univ : set α) :=
by tidy

lemma set_is_union_of_fibers {α β : Type*} (f : α → β) (s : set α) : s = set.Union (λ b, f ⁻¹'{b} ∩ s) := by ext; simp

lemma univ_is_union_of_fibers {α β : Type*} (f : α → β) : @set.univ α = set.Union (λ b, f⁻¹' {b}) :=
  begin [smt] eblast_using [set.preimage_Union, @set.preimage_univ α β f, univ_singletons] end

lemma countable_of_injection_to_countable {α β : Type*} {s : set α} {s' : set β} (f : s → s') {hf : function.injective f} (h' : set.countable s') : set.countable s :=
begin
  have := set.countable_iff_exists_injective.mp h', apply set.countable_iff_exists_injective.mpr,
  cases this, refine ⟨this_w ∘ f,_⟩, exact function.injective_comp (this_h) hf
end

lemma countable_of_bijection_with_countable {α β : Type*} {s : set α} {s' : set β} {f : s → s'}
{hf : function.bijective f} {h' : set.countable s'} : set.countable s :=
begin
  apply countable_of_injection_to_countable f, exact h', exact hf.left
end

lemma countable_of_equiv_with_countable {α β : Type*} {s : set α} {s' : set β}
{h : equiv s s'} {h' : set.countable s'} : set.countable s :=
by {apply countable_of_bijection_with_countable, apply h.bijective, exact h'}

lemma equiv_set_set_univ {α : Type*} (s : set α) : equiv s (@set.univ s) :=
by {refine ⟨λ x, ⟨x, (by trivial)⟩, λ x, x.val, _, _⟩, tidy}

/- an (s : set α) is countable if (set.univ : set s) is countable -/
lemma countable_of_countable_univ {α : Type*} (s : set α) : set.countable s ↔ set.countable (set.univ : set s) :=
begin
  split; apply countable_of_equiv_with_countable, symmetry,
  all_goals{apply equiv_set_set_univ}
end

lemma countable_of_countable_underlying_set {α : Type*} {s' : set α} {s : set α} {t : set s'} (h : s = (subtype.val '' t)) {h_ctbl : set.countable s} : set.countable t :=
begin
  let f : t → s := λ x,
    begin refine ⟨x.val, _⟩, rw[h], cases x, cases x_val, simp at *, fsplit; assumption end,
  refine countable_of_injection_to_countable f (by assumption),
    intros a₁ a₂ a, cases a₂, cases a₁, cases a₁_val, cases a₂_val, simp at *, assumption
end

lemma countable_of_countable_fibers {α β : Type*} (s : set α) (f : s → β) [encodable β] (H : ∀ b : β, set.countable (f ⁻¹' {b})) : set.countable s :=
by simp[countable_of_countable_univ, univ_is_union_of_fibers f, set.countable_Union H]

lemma countable_of_countable_fibers' {α β : Type*} (s : set α) (f : α → β) [encodable β] (H : ∀ b : β, set.countable ((f ⁻¹' {b}) ∩ s)) : set.countable s :=
by {rw[set_is_union_of_fibers f s], exact set.countable_Union H}

lemma countable_of_countable_fibers'' {α β : Type*} (s : set α) (f : s → β) [encodable β] (H : ∀ b : β, set.countable ((f ⁻¹' {b}))) : set.countable s :=
by simp[countable_of_countable_univ, univ_is_union_of_fibers f, set.countable_Union H]

lemma eq_true_of_provable {p : Prop} (h : p) : (p = true) := by simp[h]

lemma eq_false_of_provable_neg {p : Prop} (h : ¬ p) : (p = false) := by finish

@[reducible, simp]noncomputable def Prop_to_bool (p : Prop) : bool :=
by {haveI := classical.prop_decidable p, by_cases p, exact true, exact false}

@[simp]lemma Prop_to_bool_true : Prop_to_bool true = tt := by simp

@[simp]lemma Prop_to_bool_false : Prop_to_bool false = ff := by simp

noncomputable lemma equiv_Prop_bool : equiv Prop bool :=
begin
  refine ⟨Prop_to_bool,by {intro b, cases b, exact false, exact true},_,_⟩,
  {unfold function.left_inverse, intro p, haveI := classical.prop_decidable p, by_cases p,
  rw[eq_true_of_provable h, Prop_to_bool_true],
  rw[eq_false_of_provable_neg h, Prop_to_bool_false],},
  {intro x, cases x; finish}
end

noncomputable instance Prop_encodable : encodable Prop :=
 @encodable.of_equiv _ _ (by apply_instance) equiv_Prop_bool

noncomputable def size_of_domain : (@cohen_poset η) → ℕ :=
  λ p, finset.card $ set.finite.to_finset p.property

lemma size_of_domain_fiber {n} {p : @cohen_poset η} (h : p ∈ @size_of_domain η ⁻¹' {n}) : size_of_domain p = n := by finish

/-- The partial function p is defined at b and m if (b,m) is in the domain of p -/
def is_defined (p : (@cohen_poset η)) (b) (m) := (b,m) ∈ (pfun.dom p.val)

/-- p is defined at m if there exists a b such that p is defined at b and m -/
def is_defined_at (m : ℕ) : set (@cohen_poset η) :=
  {p : (@cohen_poset η) | ∃ b, is_defined p b m}

namespace finset

lemma empty_of_empty {α : Type*} {s : set α} {h : set.finite s} : set.finite.to_finset h = ∅ → s = ∅ :=
begin
  intro H, rw[set.eq_empty_iff_forall_not_mem], intros x Hx,
  suffices : x ∈ set.finite.to_finset h, by rw[H] at this; cases this, simpa[finset.mem_coe]
end

end finset

lemma empty_of_size_of_domain_0 {p : (@cohen_poset η)} (h : size_of_domain p = 0) : p.val.dom = ∅ :=
begin
  have : set.finite.to_finset p.property = ∅, from finset.card_eq_zero.mp h,
  exact finset.empty_of_empty this
end

lemma nonempty_of_size_of_domain_ne_zero {p : (@cohen_poset η)} (h : size_of_domain p ≠ 0) : nonempty p.val.dom :=
begin
  have : set.finite.to_finset p.property ≠ ∅, by {intro h, suffices : (set.finite.to_finset p.property).card = 0,
    by {apply (_root_.not_and_self ((set.finite.to_finset p.property).card = 0)).mp,refine ⟨(by assumption), this⟩},
    exact finset.card_eq_zero.mpr h},
  have := finset.exists_mem_of_ne_empty this, cases this, apply nonempty.intro,
  refine ⟨this_w,_⟩, cases this_w, cases p, simp at this_h, assumption
end

lemma nonempty_domain_defined (p : (@cohen_poset η)) (h : 0 < size_of_domain p) : ∃ m,
  is_defined_at m p :=
begin
  suffices : nonempty p.val.dom, by {have := classical.choice this, cases this,
  refine ⟨this_val.2, ⟨this_val.1,_⟩⟩, tidy}, apply nonempty_of_size_of_domain_ne_zero,
  intro h', rw[h'] at h, cases h
end

-- def is_defined_at_covers {n} {h : 0 < n} : @size_of_domain η ⁻¹' {n} ⊆ ⋃ m, is_defined_at m :=
-- begin
--   intros p Hp, simp[set.mem_preimage_eq] at *,
--   suffices : nonempty p.val.dom,
--     by {have := classical.choice this, exact ⟨this.val.snd, ⟨this.val.fst, (by tidy)⟩⟩},
--   apply nonempty_of_size_of_domain_ne_zero, intro H, have : 0 < 0, by cc, cases this
-- end

instance size_of_domain_0_subsingleton : subsingleton $ @size_of_domain η ⁻¹' {0} :=
begin
  refine ⟨λ a b, _⟩, rcases a with ⟨⟨p_a, H_f_a⟩, H_a⟩, rcases b with ⟨⟨p_b, H_f_b⟩, H_b⟩, congr,
  have := (pfun.graph_empty_iff_dom_empty _).mpr (@empty_of_size_of_domain_0 η _
                                          (by {simp[set.mem_preimage_eq] at H_b, exact H_b})),
  have := (pfun.graph_empty_iff_dom_empty _).mpr (@empty_of_size_of_domain_0 η _
                                          (by {simp[set.mem_preimage_eq] at H_a, exact H_a})),
  exact pfun.ext_graph _ _ (by cc)
end

lemma subsingleton_of_subset_of_subsingleton {α : Type*} {s s' : set α} (h_sub : s ⊆ s') [subsingleton s'] : subsingleton s :=
begin
  refine ⟨λ a b, _⟩, have : ∀ a b : s', a = b, by apply subsingleton.elim,
  let f : s → s' := λ x, ⟨x.val, h_sub _⟩,
  suffices : f a = f b, by tidy, apply this, exact x.property
end

lemma size_of_domain_0_inter_subsingleton : ∀ (a : set (@cohen_poset η)), subsingleton ↥((size_of_domain ⁻¹' {0}) ∩ a) :=
λ a, subsingleton_of_subset_of_subsingleton
     (by apply set.inter_subset_left : size_of_domain ⁻¹' {0} ∩ a ⊆ size_of_domain ⁻¹' {0})

lemma countable_subsingleton {α : Type*} (s : set α) (h : subsingleton s) : set.countable s :=
  set.countable_iff_exists_injective.mpr $ ⟨λ _, 0, λ _ _, dec_trivial⟩

-- lemma cover_Union_eq {α ι : Type*} {s : set α} {t : ι → set α} {h : s ⊆ (⋃ (i : ι), t i)} :
-- s = ⋃ i, s ∩ t i :=
--   by {rw[<-set.inter_Union_left], ext, split; intros, exact ⟨a, h a⟩, exact a.left}

lemma inter_subset_left' {α : Type*} {s t u : set α} {h : t ⊆ u} : s ∩ t ⊆ u :=
  λ _ ⟨_,_⟩, by solve_by_elim

lemma inter_subset_right' {α : Type*} {s t u : set α} {h : t ⊆ u} : t ∩ s ⊆ u :=
  λ _ ⟨_,_⟩, by solve_by_elim

section one_point_restriction

/- Given x : α, return the set λ a, a ≠ x -/
@[simp, reducible]def not_x {α : Type*} (x : α) : set α := λ a, a ≠ x

def finite_of_inter_not_x {α : Type*} {s : set α} (h : set.finite s) {x : α} : set.finite $ s ∩ not_x x := by {apply set.finite_subset, exact h, apply inter_subset_right', trivial}

def roption_indicator {α : Type*} (s : set α) : α → roption α :=
  λ x, ⟨x ∈ s, λ _, x⟩

def pfun.restriction {α β : Type*} (f : α →. β) (s : set α) : α →. β
:= λ x, do y <- roption_indicator s x, f y

lemma pfun.domain_restriction {α β : Type*} {f : α →. β} {s : set α} : (pfun.restriction f s).dom = f.dom ∩ s :=
  by ext; split; intro a; cases a; fsplit; assumption

end one_point_restriction
-- def one_point_restriction (p : (@cohen_poset η)) : ∀(x), x ∈ p.val.dom → (@cohen_poset η) :=
-- λ x H, ⟨pfun.restriction p.val (not_x x),
--          by {change set.finite (pfun.restriction p.val (not_x x)).dom,
--          rw[pfun.domain_restriction], apply finite_of_inter_not_x, apply p.property}⟩

-- def one_point_restriction' (p : (@cohen_poset η)) : ∀ (x), (@cohen_poset η) :=
-- λ x, ⟨pfun.restriction p.val (not_x x),
--          by {change set.finite (pfun.restriction p.val (not_x x)).dom,
--          rw[pfun.domain_restriction], apply finite_of_inter_not_x, apply p.property}⟩

-- lemma one_point_restriction_domain {p : (@cohen_poset η)} {x} (h : x ∈ p.val.dom) : (one_point_restriction p x h).val.dom = p.val.dom ∩ not_x x :=
-- begin
--   ext, split; {intros a, auto_cases, fsplit; assumption}
-- end

-- lemma one_point_restriction_domain' {p : (@cohen_poset η)} {x} : (one_point_restriction' p x).val.dom = p.val.dom ∩ not_x x :=
-- begin
--   ext, split; {intros a, auto_cases, fsplit; assumption}
-- end

-- lemma one_point_restriction_graph {p : (@cohen_poset η)} {x} {h_x : x ∈ p.val.dom} : ∀ y, y ∈ (one_point_restriction p x h_x).val.graph ↔ (y ∈ p.val.graph ∧ (prod.fst y ≠ x)) := sorry

-- -- lemma one_point_restriction_graph' {p : (@cohen_poset η)} {x} : (one_point_restriction' p x).val.graph = {y ∈ p.val.graph | y.fst ∈ not_x x} :=
-- -- begin
-- --   ext, split; intros,
-- -- end

-- @[simp]lemma in_one_point_restriction_of_in_dom_and_not_x {p : (@cohen_poset η)} {x} {h : x ∈ p.val.dom} {y} : y ∈ (one_point_restriction p x h).val.dom ↔ (y ∈ p.val.dom) ∧ y ≠ x :=
--   by simp[one_point_restriction_domain, not_x]; finish

-- @[simp]lemma in_one_point_restriction'_of_in_dom_and_not_x {p : (@cohen_poset η)} {x} {y} : y ∈ (one_point_restriction' p x ).val.dom ↔ (y ∈ p.val.dom) ∧ y ≠ x :=
--   by simp[one_point_restriction_domain', not_x]; finish

-- lemma one_point_restriction_domain'_subset {p : (@cohen_poset η)} {x} : (one_point_restriction' p x).val.dom ⊆ p.val.dom :=
--   λ y, by finish

-- lemma one_point_restriction_domain_subset {p : (@cohen_poset η)} {x} {h_x : x ∈ p.val.dom} : (one_point_restriction p x h_x).val.dom ⊆ p.val.dom :=
--   λ y, by finish

-- lemma one_point_restriction_domain_coe {p : (@cohen_poset η)} {x} {h : x ∈ p.val.dom} : p.val.dom = ↑(set.finite.to_finset p.property) := by simp

-- lemma one_point_restriction_finset_rewrite {p : (@cohen_poset η)} {x} {h : x ∈ p.val.dom} : set.finite.to_finset (one_point_restriction p x h).property = set.finite.to_finset (by {apply finite_of_inter_not_x, exact p.property} : set.finite $ p.val.dom ∩ not_x x) := by simp[one_point_restriction_domain]

-- lemma one_point_restriction_finset_rewrite_property {p : (@cohen_poset η)} {x} {h : x ∈ p.val.dom} : ∀ y, y ∈ set.finite.to_finset ((one_point_restriction p x h).property-- by {apply finite_of_inter_not_x, exact p.property} : set.finite $ p.val.dom ∩ not_x x
-- ) ↔ y ≠ x ∧ y ∈ p.val.dom :=
-- begin
--   intro y, split; intros, rw[one_point_restriction_finset_rewrite] at a, split,
--     {tidy, apply a_right, refl},
--     {finish},
--     {apply finset.mem_coe.mp, rw[<-one_point_restriction_domain_coe],
--     rw[one_point_restriction_domain], refine ⟨a.right,_⟩, apply a.left, swap, exact y, simp*}
-- end

-- lemma one_point_restriction_erase {p : (@cohen_poset η)} {x} {h : x ∈ p.val.dom} : set.finite.to_finset (one_point_restriction p x h).property = finset.erase (set.finite.to_finset p.property) x :=
-- begin
--   ext, rw[one_point_restriction_finset_rewrite,finset.mem_erase], conv {to_rhs,rw[<-finset.mem_coe]}, split; intros, {rw[<-one_point_restriction_domain_coe], apply (one_point_restriction_finset_rewrite_property a).mp, show set (set ℕ) × ℕ, exact x, rw[one_point_restriction_finset_rewrite], repeat{assumption}},
--   {rw[<-one_point_restriction_finset_rewrite],
--   apply (one_point_restriction_finset_rewrite_property a).mpr,
--   convert a_1, simp, assumption}
-- end

-- lemma one_point_restriction_decrease_size {n} (p : (@cohen_poset η)) (h : size_of_domain p = n + 1) (x) (h_x : x ∈ p.val.dom)  :
-- size_of_domain (one_point_restriction p x h_x) = n :=
-- begin
--   unfold size_of_domain at *, have : n = nat.pred (n+1), by refl,
--   rw[this, one_point_restriction_erase, <-h], apply finset.card_erase_of_mem,
--   apply finset.mem_coe.mp, rwa[finset.coe_to_finset]
-- end

-- def aux_c'' {p₁ p₂ : (@cohen_poset η)} {t₁ t₂ : (set $ set ℕ) × ℕ} (h_t₁ : t₁ ∈ p₁.val.dom) (h_t₂ : t₂ ∈ p₂.val.dom) (q : Prop) (h_val₁ : pfun.fn p₁.val t₁ h_t₁ = q) (h_val₂ : pfun.fn p₂.val t₂ h_t₂ = q) (c : (@cohen_poset η)) : (@cohen_poset η) :=
--   (one_point_restriction' (one_point_restriction' c t₁) t₂)

-- lemma aux_c''_dom {p₁ p₂ : (@cohen_poset η)} {t₁ t₂ : (set $ set ℕ) × ℕ} {h_t₁ : t₁ ∈ p₁.val.dom} {h_t₂ : t₂ ∈ p₂.val.dom} {q : Prop} {h_val₁ : pfun.fn p₁.val t₁ h_t₁ = q} {h_val₂ : pfun.fn p₂.val t₂ h_t₂ = q} {c : (@cohen_poset η)} : ∀ (x), x ∈ (aux_c'' h_t₁ h_t₂ q h_val₁ h_val₂ c).val.dom → x ≠ t₁ ∧ x ≠ t₂ :=
-- λ x Hx, ⟨by {apply ((in_one_point_restriction'_of_in_dom_and_not_x).mp _).right, exact c,
--             apply one_point_restriction_domain'_subset, swap, exact t₂, exact Hx},
--          by {apply ((in_one_point_restriction'_of_in_dom_and_not_x).mp _).right, exact (one_point_restriction' c t₁), exact Hx}⟩

-- lemma aux_c''_dom_of {p₁ p₂ : (@cohen_poset η)} {t₁ t₂ : (set $ set ℕ) × ℕ} {h_t₁ : t₁ ∈ p₁.val.dom} {h_t₂ : t₂ ∈ p₂.val.dom} {q : Prop} {h_val₁ : pfun.fn p₁.val t₁ h_t₁ = q} {h_val₂ : pfun.fn p₂.val t₂ h_t₂ = q} {c : (@cohen_poset η)} : ∀ (x), x ≠ t₁ ∧ x ≠ t₂ → x ∈ c.val.dom → x ∈ (aux_c'' h_t₁ h_t₂ q h_val₁ h_val₂ c).val.dom :=
-- begin
--   intros x Hx H'x, rcases Hx with ⟨Hx_r, Hx_l⟩, dsimp[aux_c''],
--   repeat{rw[one_point_restriction_domain']}, finish
-- end

-- lemma aux_c''_graph_of {p₁ p₂ : (@cohen_poset η)} {t₁ t₂ : (set $ set ℕ) × ℕ} {h_t₁ : t₁ ∈ p₁.val.dom} {h_t₂ : t₂ ∈ p₂.val.dom} {q : Prop} {h_val₁ : pfun.fn p₁.val t₁ h_t₁ = q} {h_val₂ : pfun.fn p₂.val t₂ h_t₂ = q} {c : (@cohen_poset η)} : ∀ x, (x ∈ c.val.graph ∧ (prod.fst x ≠ t₁ ) ∧ (prod.fst x ≠ t₂)) ↔ x ∈ (aux_c'' h_t₁ h_t₂ q h_val₁ h_val₂ c).val.graph := sorry

-- lemma aux_c''_dom_finite {p₁ p₂ : (@cohen_poset η)} {t₁ t₂ : (set $ set ℕ) × ℕ} {h_t₁ : t₁ ∈ p₁.val.dom} {h_t₂ : t₂ ∈ p₂.val.dom} {q : Prop} {h_val₁ : pfun.fn p₁.val t₁ h_t₁ = q} {h_val₂ : pfun.fn p₂.val t₂ h_t₂ = q} {c : (@cohen_poset η)} : set.finite (aux_c'' h_t₁ h_t₂ q h_val₁ h_val₂ c).val.dom :=
-- begin
--   dsimp[aux_c''], repeat{rw[one_point_restriction_domain']}, repeat{apply finite_of_inter_not_x},
--   exact c.property
-- end
-- -- λ x Hx, ⟨by {apply ((in_one_point_restriction'_of_in_dom_and_not_x).mp _).right, exact c,
-- --             apply one_point_restriction_domain'_subset, swap, exact t₂, exact Hx},
-- --          by {apply ((in_one_point_restriction'_of_in_dom_and_not_x).mp _).right, exact (one_point_restriction' c t₁), exact Hx}⟩

-- /- Let p₁ and p₂ be two partial functions such that there is a point (b₁,m) for p₁ and a point (b₂, m) for p₂ where p₁ and p₂ have the same value.
--     Suppose that the one-point restrictions of p₁ and p₂ with respect to (b₁,m) and (b₂,m) have a common refinement c.
--     Then c (after making sure (b₁, m) and (b₂,m) are not in its domain) extended by (b₁,m) and (b₂,m) is a common refinement for p₁ and p₂. -/

-- /-- the graph of the extension of c by (b₁,m) and (b₂,m) -/
-- def one_point_restriction_refinement_extension_graph {p₁ p₂ : (@cohen_poset η)} {t₁ t₂ : (set $ set ℕ) × ℕ} (h_t₁ : t₁ ∈ p₁.val.dom) (h_t₂ : t₂ ∈ p₂.val.dom) (q : Prop) (h_val₁ : pfun.fn p₁.val t₁ h_t₁ = q) (h_val₂ : pfun.fn p₂.val t₂ h_t₂ = q) (c : (@cohen_poset η)) :=
--   ((aux_c'' h_t₁ h_t₂ q h_val₁ h_val₂ c).val.graph ∪ {(t₁,q)} ∪ {(t₂,q)})

-- lemma one_point_restriction_refinement_extension_graph_functional {p₁ p₂ : (@cohen_poset η)} {t₁ t₂ : (set $ set ℕ) × ℕ} (h_t₁ : t₁ ∈ p₁.val.dom) (h_t₂ : t₂ ∈ p₂.val.dom) (q : Prop) (h_val₁ : pfun.fn p₁.val t₁ h_t₁ = q) (h_val₂ : pfun.fn p₂.val t₂ h_t₂ = q) (c : (@cohen_poset η)) (h_c_left : c ≤ (one_point_restriction p₁ t₁ h_t₁)) (h_c_right : c ≤ (one_point_restriction p₂ t₂ h_t₂)) :
--   pfun.functional $ one_point_restriction_refinement_extension_graph h_t₁ h_t₂ q h_val₁ h_val₂ c :=
-- begin
--   intros x q₁ q₂ H₁ H₂, let c' := (aux_c'' h_t₁ h_t₂ q h_val₁ h_val₂ c), cases H₁; cases H₂; cases H₁; cases H₂,
--   apply pfun.graph_functional (aux_c'' h_t₁ h_t₂ q h_val₁ h_val₂ c).val, exact H₁, exact H₂,
--   {have : x ∈ c'.val.dom,
--     by {apply (pfun.dom_iff_graph c'.val x).mpr, exact ⟨q₁, H₁⟩}, have := (aux_c''_dom x this).left, suffices : x = t₁, by contradiction, repeat{cases H₂}, refl},
--   {repeat{cases H₁}, suffices : t₁ ≠ t₁, by contradiction, have : t₁ ∈ c'.val.dom,
--    by {apply (pfun.dom_iff_graph c'.val t₁).mpr, exact ⟨q₂, H₂⟩},
--    exact (aux_c''_dom t₁ this).left},
--   {cases H₁; cases H₁; cases H₂; cases H₂, cc},
--   {repeat{cases H₂}, suffices : t₂ ≠ t₂, by contradiction, have : t₂ ∈ c'.val.dom,
--    by {apply (pfun.dom_iff_graph c'.val t₂).mpr, exact ⟨q₁, H₁⟩},
--    exact (aux_c''_dom t₂ this).right},
--   {cases H₂},
--   {repeat{cases H₁}, cases H₂, refl},
--   {cases H₂},
--   {repeat{cases H₁}, suffices : t₂ ≠ t₂, by contradiction, have : t₂ ∈ c'.val.dom,
--    by {apply (pfun.dom_iff_graph c'.val t₂).mpr, refine ⟨_,_⟩, exact q₂, exact H₂},
--    exact (aux_c''_dom t₂ this).right}, {repeat{cases H₂}, cases H₁, refl},
--   {cases H₁}, {cases H₁}, {cc}, {cases H₂}, {cases H₁}, {cases H₁},
-- end

-- /-- the graph of the extension of c by (b₁,m) and (b₂,m) contains the graphs of p₁ and p₂ -/
-- lemma one_point_restriction_refinement_extension_graph_extends {p₁ p₂ : (@cohen_poset η)} {t₁ t₂ : (set $ set ℕ) × ℕ} (h_t₁ : t₁ ∈ p₁.val.dom) (h_t₂ : t₂ ∈ p₂.val.dom) (q : Prop) (h_val₁ : pfun.fn p₁.val t₁ h_t₁ = q) (h_val₂ : pfun.fn p₂.val t₂ h_t₂ = q) (c : (@cohen_poset η)) (h_c_left : c ≤ (one_point_restriction p₁ t₁ h_t₁)) (h_c_right : c ≤ (one_point_restriction p₂ t₂ h_t₂)) : p₁.val.graph ⊆ (one_point_restriction_refinement_extension_graph h_t₁ h_t₂ q h_val₁ h_val₂ c) ∧ p₂.val.graph ⊆ (one_point_restriction_refinement_extension_graph h_t₁ h_t₂ q h_val₁ h_val₂ c) :=
-- begin
--   split; intros x Hx; rcases x with ⟨x, q'⟩;
--   dsimp[one_point_restriction_refinement_extension_graph],
--   suffices : ((x, q') ∈ pfun.graph ((aux_c'' h_t₁ h_t₂ q h_val₁ h_val₂ c).val)) ∨ ((x, q') ∈ {(t₁, q)} ∨
--     (x, q') ∈ {(t₂, q)}), by rwa[or_assoc],
--   let H, swap, change _ ∨ H, haveI : decidable H := by apply classical.prop_decidable _,
--   by_cases H,
--     {apply or.elim h, exact λ A, or.inr $ or.inl $ A,
--                       exact λ A, or.inr $ or.inr $ A},
--     {-- dsimp[H] at h, rw[not_or_distrib] at h, apply or.inl,
--     repeat{sorry}

--     -- apply (aux_c''_graph_of (x,q')).mp,
--      -- refine ⟨_, _⟩,

-- -- dsimp[H] at h, rw[not_or_distrib] at h,
-- --      have Hx' : (x,q') ∈ (c.val).graph,
-- --        by {apply h_c_left, apply (one_point_restriction_graph (x,q')).mpr,
-- --        refine ⟨(by assumption), _⟩, change x ≠ t₁, cases h, intro hx, apply h_left, rw[hx], simp,
-- --               apply (pfun.graph_functional p₁.val), exact Hx,
-- --               rw[hx], apply (pfun.lift_graph' _).mpr, exact h_val₁},
-- --      apply or.inl, have : x ∈ p₁.val.dom, by apply (pfun.dom_iff_graph _ x).mpr; exact ⟨q', Hx⟩,
-- --      have : x ∈ ((aux_c'' h_t₁ h_t₂ q h_val₁ h_val₂ c).val).dom,
-- --        by {apply aux_c''_dom_of, {split, {change x ≠ t₁, cases h, intro hx,
-- --           apply h_left, rw[hx], simp, apply (pfun.graph_functional p₁.val), exact Hx,
-- --           rw[hx], apply (pfun.lift_graph' _).mpr, exact h_val₁}, {change x ≠ t₂, cases h, intro hx, apply h_right, rw[hx], simp, apply (pfun.graph_functional p₂.val), repeat{sorry} -- exact Hx, rw[hx], apply (pfun.lift_graph' _).mpr, exact h_val₂
-- --               }}, {apply (pfun.dom_iff_graph _ x).mpr, exact ⟨q', Hx'⟩}},

--     },
--   -- by_cases H, repeat{sorry}
--   -- have : ((x, q') ∈ {(t₁, q)} ∨ (x, q') ∈ {(t₂, q)}) → (x,q') ∉ pfun.graph ((aux_c'' h_t₁ h_t₂ q h_val₁ h_val₂ c).val),
--   -- by {intros H₁ H₂, have : x ∈ (aux_c'' h_t₁ h_t₂ q h_val₁ h_val₂ c).val.dom,
--   --    by {apply (pfun.dom_iff_graph _ x).mpr, exact ⟨q', H₂⟩}, have := aux_c''_dom x this,
--   --    cases H₁, have : (x,q') = (t₁, q), from set.eq_of_mem_singleton (by assumption), finish,
--   --    have : (x,q') = (t₂, q), from set.eq_of_mem_singleton (by assumption), finish},
--   repeat{sorry}

-- end

-- /-- the extension of c by (b₁, m) and (b₂,m) has finite domain -/
-- lemma one_point_restriction_refinement_extension_finite {p₁ p₂ : (@cohen_poset η)} {t₁ t₂ : (set $ set ℕ) × ℕ} (h_t₁ : t₁ ∈ p₁.val.dom) (h_t₂ : t₂ ∈ p₂.val.dom) (q : Prop) (h_val₁ : pfun.fn p₁.val t₁ h_t₁ = q) (h_val₂ : pfun.fn p₂.val t₂ h_t₂ = q) (c : (@cohen_poset η)) (h_c_left : c ≤ (one_point_restriction p₁ t₁ h_t₁)) (h_c_right : c ≤ (one_point_restriction p₂ t₂ h_t₂)) : set.finite (pfun.of_graph (one_point_restriction_refinement_extension_graph h_t₁ h_t₂ q h_val₁ h_val₂ c) (by {apply one_point_restriction_refinement_extension_graph_functional, repeat{assumption}})).dom :=
-- begin
--   unfold one_point_restriction_refinement_extension_graph,
--   rw[pfun.dom_of_graph_union], swap,
--   apply pfun.functional_subset (one_point_restriction_refinement_extension_graph h_t₁ h_t₂ q h_val₁ h_val₂ c),
--     by {unfold one_point_restriction_refinement_extension_graph, finish},
--   apply one_point_restriction_refinement_extension_graph_functional, repeat{assumption},
--   rw[pfun.dom_of_graph_union, pfun.of_graph_graph], simp only [set.union_singleton], repeat{apply set.finite_insert}, apply aux_c''_dom_finite
-- end

-- noncomputable def one_point_restriction_refinement_extension {p₁ p₂ : (@cohen_poset η)} {t₁ t₂ : (set $ set ℕ) × ℕ} (h_t₁ : t₁ ∈ p₁.val.dom) (h_t₂ : t₂ ∈ p₂.val.dom) (q : Prop) (h_val₁ : pfun.fn p₁.val t₁ h_t₁ = q) (h_val₂ : pfun.fn p₂.val t₂ h_t₂ = q) (c : (@cohen_poset η)) (h_c_left : c ≤ (one_point_restriction p₁ t₁ h_t₁)) (h_c_right : c ≤ (one_point_restriction p₂ t₂ h_t₂)) : (@cohen_poset η) :=
--   ⟨pfun.of_graph (one_point_restriction_refinement_extension_graph h_t₁ h_t₂ q h_val₁ h_val₂ c) (by {apply one_point_restriction_refinement_extension_graph_functional, repeat{assumption}}),
--    (by {apply one_point_restriction_refinement_extension_finite, repeat{assumption}})⟩

-- lemma one_point_restriction_refinement_extension_spec (p₁ p₂ : (@cohen_poset η)) {t₁ t₂ : (set $ set ℕ) × ℕ} {h_t₁ : t₁ ∈ p₁.val.dom} {h_t₂ : t₂ ∈ p₂.val.dom} {q : Prop} {h_val₁ : pfun.fn p₁.val t₁ h_t₁ = q} {h_val₂ : pfun.fn p₂.val t₂ h_t₂ = q} {c : (@cohen_poset η)} (h_c_left : c ≤ (one_point_restriction p₁ t₁ h_t₁)) (h_c_right : c ≤ (one_point_restriction p₂ t₂ h_t₂)) : ∃ c' : (@cohen_poset η), c' ≤ p₁ ∧ c' ≤ p₂ :=
-- begin
--   refine ⟨by {fapply one_point_restriction_refinement_extension h_t₁ h_t₂ q h_val₁ h_val₂ c,
--              repeat{assumption}}, _⟩,
--   have := one_point_restriction_refinement_extension_graph_extends h_t₁ h_t₂ q h_val₁ h_val₂ c h_c_left h_c_right,
--   convert this; convert rfl; simp[one_point_restriction_refinement_extension, one_point_restriction_refinement_extension_graph, pfun.graph_of_graph]
-- end

-- lemma wit_incompatible {p₁ p₂ : (@cohen_poset η)} (h_incompat : incompatible p₁ p₂) : ∃ w ∈ p₁.val.dom ∩ p₂.val.dom, pfun.fn (p₁.val) w (by exact H.left) ≠ pfun.fn (p₂.val) w H.right :=
-- begin
--   sorry
--   -- let p, swap, change p, haveI : decidable p := by apply classical.prop_decidable _,
--   -- by_contra, dsimp[p] at a, clear _inst p,
--   -- simp at a, sorry
-- end

-- lemma wit_incompatible' {p₁ p₂ : (@cohen_poset η)} (h_incompat : incompatible p₁ p₂) : ∃ w q₁ q₂, (w,q₁) ∈ p₁.val.graph ∧ (w,q₂) ∈ p₂.val.graph ∧ q₁ ≠ q₂ := sorry

-- end one_point_restriction

-- lemma congr_neq {α β : Type*} {f : α → β} {x' y' : α} {x y : β} {h_x : f x' = x} {h_y : f y' = y} {h_neq : x ≠ y} : x' ≠ y' := λ _, by {cc}

-- lemma coe_subtype_injective {α : Type*} {s : set α} {x y : s} : (↑x = (↑y : α)) → x = y :=
--   λ h, by {cases x, cases y, dsimp at h, subst h}

-- -- /- The Cohen poset has the countable chain condition -/
-- -- lemma (@cohen_poset η)_ccc : countable_chain_condition (@cohen_poset η) :=
-- -- begin
-- --   intros a Ha, apply countable_of_countable_fibers' a size_of_domain,
-- --   intro n, induction n with n ih generalizing a,
-- --     {apply countable_subsingleton, apply size_of_domain_0_inter_subsingleton},
-- --     {let A_n, swap, change set.countable A_n,
-- --       have : A_n ⊆ ⋃ m, is_defined_at m, by {dsimp[A_n], apply inter_subset_right',
-- --              apply is_defined_at_covers, apply nat.zero_lt_succ},
-- --      rw[@cover_Union_eq _ _ A_n is_defined_at this], apply set.countable_Union,
-- --      intro m, let A_n_m, swap, change set.countable A_n_m,
-- --        have choice_aux : ∀ p : A_n_m, ∃ b : (set $ set ℕ), (b,m) ∈ (pfun.dom p.val.val),
-- --          by {intros p, cases p, cases p_property, cases p_val, assumption},
-- --        have := classical.axiom_of_choice choice_aux, cases this with wit wit_spec,
-- --        let eval : A_n_m → Prop :=
-- --              λ (p : ↥A_n_m), pfun.fn ((p.val).val) (wit p, m) (by apply wit_spec),
-- --        apply countable_of_countable_fibers'' _ eval, intro q,
-- --        let A_n_m_q, swap, change set.countable A_n_m_q,

-- --          let red : A_n_m → (@cohen_poset η) :=
-- --            λ X, one_point_restriction X.val (wit X, m) (by apply wit_spec),

-- --          have h_anti : antichain (red '' A_n_m_q) :=
-- --            by {intros x H_x y H_y H_neq H_compat, rcases H_compat with ⟨c, ⟨H_cx,H_cy⟩⟩,
-- --                rcases H_x with ⟨x', H_x'⟩, rcases H_y with ⟨y', H_y'⟩,
-- --                have h_neq : x' ≠ y',
-- --                  by {apply congr_neq, exact H_x'.right, exact H_y'.right, exact H_neq},
-- --                have : ↑x' ≠ ↑y', by {intro, apply h_neq, exact coe_subtype_injective a_1},
-- --                have h_incompat := Ha x' (x'.property.left.right) y' (y'.property.left.right) this,
-- --                have := wit_incompatible' h_incompat, rcases this with ⟨w,q₁,q₂, ⟨H₁,⟨H₂,H₃⟩⟩⟩,
-- --                have w_not_t₁ : w ≠ (wit (x'), m),
-- --                  by {intro H_eq, have := pfun.congr_arg (subtype.val (↑x'))
-- --                                          (pfun.in_dom_of_in_graph (by assumption))
-- --                                          (pfun.in_dom_of_in_graph (sorry)) H_eq, repeat{sorry}
-- --                      },
-- --                have w_not_t₂ : w.fst ≠ wit (y'), by sorry,
-- --                have w_in_red_1 : (w,q₁) ∈ (x).val.graph, by sorry,
-- --                have w_in_red_2 : (w,q₂) ∈ (y).val.graph, by sorry,
-- --                have w_in_c_1 : (w,q₁) ∈ c.val.graph, from H_cx w_in_red_1,
-- --                have w_in_c_2 : (w,q₂) ∈ c.val.graph, from H_cy w_in_red_2,
-- --                suffices : q₁ = q₂, by contradiction,
-- --                apply pfun.graph_functional c.val, exacts [w_in_c_1, w_in_c_2]
-- --                },

-- --          have ih_rewrite : size_of_domain ⁻¹' {n} ∩ red '' A_n_m_q = red '' A_n_m_q,
-- --            by {apply set.inter_eq_self_of_subset_right, intros x H_x,
-- --               simp only [set.mem_singleton_iff, set.mem_preimage_eq],
-- --               dsimp[red] at H_x, cases H_x, rw[<-H_x_h.right],
-- --               apply one_point_restriction_decrease_size,
-- --               apply size_of_domain_fiber H_x_w.property.left.left},

-- --          have h_inj : set.inj_on red A_n_m_q,
-- --            by {intros x' y' H_x' H_y',
-- --               haveI : decidable_eq ↥A_n_m := λ _ _, classical.prop_decidable _,
-- --               by_cases x' = y', exact λ _, ‹x' = y'›, rename h h_neq,
-- --               intro H, exfalso,
-- --                refine Ha x' (x'.property.left.right) y' (y'.property.left.right)
-- --                            (by {intro, apply h_neq, exact coe_subtype_injective a_1}) _,
-- --               apply one_point_restriction_refinement_extension_spec (↑x') (↑y'),
-- --               have : red x' ≤ red x', by {apply le_of_eq rfl},
-- --               convert this, convert (le_of_eq H), exact q,
-- --                cases H_x', convert H_x', cases H_x',
-- --                cases H_y', convert H_y', cases H_y'},

-- --          have ih' := ih (red '' A_n_m_q) h_anti,

-- --          exact set.countable_of_injective_of_countable_image h_inj (by rwa[<-ih_rewrite])}
-- end


import .syntax

open val bin_op exp instruction

def eval (n m : ℕ) : bin_op → val
| PlusOp  := VNat (n + m)
| MinusOp := VNat (n - m)
| TimesOp := VNat (n * m)
| ModOp   := VNat (n % m)
| GeOp    := VBool (n ≥ m)
| GtOp    := VBool (n > m)
| LeOp    := VBool (n ≤ m)
| LtOp    := VBool (n < m)
| EqOp    := VBool (n = m)

def subst (v : val) (x : string) : exp → exp
| (EVar y) := if x = y then (EVal v) else (EVar y)
| (ELet y e body) :=
      if x = y then ELet y (subst e) body
      else ELet y (subst e) (subst body)
| (EIf c t e) := EIf (subst c) (subst t) (subst e)
| (EOp op e₁ e₂) := EOp op (subst e₁) (subst e₂)
| (EVal v) := (EVal v)

def remove (name : string) : list (string × val) → list (string × val)
| [] := []
| ((x, v) :: nv') := if x = name then remove nv' else (x, v) :: remove nv'

def big_subst : list (string × val) → exp → exp
| [] expr := expr
| ((x, v) :: nv') e := big_subst nv' (subst v x e)

inductive big_step : exp → val → Prop
| RunVal {v} : big_step (EVal v) v
| RunOp {op eₙ eₘ n m}
    (_ : big_step eₙ (VNat n))
    (_ : big_step eₘ (VNat m))
  : big_step (EOp op eₙ eₘ) (eval n m op)
| RunIfT {c t f : exp} {v : val}
    (_ : big_step c (VBool tt))
    (_ : big_step t v)
  : big_step (EIf c t f) v
| RunIfF {c t f : exp} {v : val}
    (_ : big_step c (VBool ff))
    (_ : big_step f v)
  : big_step (EIf c t f) v
| RunLet {e body : exp} {x : string} {v r : val}
  (_ : big_step e v)
  (_ : big_step (subst v x body) r)
  : big_step (ELet x e body) r

infixr ` ⟹ ` : 30 := big_step

def at_least {α : Type} (n : ℕ) : list α → Prop
| (l : list α) := l.length ≥ n

lemma at_least_refl {α : Type} {l : list α} : at_least l.length l :=
by rw [at_least]; exact nat.le_refl (l.length)

inductive bound : string → val → list (string × val) → Prop
| bhead {x v env}     : bound x v ((x, v) :: env)
| btail {x y v u env} : x ≠ y → bound x v env → bound x v (⟨y, u⟩ :: env)

inductive vm_big_step :
  list (string × val) × list instruction × list val → list val → Prop
| RunEmpty {env stack} : vm_big_step (env, [], stack) stack
| RunPush {env instrs stack res v}
    (_ : vm_big_step (env, instrs, v :: stack) res)
  : vm_big_step (env, IPush v :: instrs, stack) res
| RunOpInstr {env instrs stack res op} {n m : ℕ}
    (_ : vm_big_step (env, instrs, eval n m op :: stack) res)
  : vm_big_step (env, IOp op :: instrs, VNat n :: VNat m :: stack) res
| RunTBranch {env instrs stack res n}
    (_ : vm_big_step (env, instrs, stack) res)
  : vm_big_step (env, IBranch n :: instrs, VBool tt :: stack) res
| RunFBranch {env instrs stack res n}
    (_ : at_least n instrs)
    (_ : vm_big_step (env, instrs.drop n, stack) res)
  : vm_big_step (env, IBranch n :: instrs, VBool ff :: stack) res
| RunJump {env instrs stack res n}
    (_ : at_least n instrs)
    (_ : vm_big_step (env, instrs.drop n, stack) res)
  : vm_big_step (env, IJump n :: instrs, stack) res
| RunLookup {env x v instrs stack res}
  (_ : bound x v env)
  (_ : vm_big_step (env, instrs, v :: stack) res)
 : vm_big_step (env, ILookup x :: instrs, stack) res
| RunOpenScope {env x v instrs stack res}
  (_ : vm_big_step (⟨x, v⟩ :: env, instrs, stack) res)
  : vm_big_step (env, IOpenScope x :: instrs, v :: stack) res
| RunCloseScope {env x v instrs stack res}
  (_ : vm_big_step (env, instrs, stack) res)
  : vm_big_step (⟨x, v⟩ :: env, ICloseScope :: instrs, stack) res

infix ` ⟹ᵥₘ ` : 50 := vm_big_step

-- big-step semantics including resulting environment
inductive env_big_step :
    list (string × val) × list instruction × list val
  → list (string × val) × list val → Prop
| ERunEmpty {env stack} : env_big_step (env, [], stack) (env, stack)
| ERunPush {env instrs stack res v}
    (_ : env_big_step (env, instrs, v :: stack) res)
  : env_big_step (env, IPush v :: instrs, stack) res
| ERunOpInstr {env instrs stack res op} {n m : ℕ}
    (_ : env_big_step (env, instrs, eval n m op :: stack) res)
  : env_big_step (env, IOp op :: instrs, VNat n :: VNat m :: stack) res
| ERunTBranch {env instrs stack res n}
    (_ : env_big_step (env, instrs, stack) res)
  : env_big_step (env, IBranch n :: instrs, VBool tt :: stack) res
| ERunFBranch {env instrs stack res n}
    (_ : at_least n instrs)
    (_ : env_big_step (env, instrs.drop n, stack) res)
  : env_big_step (env, IBranch n :: instrs, VBool ff :: stack) res
| ERunJump {env instrs stack res n}
    (_ : at_least n instrs)
    (_ : env_big_step (env, instrs.drop n, stack) res)
  : env_big_step (env, IJump n :: instrs, stack) res
| ERunLookup {env x v instrs stack res}
  (_ : bound x v env)
  (_ : env_big_step (env, instrs, v :: stack) res)
 : env_big_step (env, ILookup x :: instrs, stack) res
| ERunOpenScope {env x v instrs stack res}
  (_ : env_big_step (⟨x, v⟩ :: env, instrs, stack) res)
  : env_big_step (env, IOpenScope x :: instrs, v :: stack) res
| ERunCloseScope {env x v instrs stack res}
  (_ : env_big_step (env, instrs, stack) res)
  : env_big_step (⟨x, v⟩ :: env, ICloseScope :: instrs, stack) res

infix ` ⟹ₙᵥ ` : 50 := env_big_step


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.monoidal.braided
import Mathlib.category_theory.functor_category
import Mathlib.category_theory.const
import Mathlib.PostPort

universes u₁ u₂ v₁ v₂

namespace Mathlib

/-!
# Monoidal structure on `C ⥤ D` when `D` is monoidal.

When `C` is any category, and `D` is a monoidal category,
there is a natural "pointwise" monoidal structure on `C ⥤ D`.

The initial intended application is tensor product of presheaves.
-/

namespace category_theory.monoidal

namespace functor_category

/--
(An auxiliary definition for `functor_category_monoidal`.)
Tensor product of functors `C ⥤ D`, when `D` is monoidal.
 -/
def tensor_obj {C : Type u₁} [category C] {D : Type u₂} [category D] [monoidal_category D]
    (F : C ⥤ D) (G : C ⥤ D) : C ⥤ D :=
  functor.mk (fun (X : C) => functor.obj F X ⊗ functor.obj G X)
    fun (X Y : C) (f : X ⟶ Y) => functor.map F f ⊗ functor.map G f

/--
(An auxiliary definition for `functor_category_monoidal`.)
Tensor product of natural transformations into `D`, when `D` is monoidal.
-/
def tensor_hom {C : Type u₁} [category C] {D : Type u₂} [category D] [monoidal_category D]
    {F : C ⥤ D} {G : C ⥤ D} {F' : C ⥤ D} {G' : C ⥤ D} (α : F ⟶ G) (β : F' ⟶ G') :
    tensor_obj F F' ⟶ tensor_obj G G' :=
  nat_trans.mk fun (X : C) => nat_trans.app α X ⊗ nat_trans.app β X

end functor_category

/--
When `C` is any category, and `D` is a monoidal category,
the functor category `C ⥤ D` has a natural pointwise monoidal structure,
where `(F ⊗ G).obj X = F.obj X ⊗ G.obj X`.
-/
protected instance functor_category_monoidal {C : Type u₁} [category C] {D : Type u₂} [category D]
    [monoidal_category D] : monoidal_category (C ⥤ D) :=
  monoidal_category.mk (fun (F G : C ⥤ D) => functor_category.tensor_obj F G)
    (fun (F G F' G' : C ⥤ D) (α : F ⟶ G) (β : F' ⟶ G') => functor_category.tensor_hom α β)
    (functor.obj (functor.const C) 𝟙_)
    (fun (F G H : C ⥤ D) => nat_iso.of_components (fun (X : C) => α_) sorry)
    (fun (F : C ⥤ D) => nat_iso.of_components (fun (X : C) => λ_) sorry)
    fun (F : C ⥤ D) => nat_iso.of_components (fun (X : C) => ρ_) sorry

@[simp] theorem tensor_unit_obj {C : Type u₁} [category C] {D : Type u₂} [category D]
    [monoidal_category D] {X : C} : functor.obj 𝟙_ X = 𝟙_ :=
  rfl

@[simp] theorem tensor_unit_map {C : Type u₁} [category C] {D : Type u₂} [category D]
    [monoidal_category D] {X : C} {Y : C} {f : X ⟶ Y} : functor.map 𝟙_ f = 𝟙 :=
  rfl

@[simp] theorem tensor_obj_obj {C : Type u₁} [category C] {D : Type u₂} [category D]
    [monoidal_category D] {F : C ⥤ D} {G : C ⥤ D} {X : C} :
    functor.obj (F ⊗ G) X = functor.obj F X ⊗ functor.obj G X :=
  rfl

@[simp] theorem tensor_obj_map {C : Type u₁} [category C] {D : Type u₂} [category D]
    [monoidal_category D] {F : C ⥤ D} {G : C ⥤ D} {X : C} {Y : C} {f : X ⟶ Y} :
    functor.map (F ⊗ G) f = functor.map F f ⊗ functor.map G f :=
  rfl

@[simp] theorem tensor_hom_app {C : Type u₁} [category C] {D : Type u₂} [category D]
    [monoidal_category D] {F : C ⥤ D} {G : C ⥤ D} {F' : C ⥤ D} {G' : C ⥤ D} {α : F ⟶ G}
    {β : F' ⟶ G'} {X : C} : nat_trans.app (α ⊗ β) X = nat_trans.app α X ⊗ nat_trans.app β X :=
  rfl

@[simp] theorem left_unitor_hom_app {C : Type u₁} [category C] {D : Type u₂} [category D]
    [monoidal_category D] {F : C ⥤ D} {X : C} : nat_trans.app (iso.hom λ_) X = iso.hom λ_ :=
  rfl

@[simp] theorem left_unitor_inv_app {C : Type u₁} [category C] {D : Type u₂} [category D]
    [monoidal_category D] {F : C ⥤ D} {X : C} : nat_trans.app (iso.inv λ_) X = iso.inv λ_ :=
  rfl

@[simp] theorem right_unitor_hom_app {C : Type u₁} [category C] {D : Type u₂} [category D]
    [monoidal_category D] {F : C ⥤ D} {X : C} : nat_trans.app (iso.hom ρ_) X = iso.hom ρ_ :=
  rfl

@[simp] theorem right_unitor_inv_app {C : Type u₁} [category C] {D : Type u₂} [category D]
    [monoidal_category D] {F : C ⥤ D} {X : C} : nat_trans.app (iso.inv ρ_) X = iso.inv ρ_ :=
  rfl

@[simp] theorem associator_hom_app {C : Type u₁} [category C] {D : Type u₂} [category D]
    [monoidal_category D] {F : C ⥤ D} {G : C ⥤ D} {H : C ⥤ D} {X : C} :
    nat_trans.app (iso.hom α_) X = iso.hom α_ :=
  rfl

@[simp] theorem associator_inv_app {C : Type u₁} [category C] {D : Type u₂} [category D]
    [monoidal_category D] {F : C ⥤ D} {G : C ⥤ D} {H : C ⥤ D} {X : C} :
    nat_trans.app (iso.inv α_) X = iso.inv α_ :=
  rfl

/--
When `C` is any category, and `D` is a braided monoidal category,
the natural pointwise monoidal structure on the functor category `C ⥤ D`
is also braided.
-/
protected instance functor_category_braided {C : Type u₁} [category C] {D : Type u₂} [category D]
    [monoidal_category D] [braided_category D] : braided_category (C ⥤ D) :=
  braided_category.mk fun (F G : C ⥤ D) => nat_iso.of_components (fun (X : C) => β_) sorry

/--
When `C` is any category, and `D` is a symmetric monoidal category,
the natural pointwise monoidal structure on the functor category `C ⥤ D`
is also symmetric.
-/
protected instance functor_category_symmetric {C : Type u₁} [category C] {D : Type u₂} [category D]
    [monoidal_category D] [symmetric_category D] : symmetric_category (C ⥤ D) :=
  symmetric_category.mk

end Mathlib