import natural_deduction
import semantics

variables {vars : Type} {Γ : set (Form vars)} {A B C : Form vars}

theorem soundness : (Γ ⊩ A) → (Γ ⊨ A) :=
begin
  -- induce on the structure of the derivation
  -- but before that we unwrap definitions and introduce hypotheses
  -- to avoid repeating the process in each case
  intro deriv,
  rw entail,
  intros v hΓ,
  induction deriv,
  case Deriv.Bottom_E : Γ A h ih {
   -- the ih can be used to derive falsehood, from which anything follows
   specialize ih hΓ,
   simp [eval] at ih,
   exfalso,
   exact ih,
  },
  case Deriv.Ax : Γ A h {
   exact hΓ A h,
  },
  case Deriv.Not_I : Γ A h ih {
   -- see what the goal really is (when simplified) first
   simp [eval],
   -- we need A to evaluate to truth in order to use the ih,
   -- so try to prove by contradiction as it assumes exactly this
   by_contra hA,
   simp at hA,
   -- use the ih: we first have to prove the precedent in the
   -- exactly required form
   have : ∀ (γ : Form vars), γ ∈ (insert A Γ) → (↥⟦γ⟧_ v),
   { -- either γ is A or its in Γ
     intros γ hγ,
     simp at hγ, cases hγ,
     {rw hγ, exact hA}, -- in the former case, we use hA
     {exact hΓ γ hγ}    -- in the latter case, we use hΓ
   },
   specialize ih this,
   -- now the evaluation of the ih is really just falsehood, exactly what we
   -- need
   simp [eval] at ih,
   exact ih
  },
  case Deriv.Not_E : Γ A h₁ h₂ ih₁ ih₂ {
   -- ih₁ and ih₂ have contradicting antecedents, so we first obtain those
   specialize ih₁ hΓ,
   specialize ih₂ hΓ,
   simp [eval] at ih₁ ih₂ ⊢,
   -- form the contradiction to obtain falsehood
   rw ih₁ at ih₂,
   simp at ih₂,
   exact ih₂
  },
  case Deriv.And_I : Γ A B h₁ h₂ ih₁ ih₂ {
   -- similar to case above, but we make A ⋀ B instead of a contradiction
   specialize ih₁ hΓ,
   specialize ih₂ hΓ,
   simp [eval] at ⊢,
   exact ⟨ih₁, ih₂⟩
  },
  case Deriv.And_E_1 : Γ A B h ih {
   -- take out the truth of A from the truth of A and B
   specialize ih hΓ,
   simp [eval] at ih,
   cases ih with ih₁ ih₂,
   exact ih₁
  },
  case Deriv.And_E_2 : Γ A B h ih {
   -- As in the previous case, but we want B
   specialize ih hΓ,
   simp [eval] at ih,
   cases ih with ih₁ ih₂,
   exact ih₂
  },
  case Deriv.Or_I_1 : Γ A B h ih {
   specialize ih hΓ,
   simp [eval],
   left,
   exact ih
  },
  case Deriv.Or_I_2 : Γ A B h ih {
   specialize ih hΓ,
   simp [eval],
   right,
   exact ih
  },
  case Deriv.Or_E : Γ A B C h h₁ h₂ ih ih₁ ih₂ {
   -- the antecedent of ih₁ and ih₂ both are the goal we want,
   -- but we cannot apply them directly as this would require proving that A
   -- (respectively B) evaluates to true. This we cannot do. Instead use ih
   -- to obtain the A ⋁ B, which allows an analysis by cases.
   specialize ih hΓ,
   simp [eval] at ih,
   cases ih,
   -- from here, we can use ih₁ in the first case and ih₂ in the second.
   {
     apply ih₁,
     intros γ hγ,
     cases hγ,
     {rw hγ, exact ih}, -- if γ = A
     {exact hΓ γ hγ}    -- if γ in Γ
   },
   {
     apply ih₂,
     intros γ hγ,
     cases hγ,
     {rw hγ, exact ih}, -- if γ = A
     {exact hΓ γ hγ}    -- if γ in Γ
   },
  },
  case Deriv.Contra : Γ A h ih {
   -- as with Not_I, we need a proof by contradiction.
   -- the structure of the proof is very similar.
   by_contra hA,
   simp [eval] at hA,
   have : ∀ (γ : Form vars), γ ∈ (insert (~ A) Γ) → (↥⟦γ⟧_ v),
   {
     intros γ hγ,
     simp at hγ, cases hγ,
     {rw hγ, simp [eval], exact hA},
     {exact hΓ γ hγ}
   },
   specialize ih this, simp [eval] at ih,
   exact ih
  },
  case Deriv.Weakening : Γ Γ' A hsub h ih {
    apply ih,
    intros γ hγ,
    apply hΓ,
    apply hsub,
    exact hγ
  }
end

theorem soundness' : satisfiable Γ → consistent Γ :=
begin
  rw [consistent, satisfiable_iff],
  intro hsat,
  -- suppose towards a contradiction that Γ is inconsistent, so Γ ⊩ ⊥
  by_contra hcon,
  -- by the soundness theorem, Γ ⊨ ⊥, which contradicts Γ being satisfiable
  have : (Γ ⊨ ⊥) := soundness hcon,
  exact hsat this
end

#lint


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import topology.sheaves.sheaf_condition.sites

/-!
# Another version of the sheaf condition.

Given a family of open sets `U : ι → opens X` we can form the subcategory
`{ V : opens X // ∃ i, V ≤ U i }`, which has `supr U` as a cocone.

The sheaf condition on a presheaf `F` is equivalent to
`F` sending the opposite of this cocone to a limit cone in `C`, for every `U`.

This condition is particularly nice when checking the sheaf condition
because we don't need to do any case bashing
(depending on whether we're looking at single or double intersections,
or equivalently whether we're looking at the first or second object in an equalizer diagram).

## Main statement

`Top.presheaf.is_sheaf_iff_is_sheaf_opens_le_cover`: for a presheaf on a topological space,
the sheaf condition in terms of Grothendieck topology is equivalent to the `opens_le_cover`
sheaf condition. This result will be used to further connect to other sheaf conditions on spaces,
like `pairwise_intersections` and `equalizer_products`.

## References
* This is the definition Lurie uses in [Spectral Algebraic Geometry][LurieSAG].
-/

universes w v u

noncomputable theory

open category_theory category_theory.limits topological_space topological_space.opens opposite

namespace Top

variables {C : Type u} [category.{v} C]
variables {X : Top.{w}} (F : presheaf C X) {ι : Type w} (U : ι → opens X)

namespace presheaf

namespace sheaf_condition

/--
The category of open sets contained in some element of the cover.
-/
@[derive category]
def opens_le_cover : Type w := full_subcategory (λ (V : opens X), ∃ i, V ≤ U i)

instance [inhabited ι] : inhabited (opens_le_cover U) :=
⟨⟨⊥, default, bot_le⟩⟩

namespace opens_le_cover

variables {U}

/--
An arbitrarily chosen index such that `V ≤ U i`.
-/
def index (V : opens_le_cover U) : ι := V.property.some

/--
The morphism from `V` to `U i` for some `i`.
-/
def hom_to_index (V : opens_le_cover U) : V.obj ⟶ U (index V) :=
(V.property.some_spec).hom

end opens_le_cover

/--
`supr U` as a cocone over the opens sets contained in some element of the cover.

(In fact this is a colimit cocone.)
-/
def opens_le_cover_cocone : cocone (full_subcategory_inclusion _ : opens_le_cover U ⥤ opens X) :=
{ X := supr U,
  ι := { app := λ V : opens_le_cover U, V.hom_to_index ≫ opens.le_supr U _, } }

end sheaf_condition

open sheaf_condition

/--
An equivalent formulation of the sheaf condition
(which we prove equivalent to the usual one below as
`is_sheaf_iff_is_sheaf_opens_le_cover`).

A presheaf is a sheaf if `F` sends the cone `(opens_le_cover_cocone U).op` to a limit cone.
(Recall `opens_le_cover_cocone U`, has cone point `supr U`,
mapping down to any `V` which is contained in some `U i`.)
-/
def is_sheaf_opens_le_cover : Prop :=
∀ ⦃ι : Type w⦄ (U : ι → opens X), nonempty (is_limit (F.map_cone (opens_le_cover_cocone U).op))

section

variables {Y : opens X} (hY : Y = supr U)

/-- Given a family of opens `U` and an open `Y` equal to the union of opens in `U`, we may
    take the presieve on `Y` associated to `U` and the sieve generated by it, and form the
    full subcategory (subposet) of opens contained in `Y` (`over Y`) consisting of arrows
    in the sieve. This full subcategory is equivalent to `opens_le_cover U`, the (poset)
    category of opens contained in some `U i`. -/
@[simps] def generate_equivalence_opens_le :
  full_subcategory (λ (f : over Y), (sieve.generate (presieve_of_covering_aux U Y)).arrows f.hom) ≌
  opens_le_cover U :=
{ functor :=
  { obj := λ f, ⟨f.1.left, let ⟨_,h,_,⟨i,hY⟩,_⟩ := f.2 in ⟨i, hY ▸ h.le⟩⟩,
    map := λ _ _ g, g.left },
  inverse :=
  { obj := λ V, ⟨over.mk (hY.substr (let ⟨i,h⟩ := V.2 in h.trans (le_supr U i))).hom,
      let ⟨i,h⟩ := V.2 in ⟨U i, h.hom, (hY.substr (le_supr U i)).hom, ⟨i, rfl⟩, rfl⟩⟩,
    map := λ _ _ g, over.hom_mk g },
  unit_iso := eq_to_iso $ category_theory.functor.ext
    (by {rintro ⟨⟨_,_⟩,_⟩, dsimp, congr; ext}) (by {intros, ext}),
  counit_iso := eq_to_iso $ category_theory.functor.hext
    (by {intro, ext, refl}) (by {intros, refl}) }

/-- Given a family of opens `opens_le_cover_cocone U` is essentially the natural cocone
    associated to the sieve generated by the presieve associated to `U` with indexing
    category changed using the above equivalence. -/
@[simps] def whisker_iso_map_generate_cocone :
  (F.map_cone (opens_le_cover_cocone U).op).whisker (generate_equivalence_opens_le U hY).op.functor
    ≅ F.map_cone (sieve.generate (presieve_of_covering_aux U Y)).arrows.cocone.op :=
{ hom :=
  { hom := F.map (eq_to_hom (congr_arg op hY.symm)),
    w' := λ j, by { erw ← F.map_comp, congr } },
  inv :=
  { hom := F.map (eq_to_hom (congr_arg op hY)),
    w' := λ j, by { erw ← F.map_comp, congr } },
  hom_inv_id' := by { ext, simp [eq_to_hom_map], },
  inv_hom_id' := by { ext, simp [eq_to_hom_map], } }

/-- Given a presheaf `F` on the topological space `X` and a family of opens `U` of `X`,
    the natural cone associated to `F` and `U` used in the definition of
    `F.is_sheaf_opens_le_cover` is a limit cone iff the natural cone associated to `F`
    and the sieve generated by the presieve associated to `U` is a limit cone. -/
def is_limit_opens_le_equiv_generate₁ :
  is_limit (F.map_cone (opens_le_cover_cocone U).op) ≃
  is_limit (F.map_cone (sieve.generate (presieve_of_covering_aux U Y)).arrows.cocone.op) :=
(is_limit.whisker_equivalence_equiv (generate_equivalence_opens_le U hY).op).trans
  (is_limit.equiv_iso_limit (whisker_iso_map_generate_cocone F U hY))

/-- Given a presheaf `F` on the topological space `X` and a presieve `R` whose generated sieve
    is covering for the associated Grothendieck topology (equivalently, the presieve is covering
    for the associated pretopology), the natural cone associated to `F` and the family of opens
    associated to `R` is a limit cone iff the natural cone associated to `F` and the generated
    sieve is a limit cone.
    Since only the existence of a 1-1 correspondence will be used, the exact definition does
    not matter, so tactics are used liberally. -/
def is_limit_opens_le_equiv_generate₂ (R : presieve Y)
  (hR : sieve.generate R ∈ opens.grothendieck_topology X Y) :
  is_limit (F.map_cone (opens_le_cover_cocone (covering_of_presieve Y R)).op) ≃
  is_limit (F.map_cone (sieve.generate R).arrows.cocone.op) :=
begin
  convert is_limit_opens_le_equiv_generate₁ F (covering_of_presieve Y R)
    (covering_of_presieve.supr_eq_of_mem_grothendieck Y R hR).symm using 2;
  rw covering_presieve_eq_self R,
end

/-- A presheaf `(opens X)ᵒᵖ ⥤ C` on a topological space `X` is a sheaf on the site `opens X` iff
    it satisfies the `is_sheaf_opens_le_cover` sheaf condition. The latter is not the
    official definition of sheaves on spaces, but has the advantage that it does not
    require `has_products C`. -/
lemma is_sheaf_iff_is_sheaf_opens_le_cover :
  F.is_sheaf ↔ F.is_sheaf_opens_le_cover :=
begin
  refine (presheaf.is_sheaf_iff_is_limit _ _).trans _,
  split,
  { intros h ι U, rw (is_limit_opens_le_equiv_generate₁ F U rfl).nonempty_congr,
    apply h, apply presieve_of_covering.mem_grothendieck_topology },
  { intros h Y S, rw ← sieve.generate_sieve S, intro hS,
    rw ← (is_limit_opens_le_equiv_generate₂ F S hS).nonempty_congr, apply h },
end

end

end presheaf

end Top


def Foo := Nat
def Foo.pow (x : Nat) (k : Nat) : Foo :=
  match k with
  | 0 => x
  | k+1 => pow x k

instance : Pow Foo Nat := ⟨Foo.pow⟩

example (x : Foo) : x ^ 2048 = x := by
  show Foo.pow x 2048 = x
  sorry


import .collapse .aleph_one

/-
  Forcing the continuum hypothesis.
-/

universe u

open lattice bSet topological_space pSet cardinal

local infix ` ⟹ `:65 := lattice.imp

local infix ` ⇔ `:50 := lattice.biimp

local infix `≺`:75 := (λ x y, -(bSet.larger_than x y))

local infix `≼`:75 := (λ x y, bSet.injects_into x y)

@[reducible]private noncomputable definition ℵ₁ : pSet := (card_ex $ aleph 1)

local notation `ω` := (bSet.omega)

local attribute [instance, priority 0] classical.prop_decidable

namespace bSet

section aleph_one

variables {𝔹 : Type*} [nontrivial_complete_boolean_algebra 𝔹]

noncomputable def aleph_one : bSet 𝔹 := a1

lemma aleph_one_satisfies_spec {Γ : 𝔹} : Γ ≤ aleph_one_Ord_spec (aleph_one) :=
a1_spec

lemma aleph_one_check_sub_aleph_one {Γ : 𝔹} : Γ ≤ (pSet.card_ex (aleph 1))̌  ⊆ᴮ aleph_one :=
aleph_one_check_sub_aleph_one_aux a1_Ord a1_spec

lemma aleph_one_le_of_omega_lt {Γ : 𝔹} : Γ ≤ le_of_omega_lt (aleph_one) :=
a1_le_of_omega_lt

end aleph_one

section lemmas

variables {𝔹 : Type u} [nontrivial_complete_boolean_algebra 𝔹]

/-- Corresponds to proposition 5.2 in Moore's 'the method of forcing':
Let x be a set and let ϕ(v) be a formula in the forcing language. If ∀ y ∈ x, p ⊩ ϕ(y̌), then p ⊩ ∀ y ∈ (x̌), ϕ(y)
-/
lemma check_forall (x : pSet.{u}) (ϕ : bSet 𝔹 → 𝔹) {b : 𝔹} :
  (∀ (y : x.type), b ≤ ϕ((x.func y)̌ )) → (b ≤ (⨅(y : x.type), ϕ((x.func y)̌ ))) :=
λ H, le_infi ‹_›

lemma aleph_one_check_is_aleph_one_of_omega_lt {Γ : 𝔹} (H : Γ ≤ bSet.omega ≺ (ℵ₁)̌ ): Γ ≤ (ℵ₁̌ ) =ᴮ (aleph_one) :=
begin
  refine subset_ext aleph_one_check_sub_aleph_one _,
  have := @bSet.aleph_one_satisfies_spec _ _ Γ, unfold aleph_one_Ord_spec at this,
  bv_split, bv_split_at this_right,
  refine this_right_right (ℵ₁ ̌) (by simp) _, dsimp at H, rw ←imp_bot at ⊢ H,
  bv_imp_intro H', refine H (larger_than_of_surjects_onto $ surjects_onto_of_injects_into ‹_› $ by simp),
end

theorem CH_true_aux
  (H_aleph_one : ∀{Γ : 𝔹}, Γ ≤ le_of_omega_lt (ℵ₁̌ ))
  (H_not_lt    : ∀{Γ : 𝔹}, Γ ≤ - ((ℵ₁)̌  ≺ 𝒫(ω)))
  : ∀{Γ : 𝔹}, Γ ≤ CH :=
begin
  intro Γ, unfold CH, rw ←imp_bot, bv_imp_intro H_CH,
  suffices H_aleph_lt_continuum : Γ_1 ≤ (ℵ₁)̌  ≺ 𝒫(ω),
    by {refine bv_absurd _ ‹Γ_1 ≤ (ℵ₁)̌  ≺ 𝒫(ω)› (by solve_by_elim) },
  bv_cases_at H_CH x Hx, bv_split_at Hx, bv_cases_at Hx_right y Hy,
  bv_split_at Hy, bv_split_at Hy_left,
  refine bSet_lt_of_lt_of_le _ Hy_right,
  refine bSet_lt_of_le_of_lt _ Hy_left_right,
  refine @H_aleph_one Γ_3 x Hx_left Hy_left_left
end

def rel_of_array (x y : bSet 𝔹) (af : x.type → y.type → 𝔹) : bSet 𝔹 :=
set_of_indicator (λ pr, (af pr.1 pr.2) : (prod x y).type → 𝔹)

lemma rel_of_array_surj (x y : bSet 𝔹) (af : x.type → y.type → 𝔹)
  (H_bval₁ : ∀ i, x.bval i = ⊤)
  (H_bval₂ : ∀ i, y.bval i = ⊤)
  (H_wide : ∀ j, (⨆ i, af i j) = ⊤) {Γ}
  : Γ ≤ (is_surj x y (rel_of_array x y af)) :=
begin
  bv_intro z, bv_imp_intro Hz, rw[<-@bounded_exists 𝔹 _ x _ _],
  simp [H_bval₁],
    { rw[bSet.mem_unfold] at Hz, bv_cases_at Hz i, simp[H_bval₂] at Hz_1,
     apply bv_rw' Hz_1,
       { apply B_ext_supr, intro i,
       from @B_ext_pair_right 𝔹 _ (λ z, z ∈ᴮ rel_of_array x y af) (by simp) _},
       { rw[rel_of_array], simp, erw[supr_comm],
         transitivity ⨆ (j : type x), af j i ⊓
           pair (func x j) (func y i) =ᴮ pair (func x j) (func y i),
         conv {congr, skip, congr, funext, rw[bv_eq_refl _]}, simp[H_wide],
         clear_except, tidy_context,
         bv_cases_at a j, refine bv_use (j,i),
         refine bv_use j, from ‹_›}},
    { change B_ext _, from B_ext_term _ _ (B_ext_mem_left) (by simp) }
end

lemma mem_left_of_mem_rel_of_array {x y w₁ w₂ : bSet 𝔹} {af : x.type → y.type → 𝔹}
  {Γ} (H_mem_left : Γ ≤ pair w₁ w₂ ∈ᴮ rel_of_array x y af)
  (H_bval₁ : ∀ i, x.bval i = ⊤)
  : Γ ≤ w₁ ∈ᴮ x :=
begin
  unfold rel_of_array at H_mem_left, dsimp at H_mem_left,
  bv_cases_at H_mem_left p, cases p with i j, dsimp at H_mem_left_1,
  bv_split_at H_mem_left_1, have := eq_of_eq_pair_left' ‹_›,
  apply bv_rw' this, simp, from mem.mk'' (by simp only [H_bval₁ _, le_top])
end

lemma mem_right_of_mem_rel_of_array {x y w₁ w₂ : bSet 𝔹} {af : x.type → y.type → 𝔹}
  {Γ} (H_mem_right : Γ ≤ pair w₁ w₂ ∈ᴮ rel_of_array x y af)
  (H_bval₂ : ∀ i, y.bval i = ⊤)
  : Γ ≤ w₂ ∈ᴮ y :=
begin
  unfold rel_of_array at H_mem_right, dsimp at H_mem_right,
  bv_cases_at H_mem_right p, cases p with i j, dsimp at H_mem_right_1,
  bv_split_at H_mem_right_1, have := eq_of_eq_pair_right' ‹_›,
  apply bv_rw' this, simp, apply mem.mk'', simp only [H_bval₂ _, le_top]
end

local attribute [instance] classical.prop_decidable

lemma rel_of_array_extensional (x y : bSet 𝔹) (af : x.type → y.type → 𝔹)
  (H_anti : ∀ i, (∀ j₁ j₂, j₁ ≠ j₂ → af i j₁ ⊓ af i j₂ ≤ ⊥))
  (H_inj  : ∀ i₁ i₂, ⊥ < (func x i₁) =ᴮ (func x i₂) → i₁ = i₂)
  {Γ}
  : Γ ≤ (is_func (rel_of_array x y af)) :=
begin
  bv_intro w₁, bv_intro v₁, bv_intro w₂, bv_intro v₂,
  bv_imp_intro H_mem, bv_split,
  bv_imp_intro H_eq,
  have this : Γ_2 ≤ pair w₁ v₂ ∈ᴮ rel_of_array x y af,
    by {apply bv_rw' H_eq,
          { exact B_ext_term _ _ (B_ext_mem_left) (by simp) },
          { from ‹_› }},
  clear_except H_mem_left this H_anti H_inj H_eq,
  dsimp[rel_of_array] at H_mem_left this,
  bv_cases_at H_mem_left p₁, cases p₁ with i₁ j₁,
  suffices : Γ_3 ≤ v₂ =ᴮ (y.func j₁),
    by {refine bv_trans _ (bv_symm this), bv_split,
         from eq_of_eq_pair_right' ‹_›},
  bv_cases_at this p₂, cases p₂ with i₂ j₂,
  suffices : Γ_4 ≤ (y.func j₂) =ᴮ (func y j₁),
    by {exact bv_trans (by bv_split; from eq_of_eq_pair_right' ‹_›) (this)},
  by_cases j₁ = j₂,
    { subst h, from bv_refl},
    { bv_exfalso, by_cases i₁ = i₂,
        { subst h, specialize H_anti i₁ j₁ j₂ ‹_›, refine le_trans _ H_anti,
          bv_split, bv_split_goal},
        { suffices : Γ_4 ≤ - (w₁ =ᴮ v₁),
            by {exact bv_absurd (w₁ =ᴮ v₁) ‹_› ‹_›},
          suffices : Γ_4 ≤ w₁ =ᴮ (func x i₁) ∧ Γ_4 ≤ v₁ =ᴮ (func x i₂),
            by { clear_except H_inj this h,
                 apply bv_rw' this.left, by simp,
                 apply bv_rw' this.right, by simp,
                 suffices H_le_bot : (func x i₁ =ᴮ func x i₂) ≤ ⊥,
                   by {rw[<-imp_bot, <-deduction], from le_trans (by simp) H_le_bot},
                 suffices H_not_bot_lt : ¬ (⊥ < func x i₁ =ᴮ func x i₂),
                   by {clear_except H_not_bot_lt, finish[bot_lt_iff_not_le_bot]},
                 clear_except H_inj h, intro H, from absurd (H_inj _ _ H) ‹_›},
          bv_split,
          exact ⟨eq_of_eq_pair_left' H_mem_left_1_right,
                   bv_trans (bv_symm H_eq) (eq_of_eq_pair_left' this_1_right)⟩}}
end

lemma rel_of_array_is_func'  (x y : bSet 𝔹) (af : x.type → y.type → 𝔹)
  (H_bval₂ : ∀ i, y.bval i = ⊤)
  (H_tall : ∀ i, (⨆ j, af i j) = ⊤) -- this is not in the book, but I think it should be
  (H_anti : ∀ i, (∀ j₁ j₂, j₁ ≠ j₂ → af i j₁ ⊓ af i j₂ ≤ ⊥))
  (H_inj  : ∀ i₁ i₂, ⊥ < (func x i₁) =ᴮ (func x i₂) → i₁ = i₂)
  {Γ}
  : Γ ≤ is_func' x y (rel_of_array x y af) :=
begin
  refine le_inf (by apply rel_of_array_extensional; assumption) _, rw bSet.is_total,
  rw[<-bounded_forall], bv_intro i_x, bv_imp_intro Hi_x, rw[<-bounded_exists],
    { simp[*,rel_of_array, -Γ_1], erw[supr_comm, supr_prod],
      apply bv_use i_x,
      transitivity ⨆ (j : type y),
      af ((i_x, j).fst) ((i_x, j).snd) ⊓ pair (func x i_x) (func y j) =ᴮ pair (func x ((i_x, j).fst)) (func y ((i_x, j).snd)),
        { conv { to_rhs, funext, congr, funext,rw[bv_eq_refl] }, simp[H_tall]},
        { exact diagonal_supr_le_supr (by refl) }},
    { change B_ext _, from B_ext_term _ _ (B_ext_mem_left) (by simp) },
    { change B_ext _, apply B_ext_supr, intro, apply B_ext_inf,
      { simp },
      { from B_ext_term _ _ (B_ext_mem_left) (by simp) }}
end

section function_reflect

variables {D : set 𝔹}
          (H_docs : dense_omega_closed_subset D)
          {y : pSet.{u}}
          {g : bSet 𝔹}
          {Γ : 𝔹}
          (H_nonzero : ⊥ < Γ)
          (H : Γ ≤ is_func' bSet.omega y̌ g)
          (AE : ∀ (x y : pSet) {f : bSet 𝔹} {Γ : 𝔹},
                  Γ ≤ is_func' x̌  y̌  f →
                    ⊥ < Γ →
                      ∀ (i : pSet.type x),
                        ∃ (j : pSet.type y) (Γ' : 𝔹) (H_nonzero' : ⊥ < Γ') (H_le : Γ' ≤ Γ),
                          Γ' ≤ is_func' x̌  y̌  f ∧ Γ' ≤ pair (pSet.func x i)̌  (pSet.func y j)̌  ∈ᴮ f ∧ Γ' ∈ D )

local notation `ae₀` := AE pSet.omega y H H_nonzero

local notation `aeₖ` := AE pSet.omega y

include y g Γ H_nonzero H AE

noncomputable def function_reflect.fB : ℕ → Σ' (j : y.type) (B : 𝔹), (⊥ < B ∧ B ≤ is_func' bSet.omega y̌ g)
| 0 := begin
         use classical.some (ae₀ (ulift.up 0)), use classical.some (classical.some_spec (ae₀ (ulift.up 0))),
         rcases classical.some_spec (classical.some_spec (ae₀ (ulift.up 0))) with ⟨_,_,_,_⟩, from ⟨‹_›,‹_›⟩
       end
| (k+1) := begin
             use classical.some ((aeₖ ((function_reflect.fB) k).2.2.2 ((function_reflect.fB) k).2.2.1 ((ulift.up $ k + 1)))),
             use classical.some (classical.some_spec ((aeₖ ((function_reflect.fB) k).2.2.2 ((function_reflect.fB) k).2.2.1 ((ulift.up $ k + 1))))),
             rcases classical.some_spec (classical.some_spec ((aeₖ ((function_reflect.fB) k).2.2.2 ((function_reflect.fB) k).2.2.1 ((ulift.up $ k + 1))))) with ⟨_,_,_,_⟩,
             from ⟨‹_›,‹_›⟩
           end

@[reducible]noncomputable def function_reflect.B : ℕ → 𝔹 := λ n, (function_reflect.fB H_nonzero H AE n).2.1

@[reducible]noncomputable def function_reflect.f : ℕ → y.type := λ n, (function_reflect.fB H_nonzero H AE n).1

lemma function_reflect.B_nonzero (n) : ⊥ < (function_reflect.B H_nonzero H AE n) :=
(function_reflect.fB H_nonzero H AE n).2.2.left

lemma function_reflect.B_is_func' (n) : (function_reflect.B H_nonzero H AE n) ≤ is_func' bSet.omega y̌ g :=
(function_reflect.fB H_nonzero H AE n).2.2.right

lemma function_reflect.B_unfold {n} : function_reflect.B H_nonzero H AE (n+1)
  = classical.some ((function_reflect.fB._main._proof_7 H_nonzero H AE n)) -- yuck
:=  rfl

lemma function_reflect.B_le {n} : (function_reflect.B H_nonzero H AE (n + 1)) ≤ function_reflect.B H_nonzero H AE n :=
begin
  rw function_reflect.B_unfold, let p := _, change classical.some p ≤ _,
  rcases classical.some_spec p with ⟨_,_,_,_⟩, convert h_w, clear_except, unfold function_reflect.B, cases n, refl, refl,
end

lemma function_reflect.B_pair {n} : (function_reflect.B H_nonzero H AE n) ≤ pair (pSet.omega.func (ulift.up n))̌  (y.func $ function_reflect.f H_nonzero H AE n)̌  ∈ᴮ g :=
begin
  cases n,
    { change classical.some _ ≤ _, let p := _, change classical.some p ≤ _,
      rcases classical.some_spec p with ⟨_,_,_,_,_⟩, from ‹_› },
    { rw function_reflect.B_unfold, let p := _, change classical.some p ≤ _,
      rcases classical.some_spec p with ⟨_,_,_,_,_⟩, from ‹_› }
end

lemma function_reflect.B_mem_dense {n} : (function_reflect.B H_nonzero H AE n) ∈ D :=
begin
  cases n,
    { let p := _, change classical.some p ∈ _,
      rcases classical.some_spec p with ⟨_,_,_,_,_⟩, from ‹_› },
    { rw function_reflect.B_unfold, let p := _, change classical.some p ∈ _,
      rcases classical.some_spec p with ⟨_,_,_,_,_⟩, from ‹_› }
end

variable (H_function : Γ ≤ is_function bSet.omega y̌ g)

lemma function_reflect.B_infty_le_Γ : (⨅ n, (function_reflect.B H_nonzero H AE n)) ≤ Γ :=
begin
  refine infi_le_of_le 0 _, let p := _, change classical.some p ≤ _,
  rcases classical.some_spec p with ⟨_,_,_,_⟩, from ‹_›
end

lemma function_reflect_aux : (⨅n, function_reflect.B H_nonzero H AE n) ≤ (⨅n, pair (pSet.omega.func (ulift.up n))̌  (y.func $ function_reflect.f H_nonzero H AE n)̌  ∈ᴮ g) :=
infi_le_infi $ λ _, by apply function_reflect.B_pair

noncomputable def function_reflect.f' : pSet.{u} :=
begin
  refine @pSet.function.mk pSet.omega _ _,
  intro k, cases k with k',
  exact y.func (function_reflect.f H_nonzero H AE k'),
  intros i j Heqv,
  suffices this : i = j,
    by { subst this },
  from pSet.omega_inj ‹_›
end

lemma function_reflect.f'_is_function : ∀ {Γ : 𝔹}, Γ ≤ is_function (pSet.omega)̌  y̌ (function_reflect.f' H_nonzero H AE)̌  :=
begin
  refine @check_is_func 𝔹 _ pSet.omega y (function_reflect.f' H_nonzero H AE) _, apply pSet.function.mk_is_func, intro i, cases i, simp
end

lemma function_reflect_aux₂ : (⨅n, function_reflect.B H_nonzero H AE n) ≤ (⨅n, (pair (pSet.omega.func (ulift.up n))̌  (y.func $ function_reflect.f H_nonzero H AE n)̌  ∈ᴮ (function_reflect.f' H_nonzero H AE)̌  ⇔ (pair (pSet.omega.func (ulift.up n))̌  (y.func $ function_reflect.f H_nonzero H AE n)̌  ∈ᴮ g))) :=
begin
  refine infi_le_infi (λ n, _), tidy_context, refine ⟨_,_⟩; bv_imp_intro H_mem,
    { refine le_trans a _, apply function_reflect.B_pair },
    { apply @bv_rw' _ _ _ _ _ (bv_symm check_pair) (λ z, z ∈ᴮ  (function_reflect.f' H_nonzero H AE)̌ ), simp,
      refine check_mem _, convert pSet.function.mk_mem, refl }
end

include H_function

lemma function_reflect.B_infty_le_function : (⨅ n, (function_reflect.B H_nonzero H AE n)) ≤ is_function ω y̌ g :=
le_trans (by apply function_reflect.B_infty_le_Γ) H_function

lemma function_reflect_aux₃ : (⨅n, function_reflect.B H_nonzero H AE n) ≤ ⨅ (p : bSet 𝔹), p ∈ᴮ prod pSet.omegǎ  y̌  ⟹ (p ∈ᴮ (function_reflect.f' H_nonzero H AE)̌  ⇔ p ∈ᴮ g) :=
begin
  rw ←bounded_forall, swap, {change B_ext _, simp},
  bv_intro pr, rcases pr with ⟨⟨i⟩, j⟩, simp only [prod_check_bval, top_imp, prod_func],
  have := (function_reflect_aux₂ H_nonzero H AE) i, bv_split_at this,
  refine le_inf _ _; bv_imp_intro H',
    { have this' : Γ_1 ≤ (pair (func pSet.omegǎ  {down := i}) (func y̌  j)) =ᴮ (pair (pSet.func pSet.omega {down := i})̌  (pSet.func y (function_reflect.f H_nonzero H AE i))̌ ),
        by {rw pair_eq_pair_iff, refine ⟨bv_refl, _⟩,
            refine eq_of_is_func'_of_eq (is_func'_of_is_function _) _ _ _, show _ ≤ is_function bSet.omega y̌ (function_reflect.f' H_nonzero H AE)̌ ,
            refine check_is_func _, apply pSet.function.mk_is_func, intro n, cases n, simp,
            show _ ≤ _ =ᴮ _, apply bv_refl, from H',
            refine this_right _,
            refine le_trans (inf_le_right) (infi_le_of_le i (by apply function_reflect.B_pair))},
      apply @bv_rw' _ _ _ _ _ this' (λ z, z ∈ᴮ g), simp,
      have := (inf_le_right : Γ_1 ≤ _),
      exact le_trans this (le_trans
              (by apply function_reflect_aux) (infi_le_of_le i (by refl)))},
    { have this' : Γ_1 ≤ (pair (func pSet.omegǎ  {down := i}) (func y̌  j)) =ᴮ (pair (pSet.func pSet.omega {down := i})̌  (pSet.func y (function_reflect.f H_nonzero H AE i))̌ ),
        by {rw pair_eq_pair_iff, refine ⟨bv_refl, _⟩,
            refine eq_of_is_func'_of_eq (is_func'_of_is_function _) _ _ _, show _ ≤ is_function _ _ _, refine le_trans inf_le_right (function_reflect.B_infty_le_function _ _ _ H_function),
            show _ ≤ _ =ᴮ _, from (bv_refl : _ ≤ (func pSet.omegǎ  {down := i}) =ᴮ _), from H',
        refine le_trans (inf_le_right) (infi_le_of_le i _), apply function_reflect.B_pair },
      apply @bv_rw' _ _ _ _ _ this' (λ z, z ∈ᴮ ((function_reflect.f' H_nonzero H AE)̌ )), simp,
      apply @bv_rw' _ _ _ _ _ (bv_symm check_pair) (λ z, z ∈ᴮ  (function_reflect.f' H_nonzero H AE)̌ ), simp,
      refine check_mem _, convert pSet.function.mk_mem, refl}
end

include H_docs
lemma function_reflect_of_omega_closed : ∃ (f : pSet.{u}) (Γ' : 𝔹) (H_nonzero' : ⊥ < Γ') (H_le' : Γ' ≤ Γ), (Γ' ≤ f̌ =ᴮ g) ∧ pSet.is_func pSet.omega y f :=
begin
  refine ⟨function_reflect.f' H_nonzero H AE,_⟩,
    { use (⨅ n, function_reflect.B H_nonzero H AE n), -- this is Γ'
      refine ⟨_,_,⟨_,_⟩⟩,
        { apply nonzero_infi_of_mem_dense_omega_closed_subset, apply H_docs, apply function_reflect.B_le,
          apply function_reflect.B_mem_dense  },
        { refine infi_le_of_le 0 _, let p := _, change classical.some p ≤ _,
          rcases classical.some_spec p with ⟨_,_,_,_⟩, from ‹_› },
        { apply bSet.funext, apply function_reflect.f'_is_function,
          refine le_trans _ H_function, {exact function_reflect.B_infty_le_Γ H_nonzero H AE},
          apply function_reflect_aux₃, from ‹_› },
          { apply pSet.function.mk_is_func, intro n, cases n, simp }
    }
end

end function_reflect

end lemmas

end bSet

namespace collapse_algebra

open bSet

local prefix `#`:50 := cardinal.mk
local attribute [instance] collapse_space

open collapse_poset

def 𝔹_collapse : Type u := collapse_algebra ((ℵ₁ : pSet.{u}).type) (powerset omega : pSet.{u}).type

attribute instance 𝔹_collapse_boolean_algebra : nontrivial_complete_boolean_algebra 𝔹_collapse := by {unfold 𝔹_collapse, apply_instance}

local notation `β` := 𝔹_collapse

section AE_of_check_func_check'

local notation `ι` := (collapse_poset.inclusion : _ → 𝔹_collapse)

local attribute [irreducible] regular_open_algebra

lemma nonzero_wit'' {𝓑 : Type*} [nontrivial_complete_boolean_algebra 𝓑] {D : set 𝓑}
   (H_docs : dense_omega_closed_subset D) {I : Type*} {s : I → 𝓑} {Γ : 𝓑}
  (H_nonzero : ⊥ < Γ) (H_le : Γ ≤ ⨆ i , s i ):
  ∃ (j) (Γ' : 𝓑) (H_nonzero' : ⊥ < Γ') (H_le' : Γ' ≤ s j ⊓ Γ), Γ' ∈ D :=
begin
  have := nonzero_wit' H_nonzero H_le,
  cases this with j Hj,
  have := H_docs.left, rcases this with ⟨H_dense₁, H_dense₂⟩,
  specialize H_dense₂ _ Hj, rcases H_dense₂ with ⟨Γ', HΓ'₁, HΓ'₂⟩,
  use j, use Γ', use (nonzero_of_mem_dense_omega_closed_subset H_docs ‹_›),
  use ‹_›, from ‹_›
end

lemma AE_of_check_func_check' (x y : pSet) {f : bSet (collapse_algebra (type ℵ₁) (type (powerset omega)))}
  {Γ : collapse_algebra (type ℵ₁) (type (powerset omega))}
   (H :  Γ ≤ is_func' x̌  y̌  f)
    (H_nonzero : ⊥ < Γ )
    (i : type x) :
      ∃ (j : type y) (Γ' : collapse_algebra (type ℵ₁) (type (powerset omega))) (H_nonzero' : ⊥ < Γ')
        (H_le : Γ' ≤ Γ),
        Γ' ≤ is_func' x̌  y̌  f ∧
          Γ' ≤ pair (func x i)̌  (func y j)̌  ∈ᴮ f ∧ Γ' ∈ set.range ι :=
begin
  have := is_total_of_is_func' H ((x.func i)̌ ) (by simp),

  have H' : Γ ≤ (is_func' (x̌) (y̌) f) ⊓ ⨆ w, w ∈ᴮ (y̌) ⊓ pair (x.func i)̌  w ∈ᴮ f ,
    by exact le_inf ‹_› ‹_›,
  erw[←bounded_exists] at H', swap, {exact B_ext_pair_mem_right},
  rw[inf_supr_eq] at H',
  cases y, dsimp at H', simp only [top_inf_eq] at H',
  have := nonzero_wit'' principal_opens_dense_omega_closed H_nonzero H',
  rcases this with ⟨j,Γ', Γ'_nonzero, Γ'_le, HΓ'⟩,
  use j, use Γ', use ‹_›, bv_split_at Γ'_le, use ‹_›, bv_split_at Γ'_le_left,
  from ⟨‹_›,‹_›,‹_›⟩
end

end AE_of_check_func_check'

lemma check_functions_eq_functions (y : pSet.{u})
  {Γ : β} : Γ ≤ check (functions (pSet.omega) y) =ᴮ functions (bSet.omega) y̌ :=
begin
  refine subset_ext check_functions_subset_functions _,
  rw[subset_unfold'], bv_intro g, bv_imp_intro Hg, rw[mem_unfold'],
  let A := _, change _ ≤ A, let B := _, change _ ≤ B at Hg,
  suffices this : A ⊓ B = B,
    by {refine le_trans _ inf_le_left, from B, rw this, simp* },
  apply Sup_eq_top_of_dense_Union_rel, apply rel_dense_of_dense_in_basis B.1 _ collapse_space_basis_spec,
  intros D HD HD_ne, unfold collapse_space_basis at HD, cases HD with p Hp,
    { clear_except p HD_ne, exfalso, finish },
    rcases Hp with ⟨p,⟨_,Hp⟩⟩, subst Hp, let P : β := ⟨principal_open p, is_regular_principal_open p⟩,
    have bot_lt_Γ : (⊥ : β) < P ⊓ B,
    rw [bot_lt_iff_not_le_bot, le_bot_iff], rwa subtype.ext,
    have := function_reflect_of_omega_closed principal_opens_dense_omega_closed bot_lt_Γ
      (by {dsimp[B], refine inf_le_right_of_le (is_func'_of_is_function
            (by { refine poset_yoneda _, rotate 2, intros Γ HΓ, rw[bSet.mem_functions_iff] at HΓ, convert HΓ }))}) _ (by {dsimp [B],
              refine poset_yoneda _, intros Γ HΓ, exact bSet.mem_functions_iff.mp (bv_and.right HΓ) }),
    rcases this with ⟨f, Γ', H_nonzero', H_lt', H_pr', H_func'⟩, apply set.inter_sUnion_ne_empty_of_exists_mem,
    let C := g ∈ᴮ (functions omega y)̌  ⊓ g =ᴮ g,
    use C.val, simp, refine ⟨⟨C.property, _⟩, _⟩, use g,
    suffices this : P ⊓ B ⊓ C ≠ ⊥,
      by {change ¬ _ at this, rwa subtype.ext at this }, rw ←bot_lt_iff_ne_bot,
    suffices this : Γ' ≤ C,
      by {exact lt_of_lt_of_le H_nonzero' (le_inf ‹_› ‹_›)},
    refine le_inf _ (bv_refl), apply bv_rw' (bv_symm H_pr'), simp,
    rw ←pSet.mem_functions_iff at H_func', from check_mem H_func',
    exact AE_of_check_func_check'
end

lemma π_χ_regular (p : type (card_ex (aleph 1)) × (powerset omega).type) : @topological_space.is_regular _ collapse_space {g : type (card_ex (aleph 1)) → type (powerset omega) | g (p.fst) = p.snd} :=
by simp

def π_χ : ((ℵ₁ : pSet.{u}).type × (pSet.powerset omega : pSet.{u}).type) → β :=
λ p, ⟨{g | g p.1 = p.2}, π_χ_regular _⟩

private lemma eq₀ : ((ℵ₁)̌  : bSet β).type = (ℵ₁).type := by simp

private lemma eq₀' : ((powerset omega)̌  : bSet.{u} β).type = (powerset omega).type := by simp

private lemma eq₁ : ((ℵ₁̌  : bSet β).type × ((powerset omega)̌  : bSet β).type) = ((ℵ₁).type × (powerset omega : pSet.{u}).type ):= by simp

lemma aleph_one_type_uncountable : cardinal.omega.succ ≤ # ℵ₁.type :=
by simp only [succ_le, pSet.omega_lt_aleph_one, pSet.mk_type_mk_eq''']

@[reducible]def π_af : ((ℵ₁̌  : bSet β) .type) → ((powerset omega)̌  : bSet β) .type → β :=
λ η S, (⟨{g | g (cast eq₀ η) = (cast eq₀' S)}, by simp⟩ : β)

lemma π_af_wide :  ∀ (j : ((powerset omega)̌ ).type), (⨆ (i : type (ℵ₁̌ )), π_af i j) = (⊤ : β) :=
begin
 intro S,
   refine Sup_eq_top_of_dense_Union _,
   apply dense_of_dense_in_basis _ collapse_space_basis_spec _,
   intros B HB HB_ne,
   unfold collapse_space_basis at HB, cases HB with p Hp,
   { contradiction }, cases Hp with p Hp,
   simp at Hp, subst Hp,
   refine set.ne_empty_of_exists_mem _,
   { cases exists_mem_compl_dom_of_unctbl p aleph_one_type_uncountable with η Hη,
     use p.f.trivial_extension S, use trivial_extension_mem_principal_open,
     change ∃ x, _, use (π_af (cast eq₀.symm η) S).val,
     refine ⟨_, _⟩, change ∃ x, _, refine ⟨_,_⟩,
     apply π_af (cast eq₀.symm η) S, refine ⟨_,_⟩,
       { exact set.mem_range_self _ },
       { refl },
     { unfold pfun.trivial_extension pfun.extend_via, dsimp,
       suffices this : (cast eq₀ (cast eq₀.symm η) ∉ pfun.dom (p.f)),
         by {simpa*},
       intro, apply Hη, cc } }
end

lemma π_af_tall : ∀ (i : (card_ex $ aleph 1)̌ .type), (⨆(j : (powerset omega)̌ .type), π_af i j) = (⊤ : β) :=
begin
  intro i, refine Sup_eq_top_of_dense_Union _,
  apply dense_of_dense_in_basis _ collapse_space_basis_spec _,
  intros B HB HB_ne,
  unfold collapse_space_basis at HB, cases HB with p Hp,
    { contradiction },
    { cases Hp with p Hp, simp at Hp, subst Hp, refine set.ne_empty_of_exists_mem _,
      let f := classical.choice (classical.nonempty_of_not_empty _ ‹_›),
      use f, use f.property, refine ⟨_,_⟩,
        { exact {g | g (cast eq₀ i) = f.val (cast eq₀ i)} },
        { refine ⟨⟨_,_⟩,by ext; refl⟩,
          { exact ⟨_, π_χ_regular ((cast eq₀ i), f.val (cast eq₀ i))⟩ },
          { exact ⟨⟨f.val (cast eq₀ i), rfl⟩, rfl⟩ }}}
end

lemma π_af_anti : ∀ (i : type (ℵ₁̌  : bSet β)) (j₁ j₂ : type ((powerset omega)̌ )),
    j₁ ≠ j₂ → π_af i j₁ ⊓ π_af i j₂ ≤ ⊥ :=
λ _ _ _ _ _ h, by cases h; finish

lemma check_index_inj_of_pSet_index_inj {x : pSet.{u}} (H_inj : ∀ i₁ i₂ : x.type, pSet.equiv (x.func i₁) (x.func i₂) → i₁ = i₂) : ∀ i₁ i₂ : (x̌ : bSet β).type, ⊥ < x̌.func i₁ =ᴮ x̌.func i₂ → i₁ = i₂ :=
begin
  have : ∀ i₁ i₂ : x.type, i₁ ≠ i₂ → ¬ equiv (func x i₁) (func x i₂),
    by finish,
  {intros i₁ i₂ H, haveI : decidable (i₁ = i₂) := classical.prop_decidable _,
        by_contra,
        have H_cast_eq : (check_cast i₁) ≠ (check_cast i₂),
          by { intro H_eq, apply a, unfold check_cast at H_eq, cc },
        specialize this (check_cast i₁) (check_cast i₂) ‹_›,
        have this₀ := check_bv_eq_bot_of_not_equiv this,
        suffices this₁ : x̌.func i₁ =ᴮ x̌.func i₂ = ⊥,
          by {exfalso, rw[eq_bot_iff] at this₀, rw[bot_lt_iff_not_le_bot] at H,
              suffices : x̌.func i₁ =ᴮ x̌.func i₂ ≤ ⊥, by contradiction,
              convert_to (func x (check_cast i₁))̌   =ᴮ (func x (check_cast i₂)) ̌ ≤ ⊥ using 2,
              apply check_func, apply check_func, from ‹_›},
        convert this₀; apply check_func}
end

lemma aleph_one_inj : (∀ i₁ i₂, ⊥ < (func (ℵ₁̌  : bSet β) i₁) =ᴮ (func (ℵ₁̌  : bSet β) i₂) → i₁ = i₂) :=
check_index_inj_of_pSet_index_inj $
  by {intros _ _ H, contrapose H, apply ordinal.mk_inj, from ‹_› }

noncomputable def π : bSet β :=
rel_of_array (ℵ₁̌  : bSet β) ((powerset omega)̌ ) π_af

lemma π_is_func {Γ} : Γ ≤ is_func π :=
begin
  unfold π, refine rel_of_array_extensional _ _ _ _ _,
  { from π_af_anti },
  { from aleph_one_inj },
end

lemma π_is_func' {Γ} : Γ ≤ is_func' (ℵ₁̌  : bSet β) ((powerset omega)̌ ) π :=
begin
  unfold π, refine rel_of_array_is_func' _ _ _ (by simp) _ _ _,
    { from π_af_tall },
    { from π_af_anti },
    { from aleph_one_inj }
end

lemma π_is_functional {Γ} : Γ ≤ is_functional π := is_functional_of_is_func _ π_is_func

lemma π_is_surj {Γ} : Γ ≤ is_surj (ℵ₁̌ ) ((powerset omega)̌ ) π :=
rel_of_array_surj _ _ _ (by simp) (by simp) (π_af_wide)

lemma π_spec {Γ : β} : Γ ≤ (is_func π) ⊓ ⨅v, v ∈ᴮ (powerset omega)̌  ⟹ (⨆w, w ∈ᴮ (ℵ₁̌ ) ⊓ pair w v ∈ᴮ π) := le_inf π_is_func π_is_surj

lemma π_spec' {Γ : β} : Γ ≤ (is_func' ((card_ex $ aleph 1)̌ ) ((powerset omega)̌ ) π) ⊓ is_surj ((card_ex $ aleph 1)̌ ) ((powerset omega)̌ ) π:=  le_inf π_is_func' π_is_surj

lemma ℵ₁_larger_than_continuum {Γ : β} : Γ ≤ larger_than (ℵ₁ ̌) ((powerset omega)̌ ) :=
by { apply bv_use (ℵ₁ ̌), apply bv_use π, rw[inf_assoc], from le_inf subset_self π_spec' }

lemma surjection_reflect {Γ : β} (H_bot_lt : ⊥ < Γ) (H_surj : Γ ≤ surjects_onto (bSet.omega : bSet.{u} β) ((ℵ₁)̌  : bSet β))
: ∃ (f : pSet.{u}), is_func omega (ordinal.mk (ord (aleph 1))) f
   ∧ is_surj pSet.omega (card_ex $ aleph 1) f :=
begin
  by_contra H, simp only [not_exists, not_and_distrib] at H,
  suffices this : Γ ≤ ⊥,
    by {rw[bot_lt_iff_not_le_bot] at H_bot_lt, contradiction},
  have := exists_surjection_of_surjects_onto H_surj,
  bv_cases_at this f Hf, bv_split_at Hf,
  rw[<-bSet.mem_functions_iff] at Hf_left,
  suffices this : Γ_1 ≤ f ∈ᴮ (pSet.functions pSet.omega (ℵ₁))̌ ,
    by { by_contra H', rw[<-bot_lt_iff_not_le_bot] at H',
         replace this := eq_check_of_mem_check H' this,
         rcases this with ⟨i_g, Γ', H₁,H₂,H₃⟩,
         apply_at Hf_right le_trans H₂,
         apply_at Hf_left le_trans H₂,
         let g := (pSet.functions pSet.omega ℵ₁).func i_g,
         specialize H g, cases H,
           { apply_at H check_not_is_func, show β, from Γ',
           rw[bSet.mem_functions_iff] at Hf_left,
           tactic.rotate 1, apply_instance,
           refine false_of_bot_lt_and_le_bot H₁ (H _),

           change Γ' ≤ f =ᴮ ǧ at H₃, apply_at H₃ bv_symm,
           apply bv_rw' H₃, simp, from Hf_left },
           { apply_at H check_not_is_surj,  show β, from Γ',
           tactic.rotate 1, apply_instance,
           refine false_of_bot_lt_and_le_bot H₁ (H _),
           change Γ' ≤ f =ᴮ ǧ at H₃, apply_at H₃ bv_symm,
           apply bv_rw' H₃, simp, from Hf_right}
         },
  have : Γ_1 ≤ _,
    from check_functions_eq_functions ℵ₁,
  bv_cc
end

lemma omega_lt_aleph_one {Γ : β} : Γ ≤ bSet.omega ≺ (ℵ₁̌ ) :=
begin
  unfold larger_than, rw[<-imp_bot, <-deduction],
  /- `tidy_context` says -/ refine poset_yoneda _, intros Γ_1 a, simp only [le_inf_iff] at *, cases a,
  bv_cases_at a_right S HS, apply lattice.context_Or_elim HS,
  intros f Hf, specialize_context Γ_2,
  simp only [le_inf_iff] at Hf, repeat{auto_cases}, by_contra H,
  replace H := (bot_lt_iff_not_le_bot.mpr H),
  suffices : ∃ f : pSet, is_func pSet.omega (ordinal.mk (aleph 1).ord) f ∧ pSet.is_surj (pSet.omega) (ordinal.mk (aleph 1).ord) f,
    by {exfalso, from ex_no_surj_omega_aleph_one ‹_›},
  suffices : Γ_3 ≤ surjects_onto ω ℵ₁̌ ,
    by {from surjection_reflect H this},
  refine surjects_onto_of_larger_than_and_exists_mem ‹_› (by simp),
end

lemma aleph_one_check_le_of_omega_lt (Γ : β) : Γ ≤ le_of_omega_lt (ℵ₁̌  : bSet β) :=
begin
  apply bv_rw' (aleph_one_check_is_aleph_one_of_omega_lt (omega_lt_aleph_one)),
  { simp },
  { exact aleph_one_le_of_omega_lt }
end

lemma continuum_le_continuum_check {Γ : β} :
  Γ ≤ bv_powerset (bSet.omega : bSet β) ≼ (pSet.powerset (pSet.omega : pSet.{u}) : pSet.{u})̌ :=
begin
    refine injects_into_trans _ _, tactic.rotate 1, from powerset_injects_into_functions,
  have : (Γ : β) ≤ injects_into (functions pSet.omega (of_nat 2) : pSet.{u})̌  (powerset (omega) : pSet.{u})̌ ,
    by { rw injects_into_iff_injection_into,
         rcases functions_2_injects_into_powerset (pSet.omega : pSet.{u}) with ⟨f,Hf⟩,
         apply bv_use f̌, refine check_is_injective_function _, from Hf
 },
  change Γ ≤ (λ z, injects_into z (powerset omega)̌ ) _ at this,
  have := bv_rw'' _ this, tactic.rotate 2,
  exact check_functions_eq_functions (of_nat 2),
  from this
end

lemma aleph_one_not_lt_powerset_omega : ∀ {Γ : β}, Γ ≤ - (ℵ₁̌ ≺ 𝒫(ω)) :=
begin
  intro Γ, rw[<-imp_bot], dsimp, bv_imp_intro H,
  refine bv_absurd _ ℵ₁_larger_than_continuum _,
  exact bSet_lt_of_lt_of_le H continuum_le_continuum_check
end

theorem CH_true : (⊤ : β) ≤ CH :=
CH_true_aux aleph_one_check_le_of_omega_lt (by apply aleph_one_not_lt_powerset_omega)

theorem CH₂_true : (⊤ : β) ≤ CH₂ :=
CH_iff_CH₂.mp CH_true

end collapse_algebra


import data.vector

variables {n : ℕ} {α : Type}

inductive column
| left : column
| middle : column
| right : column

-- TODO: apparently arrays could be very natural in this situation

-- okay so we encode valid states as fixed length sequences
def validstate (n : ℕ) := vector column n

lemma update_preserve_length {a : α} (l : list α) :
    ∀ i, list.length l = list.length (list.update_nth l i a) :=
begin
    induction l; intro i; cases i; simp [list.update_nth, list.length]; rw l_ih i
end

def vector.update_nth : vector α n → fin n → α → vector α n
| v i a := ⟨ list.update_nth v.val i.val a, by { rw ←(update_preserve_length v.val), exact v.property } ⟩

def zero_fin (n : ℕ) : fin (nat.succ n) := ⟨0, dec_trivial⟩

lemma update_nth_helper (v : vector α n) (i : fin n) (a b : α)
    : vector.cons b (vector.update_nth v i a) = vector.update_nth (vector.cons b v) (fin.succ i) a :=
begin
    cases v,
    cases i,
    refl
end

lemma vector_nth_helper (v : vector α n) (i : fin n) (a : α)
    : vector.nth (vector.cons a v) (fin.succ i) = vector.nth v i :=
begin
    cases i,
    cases v,
    cases n,
    cases i_is_lt,
    refl
end

def movestone (s : validstate n) (i : fin n) (dest : column)
    (valid_move: ∀j, j > i → vector.nth s j ≠ dest ∧ vector.nth s j ≠ vector.nth s i) : validstate n :=
vector.update_nth s i dest

/-- `refl_trans r`: relexive and transitive closure of `r` -/
inductive refl_trans {α : Sort*} (r : α → α → Prop) (a : α) : α → Prop
| refl {} : refl_trans a
| tail {b c} : refl_trans b → r b c → refl_trans c

def one_step : validstate n → validstate n → Prop
| s1 s2 := ∃ (i : fin n) (dest : column) pf, s2 = movestone s1 i dest pf

def multi_step : validstate n → validstate n → Prop := refl_trans one_step

lemma vector.eq_iff {n} {a b : vector α n} : a = b ↔ a.1 = b.1 :=
begin
    cases a; cases b,
    split,
    { intro h, exact congr_arg subtype.val h },
    { apply vector.eq }
end

lemma update_with_self (l : list α) (i : ℕ) (h : i < list.length l) :
    l = list.update_nth l i (list.nth_le l i h) :=
begin
    induction l generalizing i,
    cases h,
    cases i; simp [list.update_nth],
    apply l_ih
end

lemma conseq_updates (l : list α) (a b : α) (i : ℕ) :
    list.update_nth (list.update_nth l i a) i b = list.update_nth l i b :=
begin
    induction l generalizing i,
    refl,
    cases i; simp [list.update_nth],
    apply l_ih
end

lemma update_reversibility (i : fin n) (a : column) (s1 s2 : validstate n) (h : s1 = vector.update_nth s2 i a) :
  s2 = vector.update_nth s1 i (vector.nth s2 i) :=
begin
    apply vector.eq,
    change s2.val = list.update_nth s1.val (i.val) (vector.nth s2 i),
    cases s2,
    cases s1,
    cases i,
    induction s1_val generalizing i_val s2_val n,
    {
        rw [←s1_property] at i_is_lt,
        cases i_is_lt,
    },
    {
        have yolo := (iff.elim_left vector.eq_iff) h,
        simp [vector.update_nth] at yolo,
        simp [vector.nth, yolo, conseq_updates],
        exact update_with_self _ _ _
    }
end

lemma fin_pred (j : fin (nat.succ n)) (k : fin n) (h : j > fin.succ k)
    : ∃ (i : fin n), fin.succ i = j ∧ i > k :=
begin
    cases j,
    cases j_val,
    cases h,
    cases k,
    exact ⟨ ⟨ j_val, nat.lt_of_succ_lt_succ j_is_lt ⟩, ⟨ rfl, nat.lt_of_succ_lt_succ h ⟩ ⟩
end

-- this h₃ we can actually construct from the arguments, but oh well
lemma list_jth_after_update_i (l : list α) (i j : ℕ) (a : α) (h₁ : j < list.length l) (h₃ : j < list.length (list.update_nth l i a)) (h₂ : i < j) :
    list.nth_le (list.update_nth l i a) j h₃ = list.nth_le l j h₁ :=
begin
    induction l generalizing i j,
    cases h₁,
    cases i; cases j,
    cases h₂,
    simp [list.update_nth],
    cases h₂,
    exact l_ih _ _ _ _ (nat.lt_of_succ_lt_succ h₂)
end

lemma jth_after_update_i (i j : fin n) (a : column) (s : validstate n) (h : i < j) :
    vector.nth (vector.update_nth s i a) j = vector.nth s j :=
begin
    cases s,
    exact list_jth_after_update_i _ _ _ _ _ _ h
end

lemma ith_after_update_i (i : fin n) (a : column) (s : validstate n)
    : vector.nth (vector.update_nth s i a) i = a :=
begin
    cases i,
    cases s,
    induction s_val generalizing n i_val,
    {
        rw ←s_property at i_is_lt,
        cases i_is_lt,
    },
    {
        cases n,
        cases i_is_lt,
        cases i_val,
        refl,
        apply s_val_ih _ (nat.lt_of_succ_lt_succ i_is_lt) (nat.add_right_cancel s_property)
    }
end

lemma one_step_symm {s1 s2 : validstate n} (h: one_step s1 s2) : one_step s2 s1 :=
begin
    cases h,
    cases h_h,
    cases h_h_h,
    cases n,
    {
        cases h_w,
        cases h_w_is_lt,
    },
    rw movestone at h_h_h_h,
    apply exists.intro h_w,
    apply exists.intro (vector.nth s1 h_w),
    apply exists.intro _,
    exact update_reversibility _ _ _ _ h_h_h_h,
    intros j hj,
    rw [h_h_h_h, jth_after_update_i _ _ _ _ hj, ith_after_update_i],
    exact and.swap (h_h_h_w j hj)
end

lemma multi_step_transitive {a b c : validstate n} (hab : multi_step a b) (hbc : multi_step b c) : multi_step a c :=
begin
    induction hbc,
    assumption,
    exact hbc_ih.tail hbc_a_1
end

lemma multi_step_symmetric {a b : validstate n} (hab : multi_step a b) : multi_step b a :=
begin
    induction hab,
    exact refl_trans.refl,
    exact multi_step_transitive (refl_trans.tail refl_trans.refl (one_step_symm hab_a_1)) hab_ih
end

-- picks an unused column
def third_column : column → column → column
| column.left column.right := column.middle
| column.right column.left := column.middle
| column.left _ := column.right
| column.right _ := column.left
| column.middle column.left := column.right
| column.middle _ := column.left

lemma third_column_unused : ∀ c1 c2, third_column c1 c2 ≠ c1 ∧ third_column c1 c2 ≠ c2 :=
begin
    intros c1 c2,
    cases c1;
    cases c2;
    simp [third_column],
end

lemma equiv_cons (s1 s2 : validstate n) (a : column) (h : multi_step s1 s2)
    : multi_step (vector.cons a s1) (vector.cons a s2) :=
begin
    induction h,
    exact refl_trans.refl,
    apply refl_trans.tail h_ih,
    cases h_a_1,
    cases h_a_1_h,
    cases h_a_1_h_h,
    rw one_step,
    apply exists.intro (fin.succ h_a_1_w),
    apply exists.intro h_a_1_h_w,
    apply exists.intro _,
    {
        rw h_a_1_h_h_h,
        apply update_nth_helper
    },
    {
        -- repackage IH pf
        intros j h2,
        cases fin_pred j h_a_1_w h2,
        rw [vector_nth_helper, ←h.left, vector_nth_helper],
        exact (h_a_1_h_h_w w h.right)
    }
end

lemma nth_of_list_repeat (a : α) (i n : ℕ) (h : i < list.length (list.repeat a n))
    : list.nth_le (list.repeat a n) i h = a :=
begin
    induction i generalizing n;
    {
        cases n,
        cases h,
        simp *,
    }
end

lemma nth_of_repeat (i : fin n) (a : α)
    : vector.nth (vector.repeat a n) i = a :=
begin
    cases i,
    cases n,
    cases i_is_lt,
    cases i_val,
    refl,
    simp [vector.repeat, vector.nth],
    have i_lt_n := nat.lt_of_succ_lt_succ i_is_lt,
    have len_repeat_n : n = list.length (list.repeat a n) := by simp *,
    rw len_repeat_n at i_lt_n,
    exact nth_of_list_repeat a i_val n i_lt_n
end

lemma zeroth_of_cons (a : α) (v : vector α n)
    : vector.nth (vector.cons a v) ⟨0, dec_trivial⟩ = a :=
begin
    cases v,
    refl
end

lemma all_states_equiv (s1 s2 : validstate n) : multi_step s1 s2 :=
begin
    induction n,
    {
        have s1_eq_s2 : s1 = s2 := begin
            cases s1,
            cases s2,
            cases s1_val,
            {
                cases s2_val,
                refl,
                cases s2_property,
            },
            cases s1_property,
        end,
        rw s1_eq_s2,
        exact refl_trans.refl
    },
    {
        -- IDEA:
        -- s1 : [x0, x1, ..., x(n-1)],
        -- s2 : [y0, y1, ..., y(n-1)],
        -- let z = third_column x0 y0
        -- by induction hypothesis:
        -- [x1, ..., x(n-1)] ~ [z, ..., z]
        -- [y1, ..., y(n-1)] ~ [z, ..., z]
        -- then by prefix lemma,
        -- s1 ~ [x0, z, ..., z]
        -- s2 ~ [y0, z, ..., z]
        -- and we can go from [x0, z, ..., z] to [y0, z, ..., z] in one step
        -- since ~ (multi_step) is an equivalence (trans, symm), s1 ~ s2
        cases s1,
        cases s1_val,
        cases s1_property,
        cases s2,
        cases s2_val,
        cases s2_property,
        -- z = third_column s1_val_hd s2_val_hd

        -- s1 ~ [x0, z, ..., z]
        have proppp1 : list.length s1_val_tl = n_n := begin
            cases s1_property,
            refl
        end,
        -- FIXME: this is a mess lol
        have s1_equiv_s10zzz : multi_step ⟨s1_val_hd :: s1_val_tl, s1_property⟩ (vector.cons s1_val_hd (vector.repeat (third_column s1_val_hd s2_val_hd) n_n)) :=
            begin
                have yolo : (vector.cons s1_val_hd ⟨s1_val_tl, proppp1⟩) = ⟨s1_val_hd :: s1_val_tl, s1_property⟩ := rfl,
                rw ←yolo,
                apply equiv_cons,
                apply n_ih,
            end,

        -- s2 ~ [y0, z, ..., z]
        have proppp2 : list.length s2_val_tl = n_n := begin
            cases s2_property,
            refl
        end,
        have s2_equiv_s20zzz : multi_step ⟨s2_val_hd :: s2_val_tl, s2_property⟩ (vector.cons s2_val_hd (vector.repeat (third_column s1_val_hd s2_val_hd) n_n)) :=
            begin
                have yolo : (vector.cons s2_val_hd ⟨s2_val_tl, proppp2⟩) = ⟨s2_val_hd :: s2_val_tl, s2_property⟩ := rfl,
                rw ←yolo,
                apply equiv_cons,
                apply n_ih,
            end,

        have small_step : one_step (vector.cons s1_val_hd (vector.repeat (third_column s1_val_hd s2_val_hd) n_n))
            (vector.cons s2_val_hd (vector.repeat (third_column s1_val_hd s2_val_hd) n_n)) :=
        begin
            apply exists.intro (zero_fin n_n),
            {
                apply exists.intro s2_val_hd,
                apply exists.intro,
                refl,
                intros j h,
                cases j,
                cases j_val,
                cases h,
                apply and.intro,
                {
                    rw ←fin.succ,
                    {
                        rw [vector_nth_helper, nth_of_repeat],
                        exact (third_column_unused _ _).right
                    },
                    exact nat.lt_of_succ_lt_succ j_is_lt
                },
                {
                    rw ←fin.succ,
                    {
                        rw [vector_nth_helper, zero_fin, nth_of_repeat, zeroth_of_cons],
                        exact (third_column_unused _ _).left
                    },
                    exact nat.lt_of_succ_lt_succ j_is_lt
                }
            }
        end,

        exact multi_step_transitive (refl_trans.tail s1_equiv_s10zzz small_step) (multi_step_symmetric s2_equiv_s20zzz)
    }
end

theorem towers_hanoi_solvable : ∀ n : ℕ, multi_step (vector.repeat column.left n) (vector.repeat column.right n) :=
    λ n, all_states_equiv (vector.repeat column.left n) (vector.repeat column.right n)


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

Godel numbering for partial recursive functions.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.computability.partrec
import Mathlib.PostPort

universes l u_1 u_2

namespace Mathlib

namespace nat.partrec

theorem rfind' {f : ℕ →. ℕ} (hf : partrec f) :
    partrec
        (unpaired
          fun (a m : ℕ) =>
            roption.map (fun (_x : ℕ) => _x + m)
              (rfind fun (n : ℕ) => (fun (m : ℕ) => to_bool (m = 0)) <$> f (mkpair a (n + m)))) :=
  sorry

inductive code where
| zero : code
| succ : code
| left : code
| right : code
| pair : code → code → code
| comp : code → code → code
| prec : code → code → code
| rfind' : code → code

end nat.partrec

namespace nat.partrec.code

protected instance inhabited : Inhabited code := { default := zero }

protected def const : ℕ → code := sorry

theorem const_inj {n₁ : ℕ} {n₂ : ℕ} : code.const n₁ = code.const n₂ → n₁ = n₂ := sorry

protected def id : code := pair left right

def curry (c : code) (n : ℕ) : code := comp c (pair (code.const n) code.id)

def encode_code : code → ℕ := sorry

def of_nat_code : ℕ → code := sorry

protected instance denumerable : denumerable code :=
  denumerable.mk' (equiv.mk encode_code of_nat_code sorry encode_of_nat_code)

theorem encode_code_eq : encodable.encode = encode_code := rfl

theorem of_nat_code_eq : denumerable.of_nat code = of_nat_code := rfl

theorem encode_lt_pair (cf : code) (cg : code) :
    encodable.encode cf < encodable.encode (pair cf cg) ∧
        encodable.encode cg < encodable.encode (pair cf cg) :=
  sorry

theorem encode_lt_comp (cf : code) (cg : code) :
    encodable.encode cf < encodable.encode (comp cf cg) ∧
        encodable.encode cg < encodable.encode (comp cf cg) :=
  sorry

theorem encode_lt_prec (cf : code) (cg : code) :
    encodable.encode cf < encodable.encode (prec cf cg) ∧
        encodable.encode cg < encodable.encode (prec cf cg) :=
  sorry

theorem encode_lt_rfind' (cf : code) : encodable.encode cf < encodable.encode (rfind' cf) := sorry

theorem pair_prim : primrec₂ pair := sorry

theorem comp_prim : primrec₂ comp := sorry

theorem prec_prim : primrec₂ prec := sorry

theorem rfind_prim : primrec rfind' := sorry

theorem rec_prim' {α : Type u_1} {σ : Type u_2} [primcodable α] [primcodable σ] {c : α → code}
    (hc : primrec c) {z : α → σ} (hz : primrec z) {s : α → σ} (hs : primrec s) {l : α → σ}
    (hl : primrec l) {r : α → σ} (hr : primrec r) {pr : α → code × code × σ × σ → σ}
    (hpr : primrec₂ pr) {co : α → code × code × σ × σ → σ} (hco : primrec₂ co)
    {pc : α → code × code × σ × σ → σ} (hpc : primrec₂ pc) {rf : α → code × σ → σ}
    (hrf : primrec₂ rf) :
    let PR : α → code → code → σ → σ → σ :=
        fun (a : α) (cf cg : code) (hf hg : σ) => pr a (cf, cg, hf, hg);
      let CO : α → code → code → σ → σ → σ :=
        fun (a : α) (cf cg : code) (hf hg : σ) => co a (cf, cg, hf, hg);
      let PC : α → code → code → σ → σ → σ :=
        fun (a : α) (cf cg : code) (hf hg : σ) => pc a (cf, cg, hf, hg);
      let RF : α → code → σ → σ := fun (a : α) (cf : code) (hf : σ) => rf a (cf, hf);
      let F : α → code → σ :=
        fun (a : α) (c : code) => code.rec_on c (z a) (s a) (l a) (r a) (PR a) (CO a) (PC a) (RF a);
      primrec fun (a : α) => F a (c a) :=
  sorry

theorem rec_prim {α : Type u_1} {σ : Type u_2} [primcodable α] [primcodable σ] {c : α → code}
    (hc : primrec c) {z : α → σ} (hz : primrec z) {s : α → σ} (hs : primrec s) {l : α → σ}
    (hl : primrec l) {r : α → σ} (hr : primrec r) {pr : α → code → code → σ → σ → σ}
    (hpr :
      primrec
        fun (a : α × code × code × σ × σ) =>
          pr (prod.fst a) (prod.fst (prod.snd a)) (prod.fst (prod.snd (prod.snd a)))
            (prod.fst (prod.snd (prod.snd (prod.snd a))))
            (prod.snd (prod.snd (prod.snd (prod.snd a)))))
    {co : α → code → code → σ → σ → σ}
    (hco :
      primrec
        fun (a : α × code × code × σ × σ) =>
          co (prod.fst a) (prod.fst (prod.snd a)) (prod.fst (prod.snd (prod.snd a)))
            (prod.fst (prod.snd (prod.snd (prod.snd a))))
            (prod.snd (prod.snd (prod.snd (prod.snd a)))))
    {pc : α → code → code → σ → σ → σ}
    (hpc :
      primrec
        fun (a : α × code × code × σ × σ) =>
          pc (prod.fst a) (prod.fst (prod.snd a)) (prod.fst (prod.snd (prod.snd a)))
            (prod.fst (prod.snd (prod.snd (prod.snd a))))
            (prod.snd (prod.snd (prod.snd (prod.snd a)))))
    {rf : α → code → σ → σ}
    (hrf :
      primrec
        fun (a : α × code × σ) => rf (prod.fst a) (prod.fst (prod.snd a)) (prod.snd (prod.snd a))) :
    let F : α → code → σ :=
        fun (a : α) (c : code) => code.rec_on c (z a) (s a) (l a) (r a) (pr a) (co a) (pc a) (rf a);
      primrec fun (a : α) => F a (c a) :=
  sorry

/- TODO(Mario): less copy-paste from previous proof -/

theorem rec_computable {α : Type u_1} {σ : Type u_2} [primcodable α] [primcodable σ] {c : α → code}
    (hc : computable c) {z : α → σ} (hz : computable z) {s : α → σ} (hs : computable s) {l : α → σ}
    (hl : computable l) {r : α → σ} (hr : computable r) {pr : α → code × code × σ × σ → σ}
    (hpr : computable₂ pr) {co : α → code × code × σ × σ → σ} (hco : computable₂ co)
    {pc : α → code × code × σ × σ → σ} (hpc : computable₂ pc) {rf : α → code × σ → σ}
    (hrf : computable₂ rf) :
    let PR : α → code → code → σ → σ → σ :=
        fun (a : α) (cf cg : code) (hf hg : σ) => pr a (cf, cg, hf, hg);
      let CO : α → code → code → σ → σ → σ :=
        fun (a : α) (cf cg : code) (hf hg : σ) => co a (cf, cg, hf, hg);
      let PC : α → code → code → σ → σ → σ :=
        fun (a : α) (cf cg : code) (hf hg : σ) => pc a (cf, cg, hf, hg);
      let RF : α → code → σ → σ := fun (a : α) (cf : code) (hf : σ) => rf a (cf, hf);
      let F : α → code → σ :=
        fun (a : α) (c : code) => code.rec_on c (z a) (s a) (l a) (r a) (PR a) (CO a) (PC a) (RF a);
      computable fun (a : α) => F a (c a) :=
  sorry

def eval : code → ℕ →. ℕ := sorry

protected instance has_mem : has_mem (ℕ →. ℕ) code :=
  has_mem.mk fun (f : ℕ →. ℕ) (c : code) => eval c = f

@[simp] theorem eval_const (n : ℕ) (m : ℕ) : eval (code.const n) m = roption.some n := sorry

@[simp] theorem eval_id (n : ℕ) : eval code.id n = roption.some n := sorry

@[simp] theorem eval_curry (c : code) (n : ℕ) (x : ℕ) : eval (curry c n) x = eval c (mkpair n x) :=
  sorry

theorem const_prim : primrec code.const := sorry

theorem curry_prim : primrec₂ curry :=
  primrec₂.comp comp_prim primrec.fst
    (primrec₂.comp pair_prim (primrec.comp const_prim primrec.snd) (primrec.const code.id))

theorem curry_inj {c₁ : code} {c₂ : code} {n₁ : ℕ} {n₂ : ℕ} (h : curry c₁ n₁ = curry c₂ n₂) :
    c₁ = c₂ ∧ n₁ = n₂ :=
  sorry

theorem smn :
    ∃ (f : code → ℕ → code),
        computable₂ f ∧ ∀ (c : code) (n x : ℕ), eval (f c n) x = eval c (mkpair n x) :=
  Exists.intro curry { left := primrec₂.to_comp curry_prim, right := eval_curry }

theorem exists_code {f : ℕ →. ℕ} : partrec f ↔ ∃ (c : code), eval c = f := sorry

def evaln (k : ℕ) : code → ℕ → Option ℕ := sorry

theorem evaln_bound {k : ℕ} {c : code} {n : ℕ} {x : ℕ} : x ∈ evaln k c n → n < k := sorry

theorem evaln_mono {k₁ : ℕ} {k₂ : ℕ} {c : code} {n : ℕ} {x : ℕ} :
    k₁ ≤ k₂ → x ∈ evaln k₁ c n → x ∈ evaln k₂ c n :=
  sorry

theorem evaln_sound {k : ℕ} {c : code} {n : ℕ} {x : ℕ} : x ∈ evaln k c n → x ∈ eval c n := sorry

theorem evaln_complete {c : code} {n : ℕ} {x : ℕ} : x ∈ eval c n ↔ ∃ (k : ℕ), x ∈ evaln k c n :=
  sorry

theorem evaln_prim :
    primrec
        fun (a : (ℕ × code) × ℕ) =>
          evaln (prod.fst (prod.fst a)) (prod.snd (prod.fst a)) (prod.snd a) :=
  sorry

theorem eval_eq_rfind_opt (c : code) (n : ℕ) : eval c n = rfind_opt fun (k : ℕ) => evaln k c n :=
  roption.ext
    fun (x : ℕ) =>
      iff.trans evaln_complete
        (iff.symm (rfind_opt_mono fun (a m n_1 : ℕ) (hl : m ≤ n_1) => evaln_mono hl))

theorem eval_part : partrec₂ eval := sorry

theorem fixed_point {f : code → code} (hf : computable f) : ∃ (c : code), eval (f c) = eval c :=
  sorry

theorem fixed_point₂ {f : code → ℕ →. ℕ} (hf : partrec₂ f) : ∃ (c : code), eval c = f c := sorry

end Mathlib


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Yury Kudryashov

! This file was ported from Lean 3 source module algebra.order.group.bounds
! leanprover-community/mathlib commit c3291da49cfa65f0d43b094750541c0731edc932
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Order.Bounds.Basic
import Mathbin.Algebra.Order.Group.Defs

/-!
# Least upper bound and the greatest lower bound in linear ordered additive commutative groups

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

variable {α : Type _}

section LinearOrderedAddCommGroup

variable [LinearOrderedAddCommGroup α] {s : Set α} {a ε : α}

/- warning: is_glb.exists_between_self_add -> IsGLB.exists_between_self_add is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : LinearOrderedAddCommGroup.{u1} α] {s : Set.{u1} α} {a : α} {ε : α}, (IsGLB.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1))) s a) -> (LT.lt.{u1} α (Preorder.toLT.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))) (OfNat.ofNat.{u1} α 0 (OfNat.mk.{u1} α 0 (Zero.zero.{u1} α (AddZeroClass.toHasZero.{u1} α (AddMonoid.toAddZeroClass.{u1} α (SubNegMonoid.toAddMonoid.{u1} α (AddGroup.toSubNegMonoid.{u1} α (AddCommGroup.toAddGroup.{u1} α (OrderedAddCommGroup.toAddCommGroup.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))))))))) ε) -> (Exists.{succ u1} α (fun (b : α) => Exists.{0} (Membership.Mem.{u1, u1} α (Set.{u1} α) (Set.hasMem.{u1} α) b s) (fun (H : Membership.Mem.{u1, u1} α (Set.{u1} α) (Set.hasMem.{u1} α) b s) => And (LE.le.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))) a b) (LT.lt.{u1} α (Preorder.toLT.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))) b (HAdd.hAdd.{u1, u1, u1} α α α (instHAdd.{u1} α (AddZeroClass.toHasAdd.{u1} α (AddMonoid.toAddZeroClass.{u1} α (SubNegMonoid.toAddMonoid.{u1} α (AddGroup.toSubNegMonoid.{u1} α (AddCommGroup.toAddGroup.{u1} α (OrderedAddCommGroup.toAddCommGroup.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))))))) a ε)))))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : LinearOrderedAddCommGroup.{u1} α] {s : Set.{u1} α} {a : α} {ε : α}, (IsGLB.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1))) s a) -> (LT.lt.{u1} α (Preorder.toLT.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))) (OfNat.ofNat.{u1} α 0 (Zero.toOfNat0.{u1} α (NegZeroClass.toZero.{u1} α (SubNegZeroMonoid.toNegZeroClass.{u1} α (SubtractionMonoid.toSubNegZeroMonoid.{u1} α (SubtractionCommMonoid.toSubtractionMonoid.{u1} α (AddCommGroup.toDivisionAddCommMonoid.{u1} α (OrderedAddCommGroup.toAddCommGroup.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1))))))))) ε) -> (Exists.{succ u1} α (fun (b : α) => And (Membership.mem.{u1, u1} α (Set.{u1} α) (Set.instMembershipSet.{u1} α) b s) (And (LE.le.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))) a b) (LT.lt.{u1} α (Preorder.toLT.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))) b (HAdd.hAdd.{u1, u1, u1} α α α (instHAdd.{u1} α (AddZeroClass.toAdd.{u1} α (AddMonoid.toAddZeroClass.{u1} α (SubNegMonoid.toAddMonoid.{u1} α (AddGroup.toSubNegMonoid.{u1} α (AddCommGroup.toAddGroup.{u1} α (OrderedAddCommGroup.toAddCommGroup.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))))))) a ε)))))
Case conversion may be inaccurate. Consider using '#align is_glb.exists_between_self_add IsGLB.exists_between_self_addₓ'. -/
theorem IsGLB.exists_between_self_add (h : IsGLB s a) (hε : 0 < ε) : ∃ b ∈ s, a ≤ b ∧ b < a + ε :=
  h.exists_between <| lt_add_of_pos_right _ hε
#align is_glb.exists_between_self_add IsGLB.exists_between_self_add

/- warning: is_glb.exists_between_self_add' -> IsGLB.exists_between_self_add' is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : LinearOrderedAddCommGroup.{u1} α] {s : Set.{u1} α} {a : α} {ε : α}, (IsGLB.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1))) s a) -> (Not (Membership.Mem.{u1, u1} α (Set.{u1} α) (Set.hasMem.{u1} α) a s)) -> (LT.lt.{u1} α (Preorder.toLT.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))) (OfNat.ofNat.{u1} α 0 (OfNat.mk.{u1} α 0 (Zero.zero.{u1} α (AddZeroClass.toHasZero.{u1} α (AddMonoid.toAddZeroClass.{u1} α (SubNegMonoid.toAddMonoid.{u1} α (AddGroup.toSubNegMonoid.{u1} α (AddCommGroup.toAddGroup.{u1} α (OrderedAddCommGroup.toAddCommGroup.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))))))))) ε) -> (Exists.{succ u1} α (fun (b : α) => Exists.{0} (Membership.Mem.{u1, u1} α (Set.{u1} α) (Set.hasMem.{u1} α) b s) (fun (H : Membership.Mem.{u1, u1} α (Set.{u1} α) (Set.hasMem.{u1} α) b s) => And (LT.lt.{u1} α (Preorder.toLT.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))) a b) (LT.lt.{u1} α (Preorder.toLT.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))) b (HAdd.hAdd.{u1, u1, u1} α α α (instHAdd.{u1} α (AddZeroClass.toHasAdd.{u1} α (AddMonoid.toAddZeroClass.{u1} α (SubNegMonoid.toAddMonoid.{u1} α (AddGroup.toSubNegMonoid.{u1} α (AddCommGroup.toAddGroup.{u1} α (OrderedAddCommGroup.toAddCommGroup.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))))))) a ε)))))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : LinearOrderedAddCommGroup.{u1} α] {s : Set.{u1} α} {a : α} {ε : α}, (IsGLB.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1))) s a) -> (Not (Membership.mem.{u1, u1} α (Set.{u1} α) (Set.instMembershipSet.{u1} α) a s)) -> (LT.lt.{u1} α (Preorder.toLT.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))) (OfNat.ofNat.{u1} α 0 (Zero.toOfNat0.{u1} α (NegZeroClass.toZero.{u1} α (SubNegZeroMonoid.toNegZeroClass.{u1} α (SubtractionMonoid.toSubNegZeroMonoid.{u1} α (SubtractionCommMonoid.toSubtractionMonoid.{u1} α (AddCommGroup.toDivisionAddCommMonoid.{u1} α (OrderedAddCommGroup.toAddCommGroup.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1))))))))) ε) -> (Exists.{succ u1} α (fun (b : α) => And (Membership.mem.{u1, u1} α (Set.{u1} α) (Set.instMembershipSet.{u1} α) b s) (And (LT.lt.{u1} α (Preorder.toLT.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))) a b) (LT.lt.{u1} α (Preorder.toLT.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))) b (HAdd.hAdd.{u1, u1, u1} α α α (instHAdd.{u1} α (AddZeroClass.toAdd.{u1} α (AddMonoid.toAddZeroClass.{u1} α (SubNegMonoid.toAddMonoid.{u1} α (AddGroup.toSubNegMonoid.{u1} α (AddCommGroup.toAddGroup.{u1} α (OrderedAddCommGroup.toAddCommGroup.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))))))) a ε)))))
Case conversion may be inaccurate. Consider using '#align is_glb.exists_between_self_add' IsGLB.exists_between_self_add'ₓ'. -/
theorem IsGLB.exists_between_self_add' (h : IsGLB s a) (h₂ : a ∉ s) (hε : 0 < ε) :
    ∃ b ∈ s, a < b ∧ b < a + ε :=
  h.exists_between' h₂ <| lt_add_of_pos_right _ hε
#align is_glb.exists_between_self_add' IsGLB.exists_between_self_add'

/- warning: is_lub.exists_between_sub_self -> IsLUB.exists_between_sub_self is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : LinearOrderedAddCommGroup.{u1} α] {s : Set.{u1} α} {a : α} {ε : α}, (IsLUB.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1))) s a) -> (LT.lt.{u1} α (Preorder.toLT.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))) (OfNat.ofNat.{u1} α 0 (OfNat.mk.{u1} α 0 (Zero.zero.{u1} α (AddZeroClass.toHasZero.{u1} α (AddMonoid.toAddZeroClass.{u1} α (SubNegMonoid.toAddMonoid.{u1} α (AddGroup.toSubNegMonoid.{u1} α (AddCommGroup.toAddGroup.{u1} α (OrderedAddCommGroup.toAddCommGroup.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))))))))) ε) -> (Exists.{succ u1} α (fun (b : α) => Exists.{0} (Membership.Mem.{u1, u1} α (Set.{u1} α) (Set.hasMem.{u1} α) b s) (fun (H : Membership.Mem.{u1, u1} α (Set.{u1} α) (Set.hasMem.{u1} α) b s) => And (LT.lt.{u1} α (Preorder.toLT.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))) (HSub.hSub.{u1, u1, u1} α α α (instHSub.{u1} α (SubNegMonoid.toHasSub.{u1} α (AddGroup.toSubNegMonoid.{u1} α (AddCommGroup.toAddGroup.{u1} α (OrderedAddCommGroup.toAddCommGroup.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))))) a ε) b) (LE.le.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))) b a))))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : LinearOrderedAddCommGroup.{u1} α] {s : Set.{u1} α} {a : α} {ε : α}, (IsLUB.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1))) s a) -> (LT.lt.{u1} α (Preorder.toLT.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))) (OfNat.ofNat.{u1} α 0 (Zero.toOfNat0.{u1} α (NegZeroClass.toZero.{u1} α (SubNegZeroMonoid.toNegZeroClass.{u1} α (SubtractionMonoid.toSubNegZeroMonoid.{u1} α (SubtractionCommMonoid.toSubtractionMonoid.{u1} α (AddCommGroup.toDivisionAddCommMonoid.{u1} α (OrderedAddCommGroup.toAddCommGroup.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1))))))))) ε) -> (Exists.{succ u1} α (fun (b : α) => And (Membership.mem.{u1, u1} α (Set.{u1} α) (Set.instMembershipSet.{u1} α) b s) (And (LT.lt.{u1} α (Preorder.toLT.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))) (HSub.hSub.{u1, u1, u1} α α α (instHSub.{u1} α (SubNegMonoid.toSub.{u1} α (AddGroup.toSubNegMonoid.{u1} α (AddCommGroup.toAddGroup.{u1} α (OrderedAddCommGroup.toAddCommGroup.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))))) a ε) b) (LE.le.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))) b a))))
Case conversion may be inaccurate. Consider using '#align is_lub.exists_between_sub_self IsLUB.exists_between_sub_selfₓ'. -/
theorem IsLUB.exists_between_sub_self (h : IsLUB s a) (hε : 0 < ε) : ∃ b ∈ s, a - ε < b ∧ b ≤ a :=
  h.exists_between <| sub_lt_self _ hε
#align is_lub.exists_between_sub_self IsLUB.exists_between_sub_self

/- warning: is_lub.exists_between_sub_self' -> IsLUB.exists_between_sub_self' is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : LinearOrderedAddCommGroup.{u1} α] {s : Set.{u1} α} {a : α} {ε : α}, (IsLUB.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1))) s a) -> (Not (Membership.Mem.{u1, u1} α (Set.{u1} α) (Set.hasMem.{u1} α) a s)) -> (LT.lt.{u1} α (Preorder.toLT.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))) (OfNat.ofNat.{u1} α 0 (OfNat.mk.{u1} α 0 (Zero.zero.{u1} α (AddZeroClass.toHasZero.{u1} α (AddMonoid.toAddZeroClass.{u1} α (SubNegMonoid.toAddMonoid.{u1} α (AddGroup.toSubNegMonoid.{u1} α (AddCommGroup.toAddGroup.{u1} α (OrderedAddCommGroup.toAddCommGroup.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))))))))) ε) -> (Exists.{succ u1} α (fun (b : α) => Exists.{0} (Membership.Mem.{u1, u1} α (Set.{u1} α) (Set.hasMem.{u1} α) b s) (fun (H : Membership.Mem.{u1, u1} α (Set.{u1} α) (Set.hasMem.{u1} α) b s) => And (LT.lt.{u1} α (Preorder.toLT.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))) (HSub.hSub.{u1, u1, u1} α α α (instHSub.{u1} α (SubNegMonoid.toHasSub.{u1} α (AddGroup.toSubNegMonoid.{u1} α (AddCommGroup.toAddGroup.{u1} α (OrderedAddCommGroup.toAddCommGroup.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))))) a ε) b) (LT.lt.{u1} α (Preorder.toLT.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))) b a))))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : LinearOrderedAddCommGroup.{u1} α] {s : Set.{u1} α} {a : α} {ε : α}, (IsLUB.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1))) s a) -> (Not (Membership.mem.{u1, u1} α (Set.{u1} α) (Set.instMembershipSet.{u1} α) a s)) -> (LT.lt.{u1} α (Preorder.toLT.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))) (OfNat.ofNat.{u1} α 0 (Zero.toOfNat0.{u1} α (NegZeroClass.toZero.{u1} α (SubNegZeroMonoid.toNegZeroClass.{u1} α (SubtractionMonoid.toSubNegZeroMonoid.{u1} α (SubtractionCommMonoid.toSubtractionMonoid.{u1} α (AddCommGroup.toDivisionAddCommMonoid.{u1} α (OrderedAddCommGroup.toAddCommGroup.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1))))))))) ε) -> (Exists.{succ u1} α (fun (b : α) => And (Membership.mem.{u1, u1} α (Set.{u1} α) (Set.instMembershipSet.{u1} α) b s) (And (LT.lt.{u1} α (Preorder.toLT.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))) (HSub.hSub.{u1, u1, u1} α α α (instHSub.{u1} α (SubNegMonoid.toSub.{u1} α (AddGroup.toSubNegMonoid.{u1} α (AddCommGroup.toAddGroup.{u1} α (OrderedAddCommGroup.toAddCommGroup.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))))) a ε) b) (LT.lt.{u1} α (Preorder.toLT.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedAddCommGroup.toPartialOrder.{u1} α (LinearOrderedAddCommGroup.toOrderedAddCommGroup.{u1} α _inst_1)))) b a))))
Case conversion may be inaccurate. Consider using '#align is_lub.exists_between_sub_self' IsLUB.exists_between_sub_self'ₓ'. -/
theorem IsLUB.exists_between_sub_self' (h : IsLUB s a) (h₂ : a ∉ s) (hε : 0 < ε) :
    ∃ b ∈ s, a - ε < b ∧ b < a :=
  h.exists_between' h₂ <| sub_lt_self _ hε
#align is_lub.exists_between_sub_self' IsLUB.exists_between_sub_self'

end LinearOrderedAddCommGroup


import Meta.Boolean
import Meta.Resolution
import Meta.PermutateOr

universe u

variable {U : Type u}

variable {f : U → U → U}

variable {p₁ p₂ p₃ : Prop}

variable {a b c d : U}

theorem euf : (a = b) → (c = d) → p₁ ∧ True → (¬ p₁) ∨ (p₂ ∧ p₃) → (¬ p₃) ∨ (¬ (f a c = f b d)) → False :=
  fun lean_a0 : (a = b) =>
  fun lean_a1 : (c = d) =>
  fun lean_a2 : p₁ ∧ True =>
  fun lean_a3 : (¬ p₁) ∨ (p₂ ∧ p₃) =>
  fun lean_a4 : (¬ p₃) ∨ (¬ (f a c = f b d)) =>
    have lean_s0 : ((a = b) ∧ (c = d)) ∨ ¬ (a = b) ∨ (¬ (c = d)) := cnfAndNeg [(a = b), (c = d)]
    have lean_s1 : ¬ (a = b) ∨ (¬ (c = d)) ∨ (f a c = f b d) :=
      scope (λ lean_a5 : (a = b) =>
        (scope (λ lean_a6 : (c = d) =>
          let lean_s1 : f = f := rfl
          have lean_s2 : b = a := Eq.symm lean_a5
          have lean_s3 : (a = b) := Eq.symm lean_s2
          let lean_s4 := cong lean_s1 lean_s3
          have lean_s5 : d = c := Eq.symm lean_a6
          have lean_s6 : (c = d) := Eq.symm lean_s5
          have lean_s7 : (f a c = f b d) := cong lean_s4 lean_s6
          show (f a c = f b d) from lean_s7
        )
      ))
    have lean_s2  : a = b ∧ c = d → f a c = f b d := by liftOrNToImp lean_s1, 2
    have lean_s3  : (¬ ((a = b) ∧ (c = d))) ∨ (f a c = f b d) := impliesElim lean_s2
    have lean_s5  : ¬ (a = b) ∨ ¬ (c = d) ∨ f a c = f b d := by R1 lean_s0, lean_s3, ((a = b) ∧ (c = d))
    have lean_s6  : f a c = f b d ∨ ¬ (a = b) ∨ ¬ (c = d) := by permutateOr lean_s5, [2, 0, 1]
    have lean_s7  := lean_a4
    have lean_s8  : (¬ (p₂ ∧ p₃)) ∨ p₃ := @cnfAndPos ([p₂, p₃]) 1
    have lean_s9  : p₃ ∨ (¬ (p₂ ∧ p₃)) := by permutateOr lean_s8, [1, 0]
    have lean_s10 := lean_a3
    have lean_s11 : (p₁ ∧ True) → p₁ := And.left
    have lean_s12 : p₁ := lean_s11 lean_a2
    have lean_s13 := lean_s12
    have lean_s14 : p₂ ∧ p₃ := by R2 lean_s10, lean_s13, p₁
    have lean_s15 : p₃ := by R2 lean_s9, lean_s14, (p₂ ∧ p₃)
    have lean_s16 : ¬ (f a c = f b d) := by R2 lean_s7, lean_s15, p₃
    have lean_s17 : ¬ (a = b) ∨ ¬ (c = d) := by R1 lean_s6, lean_s16, (f a c = f b d)
    have lean_s18 := lean_a1
    have lean_s19 : ¬ (a = b) := by R2 lean_s17, lean_s18, (c = d)
    have lean_s20 := lean_a0
    show False from by R2 lean_s19, lean_s20, (a = b)


import init.data.nat.basic
import tactic.finish
import tactic.ext
import biject
import init.data.int.basic
import data.int.basic
import data.nat.parity
import tactic.hint
import data.nat.basic

universes u1 u2 u3 u4

def denombrable (α : Sort u1) : Prop :=
  in_bijection ℕ α

theorem tf_l {A : Sort u1} {B : Sort u2} {x3 x4 :pprod A  B} : x3 = x4 →  x3.1 = x4.1 ∧ x3.2 = x4.2 :=
  begin
        intro a,
        apply and.intro,
          apply map_eq (λ x :pprod A  B, x.1) a,
          apply map_eq (λ x :pprod A B, x.2) a,
  end

theorem tf_r {A : Sort u1} {B : Sort u2} {x3 x4 :pprod A  B} : x3.1 = x4.1 ∧ x3.2 = x4.2 → x3 = x4 :=
  begin
      intro eq1,
      cases eq1 with a b,
      cases x3,
      cases x4,
      finish
  end

theorem tf  {A : Sort u1} {B : Sort u2} (x3 x4 :pprod A  B) : x3 = x4 ↔  x3.1 = x4.1 ∧ x3.2 = x4.2 :=
  begin
    split,
    apply tf_l,
    apply tf_r
  end

def prod_func {A : Sort u1} {B : Sort u2} {C : Sort u3}
{D : Sort u4} (f : A → B) (g : C → D) : pprod A C → pprod B D :=
  λ x : pprod A C , pprod.mk (f (x.fst))  (g x.snd)

theorem prod_bij_prod_left {A : Sort u1} {B : Sort u2} {C : Sort u3}
{D : Sort u4} (f : A → B) (g : C → D) [bijective f] [bijective g] :
  bijective (prod_func f g) :=
  begin
    apply and.intro,
      intros x1 x2,
      rw prod_func,
      simp,
      intro h,
      apply iff.elim_right (tf x1 x2),
      apply and.intro,
      apply _inst_1.left x1.fst x2.fst
          ((tf (prod_func f g x1) (prod_func f g x2)).elim_left h).left,
      apply _inst_2.left x1.snd x2.snd
          ((tf (prod_func f g x1) (prod_func f g x2)).elim_left h).right,

    intro y,
    let x1 := (_inst_1.elim_right y.1).some,
    let x2 := (_inst_2.elim_right y.2).some,
    use pprod.mk x1 x2,
    rw prod_func,
    simp,
    apply tf_r,
    simp,
    change x1 with (_inst_1.elim_right y.1).some,
    change x2 with (_inst_2.elim_right y.2).some,
    split,
    apply Exists.some_spec (_inst_1.elim_right y.1),
    apply Exists.some_spec (_inst_2.elim_right y.2)
  end

def nat_plus := { n : ℕ // ¬ n = 0}

lemma nat_succ_not_zero (n : ℕ) : ¬ n.succ = 0 :=
  begin
    apply not.intro,
    trivial
  end

def succ_plus (n : ℕ ) : nat_plus :=
  ⟨ n.succ,nat_succ_not_zero n⟩

lemma not_zero_le (n : ℕ) : ¬ n = 0 ↔ 0 < n :=
  begin
    split,
    apply nat.cases_on n,
    trivial,
    intro m,
    simp,
    apply nat.cases_on n,
    simp,
    intro m,
    simp,
    trivial
  end

lemma bon (n : nat_plus) : n.val.pred.succ = n.val :=
  begin
  apply n.cases_on,
  intros k p,
  simp,
  apply nat.succ_pred_eq_of_pos ((not_zero_le k).elim_left p)
  end

theorem Nplus_denumbrable : denombrable nat_plus :=
  begin
    rw [denombrable,in_bijection],
    use succ_plus,
    split,
    intros x1 x2,
    rw [succ_plus,succ_plus],
    intro hyp,
    apply subtype.mk.inj,
    simp,
    apply nat.succ.inj (subtype.mk_eq_mk.elim_left hyp),
    exact (λ n : ℕ , true),
    trivial,
    trivial,
    intro y,
    use y.val.pred,
    rw succ_plus,
    rw eq.symm (subtype.coe_eta y y.property),
    rw subtype.mk.inj_eq,
    simp,
    apply bon y
  end

def abs_nat : ℤ → ℕ
  |(int.of_nat k) := k
  |(int.neg_succ_of_nat k) := k

@[simp] def nat_abs : ℤ → ℕ
| (int.of_nat m) := m
| -[1+ m]    := m.succ

constant h : Prop
constant dh : decidable h
constants a b : α

lemma if_works {α : Sort u1} {p : Prop} [decidable p] {a b: α} : p →  (ite p a b = a)  :=
  begin
    intro h,
    simp,
    intro nh,
    trivial
  end

lemma if_not_works {α : Sort u1} {p : Prop} [decidable p] {a b: α} : ¬ p →  (ite p a b = b)  :=
  begin
    intro h,
    rw eq.symm (ite_not p b a),
    apply if_works,
    exact h
  end

lemma whatever_decidable : decidable (∀ (n : ℕ), 0 ≤ (n : ℤ )) :=
  begin
    simp,
    apply decidable.true
  end

def f : ℕ → ℤ  := λ n: ℕ , (-1) ^n *(n/2)
def g : ℤ → ℕ  := λ z : ℤ, if z ≤  0  then (0-2*(nat_abs z)) else 1+2*(nat_abs z)

lemma leq_two_z_o (n : ℕ) : n<2 → n=0 ∨ n=1 :=
  begin
    cases n,
    tauto,
    intro,
    fconstructor,
    hint

  end

lemma is_le_one_is_zero : ∀ n : ℕ, n<1 → n=0 :=
  begin
    intro n,
    cases n,
    simp,
    intro h,
    have p : ¬ n.succ < 1 := dec_trivial,
    apply absurd h p
  end

lemma even_succ_not_zero (n : ℕ) (h : even n.succ) : ¬(n.succ / 2 = 0) :=
  begin
     apply not.intro,
     have wut : 0 < 2 := by simp,
     rw nat.div_eq_zero_iff wut,
     simp at *,
     cases h,
     norm_cast at *,
     intro x,
     safe,
     rw eq.symm (nat.one_mul 2) at x,
     rw nat.mul_assoc at x,
     have lol :  1 * (2 * h_w) =  (2 * h_w) := by simp,
     rw lol at x,
     rw nat.mul_comm 1 2 at x,
     have triv : 0 ≤ 2 := by simp,
     have hmm := @lt_of_mul_lt_mul_left nat nat.linear_ordered_semiring h_w 1 2 x triv,
     have hw_z : h_w= 0 := by apply is_le_one_is_zero h_w hmm,
     rw hw_z at h_h,
     simp at h_h,
     have triv : ¬ n.succ = 0 := by trivial,
     apply absurd h_h triv
  end

theorem comp_fg_is_id : comp g f = id :=
  begin
    rw comp,
    change g with λ (z : ℤ), ite (z ≤ 0) (0 - 2 * nat_abs z) (1+2 * nat_abs z),
    change f with λ (n : ℕ), (-1) ^ n * (↑n / 2),
    simp,
    rw function.funext_iff,
    intro n,
    simp,
    by_cases even n,
    rw nat.neg_one_pow_of_even h,
    simp,
    cases n,
    simp,
    have p : ¬(n.succ / 2 ≤  0) := by simp;exact even_succ_not_zero n h,
    simp at p,
    split_ifs,
    simp at h_1,
    norm_cast at *,
    rw nat.succ_eq_add_one n at p,
    simp at h_1,
    apply absurd h_1 p,
    simp,
    cases n,
    simp,
    apply or.intro_right,
    finish,
    norm_cast at *,
    simp,
    cases n,
    simp,

  end

/- theorem Z_denumbrable : denombrable ℤ :=
  begin
    rw denombrable,
    rw in_bijection,
    use f,
    rw [bijective,and_comm],
    split,
    intro x,
    use g x,
    change g with λ (z : ℤ), ite (z ≤ 0) (1 - 2 * nat_abs z) (2 * nat_abs z),
    change f with λ (n : ℕ), (-1) ^ n * (↑n / 2),
    cases x,
    simp,
    apply if_works int.coe_nat_nonneg,

  end -/


import ..expressions.time_expr_current

open lang.time

abbreviation F := lang.time.K
lemma k_eq_Q : F = ℚ := rfl --lang is configured for the rationals

def world_time_in_seconds_fr : time_frame_expr := [time_std_frame F]
def world_time_in_seconds : time_space_expr world_time_in_seconds_fr :=
  [time_std_space F]

def world_time_in_years_fr : time_frame_expr :=
  let origin := [(mk_time world_time_in_seconds.value 0)] in
  let basis := [(mk_duration world_time_in_seconds.value (60*60*24*365))] in
  mk_time_frame_expr origin basis --not deeply embedded,
def world_time_in_years : time_space_expr world_time_in_years_fr :=
  mk_time_space_expr world_time_in_years_fr

def launch_time_in_seconds : time_expr world_time_in_seconds :=
  [(mk_time world_time_in_seconds.value 0)]

def launch_time_in_years : time_expr world_time_in_years :=
  [(mk_time world_time_in_years.value 0)]

def one_second : duration_expr world_time_in_seconds :=
  [(mk_duration world_time_in_seconds.value 1)]
def one_year : duration_expr world_time_in_years :=
  [(mk_duration world_time_in_years.value 1)]

--def adding_launches : time_expr world_time_in_seconds :=
--  launch_time_in_seconds +ᵥ launch_time_in_seconds --can't add times

def two_seconds : duration_expr world_time_in_seconds :=
  one_second +ᵥ one_second

def one_second_after_launch : time_expr world_time_in_seconds :=
  one_second +ᵥ launch_time_in_seconds

def what_after_what : _ :=
  one_second +ᵥ launch_time_in_years --wrong units

def two_years : duration_expr world_time_in_years :=
  one_second +ᵥ one_second

--def five_seconds : duration_expr world_time_in_seconds :=
--  5•one_second