/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.monoidal.braided
import category_theory.reflects_isomorphisms

/-!
# Half braidings and the Drinfeld center of a monoidal category

We define `center C` to be pairs `⟨X, b⟩`, where `X : C` and `b` is a half-braiding on `X`.

We show that `center C` is braided monoidal,
and provide the monoidal functor `center.forget` from `center C` back to `C`.

## Future work

Verifying the various axioms here is done by tedious rewriting.
Using the `slice` tactic may make the proofs marginally more readable.

More exciting, however, would be to make possible one of the following options:
1. Integration with homotopy.io / globular to give "picture proofs".
2. The monoidal coherence theorem, so we can ignore associators
   (after which most of these proofs are trivial;
   I'm unsure if the monoidal coherence theorem is even usable in dependent type theory).
3. Automating these proofs using `rewrite_search` or some relative.

-/

open category_theory
open category_theory.monoidal_category

universes v v₁ v₂ v₃ u u₁ u₂ u₃
noncomputable theory

namespace category_theory

variables {C : Type u₁} [category.{v₁} C] [monoidal_category C]

/--
A half-braiding on `X : C` is a family of isomorphisms `X ⊗ U ≅ U ⊗ X`,
monoidally natural in `U : C`.

Thinking of `C` as a 2-category with a single `0`-morphism, these are the same as natural
transformations (in the pseudo- sense) of the identity 2-functor on `C`, which send the unique
`0`-morphism to `X`.
-/
@[nolint has_inhabited_instance]
structure half_braiding (X : C) :=
(β : Π U, X ⊗ U ≅ U ⊗ X)
(monoidal' : ∀ U U', (β (U ⊗ U')).hom =
  (α_ _ _ _).inv ≫ ((β U).hom ⊗ 𝟙 U') ≫ (α_ _ _ _).hom ≫ (𝟙 U ⊗ (β U').hom) ≫ (α_ _ _ _).inv
  . obviously)
(naturality' : ∀ {U U'} (f : U ⟶ U'), (𝟙 X ⊗ f) ≫ (β U').hom = (β U).hom ≫ (f ⊗ 𝟙 X) . obviously)

restate_axiom half_braiding.monoidal'
attribute [reassoc, simp] half_braiding.monoidal -- the reassoc lemma is redundant as a simp lemma
restate_axiom half_braiding.naturality'
attribute [simp, reassoc] half_braiding.naturality

variables (C)
/--
The Drinfeld center of a monoidal category `C` has as objects pairs `⟨X, b⟩`, where `X : C`
and `b` is a half-braiding on `X`.
-/
@[nolint has_inhabited_instance]
def center := Σ X : C, half_braiding X

namespace center

variables {C}

/-- A morphism in the Drinfeld center of `C`. -/
@[ext, nolint has_inhabited_instance]
structure hom (X Y : center C) :=
(f : X.1 ⟶ Y.1)
(comm' : ∀ U, (f ⊗ 𝟙 U) ≫ (Y.2.β U).hom = (X.2.β U).hom ≫ (𝟙 U ⊗ f) . obviously)

restate_axiom hom.comm'
attribute [simp, reassoc] hom.comm

instance : category (center C) :=
{ hom := hom,
  id := λ X, { f := 𝟙 X.1, },
  comp := λ X Y Z f g, { f := f.f ≫ g.f, }, }

@[simp] lemma id_f (X : center C) : hom.f (𝟙 X) = 𝟙 X.1 := rfl
@[simp] lemma comp_f {X Y Z : center C} (f : X ⟶ Y) (g : Y ⟶ Z) : (f ≫ g).f = f.f ≫ g.f := rfl

@[ext]
lemma ext {X Y : center C} (f g : X ⟶ Y) (w : f.f = g.f) : f = g :=
by { cases f, cases g, congr, exact w, }

/--
Construct an isomorphism in the Drinfeld center from
a morphism whose underlying morphism is an isomorphism.
-/
@[simps]
def iso_mk {X Y : center C} (f : X ⟶ Y) [is_iso f.f] : X ≅ Y :=
{ hom := f,
  inv := ⟨inv f.f, λ U, by simp [←cancel_epi (f.f ⊗ 𝟙 U), ←comp_tensor_id_assoc, ←id_tensor_comp]⟩ }

instance is_iso_of_f_is_iso {X Y : center C} (f : X ⟶ Y) [is_iso f.f] : is_iso f :=
begin
  change is_iso (iso_mk f).hom,
  apply_instance,
end

/-- Auxiliary definition for the `monoidal_category` instance on `center C`. -/
@[simps]
def tensor_obj (X Y : center C) : center C :=
⟨X.1 ⊗ Y.1,
  { β := λ U, α_ _ _ _ ≪≫ (iso.refl X.1 ⊗ Y.2.β U) ≪≫ (α_ _ _ _).symm
      ≪≫ (X.2.β U ⊗ iso.refl Y.1) ≪≫ α_ _ _ _,
    monoidal' := λ U U',
    begin
      dsimp,
      simp only [comp_tensor_id, id_tensor_comp, category.assoc, half_braiding.monoidal],
      rw [pentagon_assoc, pentagon_inv_assoc, iso.eq_inv_comp, ←pentagon_assoc,
        ←id_tensor_comp_assoc, iso.hom_inv_id, tensor_id, category.id_comp,
        ←associator_naturality_assoc, cancel_epi, cancel_epi,
        ←associator_inv_naturality_assoc (X.2.β U).hom,
        associator_inv_naturality_assoc _ _ (Y.2.β U').hom, tensor_id, tensor_id,
        id_tensor_comp_tensor_id_assoc, associator_naturality_assoc (X.2.β U).hom,
        ←associator_naturality_assoc _ _ (Y.2.β U').hom, tensor_id, tensor_id,
        tensor_id_comp_id_tensor_assoc, ←id_tensor_comp_tensor_id, tensor_id, category.comp_id,
        ←is_iso.inv_comp_eq, inv_tensor, is_iso.inv_id, is_iso.iso.inv_inv, pentagon_assoc,
        iso.hom_inv_id_assoc, cancel_epi, cancel_epi, ←is_iso.inv_comp_eq, is_iso.iso.inv_hom,
        ←pentagon_inv_assoc, ←comp_tensor_id_assoc, iso.inv_hom_id, tensor_id, category.id_comp,
        ←associator_inv_naturality_assoc, cancel_epi, cancel_epi, ←is_iso.inv_comp_eq, inv_tensor,
        is_iso.iso.inv_hom, is_iso.inv_id, pentagon_inv_assoc, iso.inv_hom_id, category.comp_id],
    end,
    naturality' := λ U U' f,
    begin
      dsimp,
      rw [category.assoc, category.assoc, category.assoc, category.assoc,
        id_tensor_associator_naturality_assoc, ←id_tensor_comp_assoc, half_braiding.naturality,
        id_tensor_comp_assoc, associator_inv_naturality_assoc, ←comp_tensor_id_assoc,
        half_braiding.naturality, comp_tensor_id_assoc, associator_naturality, ←tensor_id],
    end, }⟩

/-- Auxiliary definition for the `monoidal_category` instance on `center C`. -/
@[simps]
def tensor_hom {X₁ Y₁ X₂ Y₂ : center C} (f : X₁ ⟶ Y₁) (g : X₂ ⟶ Y₂) :
  tensor_obj X₁ X₂ ⟶ tensor_obj Y₁ Y₂ :=
{ f := f.f ⊗ g.f,
  comm' := λ U, begin
    dsimp,
    rw [category.assoc, category.assoc, category.assoc, category.assoc,
      associator_naturality_assoc, ←tensor_id_comp_id_tensor, category.assoc,
      ←id_tensor_comp_assoc, g.comm, id_tensor_comp_assoc, tensor_id_comp_id_tensor_assoc,
      ←id_tensor_comp_tensor_id, category.assoc, associator_inv_naturality_assoc,
      id_tensor_associator_inv_naturality_assoc, tensor_id,
      id_tensor_comp_tensor_id_assoc, ←tensor_id_comp_id_tensor g.f, category.assoc,
      ←comp_tensor_id_assoc, f.comm, comp_tensor_id_assoc, id_tensor_associator_naturality,
      associator_naturality_assoc, ←id_tensor_comp, tensor_id_comp_id_tensor],
  end  }

/-- Auxiliary definition for the `monoidal_category` instance on `center C`. -/
@[simps]
def tensor_unit : center C :=
⟨𝟙_ C,
  { β := λ U, (λ_ U) ≪≫ (ρ_ U).symm,
    monoidal' := λ U U', by simp,
    naturality' := λ U U' f, begin
      dsimp,
      rw [left_unitor_naturality_assoc, right_unitor_inv_naturality, category.assoc],
    end, }⟩

/-- Auxiliary definition for the `monoidal_category` instance on `center C`. -/
def associator (X Y Z : center C) : tensor_obj (tensor_obj X Y) Z ≅ tensor_obj X (tensor_obj Y Z) :=
iso_mk ⟨(α_ X.1 Y.1 Z.1).hom, λ U, begin
  dsimp,
  simp only [category.assoc, comp_tensor_id, id_tensor_comp],
  rw [pentagon, pentagon_assoc, ←associator_naturality_assoc (𝟙 X.1) (𝟙 Y.1), tensor_id, cancel_epi,
    cancel_epi, iso.eq_inv_comp, ←pentagon_assoc, ←id_tensor_comp_assoc, iso.hom_inv_id, tensor_id,
    category.id_comp, ←associator_naturality_assoc, cancel_epi, cancel_epi, ←is_iso.inv_comp_eq,
    inv_tensor, is_iso.inv_id, is_iso.iso.inv_inv, pentagon_assoc, iso.hom_inv_id_assoc, ←tensor_id,
    ←associator_naturality_assoc],
end⟩

/-- Auxiliary definition for the `monoidal_category` instance on `center C`. -/
def left_unitor (X : center C) : tensor_obj tensor_unit X ≅ X :=
iso_mk ⟨(λ_ X.1).hom, λ U, begin
  dsimp,
  simp only [category.comp_id, category.assoc, tensor_inv_hom_id, comp_tensor_id,
    tensor_id_comp_id_tensor, triangle_assoc_comp_right_inv],
  rw [←left_unitor_tensor, left_unitor_naturality, left_unitor_tensor'_assoc],
end⟩

/-- Auxiliary definition for the `monoidal_category` instance on `center C`. -/
def right_unitor (X : center C) : tensor_obj X tensor_unit ≅ X :=
iso_mk ⟨(ρ_ X.1).hom, λ U, begin
  dsimp,
  simp only [tensor_id_comp_id_tensor_assoc, triangle_assoc, id_tensor_comp, category.assoc],
  rw [←tensor_id_comp_id_tensor_assoc (ρ_ U).inv, cancel_epi, ←right_unitor_tensor_inv_assoc,
    ←right_unitor_inv_naturality_assoc],
  simp,
end⟩

section
local attribute [simp] associator_naturality left_unitor_naturality right_unitor_naturality
  pentagon
local attribute [simp] center.associator center.left_unitor center.right_unitor

instance : monoidal_category (center C) :=
{ tensor_obj := λ X Y, tensor_obj X Y,
  tensor_hom := λ X₁ Y₁ X₂ Y₂ f g, tensor_hom f g,
  tensor_unit := tensor_unit,
  associator := associator,
  left_unitor := left_unitor,
  right_unitor := right_unitor, }

@[simp] lemma tensor_fst (X Y : center C) : (X ⊗ Y).1 = X.1 ⊗ Y.1 := rfl

@[simp] lemma tensor_β (X Y : center C) (U : C) :
  (X ⊗ Y).2.β U =
    α_ _ _ _ ≪≫ (iso.refl X.1 ⊗ Y.2.β U) ≪≫ (α_ _ _ _).symm
      ≪≫ (X.2.β U ⊗ iso.refl Y.1) ≪≫ α_ _ _ _ :=
rfl
@[simp]

@[simp] lemma tensor_unit_β (U : C) : (𝟙_ (center C)).2.β U = (λ_ U) ≪≫ (ρ_ U).symm := rfl

@[simp] lemma associator_hom_f (X Y Z : center C) : hom.f (α_ X Y Z).hom = (α_ X.1 Y.1 Z.1).hom :=
rfl

@[simp] lemma associator_inv_f (X Y Z : center C) : hom.f (α_ X Y Z).inv = (α_ X.1 Y.1 Z.1).inv :=
by { ext, rw [←associator_hom_f, ←comp_f, iso.hom_inv_id], refl, }

@[simp] lemma left_unitor_hom_f (X : center C) : hom.f (λ_ X).hom = (λ_ X.1).hom :=
rfl

@[simp] lemma left_unitor_inv_f (X : center C) : hom.f (λ_ X).inv = (λ_ X.1).inv :=
by { ext, rw [←left_unitor_hom_f, ←comp_f, iso.hom_inv_id], refl, }

@[simp] lemma right_unitor_hom_f (X : center C) : hom.f (ρ_ X).hom = (ρ_ X.1).hom :=
rfl

@[simp] lemma right_unitor_inv_f (X : center C) : hom.f (ρ_ X).inv = (ρ_ X.1).inv :=
by { ext, rw [←right_unitor_hom_f, ←comp_f, iso.hom_inv_id], refl, }

end

section
variables (C)

/-- The forgetful monoidal functor from the Drinfeld center to the original category. -/
@[simps]
def forget : monoidal_functor (center C) C :=
{ obj := λ X, X.1,
  map := λ X Y f, f.f,
  ε := 𝟙 (𝟙_ C),
  μ := λ X Y, 𝟙 (X.1 ⊗ Y.1), }

instance : reflects_isomorphisms (forget C).to_functor :=
{ reflects := λ A B f i, by { dsimp at i, resetI, change is_iso (iso_mk f).hom, apply_instance, } }

end

/-- Auxiliary definition for the `braided_category` instance on `center C`. -/
@[simps]
def braiding (X Y : center C) : X ⊗ Y ≅ Y ⊗ X :=
iso_mk ⟨(X.2.β Y.1).hom, λ U, begin
  dsimp,
  simp only [category.assoc],
  rw [←is_iso.inv_comp_eq, is_iso.iso.inv_hom, ←half_braiding.monoidal_assoc,
    ←half_braiding.naturality_assoc, half_braiding.monoidal],
  simp,
end⟩

instance braided_category_center : braided_category (center C) :=
{ braiding := braiding,
  braiding_naturality' := λ X Y X' Y' f g, begin
    ext,
    dsimp,
    rw [←tensor_id_comp_id_tensor, category.assoc, half_braiding.naturality, f.comm_assoc,
      id_tensor_comp_tensor_id],
  end, } -- `obviously` handles the hexagon axioms

section
variables [braided_category C]

open braided_category

/-- Auxiliary construction for `of_braided`. -/
@[simps]
def of_braided_obj (X : C) : center C :=
⟨X, { β := λ Y, β_ X Y,
  monoidal' := λ U U', begin
    rw [iso.eq_inv_comp, ←category.assoc, ←category.assoc, iso.eq_comp_inv,
      category.assoc, category.assoc],
    exact hexagon_forward X U U',
  end }⟩

variables (C)

/--
The functor lifting a braided category to its center, using the braiding as the half-braiding.
-/
@[simps]
def of_braided : monoidal_functor C (center C) :=
{ obj := of_braided_obj,
  map := λ X X' f,
  { f := f,
    comm' := λ U, braiding_naturality _ _, },
  ε :=
  { f := 𝟙 _,
    comm' := λ U, begin
      dsimp,
      rw [tensor_id, category.id_comp, tensor_id, category.comp_id, ←braiding_right_unitor,
        category.assoc, iso.hom_inv_id, category.comp_id],
    end, },
  μ := λ X Y,
  { f := 𝟙 _,
    comm' := λ U, begin
      dsimp,
      rw [tensor_id, tensor_id, category.id_comp, category.comp_id,
        ←iso.inv_comp_eq, ←category.assoc, ←category.assoc, ←iso.comp_inv_eq,
        category.assoc, hexagon_reverse, category.assoc],
    end, }, }

end

end center

end category_theory


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import init.meta init.data.sigma.lex init.data.nat.lemmas init.data.list.instances
import init.data.list.qsort

/- TODO(Leo): move this lemma, or delete it after we add algebraic normalizer. -/
lemma nat.lt_add_of_zero_lt_left (a b : nat) (h : 0 < b) : a < a + b :=
show a + 0 < a + b,
by {apply nat.add_lt_add_left, assumption}

/- TODO(Leo): move this lemma, or delete it after we add algebraic normalizer. -/
lemma nat.zero_lt_one_add (a : nat) : 0 < 1 + a :=
suffices 0 < a + 1, by {simp [nat.add_comm], assumption},
nat.zero_lt_succ _

/- TODO(Leo): move this lemma, or delete it after we add algebraic normalizer. -/
lemma nat.lt_add_right (a b c : nat) : a < b → a < b + c :=
λ h, lt_of_lt_of_le h (nat.le_add_right _ _)

/- TODO(Leo): move this lemma, or delete it after we add algebraic normalizer. -/
lemma nat.lt_add_left (a b c : nat) : a < b → a < c + b :=
λ h, lt_of_lt_of_le h (nat.le_add_left _ _)

protected def {u v} psum.alt.sizeof
  {α : Type u} {β : Type v} [has_sizeof α] [has_sizeof β] : psum α β → ℕ
| (psum.inl a) := sizeof a
| (psum.inr b) := sizeof b

@[reducible]
protected def {u v} psum.has_sizeof_alt
  (α : Type u) (β : Type v) [has_sizeof α] [has_sizeof β] : has_sizeof (psum α β) :=
⟨psum.alt.sizeof⟩

namespace well_founded_tactics
open tactic

def id_tag.wf : unit := ()

meta def mk_alt_sizeof : expr → expr
| (expr.app (expr.app (expr.app (expr.app (expr.const ``psum.has_sizeof l) α) β) iα) iβ) :=
  (expr.const ``psum.has_sizeof_alt l : expr) α β iα (mk_alt_sizeof iβ)
| e := e

meta def default_rel_tac (e : expr) (eqns : list expr) : tactic unit :=
do tgt ← target,
  rel ← mk_instance tgt,
  exact $ match e, rel with
    expr.local_const _ (name.mk_string "_mutual" _) _ _,
    expr.app e@`(@has_well_founded_of_has_sizeof _) sz := e (mk_alt_sizeof sz)
  | _, _ := rel
  end

private meta def clear_wf_rec_goal_aux : list expr → tactic unit
| []      := return ()
| (h::hs) := clear_wf_rec_goal_aux hs >> try (guard (h.local_pp_name.is_internal || h.is_aux_decl) >> clear h)

meta def clear_internals : tactic unit :=
local_context >>= clear_wf_rec_goal_aux

meta def unfold_wf_rel : tactic unit :=
dunfold_target [``has_well_founded.r] {fail_if_unchanged := ff}

meta def is_psigma_mk : expr → tactic (expr × expr)
| `(psigma.mk %%a %%b) := return (a, b)
| _                    := failed

meta def process_lex : tactic unit → tactic unit
| tac :=
  do t ← target >>= whnf,
  if t.is_napp_of `psigma.lex 6 then
     let a := t.app_fn.app_arg in
     let b := t.app_arg in
     do (a₁, a₂) ← is_psigma_mk a,
        (b₁, b₂) ← is_psigma_mk b,
        (is_def_eq a₁ b₁ >> `[apply psigma.lex.right] >> process_lex tac)
        <|>
        (`[apply psigma.lex.left] >> tac)
  else
     tac

private meta def unfold_sizeof_measure : tactic unit :=
dunfold_target [``sizeof_measure, ``measure, ``inv_image] {fail_if_unchanged := ff}

private meta def add_simps : simp_lemmas → list name → tactic simp_lemmas
| s []      := return s
| s (n::ns) := do s' ← s.add_simp n ff, add_simps s' ns

private meta def collect_sizeof_lemmas (e : expr) : tactic simp_lemmas :=
e.mfold simp_lemmas.mk $ λ c d s,
  if c.is_constant then
    match c.const_name with
    | name.mk_string "sizeof" p :=
      do eqns ← get_eqn_lemmas_for tt c.const_name,
         add_simps s eqns
    | _ := return s
    end
  else
    return s

private meta def unfold_sizeof_loop : tactic unit :=
do
  dunfold_target [``sizeof, ``has_sizeof.sizeof] {fail_if_unchanged := ff},
  S ← target >>= collect_sizeof_lemmas,
  (simp_target S >> unfold_sizeof_loop)
  <|>
  try `[simp]

meta def unfold_sizeof : tactic unit :=
unfold_sizeof_measure >> unfold_sizeof_loop

/- The following section should be removed as soon as we implement the
   algebraic normalizer. -/
section simple_dec_tac
open tactic expr

private meta def collect_add_args : expr → list expr
| `(%%a + %%b) := collect_add_args a ++ collect_add_args b
| e            := [e]

private meta def mk_nat_add : list expr → tactic expr
| []      := to_expr ``(0)
| [a]     := return a
| (a::as) := do
  rs ← mk_nat_add as,
  to_expr ``(%%a + %%rs)

private meta def mk_nat_add_add : list expr → list expr → tactic expr
| [] b  := mk_nat_add b
| a  [] := mk_nat_add a
| a  b  :=
  do t ← mk_nat_add a,
     s ← mk_nat_add b,
     to_expr ``(%%t + %%s)

private meta def get_add_fn (e : expr) : expr :=
if is_napp_of e `has_add.add 4 then e.app_fn.app_fn
else e

private meta def prove_eq_by_perm (a b : expr) : tactic expr :=
(is_def_eq a b >> to_expr ``(eq.refl %%a))
<|>
perm_ac (get_add_fn a) `(nat.add_assoc) `(nat.add_comm) a b

private meta def num_small_lt (a b : expr) : bool :=
if a = b then ff
else if is_napp_of a `has_one.one 2 then tt
else if is_napp_of b `has_one.one 2 then ff
else a.lt b

private meta def sort_args (args : list expr) : list expr :=
args.qsort num_small_lt

private def tagged_proof.wf : unit := ()

meta def cancel_nat_add_lt : tactic unit :=
do `(%%lhs < %%rhs) ← target,
   ty ← infer_type lhs >>= whnf,
   guard (ty = `(nat)),
   let lhs_args := collect_add_args lhs,
   let rhs_args := collect_add_args rhs,
   let common   := lhs_args.bag_inter rhs_args,
   if common = [] then return ()
   else do
     let lhs_rest := lhs_args.diff common,
     let rhs_rest := rhs_args.diff common,
     new_lhs    ← mk_nat_add_add common (sort_args lhs_rest),
     new_rhs    ← mk_nat_add_add common (sort_args rhs_rest),
     lhs_pr     ← prove_eq_by_perm lhs new_lhs,
     rhs_pr     ← prove_eq_by_perm rhs new_rhs,
     target_pr  ← to_expr ``(congr (congr_arg (<) %%lhs_pr) %%rhs_pr),
     new_target ← to_expr ``(%%new_lhs < %%new_rhs),
     replace_target new_target target_pr ``id_tag.wf,
     `[apply nat.add_lt_add_left] <|> `[apply nat.lt_add_of_zero_lt_left]

meta def check_target_is_value_lt : tactic unit :=
do `(%%lhs < %%rhs) ← target,
    guard lhs.is_numeral

meta def trivial_nat_lt : tactic unit :=
comp_val
<|>
`[apply nat.zero_lt_one_add]
<|>
assumption
<|>
(do check_target_is_value_lt,
    (`[apply nat.lt_add_right] >> trivial_nat_lt)
    <|>
    (`[apply nat.lt_add_left] >> trivial_nat_lt))
<|>
failed
end simple_dec_tac

meta def default_dec_tac : tactic unit :=
abstract $
do clear_internals,
   unfold_wf_rel,
   -- The next line was adapted from code in mathlib by Scott Morrison.
   -- Because `unfold_sizeof` could actually discharge the goal, add a test
   -- using `done` to detect this.
   process_lex (unfold_sizeof >> (done <|> (cancel_nat_add_lt >> trivial_nat_lt))) <|>
   -- Clean up the goal state but not too much before printing the error
   (unfold_sizeof >> fail "default_dec_tac failed")

end well_founded_tactics

/-- Argument for using_well_founded

  The tactic `rel_tac` has to synthesize an element of type (has_well_founded A).
  The two arguments are: a local representing the function being defined by well
  founded recursion, and a list of recursive equations.
  The equations can be used to decide which well founded relation should be used.

  The tactic `dec_tac` has to synthesize decreasing proofs.
-/
meta structure well_founded_tactics :=
(rel_tac : expr → list expr → tactic unit := well_founded_tactics.default_rel_tac)
(dec_tac : tactic unit := well_founded_tactics.default_dec_tac)

meta def well_founded_tactics.default : well_founded_tactics :=
{}


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

! This file was ported from Lean 3 source module analysis.hofer
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.SpecificLimits.Basic

/-!
# Hofer's lemma

This is an elementary lemma about complete metric spaces. It is motivated by an
application to the bubbling-off analysis for holomorphic curves in symplectic topology.
We are *very* far away from having these applications, but the proof here is a nice
example of a proof needing to construct a sequence by induction in the middle of the proof.

## References:

* H. Hofer and C. Viterbo, *The Weinstein conjecture in the presence of holomorphic spheres*
-/

open Classical Topology BigOperators

open Filter Finset

-- mathport name: exprd
local notation "d" => dist

@[simp]
theorem pos_div_pow_pos {α : Type _} [LinearOrderedSemifield α] {a b : α} (ha : 0 < a) (hb : 0 < b)
    (k : ℕ) : 0 < a / b ^ k :=
  div_pos ha (pow_pos hb k)
#align pos_div_pow_pos pos_div_pow_pos

theorem hofer {X : Type _} [MetricSpace X] [CompleteSpace X] (x : X) (ε : ℝ) (ε_pos : 0 < ε)
    {ϕ : X → ℝ} (cont : Continuous ϕ) (nonneg : ∀ y, 0 ≤ ϕ y) :
    ∃ ε' > 0,
      ∃ x' : X, ε' ≤ ε ∧ d x' x ≤ 2 * ε ∧ ε * ϕ x ≤ ε' * ϕ x' ∧ ∀ y, d x' y ≤ ε' → ϕ y ≤ 2 * ϕ x' :=
  by
  by_contra H
  have reformulation : ∀ (x') (k : ℕ), ε * ϕ x ≤ ε / 2 ^ k * ϕ x' ↔ 2 ^ k * ϕ x ≤ ϕ x' :=
    by
    intro x' k
    rw [div_mul_eq_mul_div, le_div_iff, mul_assoc, mul_le_mul_left ε_pos, mul_comm]
    positivity
  -- Now let's specialize to `ε/2^k`
  replace H :
    ∀ k : ℕ, ∀ x', d x' x ≤ 2 * ε ∧ 2 ^ k * ϕ x ≤ ϕ x' → ∃ y, d x' y ≤ ε / 2 ^ k ∧ 2 * ϕ x' < ϕ y
  · intro k x'
    push_neg  at H
    simpa [reformulation] using H (ε / 2 ^ k) (by simp [ε_pos]) x' (by simp [ε_pos.le, one_le_two])
  clear reformulation
  haveI : Nonempty X := ⟨x⟩
  choose! F hF using H
  -- Use the axiom of choice
  -- Now define u by induction starting at x, with u_{n+1} = F(n, u_n)
  let u : ℕ → X := fun n => Nat.recOn n x F
  have hu0 : u 0 = x := rfl
  -- The properties of F translate to properties of u
  have hu :
    ∀ n,
      d (u n) x ≤ 2 * ε ∧ 2 ^ n * ϕ x ≤ ϕ (u n) →
        d (u n) (u <| n + 1) ≤ ε / 2 ^ n ∧ 2 * ϕ (u n) < ϕ (u <| n + 1) :=
    by
    intro n
    exact hF n (u n)
  clear hF
  -- Key properties of u, to be proven by induction
  have key : ∀ n, d (u n) (u (n + 1)) ≤ ε / 2 ^ n ∧ 2 * ϕ (u n) < ϕ (u (n + 1)) :=
    by
    intro n
    induction' n using Nat.case_strong_induction_on with n IH
    · specialize hu 0
      simpa [hu0, mul_nonneg_iff, zero_le_one, ε_pos.le, le_refl] using hu
    have A : d (u (n + 1)) x ≤ 2 * ε := by
      rw [dist_comm]
      let r := range (n + 1)
      -- range (n+1) = {0, ..., n}
      calc
        d (u 0) (u (n + 1)) ≤ ∑ i in r, d (u i) (u <| i + 1) := dist_le_range_sum_dist u (n + 1)
        _ ≤ ∑ i in r, ε / 2 ^ i :=
          (sum_le_sum fun i i_in => (IH i <| nat.lt_succ_iff.mp <| finset.mem_range.mp i_in).1)
        _ = ∑ i in r, (1 / 2) ^ i * ε := by
          congr with i
          field_simp
        _ = (∑ i in r, (1 / 2) ^ i) * ε := finset.sum_mul.symm
        _ ≤ 2 * ε := mul_le_mul_of_nonneg_right (sum_geometric_two_le _) (le_of_lt ε_pos)

    have B : 2 ^ (n + 1) * ϕ x ≤ ϕ (u (n + 1)) :=
      by
      refine' @geom_le (ϕ ∘ u) _ zero_le_two (n + 1) fun m hm => _
      exact (IH _ <| Nat.lt_add_one_iff.1 hm).2.le
    exact hu (n + 1) ⟨A, B⟩
  cases' forall_and_distrib.mp key with key₁ key₂
  clear hu key
  -- Hence u is Cauchy
  have cauchy_u : CauchySeq u :=
    by
    refine' cauchySeq_of_le_geometric _ ε one_half_lt_one fun n => _
    simpa only [one_div, inv_pow] using key₁ n
  -- So u converges to some y
  obtain ⟨y, limy⟩ : ∃ y, tendsto u at_top (𝓝 y)
  exact CompleteSpace.complete cauchy_u
  -- And ϕ ∘ u goes to +∞
  have lim_top : tendsto (ϕ ∘ u) at_top at_top :=
    by
    let v n := (ϕ ∘ u) (n + 1)
    suffices tendsto v at_top at_top by rwa [tendsto_add_at_top_iff_nat] at this
    have hv₀ : 0 < v 0 := by
      have : 0 ≤ ϕ (u 0) := nonneg x
      calc
        0 ≤ 2 * ϕ (u 0) := by linarith
        _ < ϕ (u (0 + 1)) := key₂ 0

    apply tendsto_atTop_of_geom_le hv₀ one_lt_two
    exact fun n => (key₂ (n + 1)).le
  -- But ϕ ∘ u also needs to go to ϕ(y)
  have lim : tendsto (ϕ ∘ u) at_top (𝓝 (ϕ y)) := tendsto.comp cont.continuous_at limy
  -- So we have our contradiction!
  exact not_tendsto_atTop_of_tendsto_nhds limUnder lim_top
#align hofer hofer


import tactic data.stream.basic data.set.basic data.finset data.multiset
       category.traversable.derive
open tactic

universe u
variable {α : Type}

example (s t u : set ℕ) (h : s ⊆ t ∩ u) (h' : u ⊆ s) : u ⊆ s → true :=
begin
  dunfold has_subset.subset has_inter.inter at *,
--  trace_state,
  intro1, triv
end

example (s t u : set ℕ) (h : s ⊆ t ∩ u) (h' : u ⊆ s) : u ⊆ s → true :=
begin
  delta has_subset.subset has_inter.inter at *,
--  trace_state,
  intro1, triv
end

example (x y z : ℕ) (h'' : true) (h : 0 + y = x) (h' : 0 + y = z) : x = z + 0 :=
begin
  simp at *,
--  trace_state,
  rw [←h, ←h']
end

example (x y z : ℕ) (h'' : true) (h : 0 + y = x) (h' : 0 + y = z) : x = z + 0 :=
begin
  simp at *,
  simp [h] at h',
  simp [*]
end

def my_id (x : α) := x

def my_id_def (x : α) : my_id x = x := rfl

example (x y z : ℕ) (h'' : true) (h : 0 + my_id y = x) (h' : 0 + y = z) : x = z + 0 :=
begin
  simp [my_id_def] at *, simp [h] at h', simp [*]
end

@[simp] theorem mem_set_of {a : α} {p : α → Prop} : a ∈ {a | p a} = p a := rfl

-- TODO: write a tactic to unfold specific instances of generic notation?
theorem subset_def {s t : set α} : (s ⊆ t) = ∀ x, x ∈ s → x ∈ t := rfl
theorem union_def {s₁ s₂ : set α} : s₁ ∪ s₂ = {a | a ∈ s₁ ∨ a ∈ s₂} := rfl
theorem inter_def {s₁ s₂ : set α} : s₁ ∩ s₂ = {a | a ∈ s₁ ∧ a ∈ s₂} := rfl

theorem union_subset {s t r : set α} (sr : s ⊆ r) (tr : t ⊆ r) : s ∪ t ⊆ r :=
begin
  dsimp [subset_def, union_def] at *,
  intros x h,
  cases h; back_chaining_using_hs
end

theorem subset_inter {s t r : set α} (rs : r ⊆ s) (rt : r ⊆ t) : r ⊆ s ∩ t :=
begin
  dsimp [subset_def, inter_def] at *,
  intros x h,
  split; back_chaining_using_hs
end

/- extensionality -/

example : true :=
begin
  have : ∀ (s₀ s₁ : set ℤ), s₀ = s₁,
  { intros, ext1,
    guard_target x ∈ s₀ ↔ x ∈ s₁,
    admit },
  have : ∀ (s₀ s₁ : finset ℕ), s₀ = s₁,
  { intros, ext1,
    guard_target a ∈ s₀ ↔ a ∈ s₁,
    admit },
  have : ∀ (s₀ s₁ : multiset ℕ), s₀ = s₁,
  { intros, ext1,
    guard_target multiset.count a s₀ = multiset.count a s₁,
    admit },
  have : ∀ (s₀ s₁ : list ℕ), s₀ = s₁,
  { intros, ext1,
    guard_target list.nth s₀ n = list.nth s₁ n,
    admit },
  have : ∀ (s₀ s₁ : stream ℕ), s₀ = s₁,
  { intros, ext1,
    guard_target stream.nth n s₀ = stream.nth n s₁,
    admit },
  have : ∀ n (s₀ s₁ : array n ℕ), s₀ = s₁,
  { intros, ext1,
    guard_target array.read s₀ i = array.read s₁ i,
    admit },
  trivial
end

/- refine_struct -/
section refine_struct

variables {α} [_inst : monoid α]
include _inst

example : true :=
begin
  have : group α,
  { refine_struct { .._inst },
    guard_tags _field inv group, admit,
    guard_tags _field mul_left_inv group, admit, },
  trivial
end

end refine_struct

/- traversable -/
open tactic.interactive

run_cmd do
lawful_traversable_derive_handler' `test ``(is_lawful_traversable) ``list
-- the above creates local instances of `traversable` and `is_lawful_traversable`
-- for `list`
-- do not put in instances because they are not universe polymorphic

@[derive [traversable, is_lawful_traversable]]
structure my_struct (α : Type) :=
  (y : ℤ)

@[derive [traversable, is_lawful_traversable]]
inductive either (α : Type u)
| left : α → ℤ → either
| right : α → either

@[derive [traversable, is_lawful_traversable]]
structure my_struct2 (α : Type u) : Type u :=
  (x : α)
  (y : ℤ)
  (η : list α)
  (k : list (list α))

@[derive [traversable, is_lawful_traversable]]
inductive rec_data3 (α : Type u) : Type u
| nil : rec_data3
| cons : ℕ → α → rec_data3 → rec_data3 → rec_data3

@[derive traversable]
meta structure meta_struct (α : Type u) : Type u :=
  (x : α)
  (y : ℤ)
  (z : list α)
  (k : list (list α))
  (w : expr)


lemma pohe : ∀P, ¬(P ↔ ¬P) := begin
    intro P,
    intro w,
    have np : ¬ P, {
        intro hp,
        exact w.1 hp hp
    },
    exact np (w.2 np)
end

theorem boolean_hole :
    (∀ P Q R, (P ↔ Q) ∨ (Q ↔ R) ∨ (R ↔ P)) → ∀ P, P ∨ ¬ P := begin
    intros asm P,
    cases asm (P ∨ ¬P) ¬(P ∨ ¬P) ¬¬(P ∨ ¬P), {
        exfalso,
        apply pohe,
        assumption,
    }, cases h, {
        exfalso,
        apply pohe,
        assumption
    }, {
        apply h.1,
        intro n_pnp,
        have np : ¬ P, {
            intro p,
            apply n_pnp,
            left,
            assumption
        },
        apply n_pnp,
        right,
        assumption
    }
end


lemma contra (P Q : Prop) : (P ∧ ¬ P) → Q :=
begin
intro h,
cases h with p notp,
rw not_iff_imp_false at notp,
exfalso,
apply notp,
exact p,
end


import .bvm_extras2

universes u v

namespace pSet

section
open cardinal

lemma regularity (x : pSet.{u}) (H_nonempty : ¬ equiv x (∅ : pSet.{u})) : ∃ (y : pSet) (Hy : y ∈ x), ∀ z ∈ x, ¬ (z ∈ y) :=
begin
  have := is_epsilon_well_founded x,
  cases exists_mem_of_nonempty H_nonempty with w Hw,
  have := this x (subset_self) ‹_›,
    { rcases this with ⟨y, Hy₁, Hy₂⟩, exact ⟨y,‹_›,‹_›⟩ }
end

noncomputable def aleph_one : pSet := card_ex (aleph 1)

lemma aleph_one_Ord : Ord aleph_one := by apply Ord_mk

def aleph_one_weak_Ord_spec (x : pSet.{u}) : Prop :=
Ord x ∧ (∀ y : pSet.{u}, Ord y ∧ ¬ injects_into y pSet.omega → x ⊆ y)

def epsilon_trichotomy (x : pSet.{u}) : Prop := ∀ (y : pSet), y ∈ x → ∀ (z : pSet), z ∈ x → equiv y z ∨ y ∈ z ∨ z ∈ y

lemma epsilon_trichotomy_of_Ord {x : pSet.{u}} (H_ord : Ord x) : epsilon_trichotomy x :=
H_ord.left.left

lemma epsilon_trichotomy_of_Ord' {x : pSet.{u}} (H_ord : Ord x) : ∀ {y} (Hy : y ∈ x) {z} (Hz : z ∈ x), equiv y z ∨ y ∈ z ∨ z ∈ y :=
by { have :=  epsilon_trichotomy_of_Ord H_ord, intros, unfold epsilon_trichotomy at this, solve_by_elim }

lemma is_transitive_of_mem_Ord {x : pSet.{u}} (H_ord : Ord x) : is_transitive x := H_ord.right

lemma mem_of_mem_subset {x y z : pSet.{u}} (H_sub : y ⊆ z) (H_mem : x ∈ y) : x ∈ z :=
by { rw subset_iff_all_mem at H_sub, solve_by_elim }

lemma mem_of_mem_Ord {x y z : pSet.{u}} (H_ord : Ord z) (H_mem₁ : x ∈ y) (H_mem₂ : y ∈ z) : x ∈ z :=
begin
  have := is_transitive_of_mem_Ord H_ord,
  refine mem_of_mem_subset _ H_mem₁, solve_by_elim
end

lemma subset_of_mem_Ord {x z : pSet.{u}} (H_ord : Ord z) (H_mem₁ : x ∈ z) : x ⊆ z :=
by {cases H_ord with H_ewo H_trans, solve_by_elim}

lemma Ord_of_mem_Ord {x z : pSet.{u}} (H_mem : x ∈ z) (H : Ord z) : Ord x :=
begin
  refine ⟨_,_⟩,
    { refine ⟨_, by apply is_epsilon_well_founded⟩,
      intros y₁ Hy₁ y₂ Hy₂,
      apply (epsilon_trichotomy_of_Ord H); apply mem_of_mem_Ord; from ‹_› },
    { apply transitive_of_mem_Ord, repeat { assumption } }
end

def compl (x y : pSet.{u}) : pSet.{u} := {z ∈ x | ¬ z ∈ y}

lemma mem_compl_iff {x y z : pSet.{u}} : z ∈ compl x y ↔ z ∈ x ∧ ¬ z ∈ y :=
by {erw mem_sep_iff, simp}

@[reducible]def non_empty (x : pSet.{u}) : Prop := ¬ (equiv x (∅ : pSet.{u}))

lemma equiv_unfold' {x y : pSet.{u}} : equiv x y ↔ (∀ z, z ∈ x → z ∈ y) ∧ (∀ z, z ∈ y → z ∈ x ) :=
by simp [equiv.ext, subset_iff_all_mem]

lemma nonempty_iff_exists_mem {x : pSet.{u}} : non_empty x ↔ ∃ y, y ∈ x :=
begin
  refine ⟨_,_⟩,
    { exact exists_mem_of_nonempty },
    { intro H_ex_mem, intro H_eq, cases H_ex_mem with y Hy, apply pSet.mem_empty y, pSet_cc }
end

lemma nonempty_compl_of_ne {x y : pSet.{u}} (H_ne : ¬ equiv x y) : (non_empty $ compl x y) ∨ (non_empty $ compl y x) :=
begin
  rw equiv_unfold' at H_ne, push_neg at H_ne, cases H_ne,
    { rcases H_ne with ⟨z,Hz₁,Hz₂⟩, left, rw nonempty_iff_exists_mem, use z, simp[mem_compl_iff, *] },
    { rcases H_ne with ⟨z,Hz₁,Hz₂⟩, right, rw nonempty_iff_exists_mem, use z, simp [mem_compl_iff, *] }
end

lemma compl_empty_of_subset {x y : pSet.{u}} (H_sub : x ⊆ y) : equiv (compl x y) (∅ : pSet.{u}) :=
begin
  classical, by_contra H_contra, change non_empty _ at H_contra, rw nonempty_iff_exists_mem at H_contra,
  cases H_contra with z Hz, rw mem_compl_iff at Hz, cases Hz,
  suffices : z ∈ y,
    by contradiction,
  from mem_of_mem_subset H_sub ‹_›
end

def binary_inter (x y : pSet.{u}) : pSet.{u} := {z ∈ x | z ∈ y}

lemma mem_binary_inter_iff {x y z : pSet.{u}} : z ∈ binary_inter x y ↔ (z ∈ x ∧ z ∈ y) :=
by {erw mem_sep_iff, simp}

lemma binary_inter_subset {x y : pSet.{u}} : ((binary_inter x y ⊆ x) ∧ (binary_inter x y ⊆ y)) :=
by {refine ⟨_,_⟩; rw subset_iff_all_mem; intros z Hz; rw mem_binary_inter_iff at Hz; simp*}

lemma Ord_binary_inter {x y : pSet.{u}} (H₁ : Ord x) (H₂ : Ord y) : Ord (binary_inter x y) :=
begin
  refine ⟨⟨_,_⟩,_⟩,
    { intros w Hw_mem z Hz_mem, rw mem_binary_inter_iff at Hw_mem Hz_mem,
    have := epsilon_trichotomy_of_Ord H₁, tidy },
    { apply is_epsilon_well_founded },
    { intros z H_mem, rw mem_binary_inter_iff at H_mem, cases H_mem with H_mem₁ H_mem₂,
      rw subset_iff_all_mem, intros w Hw, rw mem_binary_inter_iff, refine ⟨_,_⟩,
        { exact mem_of_mem_Ord H₁ ‹_› ‹_› },
        { exact mem_of_mem_Ord H₂ ‹_› ‹_› }}
end

lemma Ord.lt_of_ne_and_le {x y : pSet.{u}} (H₁ :  Ord x) (H₂ :  Ord y) (H_ne : ¬ (equiv x y)) (H_le :  x ⊆ y) :  x ∈ y :=
begin
  have H_compl_nonempty : non_empty (compl y x),
    by { have this₁ := nonempty_compl_of_ne ‹_›,
         have this₂ := compl_empty_of_subset ‹_›,
         cases this₁,
           { exfalso, contradiction },
           { from ‹_› } },
  have H_ex_min := regularity _ H_compl_nonempty,
  rcases H_ex_min with ⟨z,⟨Hz₁,Hz₂⟩⟩,
  cases mem_compl_iff.mp Hz₁ with Hz₁ Hz₁',
  suffices H_eq : equiv x z, by pSet_cc,
  apply mem.ext, intro a, refine ⟨_,_⟩; intro H_mem,
    { have this' := epsilon_trichotomy_of_Ord' H₂ (mem_of_mem_subset H_le ‹_›) Hz₁,
      cases this',
        { exfalso, pSet_cc },
        { cases this',
          { from ‹_› },
          { exfalso, suffices : z ∈ x, by pSet_cc,
            refine mem_of_mem_Ord _ _ _, from a, repeat { assumption }}},},
    { classical, by_contra,
      have H_mem_y : a ∈ y,
        by {exact mem_of_mem_Ord ‹Ord y› H_mem ‹_› },
      have : a ∈ y ∧ ¬(a ∈ x) := ⟨‹_›,‹_›⟩,
      rw ←mem_compl_iff at this,
      refine absurd H_mem _, solve_by_elim }
end

lemma Ord.le_or_le {x y : pSet.{u}} (H₁ : Ord x) (H₂ : Ord y) : x ⊆ y ∨ y ⊆ x :=
begin
  let w := binary_inter x y,
  have w_Ord : Ord w := Ord_binary_inter H₁ H₂,
  have : equiv w x ∨ equiv w y,
    by { classical, by_contra H_contra, push_neg at H_contra,
         suffices : w ∈ x ∧ w ∈ y,
           by { suffices : w ∈ w, from mem_self ‹_›,
                rwa mem_binary_inter_iff },
         cases H_contra with H_contra₁ H_contra₂,
         refine ⟨_,_⟩,
           { exact Ord.lt_of_ne_and_le w_Ord ‹_› ‹_› binary_inter_subset.left },
           { exact Ord.lt_of_ne_and_le w_Ord H₂ ‹_› binary_inter_subset.right }},
  cases @binary_inter_subset x y with H_sub₁ H_sub₂, cases this,
    { left, dsimp[w] at this, pSet_cc },
    { right, dsimp[w] at this, pSet_cc }
end

lemma equiv.comm {x y : pSet.{u}} : equiv x y ↔ equiv y x :=
by {have := @equiv.symm, tidy} -- why does {[smt] eblast_using [equiv.symm]} fail here?

lemma Ord.trichotomy {x y : pSet.{u}} (H₁ : Ord x) (H₂ : Ord y) : equiv x y ∨ x ∈ y ∨ y ∈ x :=
begin
  classical, have := Ord.le_or_le H₁ H₂,
  cases this,
    { by_cases (equiv x y),
      { from or.inl ‹_› },
      { refine or.inr (or.inl _), from Ord.lt_of_ne_and_le H₁ H₂ ‹_› ‹_› }},
    { by_cases (equiv x y),
      { from or.inl ‹_› },
      { refine or.inr (or.inr _), rw equiv.comm at h,
        have := @Ord.lt_of_ne_and_le, tactic.back_chaining_using_hs },},
end

lemma Ord.lt_of_le_of_lt {x y z : pSet.{u}} (Hx : Ord x) (Hy : Ord y) (Hz : Ord z) (H_le : x ⊆ y) (H_lt : y ∈ z) : x ∈ z :=
begin
  have := Ord.trichotomy Hx Hy,
  have H_dichotomy : x ∈ y ∨ equiv x y,
    by {cases this, right, from ‹_›, cases this, left, from ‹_›,
        right, rw equiv.ext, refine ⟨‹_›,_⟩, apply Hx.right, from ‹_› },
  cases H_dichotomy,
    { apply mem_trans_of_transitive, from ‹_›, from ‹_›, from Hz.right },
    { rwa mem.congr_left (equiv.symm H_dichotomy) at H_lt }
end

lemma Ord.le_iff_lt_or_eq {x z : pSet.{u}} (H₁ : Ord x) (H₂ : Ord z) : x ⊆ z ↔ x ∈ z ∨ equiv x z :=
begin
  classical, refine ⟨_,_⟩; intro H,
    { by_cases H_eq : equiv x z,
      { right, from ‹_› },
      { left, refine Ord.lt_of_ne_and_le H₁ _ _ _, repeat { from ‹_› }}},
    { cases H,
      { from subset_of_mem_Ord H₂ ‹_› },
      { have : x ⊆ x := subset_self, pSet_cc }},
end

local prefix `#`:70 := cardinal.mk

lemma mk_injects_into_of_mk_le_omega {η : ordinal.{u}} (H_le : #(ordinal.mk η).type ≤ #(pSet.omega : pSet.{u}).type) : injects_into (ordinal.mk η) pSet.omega :=
begin
  have H_ex_inj : ∃ f : (ordinal.mk η).type → (omega : pSet.{u}).type, function.injective f,
    by exact cardinal.injection_of_mk_le ‹_›,
  cases H_ex_inj with f Hf,
  let ψ : (ordinal.mk η).type → pSet.{u} := λ i, omega.func (f i),
  have H_congr : ∀ i j, pSet.equiv ((ordinal.mk η).func i) ((ordinal.mk η).func j) → pSet.equiv (ψ i) (ψ j),
    by { intros i₁ i₂ H_eqv,
         suffices : i₁ = i₂, by subst this, classical, by_contra,
         have := ordinal.mk_inj η i₁ i₂ ‹_›, contradiction },
  have H_inj : ∀ i₁ i₂, equiv (ψ i₁) (ψ i₂) → equiv ((ordinal.mk η).func i₁) ((ordinal.mk η).func i₂),
    by {intros i₁ i₂ H_eqv,
        suffices : i₁ = i₂,
          by { subst this },
        have := omega_inj H_eqv, finish },
  use pSet.function.mk ψ H_congr,
  refine ⟨_,_⟩,
    { apply pSet.function.mk_is_func, simp* },
    { apply pSet.function.mk_inj_of_inj, from ‹_› }
end

lemma injects_into_omega_of_mem_aleph_one {z : pSet} (H_mem : z ∈ aleph_one) : injects_into z omega :=
begin
  rcases equiv_mk_of_mem_mk z H_mem with ⟨w, Hw_lt, Hz_eq⟩,
  suffices : injects_into (ordinal.mk w) omega,
    by { apply P_ext_injects_into_left, from equiv.symm ‹_›, from ‹_› },
  refine mk_injects_into_of_mk_le_omega _,
  rw [ordinal.mk_card, mk_omega_eq_mk_omega, ←cardinal.lt_succ],
  rwa [lt_ord, aleph_one_eq_succ_aleph_zero] at Hw_lt
end

lemma aleph_one_satisfies_spec : aleph_one_weak_Ord_spec aleph_one :=
begin
  refine ⟨aleph_one_Ord,_⟩,
  rintros z ⟨Hz₁, Hz₂⟩,
  rw Ord.le_iff_lt_or_eq (aleph_one_Ord) ‹_›,
  have := Ord.trichotomy aleph_one_Ord ‹_›,
  cases this with this₁ this,
    { from or.inr ‹_› },
    { cases this with this₂ this₃,
      { from or.inl ‹_› },
      { exfalso, from absurd (injects_into_omega_of_mem_aleph_one ‹_›) ‹_› }}
end

end

end pSet
open lattice bSet cardinal
namespace bSet

local notation `ℵ₁` := pSet.aleph_one

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

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

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

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

section well_ordering

variables {𝔹 : Type u} [nontrivial_complete_boolean_algebra 𝔹]

@[reducible]def is_rel (r x : bSet 𝔹) : 𝔹 := r ⊆ᴮ prod x x

def is_wo (r x : bSet 𝔹) : 𝔹 :=
is_rel r x ⊓ ((⨅y, pair y x ∈ᴮ r ⟹ (⨅z, pair z x ∈ᴮ r ⟹ (y =ᴮ z ⊔ pair y z ∈ᴮ r ⊔ pair z y ∈ᴮ r))) ⊓
  (⨅u, u ⊆ᴮ x ⟹ (- (u =ᴮ ∅) ⟹ ⨆y, pair y u ∈ᴮ r ⊓ (⨅z', pair z' u ∈ᴮ r ⟹ (- (pair z' y ∈ᴮ r))))))

def mem_rel (x : bSet 𝔹) : bSet 𝔹 := subset.mk (λ pr : (prod x x).type, x.func pr.1 ∈ᴮ x.func pr.2)

lemma mem_mem_rel_iff {x y z: bSet 𝔹} {Γ} : Γ ≤ pair y z ∈ᴮ mem_rel x ↔ (Γ ≤ y ∈ᴮ x ∧ Γ ≤ z ∈ᴮ x ∧ Γ ≤ y ∈ᴮ z) :=
begin
  erw mem_subset.mk_iff, refine ⟨_,_⟩; intro H,
    { simp at H, simp only [le_inf_iff.symm], bv_cases_at H pr Hpr,
      bv_split_at Hpr, rw pair_eq_pair_iff at Hpr_left, cases Hpr_left with H₁ H₂,
      simp only [le_inf_iff] at ⊢ Hpr_right, rcases Hpr_right with ⟨H'₁,H'₂,H'₃⟩,
      refine ⟨_,_,_⟩,
        { apply bv_rw' H₁, simp, simp* },
        { apply bv_rw' H₂, simp, simp* },
        { apply bv_rw' H₁, simp, apply bv_rw' H₂, simpa }},
    { rcases H with ⟨H₁, H₂, H₃⟩,
      have H₄ := H₁, have H₅ := H₂, rw mem_unfold at H₄ H₅,
      bv_cases_at H₄ i Hi, bv_cases_at H₅ j Hj, bv_split_at Hi, bv_split_at Hj,
      apply bv_use (i,j), refine le_inf _ _,
        { dsimp, rw pair_eq_pair_iff, from ⟨‹_›, ‹_›⟩ },
        { tidy, bv_cc } }
end

@[simp]lemma B_congr_mem_rel : B_congr (mem_rel : bSet 𝔹 → bSet 𝔹) :=
begin
  intros x y Γ H_eq, apply prod_ext, apply subset.mk_subset,
  { suffices : Γ ≤ prod x x =ᴮ prod y y, by {apply bv_rw' this, simp, apply subset.mk_subset },
    exact prod_congr H_eq H_eq },
  { bv_intro v, bv_imp_intro Hv_mem, bv_intro w, bv_imp_intro Hw_mem,
    refine le_inf _ _,
      { bv_imp_intro Hpr_mem, erw mem_mem_rel_iff at Hpr_mem ⊢, tidy; bv_cc },
      { bv_imp_intro Hpr_mem, erw mem_mem_rel_iff at Hpr_mem ⊢, tidy; bv_cc },}
end

def prod.map (x y v w : bSet 𝔹) (f g : bSet 𝔹) : bSet 𝔹 := subset.mk (λ (pr : (prod (prod x v) (prod y w)).type), pair (x.func pr.1.1) (y.func pr.2.1) ∈ᴮ f ⊓ pair (v.func pr.1.2) (w.func pr.2.2) ∈ᴮ g)

def prod.map_self (x y f : bSet 𝔹) : bSet 𝔹 :=
prod.map x y x y f f

lemma B_congr_prod.map_self_left_aux {y f x x' : bSet 𝔹} {Γ : 𝔹} {H_eq : Γ ≤ x =ᴮ x'}
: Γ ≤
    ⨅ (z : bSet 𝔹),
      z ∈ᴮ (λ (x : bSet 𝔹), prod.map_self x y f) x ⟹ z ∈ᴮ (λ (x : bSet 𝔹), prod.map_self x y f) x' :=
begin
   bv_intro z, bv_imp_intro H_mem, erw mem_subset.mk_iff₂ at H_mem ⊢,
      bv_cases_at H_mem pr Hpr,
      cases pr with pr₁ pr₂, cases pr₁ with a₁ a₂, cases pr₂ with b₁ b₂,
      dsimp only at Hpr,
      bv_split_at Hpr, bv_split_at Hpr_right, bv_split_at Hpr_right_right,
      simp at Hpr_left, rcases Hpr_left with ⟨⟨Ha₁, Ha₂⟩, Hb₁, Hb₂⟩,
      have Ha₁_mem : Γ_2 ≤ (x.func a₁) ∈ᴮ x' := bv_rw'' H_eq (mem.mk'' ‹_›),
      have Ha₂_mem : Γ_2 ≤ (x.func a₂) ∈ᴮ x' := bv_rw'' H_eq (mem.mk'' ‹_›),
      rw mem_unfold at Ha₁_mem Ha₂_mem, bv_cases_at Ha₁_mem a₁' Ha₁',

      bv_cases_at Ha₂_mem a₂' Ha₂', apply bv_use ((a₁', a₂'), (b₁, b₂)),
      bv_split_at Ha₁', bv_split_at Ha₂',
      refine le_inf (le_inf (le_inf ‹_› ‹_›) (le_inf ‹_› ‹_›) ) (le_inf _ (le_inf _ _)),
        { apply bv_rw' Hpr_right_left, simp, erw pair_eq_pair_iff, refine ⟨_,_⟩,
          { erw pair_eq_pair_iff, from ⟨‹_›,‹_›⟩ },
          { erw pair_eq_pair_iff, from ⟨bv_refl, bv_refl⟩ } },
        { dsimp, change _ ≤ (λ w, pair w (func y b₁) ∈ᴮ f) _, apply bv_rw' (bv_symm Ha₁'_right),
          from B_ext_pair_mem_left, from ‹_› },
        { dsimp, change _ ≤ (λ w, pair w (func y b₂) ∈ᴮ f) _, apply bv_rw' (bv_symm Ha₂'_right),
          from B_ext_pair_mem_left, from ‹_› }
end

@[simp]lemma B_congr_prod.map_self_left { y f : bSet 𝔹 } : B_congr (λ x : bSet 𝔹, prod.map_self x y f ) :=
begin
  intros x x' Γ H_eq, refine mem_ext _ _,
    { apply B_congr_prod.map_self_left_aux, from ‹_› },
    { apply B_congr_prod.map_self_left_aux, from bv_symm ‹_› }
end

lemma mem_prod.map_self_iff { x y f a₁ a₂ b₁ b₂ : bSet 𝔹 } { Γ : 𝔹 } (H_func : Γ ≤ is_function x y f) :
  Γ ≤ pair (pair a₁ a₂) (pair b₁ b₂) ∈ᴮ prod.map_self x y f ↔ Γ ≤ a₁ ∈ᴮ x ∧ Γ ≤ a₂ ∈ᴮ x ∧ Γ ≤ b₁ ∈ᴮ y ∧ Γ ≤ b₂ ∈ᴮ y ∧ Γ ≤ pair a₁ b₁ ∈ᴮ f ∧ Γ ≤ pair a₂ b₂ ∈ᴮ f :=
begin
  refine ⟨_,_⟩; intro H,
    { erw mem_subset.mk_iff₂ at H, simp only [le_inf_iff.symm],
      bv_cases_at H pr Hpr, rcases pr with ⟨⟨i₁,i₂⟩, ⟨j₁,j₂⟩⟩,
      simp only [le_inf_iff] at Hpr, rcases Hpr with ⟨Hpr, Hpr', Hpr'', Hpr'''⟩,
      simp only [le_inf_iff], simp at Hpr, rcases Hpr with ⟨⟨Hi₁, Hi₂⟩, Hj₁, Hj₂⟩,
      have Ha₁_mem : Γ_1 ≤ (x.func i₁) ∈ᴮ x := (mem.mk'' ‹_›),
      have Ha₂_mem : Γ_1 ≤ (x.func i₂) ∈ᴮ x := (mem.mk'' ‹_›),
      have Hb₁_mem : Γ_1 ≤ (y.func j₁) ∈ᴮ y := (mem.mk'' ‹_›),
      have Hb₂_mem : Γ_1 ≤ (y.func j₂) ∈ᴮ y := (mem.mk'' ‹_›),
      repeat {erw pair_eq_pair_iff at Hpr'},
      dsimp at Hpr', rcases Hpr' with ⟨⟨Heq₁, Heq₂⟩, Heq₃, Heq₄⟩,
      refine ⟨_,_,_,_,_,_⟩,
        { bv_cc },
        { bv_cc },
        { bv_cc },
        { bv_cc },
        { suffices : Γ_1 ≤ pair a₁ b₁ =ᴮ pair (func x i₁) (func y j₁),
            by { change _ ≤ (λ w, w ∈ᴮ f) _, apply bv_rw' (this), simp, from ‹_› },
          rw pair_eq_pair_iff, exact ⟨‹_›,‹_›⟩ },
        { suffices : Γ_1 ≤ pair a₂ b₂ =ᴮ pair (func x i₂) (func y j₂),
            by { change _ ≤ (λ w, w ∈ᴮ f) _, apply bv_rw' (this), simp, from ‹_› },
          rw pair_eq_pair_iff, exact ⟨‹_›,‹_›⟩ }},
    { rcases H with ⟨Ha₁_mem, Ha₂_mem, Hb₁_mem, Hb₂_mem, Hpr₁_mem, Hpr₂_mem⟩,
      erw mem_subset.mk_iff₂,
      rw mem_unfold at Ha₁_mem Ha₂_mem Hb₁_mem Hb₂_mem,
      bv_cases_at Ha₁_mem i₁ Hi₁, bv_split_at Hi₁,
      bv_cases_at Ha₂_mem i₂ Hi₂, bv_split_at Hi₂,
      bv_cases_at Hb₁_mem j₁ Hj₁, bv_split_at Hj₁,
      bv_cases_at Hb₂_mem j₂ Hj₂, bv_split_at Hj₂,
      apply bv_use ((i₁,i₂), (j₁,j₂)),
      refine le_inf (le_inf (le_inf ‹_› ‹_›) (le_inf ‹_› ‹_›)) (le_inf _ (le_inf _ _)),
        { repeat {erw pair_eq_pair_iff}, simp* },
        { dsimp, suffices : Γ_4 ≤ pair (func x i₁) (func y j₁) =ᴮ pair a₁ b₁,
            by { change _ ≤ (λ w, w ∈ᴮ f) _, apply bv_rw' this, simp, from ‹_› },
          rw pair_eq_pair_iff, refine ⟨bv_symm _, bv_symm _⟩; assumption },
        { dsimp, suffices : Γ_4 ≤ pair (func x i₂) (func y j₂) =ᴮ pair a₂ b₂,
            by { change _ ≤ (λ w, w ∈ᴮ f) _, apply bv_rw' this, simp, from ‹_› },
          rw pair_eq_pair_iff, refine ⟨bv_symm _, bv_symm _⟩; assumption } }
end

def induced_epsilon_rel (η : bSet 𝔹) (x : bSet 𝔹) (f : bSet 𝔹) : bSet 𝔹 :=
image (mem_rel η) (prod x x) (prod.map_self η x f)

lemma eq_pair_of_mem_induced_epsilon_rel {η x f pr : bSet 𝔹} {Γ} (H_mem : Γ ≤ pr ∈ᴮ induced_epsilon_rel η x f) : ∃ a b : bSet 𝔹, Γ ≤ a ∈ᴮ x ∧ Γ ≤ b ∈ᴮ x ∧ Γ ≤ pr =ᴮ pair a b ∧ Γ ≤ pair a b ∈ᴮ induced_epsilon_rel η x f :=
begin
  have : Γ ≤ pr ∈ᴮ prod x x,
    by {refine mem_of_mem_subset _ H_mem, apply subset.mk_subset},
  rw mem_prod_iff₂ at this, rcases this with ⟨v,Hv,w,Hw,H_eq⟩,
  use v, use w, refine ⟨‹_›,‹_›,‹_›, _⟩,
  change _ ≤ (λ z, z ∈ᴮ induced_epsilon_rel η x f) _, apply bv_rw' (bv_symm H_eq), simpa
end

lemma mem_induced_epsilon_rel_iff { η x f a b : bSet 𝔹 } { Γ } (H_func : Γ ≤ is_function η x f) : Γ ≤ pair a b ∈ᴮ (induced_epsilon_rel η x f) ↔ (Γ ≤ a ∈ᴮ x) ∧ (Γ ≤ b ∈ᴮ x) ∧ (Γ ≤ ⨆ a', a' ∈ᴮ η ⊓ ⨆ b', b' ∈ᴮ η ⊓ (pair a' a ∈ᴮ f ⊓ pair b' b ∈ᴮ f ⊓ a' ∈ᴮ b')) :=
begin
  refine ⟨_,_⟩; intro H,
  { erw mem_image_iff at H, cases H with H₁ H₂,
     simp at H₁, cases H₁ with H₁ H₁',
      refine ⟨‹_›,‹_›,_⟩,
      bv_cases_at H₂ z Hz, bv_split_at Hz,
      have : Γ_1 ≤ z ∈ᴮ prod η η,
        by {refine mem_of_mem_subset _ Hz_left, apply subset.mk_subset },
      rw mem_prod_iff₂ at this, rcases this with ⟨v,Hv,w,Hw,H_eq⟩,
     apply bv_use v, refine le_inf ‹_› (bv_use w), refine le_inf ‹_› _,
     have : Γ_1 ≤ pair (pair v w) (pair a b) ∈ᴮ prod.map_self η x f,
       by { change _ ≤ (λ k, pair k (pair a b) ∈ᴮ prod.map_self η x f) _, apply bv_rw' (bv_symm H_eq),
            simp, from ‹_› },
     rw mem_prod.map_self_iff at this, rcases this with ⟨_,_,_,_,_,_⟩,
     refine le_inf (le_inf ‹_› ‹_›) _,
     suffices : Γ_1 ≤ (pair v w ∈ᴮ mem_rel η),
       by { rw mem_mem_rel_iff at this, simp* },
     change _ ≤ (λ s, s ∈ᴮ mem_rel η) _, apply bv_rw' (bv_symm H_eq), simp, from ‹_›, from ‹_› },
    { rcases H with ⟨H₁,H₂,H₃⟩, bv_cases_at H₃ a' Ha',
      bv_split_at Ha', bv_cases_at Ha'_right b' Hb',
      bv_split_at Hb',
      erw mem_image_iff,
      refine ⟨_,_⟩,
        { rw mem_prod_iff, bv_split_at Hb'_right, bv_split_at Hb'_right_left,
          refine ⟨_,_⟩,
            { apply mem_codomain_of_is_function ‹_› ‹_› },
            { apply mem_codomain_of_is_function ‹Γ_2 ≤ pair b' b ∈ᴮ f› ‹_› }},
        { apply bv_use (pair a' b'), refine le_inf _ _,
          { rw mem_mem_rel_iff, exact ⟨‹_›,‹_›,bv_and.right ‹_›⟩ },
          { rw mem_prod.map_self_iff, refine ⟨‹_›,‹_›, ‹_›, ‹_›, _⟩, bv_split_at Hb'_right,
            bv_split_at Hb'_right_left, from ⟨‹_›,‹_›⟩, from ‹_› }}}
end

lemma mem_induced_epsilon_rel_of_mem {η x f a b : bSet 𝔹} {Γ} (H_mem₁ : Γ ≤ a ∈ᴮ η) (H_mem₂ : Γ ≤ b ∈ᴮ η) (H_mem : Γ ≤ a ∈ᴮ b) (H_func : Γ ≤ is_function η x f) : Γ ≤ pair (function_eval H_func a H_mem₁) (function_eval H_func b H_mem₂) ∈ᴮ induced_epsilon_rel η x f :=
begin
  rw mem_induced_epsilon_rel_iff ‹_›,
  refine ⟨_,_,_⟩,
    { apply function_eval_mem_codomain },
    { apply function_eval_mem_codomain },
    { apply bv_use a, refine le_inf ‹_› (bv_use b),
      refine le_inf ‹_› (le_inf (le_inf _ _) ‹_›),
        { apply function_eval_pair_mem },
        { apply function_eval_pair_mem }}
end

lemma mem_of_mem_induced_epsilon_rel {η x f a' b' a b : bSet 𝔹} {Γ} (H_inj : Γ ≤ is_injective_function η x f) (H_mem₁ : Γ ≤ pair a' a ∈ᴮ f) (H_mem₂ : Γ ≤ pair b' b ∈ᴮ f) (H_mem : Γ ≤ pair a b ∈ᴮ induced_epsilon_rel η x f) : Γ ≤ a' ∈ᴮ b' :=
begin
  rw (mem_induced_epsilon_rel_iff $ bv_and.left ‹_›) at H_mem,
  rcases H_mem with ⟨Ha_mem, Hb_mem, H⟩,
  bv_cases_at H a'' Ha'', bv_split_at Ha'', bv_cases_at Ha''_right b'' Hb'', simp only [le_inf_iff] at Hb'',
  rcases Hb'' with ⟨Hb''₁, ⟨Hb''₂, Hb''₃⟩, Hb''₄⟩,
  suffices : Γ_2 ≤ a' =ᴮ a'' ∧ Γ_2 ≤ b' =ᴮ b'',
    by {cases this, bv_cc},
  have H_inj' := is_inj_of_is_injective_function H_inj,
  refine ⟨_,_⟩,
    { refine H_inj' a' a'' a a _, exact le_inf (le_inf ‹_› ‹_›) bv_refl },
    { refine H_inj' b' b'' b b _, exact le_inf (le_inf ‹_› ‹_›) bv_refl }
end

lemma induced_epsilon_rel_sub_image_left { η x f a b : bSet 𝔹 } { Γ } (H_func : Γ ≤ is_function η x f) (H : Γ ≤ pair a b ∈ᴮ induced_epsilon_rel η x f ) : Γ ≤ a ∈ᴮ image η x f :=
begin
  rw mem_image_iff, rw mem_induced_epsilon_rel_iff at H,
  rcases H with ⟨H₁,H₂,H₃⟩, refine ⟨‹_›, _⟩,
  bv_cases_at H₃ a' Ha', bv_split_at Ha', bv_cases_at Ha'_right b' Hb',
  bv_split_at Hb', bv_split_at Hb'_right, bv_split_at Hb'_right_left,
  apply bv_use a', from le_inf ‹_› ‹_›,
  from ‹_›
end

lemma induced_epsilon_rel_sub_image_right { η x f a b : bSet 𝔹 } { Γ } (H_func : Γ ≤ is_function η x f) (H : Γ ≤ pair a b ∈ᴮ induced_epsilon_rel η x f ) : Γ ≤ b ∈ᴮ image η x f :=
begin
  rw mem_image_iff, rw mem_induced_epsilon_rel_iff at H,
  rcases H with ⟨H₁,H₂,H₃⟩, refine ⟨‹_›, _⟩,
  bv_cases_at H₃ a' Ha', bv_split_at Ha', bv_cases_at Ha'_right b' Hb',
  bv_split_at Hb', bv_split_at Hb'_right, bv_split_at Hb'_right_left,
  apply bv_use b', from le_inf ‹_› ‹_›,
  from ‹_›
end

lemma image_eq_of_eq_induced_epsilon_rel_aux
  { η ρ f g : bSet 𝔹 }
  { Γ }
  (Hη_inj : Γ ≤ is_injective_function η omega f)
  (Hρ_inj : Γ ≤ is_injective_function ρ omega g)
  (H_eq : Γ ≤ induced_epsilon_rel η omega f =ᴮ induced_epsilon_rel ρ omega g)
  (H_exists_two : Γ ≤ exists_two η) :
  Γ ≤ ⨅ (z : bSet 𝔹), z ∈ᴮ image η omega f ⟹ z ∈ᴮ image ρ omega g :=
begin
bv_intro z, bv_imp_intro Hz_mem, rw mem_image_iff at Hz_mem,
     cases Hz_mem with Hz_mem₁ Hz_mem₂,
     bv_cases_at Hz_mem₂ z' Hz', bv_split_at Hz',
     unfold exists_two at H_exists_two,
     replace H_exists_two := H_exists_two z' ‹_›,
     bv_cases_at H_exists_two w' Hw', bv_split_at Hw',
     bv_or_elim_at' Hw'_right,
       { let w := function_eval (bv_and.left Hη_inj) w' ‹_›,
         apply induced_epsilon_rel_sub_image_left, show bSet 𝔹, from w, from bv_and.left ‹_›,
         apply bv_rw' (bv_symm H_eq), { simp },
         rw mem_induced_epsilon_rel_iff,
         refine ⟨‹_›, by { apply function_eval_mem_codomain }, _⟩, apply bv_use z',
         refine le_inf ‹_› _, apply bv_use w', refine le_inf ‹_› _,
         refine le_inf (le_inf ‹_› (by apply function_eval_pair_mem)) ‹_›, from bv_and.left ‹_› },
       { let w := function_eval (bv_and.left Hη_inj) w' ‹_›,
         apply induced_epsilon_rel_sub_image_right, show bSet 𝔹, from w, from bv_and.left ‹_›,
         apply bv_rw' (bv_symm H_eq), { simp },
         rw mem_induced_epsilon_rel_iff,
         refine ⟨ by { apply function_eval_mem_codomain }, ‹_›, _⟩, apply bv_use w',
         refine le_inf ‹_› _, apply bv_use z', refine le_inf ‹_› _,
         refine le_inf (le_inf (by apply function_eval_pair_mem) ‹_›) ‹_›, from bv_and.left ‹_› }
end

lemma image_eq_of_eq_induced_epsilon_rel
  { η ρ f g : bSet 𝔹 }
  { Γ }
  (Hη_inj : Γ ≤ is_injective_function η omega f)
  (Hρ_inj : Γ ≤ is_injective_function ρ omega g)
  (H_eq : Γ ≤ induced_epsilon_rel η omega f =ᴮ induced_epsilon_rel ρ omega g)
  (H_exists_two : Γ ≤ exists_two η)
  (H_exists_two' : Γ ≤ exists_two ρ) :
  Γ ≤ image η omega f =ᴮ image ρ omega g :=
by { refine mem_ext _ _;
     apply image_eq_of_eq_induced_epsilon_rel_aux; repeat { assumption }, from bv_symm ‹_› }

lemma eq_of_eq_induced_epsilon_rel
  {η ρ f g : bSet 𝔹}
  {Γ}
  (Hη_ord : Γ ≤ Ord η)
  (Hρ_ord : Γ ≤ Ord ρ)
  (Hη_inj : Γ ≤ is_injective_function η omega f)
  (Hρ_inj : Γ ≤ is_injective_function ρ omega g)
  (H_eq : Γ ≤ induced_epsilon_rel η omega f =ᴮ induced_epsilon_rel ρ omega g)
  (H_exists_two : Γ ≤ exists_two η)
  (H_exists_two' : Γ ≤ exists_two ρ)
  : Γ ≤ η =ᴮ ρ :=
begin
  suffices : Γ ≤ ⨆ h, eps_iso η ρ h,
    by { exact eq_of_Ord_eps_iso Hη_ord Hρ_ord ‹_› },
  refine bv_use (injective_function_comp (factor_image_is_injective_function Hη_inj) _),
  from ρ, from injective_function_inverse Hρ_inj,
  { apply @bv_rw' _ _ _ _ _ (image_eq_of_eq_induced_epsilon_rel Hη_inj Hρ_inj ‹_› ‹_› ‹_›) (λ z, is_injective_function z ρ (injective_function_inverse Hρ_inj)), simp, from injective_function_inverse_is_injective_function },
  refine le_inf (le_inf _ _) _,
    { apply injective_function_comp_is_function },
    { rw strong_eps_hom_iff, intros,
      apply_all le_trans H_le, refine ⟨_,_⟩; intro H_mem,
        { erw mem_is_func'_comp_iff at Hpr₁_mem, rcases Hpr₁_mem with ⟨_,_,Hv₁_ex⟩,
          erw mem_is_func'_comp_iff at Hpr₂_mem, rcases Hpr₂_mem with ⟨_,_,Hv₂_ex⟩,
          bv_cases_at Hv₁_ex v₁ Hv₁, bv_cases_at Hv₂_ex v₂ Hv₂,
          have v₁_mem_v₂ : Γ_2 ≤ pair v₁ v₂ ∈ᴮ induced_epsilon_rel η omega f,
            by { rw mem_induced_epsilon_rel_iff, refine ⟨_,_,_⟩,
                 { refine mem_of_mem_subset _ (bv_and.left Hv₁), apply image_subset },
                 { refine mem_of_mem_subset _ (bv_and.left Hv₂), apply image_subset },
                 { apply bv_use z₁, refine le_inf ‹_› (bv_use z₂),
                   refine le_inf ‹_› (le_inf (le_inf _ _) _),
                     { bv_split, bv_split, from ‹_› },
                     { bv_split, bv_split, from ‹_› },
                     { from ‹_› } }, from bv_and.left ‹_› },
          have Hpr₁_mem : Γ_2 ≤ pair w₁ v₁ ∈ᴮ g,
            by { bv_split_at Hv₁, bv_split_at Hv₁_right, erw mem_inj_inverse_iff at Hv₁_right_right, simp* },
          have Hpr₂_mem : Γ_2 ≤ pair w₂ v₂ ∈ᴮ g,
            by { bv_split_at Hv₂, bv_split_at Hv₂_right, erw mem_inj_inverse_iff at Hv₂_right_right, simp* },
          refine mem_of_mem_induced_epsilon_rel Hρ_inj_1 Hpr₁_mem Hpr₂_mem _,
          apply bv_rw' (bv_symm H_eq_1), simp, from ‹_› },
        { erw mem_is_func'_comp_iff at Hpr₁_mem, rcases Hpr₁_mem with ⟨_,_,Hv₁_ex⟩,
          erw mem_is_func'_comp_iff at Hpr₂_mem, rcases Hpr₂_mem with ⟨_,_,Hv₂_ex⟩,
          bv_cases_at Hv₁_ex v₁ Hv₁, bv_cases_at Hv₂_ex v₂ Hv₂,
          have v₁_mem_v₂ : Γ_2 ≤ pair v₁ v₂ ∈ᴮ induced_epsilon_rel ρ omega g,
            by { rw mem_induced_epsilon_rel_iff, refine ⟨_,_,_⟩,
                 { refine mem_of_mem_subset _ (bv_and.left Hv₁), apply image_subset },
                 { refine mem_of_mem_subset _ (bv_and.left Hv₂), apply image_subset },
                 { apply bv_use w₁, refine le_inf ‹_› (bv_use w₂),
                   refine le_inf ‹_› (le_inf (le_inf _ _) _),
                     { bv_split_at Hv₁, bv_split_at Hv₁_right, erw mem_inj_inverse_iff at Hv₁_right_right, simp* },
                     { bv_split_at Hv₂, bv_split_at Hv₂_right, erw mem_inj_inverse_iff at Hv₂_right_right, simp* },
                     { from ‹_› } }, from bv_and.left ‹_› },
          have Hpr₁_mem : Γ_2 ≤ pair z₁ v₁ ∈ᴮ f,
            by bv_split; bv_split; from ‹_›,
          have Hpr₂_mem : Γ_2 ≤ pair z₂ v₂ ∈ᴮ f,
            by bv_split; bv_split; from ‹_›,
          refine mem_of_mem_induced_epsilon_rel Hη_inj_1 Hpr₁_mem Hpr₂_mem _,
          apply bv_rw' H_eq_1, simp, from ‹_› },
         },
    {apply is_func'_comp_surj,
       { from bv_and.right ‹_› },
       { apply injective_function_inverse_is_inj },
       { exact surj_image (is_func'_of_is_injective_function Hη_inj) },
       { change _ ≤ (λ z, is_surj z ρ (injective_function_inverse Hρ_inj)) _,
         apply bv_rw' (image_eq_of_eq_induced_epsilon_rel Hη_inj Hρ_inj ‹_› ‹_› ‹_›), simp, apply inj_inverse.is_surj }}
end

end well_ordering

section a1
parameters {𝔹 : Type u} [nontrivial_complete_boolean_algebra 𝔹]

def a1.ϕ : bSet 𝔹 → 𝔹 := λ x, (⨆η, Ord η ⊓ ⨆ f, is_injective_function η omega f ⊓ (image (mem_rel η) (prod omega omega) (prod.map_self η omega f) =ᴮ x) ⊓ (- (x =ᴮ ∅)) )

@[simp]lemma B_ext_a1.ϕ : B_ext a1.ϕ :=
by simp [a1.ϕ]

def a1' : bSet 𝔹 := comprehend a1.ϕ (bv_powerset $ prod omega omega)

def a1.type := a1'.type

def a1.bval := a1'.bval

def a1.ψ (v : bSet 𝔹) : bSet 𝔹 → 𝔹 := λ x, (Ord x ⊓ ⨆ f, is_injective_function x omega f ⊓ image (mem_rel x) (prod omega omega) (prod.map_self x omega f) =ᴮ v ⊓ (- (v =ᴮ ∅)))

@[simp]lemma B_ext_a1.ψ {v : bSet 𝔹} : B_ext (a1.ψ v) :=
by { unfold a1.ψ, apply B_ext_inf, simp, apply B_ext_supr, intro i,
     apply B_ext_inf, swap, simp, apply B_ext_inf, simp, intros x y, tidy_context,
     refine bv_symm _, refine bv_trans (bv_symm a_right) _,
     have : Γ ≤ mem_rel x =ᴮ mem_rel y,
       by { exact B_congr_mem_rel ‹_› },
     have := B_congr_image_left this, show bSet 𝔹, from prod omega omega, show bSet 𝔹, from (prod.map_self x omega i),
     dsimp at this,
     have : Γ ≤ (prod.map_self x omega i) =ᴮ (prod.map_self y omega i),
       by { exact B_congr_prod.map_self_left ‹_› },
     have := B_congr_image_right this, show bSet 𝔹, from (mem_rel y), show bSet 𝔹, from (prod omega omega),
     dsimp at this, bv_cc }

lemma a1'.AE {Γ : 𝔹} : Γ ≤ ⨅ z, z ∈ᴮ a1' ⟹ ⨆ η, Ord η ⊓ ⨆ f, is_injective_function η omega f ⊓ image (mem_rel η) (prod omega omega) (prod.map_self η omega f) =ᴮ z ⊓ (- (z =ᴮ ∅)) :=
begin
  bv_intro z, bv_imp_intro Hz_mem, erw mem_comprehend_iff at Hz_mem,
  bv_cases_at Hz_mem χ Hχ,
  bv_split_at Hχ, bv_split_at Hχ_right, apply bv_rw' Hχ_right_left, simp,
  convert Hχ_right_right, from (bv_powerset $ prod omega omega), simp
end

noncomputable def a1.func : a1.type → bSet 𝔹 := λ χ, classical.some (AE_convert' (a1.ψ) (λ z, B_ext_a1.ψ) a1' (a1'.func χ))

lemma a1.func_spec_aux {χ : a1.type} : ∀ {Γ : 𝔹}, (Γ ≤ ⨅ z, z ∈ᴮ a1' ⟹ ⨆ w, a1.ψ z w) → Γ ≤ (a1'.func χ) ∈ᴮ a1' → Γ ≤ a1.ψ (a1'.func χ) (a1.func χ) :=
by {intro Γ, exact classical.some_spec (a1.func._proof_1 χ)}

lemma a1.func_spec {χ : a1.type} : ∀ {Γ : 𝔹}, Γ ≤ (a1'.func χ) ∈ᴮ a1' → Γ ≤ a1.ψ (a1'.func χ) (a1.func χ) :=
by { intros Γ H_mem, apply a1.func_spec_aux, exact a1'.AE, from ‹_› }

-- equality of pushforward epsilon relation is not enough to guarantee 0 or 1 are in a1,
-- since injectivity fails at 0 and 1 (both epsilon relations are empty)
noncomputable def a1_aux : bSet 𝔹 := ⟨a1.type, a1.func, a1.bval⟩

lemma Ord_of_mem_a1_aux {Γ : 𝔹} {η : bSet 𝔹} (H_mem : Γ ≤ η ∈ᴮ a1_aux) : Γ ≤ Ord η :=
begin
  rw mem_unfold at H_mem, bv_cases_at H_mem χ Hχ, bv_split_at Hχ,
  have : Γ_1 ≤ a1'.func χ ∈ᴮ a1',
    by { convert mem.mk'' _, from ‹_› },
  have := a1.func_spec this, bv_split_at this,
  apply bv_rw' Hχ_right, simp, from ‹_›
end

noncomputable def a1 : bSet 𝔹 := insert 0 (insert 1 a1_aux)

lemma mem_a1_iff₀ { z : bSet 𝔹 } { Γ } : Γ ≤ z ∈ᴮ a1 ↔ Γ ≤ z =ᴮ 0 ⊔ z =ᴮ 1 ⊔ z ∈ᴮ a1_aux :=
by { simp [a1, sup_assoc] }

lemma Ord_of_mem_a1 { Γ : 𝔹 } { η : bSet 𝔹 } (H_mem : Γ ≤ η ∈ᴮ a1) : Γ ≤ Ord η :=
begin
  rw mem_a1_iff₀ at H_mem, bv_or_elim_at H_mem,
    { bv_or_elim_at H_mem.left,
      { apply bv_rw' H_mem.left.left, simp, from Ord_zero },
      { apply bv_rw' H_mem.left.right, simp, from Ord_one }},
    { from Ord_of_mem_a1_aux ‹_› }
end

lemma eq_zero_iff_eq_empty {Γ : 𝔹} { u : bSet 𝔹 } : Γ ≤ u =ᴮ 0 ↔ Γ ≤ u =ᴮ ∅ :=
begin
  refine ⟨_,_⟩; intro H,
    { apply bv_rw' (bv_symm zero_eq_empty), simp, from ‹_› },
    { apply bv_rw' zero_eq_empty, simp, from ‹_› }
end

lemma induced_rel_empty_of_eq_zero
  {η f : bSet 𝔹}
  {Γ : 𝔹}
  (H_func : Γ ≤ is_function η omega f)
  : Γ ≤ η =ᴮ 0 → Γ ≤ induced_epsilon_rel η omega f =ᴮ ∅ :=
begin
  intro H_eq_zero, apply bv_by_contra, bv_imp_intro H_contra,
  rw nonempty_iff_exists_mem at H_contra,
  bv_cases_at H_contra pr Hpr,
  rcases (eq_pair_of_mem_induced_epsilon_rel ‹_›) with ⟨a,b,Ha_mem,Hb_mem,H_eq,Hab⟩,
  replace Hab := induced_epsilon_rel_sub_image_left ‹_› Hab,
  rw mem_image_iff at Hab, cases Hab with _ H_im,
  bv_cases_at H_im z Hz, bv_split_at Hz,
  rw eq_zero_iff_eq_empty at H_eq_zero, rw empty_iff_forall_not_mem at H_eq_zero,
  replace H_eq_zero := H_eq_zero z, exact bv_absurd _ Hz_left ‹_›
end

lemma nonempty_of_induced_rel_nonempty
  {η f : bSet 𝔹}
  {Γ : 𝔹}
  (H_func : Γ ≤ is_function η omega f)
  : Γ ≤ -(induced_epsilon_rel η omega f =ᴮ ∅) → Γ ≤ -(η =ᴮ ∅) :=
begin
  intro H, rw ←imp_bot, bv_imp_intro H',
  rw ← eq_zero_iff_eq_empty at H',
  have := induced_rel_empty_of_eq_zero ‹_› ‹_›, bv_contradiction
end

lemma not_zero_of_induced_rel_nonempty
  {η f : bSet 𝔹}
  {Γ : 𝔹}
  (H_func : Γ ≤ is_function η omega f)
  : Γ ≤ -(induced_epsilon_rel η omega f =ᴮ ∅) → Γ ≤ -(η =ᴮ 0) :=
begin
  intro H', apply @bv_rw' _ _ _ _ _ (zero_eq_empty) (λ w, - (η =ᴮ w)), {simp},
  exact nonempty_of_induced_rel_nonempty ‹_› ‹_›
end

lemma not_one_of_induced_rel_nonempty
  {η f : bSet 𝔹}
  {Γ : 𝔹}
  (H_func : Γ ≤ is_function η omega f)
  : Γ ≤ -(induced_epsilon_rel η omega f =ᴮ ∅) → Γ ≤ -(η =ᴮ 1) :=
begin
  intro H, rw nonempty_iff_exists_mem at H, bv_cases_at H pr Hpr,
  rcases eq_pair_of_mem_induced_epsilon_rel Hpr with ⟨a,b,Ha,Hb,H_eq,Hab⟩,
  rw mem_induced_epsilon_rel_iff at Hab, rcases Hab with ⟨Ha, Hb, Hab⟩,
  bv_cases_at' Hab a' Ha', bv_split_at Ha',
  bv_cases_at' Ha'_right b' Hb', bv_split_at Hb', bv_split_at Hb'_right, bv_split_at Hb'_right_left,
  rw ←imp_bot, bv_imp_intro' H_eq_one,
  suffices : Γ_4 ≤ 0 ∈ᴮ 0,
    by { exact bot_of_mem_self' ‹_› },
  suffices : Γ_4 ≤ a' =ᴮ 0 ∧ Γ_4 ≤ b' =ᴮ 0,
    by { change _ ≤ (λ (w : bSet 𝔹), w ∈ᴮ 0) 0, apply bv_rw' (bv_symm this.left), simp,
         change _ ≤ (λ w, a' ∈ᴮ w) _, apply bv_rw' (bv_symm this.right), simpa },
  refine ⟨_,_⟩,
    { apply eq_zero_of_mem_one, have := mem_domain_of_is_function ‹Γ_4 ≤ pair a' a ∈ᴮ f› ‹_›, bv_cc },
    { apply eq_zero_of_mem_one, have := mem_domain_of_is_function ‹Γ_4 ≤ pair b' b ∈ᴮ f› ‹_›, bv_cc },
  from ‹_›
end

lemma nonempty_induced_rel_iff_not_zero_and_not_one
  {η f : bSet 𝔹}
  {Γ : 𝔹}
  (H_ord : Γ ≤ Ord η)
  (H_inj : Γ ≤ is_function η omega f)
  : Γ ≤ -((induced_epsilon_rel η omega f) =ᴮ ∅) ↔ (Γ ≤ -(η =ᴮ 0) ∧ Γ ≤ -(η =ᴮ 1)) :=
begin
  refine ⟨_,_⟩; intro H,
    { refine ⟨_,_⟩,
    { exact not_zero_of_induced_rel_nonempty ‹_› ‹_› },
      { exact not_one_of_induced_rel_nonempty ‹_› ‹_› }},
    { cases H with H₁ H₂, rw nonempty_iff_exists_mem,
      have := one_mem_of_not_zero_and_not_one ‹_› H₁ H₂,
      have Hmem_one : Γ ≤ _ := zero_mem_one,
      have H_zero_mem : Γ ≤ 0 ∈ᴮ η,
        by { exact mem_of_mem_Ord ‹_› ‹_ ≤ 1 ∈ᴮ η› ‹_›},
      refine bv_use _,
      swap, apply mem_induced_epsilon_rel_of_mem H_zero_mem this ‹_›, from ‹_› }
end

/--
  a1 contains every ordinal η which injects into ω
-/
lemma mem_a1_of_injects_into_omega_aux {Γ : 𝔹} {η : bSet 𝔹} (H_ord : Γ ≤ Ord η) (H_inj : Γ ≤ ⨆ f, is_injective_function η omega f) (H_not_zero : Γ ≤ - (η =ᴮ 0)) (H_not_one : Γ ≤ -(η =ᴮ 1)) : Γ ≤ η ∈ᴮ a1_aux :=
begin
  bv_cases_at H_inj f Hf,
  rw mem_unfold', let R := (induced_epsilon_rel η omega f),
  have : Γ_1 ≤ R ∈ᴮ a1',
    by { erw mem_comprehend_iff₂, apply bv_use R, refine le_inf _ (le_inf bv_refl _),
         { rw mem_powerset_iff, apply subset.mk_subset },
         { apply bv_use η, refine le_inf ‹_› _, apply bv_use f,
           refine le_inf (le_inf ‹_› bv_refl) _,
           erw nonempty_induced_rel_iff_not_zero_and_not_one, simp*, from ‹_›, from bv_and.left ‹_› },
         simp },
  rw mem_unfold at this, bv_cases_at this χ Hχ,
  apply bv_use (a1.func χ), bv_split_at Hχ, refine le_inf _ _,
  convert mem.mk'' _, refl, from ‹_›,
  have H_mem : Γ_2 ≤ (a1'.func χ) ∈ᴮ a1', from mem.mk'' ‹_›,
  have := a1.func_spec H_mem,
  bv_split_at this,
  bv_cases_at this_right g Hg, bv_split_at Hg,
  bv_split_at Hg_left,
  apply eq_of_eq_induced_epsilon_rel, from ‹_›,
  {apply Ord_of_mem_a1_aux, convert mem.mk'' _, refl, from ‹_›},
  from Hf, from Hg_left_left,
  { dsimp [R] at Hχ_right,change _ ≤ induced_epsilon_rel _ _ _ =ᴮ _ at Hg_left_right, bv_cc },
  { rw exists_two_iff; from ‹_› },
  rw exists_two_iff,
  suffices : Γ_3 ≤ -(image (mem_rel (a1.func χ)) (prod omega omega) (prod.map_self (a1.func χ) omega g) =ᴮ ∅),
    by { erw nonempty_induced_rel_iff_not_zero_and_not_one at this, cases this with this₁ this₂,
         from ‹_›, from ‹_›, from bv_and.left ‹_› },
  apply @bv_rw' _ _ _ _ _ Hg_left_right (λ w, -(w =ᴮ ∅)), simp, from ‹_›, from ‹_›
end

lemma mem_a1_iff {Γ : 𝔹} {η : bSet 𝔹} (H_ord : Γ ≤ Ord η) : Γ ≤ η ∈ᴮ a1 ↔ Γ ≤ ⨆f, is_injective_function η omega f :=
begin
  refine ⟨_,_⟩,
    { intro H_mem,
      rw mem_a1_iff₀ at H_mem,
      bv_or_elim_at H_mem, bv_or_elim_at H_mem.left,
        { apply injection_into_of_injects_into, apply injects_into_of_subset,
          apply bv_rw' H_mem.left.left, simp, apply of_nat_subset_omega },
        { apply injection_into_of_injects_into, apply injects_into_of_subset,
          apply bv_rw' H_mem.left.right, simp, apply of_nat_subset_omega },
        { rw mem_unfold at H_mem.right, bv_cases_at H_mem.right χ Hχ,
      bv_split_at Hχ,
      have : Γ_2 ≤ a1'.func χ ∈ᴮ a1',
        by { from mem.mk'' ‹_› },
      have := a1.func_spec this,
      apply bv_rw' Hχ_right, simp,
      bv_split_at this, bv_cases_at this_right f Hf, apply bv_use f,
      exact bv_and.left (bv_and.left ‹_›) }},
    { intro H_ex, rw mem_a1_iff₀, bv_cases_on η =ᴮ 1,
      { exact bv_or_left (bv_or_right ‹_›) },
      { bv_cases_on η =ᴮ 0,
        { exact bv_or_left (bv_or_left ‹_›) },
        { refine bv_or_right _, apply mem_a1_of_injects_into_omega_aux, repeat { assumption }}}}
end

lemma a1_transitive {Γ} : Γ ≤ is_transitive a1 :=
begin
  bv_intro z, bv_imp_intro Hz_mem,
  rw subset_unfold', bv_intro w, bv_imp_intro Hw_mem,
  rw mem_a1_iff _, swap,
    { refine Ord_of_mem_Ord Hw_mem _, from Ord_of_mem_a1 ‹_› },
    { have Hz_ord : Γ_2 ≤ Ord z := Ord_of_mem_a1 ‹_›,
      rw (mem_a1_iff ‹_›) at Hz_mem,
      cases (exists_convert Hz_mem) with f Hf,
      have Hw_sub : Γ_2 ≤ w ⊆ᴮ z,
        by {apply subset_of_mem_transitive, from bv_and.right ‹_›, from ‹_› },
      have Hw_inj : Γ_2 ≤ injection_into w z := injection_into_of_subset Hw_sub,
      cases (exists_convert Hw_inj) with g Hg,
      apply bv_use (injective_function_comp Hg Hf), apply injective_function_comp_is_injective_function }
end

lemma a1_ewo {Γ} : Γ ≤ ewo a1 :=
begin
  refine le_inf _ _,
    { apply epsilon_trichotomy_of_sub_Ord, bv_intro x, bv_imp_intro H_mem,
      from Ord_of_mem_a1 ‹_› },
    { apply epsilon_wf_of_sub_Ord }
end

lemma a1_Ord {Γ : 𝔹} : Γ ≤ Ord a1 := le_inf a1_ewo a1_transitive

lemma a1_not_le_omega {Γ : 𝔹} : Γ ≤ -(a1 ≼ omega) :=
begin
  rw ←imp_bot, bv_imp_intro H_contra, rw injects_into_iff_injection_into at H_contra,
  erw ←mem_a1_iff (a1_Ord) at H_contra, from bot_of_mem_self' ‹_›
end

lemma a1_spec {Γ : 𝔹} : Γ ≤ aleph_one_Ord_spec a1 :=
begin
  refine le_inf (a1_not_le_omega) _,
  refine le_inf a1_Ord _,
  bv_intro η, bv_imp_intro Ord_η, bv_imp_intro H,
  classical,
  by_cases ⊥ < Γ_2,
   { rw (Ord.le_iff_lt_or_eq a1_Ord ‹_›),
     apply bv_by_contra, bv_imp_intro H_contra,
     simp only [le_inf_iff] with bv_push_neg at H_contra,
     cases H_contra with H_contra₁ H_contra₂,
     suffices : Γ_3 ≤ injects_into η omega,
       by exact bv_absurd _ this ‹_›,
     suffices : Γ_3 ≤ η ∈ᴮ a1,
       by {replace this := (mem_a1_iff ‹_›).mp this, bv_cases_at this f Hf,
           apply bv_use f,
             from le_inf (is_func'_of_is_injective_function ‹_›) (bv_and.right ‹_›) },
     have : Γ_3 ≤ _ := Ord.trichotomy a1_Ord Ord_η,
     apply bv_by_contra, bv_imp_intro H_contra₃,
     bv_or_elim_at this,
       { bv_or_elim_at this.left,
         { bv_contradiction },
         { bv_contradiction }},
       { bv_contradiction } },
    { have : Γ_2 ≤ ⊥ := le_bot_iff_not_bot_lt.mp h,
      from le_trans this bot_le }
end

lemma a1_le_of_omega_lt {Γ : 𝔹} : Γ ≤ le_of_omega_lt a1 :=
begin
  bv_intro x, bv_imp_intro H_Ord, bv_imp_intro H_no_surj,
  have H_no_inj : Γ_2 ≤ -(injects_into x omega),
    by { rw ←imp_bot, bv_imp_intro H_contra,
         refine bv_absurd _ _ H_no_surj,
         bv_cases_on x =ᴮ ∅,
         { apply bv_use (∅ : bSet 𝔹), apply bv_use (∅ : bSet 𝔹),
          refine le_inf _ _,
          refine le_inf empty_subset _,
          exact is_func'_empty,
          apply bv_rw' H.left, simp, apply is_surj_empty },
         { apply larger_than_of_surjects_onto,
           refine surjects_onto_of_injects_into ‹_› _, rwa ←nonempty_iff_exists_mem } },
  have H_not_mem_a1 : Γ_2 ≤ -(x ∈ᴮ a1),
    by { rw ←imp_bot, bv_imp_intro H_contra, rw mem_a1_iff ‹_›at H_contra,
         have := injects_into_of_injection_into H_contra, bv_contradiction },
  refine injects_into_of_subset _,
  rw Ord.le_iff_lt_or_eq (a1_Ord) ‹_›,
  have := Ord.trichotomy (a1_Ord) ‹_›,
  bv_or_elim_at this, bv_or_elim_at this.left,
    { from bv_or_right ‹_› },
    { from bv_or_left ‹_› },
    { from bv_exfalso (by bv_contradiction) }
end

end a1

section

variables {𝔹 : Type u} [nontrivial_complete_boolean_algebra 𝔹]

lemma injects_into_omega_of_mem_aleph_one_check {Γ : 𝔹} {z : bSet 𝔹} (H_mem : Γ ≤ z ∈ᴮ (ℵ₁)̌ ): Γ ≤ injects_into z bSet.omega :=
begin
  rw mem_unfold at H_mem, bv_cases_at H_mem η Hη, simp at Hη,
  suffices : Γ_1 ≤ injects_into (ℵ₁̌.func η) bSet.omega,
  apply bv_rw' Hη, simp, from ‹_›,
  suffices : pSet.injects_into ((ℵ₁).func $ check_cast η) pSet.omega,
    by {rw check_func, apply check_injects_into, from ‹_› },
  refine pSet.injects_into_omega_of_mem_aleph_one _,
    { simp }
end

lemma mem_aleph_one_of_injects_into_omega {x : bSet 𝔹} {Γ : 𝔹} (H_aleph_one : Γ ≤ aleph_one_Ord_spec x) {z : bSet 𝔹} (H_x_Ord : Γ ≤ Ord x) (H_z_Ord : Γ ≤ Ord z) (H_inj : Γ ≤ injects_into z bSet.omega) : Γ ≤ z ∈ᴮ x :=
begin
  apply bv_by_contra, bv_imp_intro H_contra,
  have := Ord.resolve_lt H_z_Ord H_x_Ord H_contra,
  rw ← Ord.le_iff_lt_or_eq H_x_Ord H_z_Ord at this,
  suffices H_inj_omega : Γ_1 ≤ injects_into x omega,
    by {refine bv_absurd _ H_inj_omega _, from bv_and.left ‹_› },
  exact injects_into_trans (injects_into_of_subset this) (H_inj)
end

lemma aleph_one_check_sub_aleph_one_aux {x : bSet 𝔹} {Γ : 𝔹} (H_ord : Γ ≤ Ord x) (H_aleph_one : Γ ≤ aleph_one_Ord_spec x) : Γ ≤ ℵ₁̌ ⊆ᴮ x :=
begin
  rw subset_unfold', bv_intro w, bv_imp_intro H_mem_w,
  apply mem_aleph_one_of_injects_into_omega, from ‹_›, from ‹_›,
  exact Ord_of_mem_Ord H_mem_w
    (check_Ord (by {unfold pSet.aleph_one pSet.card_ex, simp })),
  exact injects_into_omega_of_mem_aleph_one_check ‹_›
end

end

end bSet


import system_of_complexes.double
import system_of_complexes.truncate
import normed_snake
import category_theory.concrete_category

import thm95.constants.spectral_constants

noncomputable theory
open_locale nnreal
open category_theory

universe variables u

namespace system_of_double_complexes

@[simps]
def truncate : system_of_double_complexes.{u} ⥤ system_of_double_complexes.{u} :=
(whiskering_right _ _ _).obj $
  @functor.map_homological_complex _ _ _ _ _ _ _ _ SemiNormedGroup.truncate.additive.{u} _
-- TODO: why do I need to give the instance manually? ↑ ↑ ↑

namespace truncate

variables (M : system_of_double_complexes.{u})

-- defeq abuse for the win!!!
lemma row (p : ℕ) :
  (truncate.obj M).row p = system_of_complexes.truncate.obj (M.row p) := rfl

lemma col_pos (q : ℕ) :
  (truncate.obj M).col (q+1) = M.col (q+1+1) :=
rfl

@[simp]
lemma d'_zero_one (c : ℝ≥0) (p : ℕ) (x : M.X c p 1) :
  (truncate.obj M).d' 0 1 (SemiNormedGroup.explicit_cokernel_π _ x) = M.d' 1 2 x := rfl

@[simp]
lemma d_π (c : ℝ≥0) (p p' : ℕ) (x : M.X c p 1) :
  @d (truncate.obj M) _ p p' 0 (SemiNormedGroup.explicit_cokernel_π _ x) =
  SemiNormedGroup.explicit_cokernel_π _ (M.d p p' x) := rfl

@[simp]
lemma res_π (c₁ c₂ : ℝ≥0) (p : ℕ) (h : fact (c₁ ≤ c₂)) (x : M.X c₂ p 1) :
  @res (truncate.obj M) _ _ p 0 h (SemiNormedGroup.explicit_cokernel_π _ x) =
  SemiNormedGroup.explicit_cokernel_π _ (M.res x) := rfl

def quotient_map : M.col 1 ⟶ (truncate.obj M).col 0 :=
{ app := λ c,
  { f := λ p, SemiNormedGroup.explicit_cokernel_π _,
    comm' := λ p p' _, by { ext, refl } },
  naturality' := by { intros, ext, refl } }

lemma admissible (hM : M.admissible) : (truncate.obj M).admissible :=
{ d_norm_noninc' := λ c p' p q h,
  begin
    cases q,
    { apply SemiNormedGroup.explicit_cokernel_desc_norm_noninc,
      exact (SemiNormedGroup.norm_noninc_explicit_cokernel_π _).comp (hM.d_norm_noninc _ _ _ _) },
    { exact hM.d_norm_noninc c p' p _ }
  end,
  d'_norm_noninc' := λ c p,
    ((M.row p).truncate_admissible (hM.row p)).d_norm_noninc' c,
  res_norm_noninc := λ c₁ c₂ p,
    ((M.row p).truncate_admissible (hM.row p)).res_norm_noninc c₁ c₂ }

end truncate

open opposite

structure normed_spectral_homotopy {row₀ row₁ : system_of_complexes.{u}} (d : row₀ ⟶ row₁)
  (m : ℕ) (k' ε : ℝ≥0) [fact (1 ≤ k')] (c₀ H : ℝ≥0) [fact (0 < H)] :=
(h : Π (q : ℕ) {q' : ℕ} {c}, row₀ (k' * c) q' ⟶ row₁ c q)
(norm_h_le : ∀ (q q' : ℕ) (hq : q ≤ m) (hq' : q+1 = q') (c) [fact (c₀ ≤ c)],
  ∥(h q : row₀ (k' * c) q' ⟶ row₁ c q)∥ ≤ H)
(δ : Π (c : ℝ≥0), row₀.obj (op $ c) ⟶ row₁.obj (op $ k' * c))
(hδ : ∀ (c : ℝ≥0) [fact (c₀ ≤ c)] (q : ℕ) (hq : q ≤ m),
  (system_of_complexes.res : row₀ (k' * (k' * c)) q ⟶ _) ≫ (δ c).f q =
    d.apply ≫ system_of_complexes.res + row₀.d q (q+1) ≫ h q + h (q-1) ≫ row₁.d (q-1) q)
(norm_δ_le : ∀ (c : ℝ≥0) [fact (c₀ ≤ c)] (q : ℕ) (hq : q ≤ m), ∥(δ c).f q∥ ≤ ε)
.

lemma normed_spectral_homotopy.hδ_apply {row₀ row₁ : system_of_complexes.{u}} {d : row₀ ⟶ row₁}
  {m : ℕ} {k' ε : ℝ≥0} [fact (1 ≤ k')] {c₀ H : ℝ≥0} [fact (0 < H)]
  (NSH : normed_spectral_homotopy d m k' ε c₀ H)
  (c : ℝ≥0) [fact (c₀ ≤ c)] (q : ℕ) (hq : q ≤ m) (x : row₀ (k' * (k' * c)) q) :
  (NSH.δ c).f q (system_of_complexes.res x) =
    system_of_complexes.res (d x) + NSH.h q (row₀.d q (q+1) x) + row₁.d (q-1) q (NSH.h (q-1) x) :=
begin
  show ((system_of_complexes.res : row₀ (k' * (k' * c)) q ⟶ _) ≫ (NSH.δ c).f q) x = _,
  rw NSH.hδ c q hq,
  dsimp, refl
end

def normed_spectral_homotopy.of_iso {row₀ row₁ : system_of_complexes.{u}} {d : row₀ ⟶ row₁}
  {m : ℕ} {k' ε : ℝ≥0} [fact (1 ≤ k')] {c₀ H : ℝ≥0} [fact (0 < H)]
  (NSH : normed_spectral_homotopy d m k' ε c₀ H)
  (row'₀ row'₁ : system_of_complexes.{u}) (d' : row'₀ ⟶ row'₁)
  (φ₀ : row₀ ≅ row'₀) (φ₁ : row₁ ≅ row'₁)
  (hφ₀ : ∀ c i (x : row'₀ c i), ∥φ₀.inv x∥ = ∥x∥)
  (hφ₁ : ∀ c i (x : row₁ c i), ∥φ₁.hom x∥ = ∥x∥)
  (hcomm : d' = φ₀.inv ≫ d ≫ φ₁.hom) :
  normed_spectral_homotopy d' m k' ε c₀ H :=
{ h := λ q q' c, φ₀.inv.apply ≫ NSH.h q ≫ φ₁.hom.apply,
  δ := λ c, φ₀.inv.app (op $ c) ≫ NSH.δ c ≫ φ₁.hom.app (op $ k' * c),
  norm_h_le :=
  begin
    introsI q q' hqm hq' c hc,
    refine normed_add_group_hom.op_norm_le_bound _ (nnreal.coe_nonneg H) (λ x, _),
    calc  ∥φ₁.hom (NSH.h q (φ₀.inv x))∥
        = ∥NSH.h q (φ₀.inv x)∥ : hφ₁ _ _ _
    ... ≤ ↑H * ∥φ₀.inv x∥ :
      normed_add_group_hom.le_of_op_norm_le _ (NSH.norm_h_le _ _ hqm hq' _) (φ₀.inv x)
    ... = ↑H * ∥x∥ : congr_arg _ (hφ₀ _ _ _),
  end,
  hδ :=
  begin
    introsI c hc q hq,
    ext1 x,
    have := congr_arg (λ x, φ₁.hom x) (NSH.hδ_apply c q hq (φ₀.inv x)),
    simp only [coe_comp, hcomm, system_of_complexes.res_apply, system_of_complexes.d_apply] at this ⊢,
    refine this.trans _, clear this,
    calc φ₁.hom (d (φ₀.inv (system_of_complexes.res x)) +
          (NSH.h q) (φ₀.inv (row'₀.d q (q+1) x)) +
          (row₁.d (q - 1) q) (NSH.h (q - 1) (φ₀.inv x)))
        = φ₁.hom (d (φ₀.inv (system_of_complexes.res x)) +
          (NSH.h q) (φ₀.inv (row'₀.d q (q+1) x))) +
          φ₁.hom ((row₁.d (q - 1) q) (NSH.h (q - 1) (φ₀.inv x))) : _
    ... = _ : _,
    { apply normed_add_group_hom.map_add' },
    congr' 1,
    { refine (normed_add_group_hom.map_add' _ _ _).trans _,
      simp only [← comp_apply, ← system_of_complexes.res_comp_apply], refl },
    { erw [system_of_complexes.d_apply], refl }
  end,
  norm_δ_le := λ c hc q hq,
  begin
    resetI,
    refine normed_add_group_hom.op_norm_le_bound _ (nnreal.coe_nonneg ε) _,
    rintro (x : row'₀ c q),
    calc  ∥φ₁.hom ((NSH.δ c).f q (φ₀.inv x))∥
        = ∥(NSH.δ c).f q (φ₀.inv x)∥ : hφ₁ _ _ _
    ... ≤ ↑ε * ∥φ₀.inv x∥ : normed_add_group_hom.le_of_op_norm_le _  (NSH.norm_δ_le _ _ hq) (φ₀.inv x)
    ... = ↑ε * ∥x∥ : congr_arg _ (hφ₀ _ _ _),
  end }

/-- The assumptions on `M` in Proposition 9.6 bundled into a structure. -/
structure normed_spectral_conditions (M : system_of_double_complexes.{u})
  (m : ℕ) (k K k' ε : ℝ≥0) [fact (1 ≤ k)] [fact (1 ≤ k')] (c₀ H : ℝ≥0) [fact (0 < H)] :=
(row_exact : 0 < m → ∀ i ≤ m + 1, (M.row i).is_weak_bounded_exact k K (m-1) c₀)
(col_exact : ∀ j ≤ m, (M.col j).is_weak_bounded_exact k K m c₀)
(htpy      : normed_spectral_homotopy (M.row_map 0 1) m k' ε c₀ H)
-- ergonomics: we bundle this assumption, instead of passing it around separately
(admissible : M.admissible)

.

namespace normed_spectral_conditions

variables {M : system_of_double_complexes.{u}}
variables {m : ℕ} {k K k' ε k₀ : ℝ≥0}
variables [fact (1 ≤ k)] [fact (1 ≤ k₀)] [fact (k₀ ≤ k')] [fact (1 ≤ k')]
variables {c₀ H : ℝ≥0} [fact (0 < H)]

lemma truncate_admissible (condM : M.normed_spectral_conditions m k K k' ε c₀ H) :
  (truncate.obj M).admissible :=
truncate.admissible _ condM.admissible

variables (condM : M.normed_spectral_conditions (m+1) k K k' ε c₀ H)

include condM

lemma col_zero_exact :
  ((truncate.obj M).col 0).is_weak_bounded_exact (k*k*k) (K*(K*K+1)) m c₀ :=
begin
  apply weak_normed_snake (M.col 0) (M.col 1) ((truncate.obj M).col 0)
    (M.col_map 0 1) (truncate.quotient_map M)
    (condM.col_exact 0 dec_trivial) (condM.col_exact 1 dec_trivial)
    (condM.admissible.col 1),
  { intros c p, exact condM.admissible.d'_norm_noninc c p 0 1 },
  { intros c hc i hi x,
    apply le_of_forall_pos_le_add,
    intros ε' hε',
    -- should we factor out a dedicated `weak_bounded_in_degrees_le_zero` lemma?
    simpa only [exists_prop, row_res, d'_self_apply, exists_eq_left, sub_zero,
      exists_and_distrib_left, zero_add, row_d, exists_eq_left', exists_const]
      using condM.row_exact (nat.zero_lt_succ _) i hi c hc 0 (nat.zero_le _) x ε' hε' },
  { intros c i, apply quotient_add_group.ker_mk },
  { intros c p, exact SemiNormedGroup.is_quotient_explicit_cokernel_π _ }
end

-- morally `q'` is `q + 1`
def h_truncate : Π (q : ℕ) {q' : ℕ} {c : ℝ≥0},
  (truncate.obj M).X (k' * c) 0 q' ⟶ (truncate.obj M).X c 1 q
| 0     1      c := condM.htpy.h 1 ≫ SemiNormedGroup.explicit_cokernel_π _
| (q+1) (q'+1) c := condM.htpy.h (q+2)
| _     _      _ := 0

@[simp]
lemma h_truncate_zero {c : ℝ≥0} (x : (truncate.obj M).X (k' * c) 0 1) :
  condM.h_truncate 0 x = SemiNormedGroup.explicit_cokernel_π _ (condM.htpy.h 1 x) := rfl

lemma norm_h_truncate_le : ∀ (q q' : ℕ), q ≤ m → q+1 = q' → ∀ (c : ℝ≥0), fact (c₀ ≤ c) →
  ∥(condM.h_truncate q : (truncate.obj M).X (k' * c) 0 q' ⟶ _)∥ ≤ H
| (q+1) (q'+1) hq rfl := condM.htpy.norm_h_le _ _ (nat.succ_le_succ hq)
                                    (by simp only [nat.add_def, add_zero])
| 0     1      hq rfl :=
begin
  introsI c hc,
  refine normed_add_group_hom.op_norm_le_bound _ (nnreal.coe_nonneg H) (λ x, _),
  calc _ = ∥SemiNormedGroup.explicit_cokernel_π _ (condM.htpy.h 1 x)∥ : rfl
  ...  ≤ ∥condM.htpy.h 1 x∥ : (SemiNormedGroup.is_quotient_explicit_cokernel_π _).norm_le _
  ... ≤ H * ∥x∥ : normed_add_group_hom.le_of_op_norm_le _ (condM.htpy.norm_h_le 1 2 dec_trivial rfl c) x
end

def δ_truncate (c : ℝ≥0) :
  ((truncate.obj M).row 0).obj (op $ c) ⟶ ((truncate.obj M).row 1).obj (op $ k' * c) :=
SemiNormedGroup.truncate.map (condM.htpy.δ c)

lemma hδ_truncate (c : ℝ≥0) [fact (c₀ ≤ c)] : ∀ (q : ℕ) (hq : q ≤ m),
  (truncate.obj M).res ≫ (condM.δ_truncate c).f q = (d _ 0 1) ≫ (truncate.obj M).res +
    (d' _ q (q+1)) ≫ condM.h_truncate q + (condM.h_truncate (q-1)) ≫ d' _ (q-1) q
| 1     h := condM.htpy.hδ _ _ (nat.succ_le_succ h)
| (q+2) h := condM.htpy.hδ _ _ (nat.succ_le_succ h)
| 0     h :=
begin
  ext x, dsimp,
  let π := λ c p, SemiNormedGroup.explicit_cokernel_π (@d' M c p 0 1),
  obtain ⟨y, hy⟩ : ∃ x', π _ _ x' = (SemiNormedGroup.explicit_cokernel_π _ x) :=
    SemiNormedGroup.explicit_cokernel_π_surjective (SemiNormedGroup.explicit_cokernel_π _ x),
  transitivity π _ _ ((condM.htpy.δ c).f 1 (M.res x)), { refl },
  erw condM.htpy.hδ_apply _ _ (nat.succ_le_succ h) x,
  simp only [nat.zero_sub, d'_self_apply, add_zero, row_d,
    truncate.d_π, truncate.res_π, truncate.d'_zero_one, h_truncate_zero,
    map_add, SemiNormedGroup.explicit_cokernel_π_apply_dom_eq_zero],
  refl
end

lemma norm_δ_truncate_le (c : ℝ≥0) [fact (c₀ ≤ c)] :
  ∀ (q : ℕ) (hq : q ≤ m), ∥(condM.δ_truncate c).f q∥ ≤ ε
| (q+1) h := condM.htpy.norm_δ_le c (q+2) (nat.succ_le_succ h)
| 0     h :=
begin
  refine SemiNormedGroup.explicit_cokernel_desc_norm_le_of_norm_le _ _
    (normed_add_group_hom.op_norm_le_bound _ (nnreal.coe_nonneg ε) (λ x, _)),
  refine (SemiNormedGroup.norm_noninc_explicit_cokernel_π _ _).trans _,
  exact normed_add_group_hom.le_of_op_norm_le _ (condM.htpy.norm_δ_le c _ (nat.succ_le_succ h)) _
end

def truncate :
  (truncate.obj M).normed_spectral_conditions m (k*k*k) (K*(K*K+1)) k' ε c₀ H :=
{ row_exact :=
  begin
    intros hm i hi,
    cases m, { exact (nat.not_lt_zero _ hm).elim },
    suffices : ((truncate.obj M).row i).is_weak_bounded_exact k K m c₀,
    { apply this.of_le (condM.truncate_admissible.row i) _ _ le_rfl ⟨le_rfl⟩;
      apply_instance },
    rw truncate.row,
    apply (M.row i).truncate_is_weak_bounded_exact,
    { refine condM.row_exact (nat.zero_lt_succ _) i (hi.trans (nat.le_succ _)), }
  end,
  col_exact :=
  begin
    rintro (j|j) hj,
    { exact condM.col_zero_exact },
    { rw truncate.col_pos,
      refine (condM.col_exact (j+2) (nat.succ_le_succ hj)).of_le
        (condM.admissible.col (j+2)) _ _ m.le_succ ⟨le_rfl⟩;
      apply_instance }
  end,
  htpy :=
  { h := condM.h_truncate,
    norm_h_le := condM.norm_h_truncate_le,
    δ := condM.δ_truncate,
    hδ := condM.hδ_truncate,
    norm_δ_le := condM.norm_δ_truncate_le },
  admissible := condM.truncate_admissible }

omit condM

variables {m_ : ℕ} {k_ K_ : ℝ≥0} [fact (1 ≤ k_)]
variables {ε_ : ℝ≥0} {k₀_ : ℝ≥0} [fact (1 ≤ k₀_)]
variables [fact (k₀_ ≤ k')] {c₀_ H_ : ℝ≥0} [fact (0 < H_)]

def of_le (cond : M.normed_spectral_conditions m k K k' ε c₀ H)
  (hm : m_ ≤ m) (hk : fact (k ≤ k_)) (hK : fact (K ≤ K_)) (hε : ε ≤ ε_)
  (hc₀ : fact (c₀ ≤ c₀_)) (hH : H ≤ H_) :
  M.normed_spectral_conditions m_ k_ K_ k' ε_ c₀_ H_ :=
{ col_exact := λ j hj, (cond.col_exact j (hj.trans hm)).of_le (cond.admissible.col j) hk hK hm hc₀,
  row_exact := λ hm_ i hi,
    (cond.row_exact (hm_.trans_le hm) i (hi.trans $ nat.succ_le_succ hm)).of_le
      (cond.admissible.row i) hk hK (nat.pred_le_pred hm) hc₀,
  htpy :=
  { h := cond.htpy.h,
    norm_h_le := λ q q' hq hq' c hc, have fact (c₀ ≤ c) := ⟨hc₀.out.trans hc.out⟩, by exactI
    begin
    refine normed_add_group_hom.op_norm_le_bound _ (nnreal.coe_nonneg H_) (λ x, _),
    calc ∥cond.htpy.h q x∥ ≤ H * ∥x∥  :
      normed_add_group_hom.le_of_op_norm_le _ (cond.htpy.norm_h_le q q' (hq.trans hm) hq' c) x
                       ... ≤ H_ * ∥x∥ : mul_le_mul_of_nonneg_right hH (norm_nonneg x),
    end,
    δ := cond.htpy.δ,
    hδ := λ c hc q hq, have fact (c₀ ≤ c) := ⟨hc₀.out.trans hc.out⟩,
      by exactI cond.htpy.hδ c q (hq.trans hm),
    norm_δ_le := λ c hc q hq, have fact (c₀ ≤ c) := ⟨hc₀.out.trans hc.out⟩, by exactI
    begin
      refine normed_add_group_hom.op_norm_le_bound _ (nnreal.coe_nonneg ε_) (λ x, _),
      refine normed_add_group_hom.le_of_op_norm_le _ _ x,
      exact le_trans (cond.htpy.norm_δ_le c q (hq.trans hm)) hε,
    end },
  admissible := cond.admissible }

end normed_spectral_conditions

namespace normed_spectral

/-- Base case of the induction for Proposition 9.6. -/
theorem base (c₀ H : ℝ≥0) [fact (0 < H)] (M : system_of_double_complexes.{u})
  (k K k' : ℝ≥0) [hk : fact (1 ≤ k)] [hK : fact (1 ≤ K)] [fact (k₀ 0 k ≤ k')] [fact (1 ≤ k')]
  (cond : M.normed_spectral_conditions 0 k K k' (ε 0 K) c₀ H) :
  (M.row 0).is_weak_bounded_exact (k' * k') (2 * K₀ 0 K * H) 0 c₀ :=
begin
  dsimp [k₀, K₀],
  introsI c hc i hi,
  interval_cases i, clear hi,
  intros x ε' hε',
  let φ : ℝ := ε' / 2,
  have hφ : 0 < φ := div_pos hε' zero_lt_two,
  have hδφ : ε' = φ + φ, { dsimp [φ], rw [← add_div, half_add_self] },
  haveI : fact (k' * (k' * c) ≤ k' * k' * c) := by { rw mul_assoc, exact ⟨le_rfl⟩ },
  have Hx1 := (cond.col_exact 0 le_rfl).of_le
    (cond.admissible.col 0) ‹_› ⟨le_rfl⟩ le_rfl ⟨le_rfl⟩ c hc 0 le_rfl,
  have Hx2 := normed_add_group_hom.le_of_op_norm_le _ (cond.htpy.norm_δ_le c 0 le_rfl) (M.res x),
  have aux := cond.htpy.hδ_apply c 0 le_rfl (M.res x),
  erw [res_res] at aux,
  rw aux at Hx2,
  simp only [row_d, col_d, d_self_apply, d'_self_apply, sub_zero, add_zero, smul_zero,
    d_res, d'_res, res_res, one_div, row_res, units.coe_one, one_smul, row_map_apply] at Hx1 Hx2 ⊢,
  refine ⟨0, 1, rfl, rfl, 0, _⟩,
  obtain ⟨i, j, hi, hj, y1, hx1⟩ := Hx1 (M.res x) φ hφ,
  simp [← eq_neg_iff_add_eq_zero] at hi hj, subst i, subst j,
  simp only [d_self_apply, d'_self_apply, sub_zero,
    nnreal.coe_mul, nnreal.coe_bit0, nnreal.coe_one, d_res] at hx1 ⊢,
  erw [res_res] at hx1,
  clear y1 Hx1,
  replace Hx1 := mul_le_mul_of_nonneg_left hx1 (ε 0 K).coe_nonneg,
  replace Hx2 := (norm_le_add_norm_add _ _).trans (add_le_add (Hx2.trans Hx1) le_rfl),
  dsimp [ε] at Hx2,
  have K0 : (K:ℝ) ≠ 0 := ne_of_gt (lt_of_lt_of_le zero_lt_one hK.out),
  simp only [mul_add, add_assoc, mul_inv, mul_assoc, inv_mul_cancel_left₀ K0] at Hx2,
  simp only [← div_eq_inv_mul, sub_half, ← sub_le_iff_le_add'] at Hx2,
  simp only [sub_le_iff_le_add', div_le_iff' (zero_lt_two : (0:ℝ) < 2)] at Hx2,
  replace Hx2 := mul_le_mul_of_nonneg_left Hx2 K.coe_nonneg,
  simp only [mul_add, div_eq_inv_mul, add_comm φ,
    mul_inv_cancel_left₀ (two_ne_zero : (2:ℝ) ≠ 0), mul_inv_cancel_left₀ K0] at Hx2,
  refine hx1.trans _,
  simp only [mul_comm (2:ℝ) K, mul_assoc, hδφ, ← add_assoc, ← mul_add, add_le_add_iff_right],
  refine Hx2.trans _,
  simp only [add_le_add_iff_right],
  refine (mul_le_mul_of_nonneg_left _ K.coe_nonneg),
  refine (mul_le_mul_of_nonneg_left _ zero_le_two),
  refine le_trans (normed_add_group_hom.le_of_op_norm_le _ (cond.htpy.norm_h_le _ _ le_rfl rfl _) _) _,
  refine mul_le_mul_of_nonneg_left (le_of_eq _) H.coe_nonneg,
  apply norm_res_of_eq,
  rw mul_assoc
end
.

end normed_spectral

open normed_spectral

/-- Proposition 9.6 in [Analytic] -/
theorem normed_spectral {m : ℕ} {c₀ H : ℝ≥0} [fact (0 < H)]
  {M : system_of_double_complexes.{u}} {k K k' : ℝ≥0}
  [fact (1 ≤ k)] [hK : fact (1 ≤ K)] [fact (k₀ m k ≤ k')] [fact (1 ≤ k')]
  (cond : M.normed_spectral_conditions m k K k' (ε m K) c₀ H) :
  (M.row 0).is_weak_bounded_exact (k' * k') (2 * K₀ m K * H) m c₀ :=
begin
  unfreezingI { revert M k K k' },
  induction m with m IH, { exact base c₀ H },
  dsimp [ε, k₀, K₀],
  introsI M k K k' _ _ _ _ cond,
  rw ← system_of_complexes.truncate_is_weak_bounded_exact_iff,
  { exact IH cond.truncate },
  { refine @IH M (k*k*k) (K*(K*K+1)) k' _ _ _ _ (cond.of_le (m.le_succ) _ _ le_rfl ⟨le_rfl⟩ le_rfl),
    all_goals { apply_instance } }
end

end system_of_double_complexes


import tactic
import row_insertion
import inverse_row_insertion

section irbs_rbs

lemma ssyt.rbs_cert.irbc_aux
  {μ : young_diagram} {T : ssyt μ} (h : T.rbs_cert)
  (cell : (h.i, h.j) ∈ μ) :
  ∃ j, ((h.i, j) ∈ μ ∧ (h.rbs cell) h.i j < h.out) :=
  ⟨h.j, ⟨cell, by { rw [h.rbs_entry, if_pos rfl],
                    exact h.out_lt_val cell }⟩⟩

lemma ssyt.rbs_cert.irbc_eq_j
  {μ : young_diagram} {T : ssyt μ} (h : T.rbs_cert)
  (cell : (h.i, h.j) ∈ μ) :
  (h.rbs cell).irbc (h.irbc_aux cell) = h.j :=
begin
  rw ssyt.irbc_eq_iff, split, exact cell,
  split,
  { rw [h.rbs_entry, if_pos rfl], exact h.out_lt_val cell },
  { intros j' hj' cell',
    rw [h.rbs_entry, if_neg],
    apply T.row_weak hj' cell',
    exact λ hij, (ne_of_lt hj').symm (prod.mk.inj_left h.i hij) }
end

@[simps]
def ssyt.rbs_cert.to_irbs_cert
  {μ : young_diagram} {T : ssyt μ} (h : T.rbs_cert)
  (cell : (h.i, h.j) ∈ μ) : (h.rbs cell).irbs_cert :=
{ i := h.i,
  val := h.out,
  exists_lt := h.irbc_aux cell,
  down := λ i' hi' cell', begin
    rw h.irbc_eq_j at ⊢ cell',
    rw h.rbs_entry_eq_of_ne_row _ (ne_of_lt hi').symm,
    exact T.col_strict hi' cell',
  end,
}

lemma ssyt.rbs_cert.to_irbs_cert_j
  {μ : young_diagram} {T : ssyt μ} (h : T.rbs_cert)
  (cell : (h.i, h.j) ∈ μ) : (h.to_irbs_cert cell).j = h.j := h.irbc_eq_j cell

lemma ssyt.rbs_cert.irbs_rbs
  {μ : young_diagram} {T : ssyt μ} (h : T.rbs_cert)
  (cell : (h.i, h.j) ∈ μ) : (h.to_irbs_cert cell).irbs = T :=
begin
  ext i j, repeat {rw ssyt.to_entry},
  rw [ssyt.irbs_cert.irbs_entry, h.to_irbs_cert_i, h.to_irbs_cert_val,
      h.to_irbs_cert_j],
  split_ifs,
    { cases h_1, refl },
    { rw [h.rbs_entry, if_neg h_1] }
end

end irbs_rbs

section rbs_irbs

lemma ssyt.irbs_cert.rbc_eq_j
  {μ : young_diagram} {T : ssyt μ} (h : T.irbs_cert) :
  h.irbs.rbc h.i h.out = h.j :=
begin
  rw ssyt.rbc_eq_iff, split,
  { intro cell,
    rw [h.irbs_entry, if_pos rfl], exact h.out_lt_val },
  { intros j' hj', rw [h.irbs_entry, if_neg],
    exact ⟨μ.nw_of (le_refl _) (le_of_lt hj') h.cell, T.row_weak hj' h.cell⟩,
    exact λ hij, (ne_of_lt hj') (prod.mk.inj_left h.i hij) }
end

@[simps]
def ssyt.irbs_cert.to_rbs_cert
  {μ : young_diagram} {T : ssyt μ} (h : T.irbs_cert) : h.irbs.rbs_cert :=
{ i := h.i,
  val := h.out,
  cell_up := λ i hi, h.rbc_eq_j.symm ▸ μ.nw_of (le_of_lt hi) (by refl) h.cell,
  up := λ i hi, begin
    rw [h.rbc_eq_j, h.irbs_entry, if_neg],
    exact T.col_strict hi h.cell,
    exact λ hij, (ne_of_lt hi) (prod.mk.inj_right h.j hij),
  end
}

lemma ssyt.irbs_cert.to_rbs_cert_j
  {μ : young_diagram} {T : ssyt μ} (h : T.irbs_cert) :
h.to_rbs_cert.j = h.j := h.rbc_eq_j

lemma ssyt.irbs_cert.to_rbs_cert_cell
  {μ : young_diagram} {T : ssyt μ} (h : T.irbs_cert) :
(h.to_rbs_cert.i, h.to_rbs_cert.j) ∈ μ := h.to_rbs_cert_j.symm ▸ h.cell

lemma ssyt.irbs_cert.rbs_irbs
  {μ : young_diagram} {T : ssyt μ} (h : T.irbs_cert) :
  h.to_rbs_cert.rbs h.to_rbs_cert_cell = T :=
begin
  ext i j, repeat {rw ssyt.to_entry},
  rw [ssyt.rbs_cert.rbs_entry, h.to_rbs_cert_i, h.to_rbs_cert_val,
      h.to_rbs_cert_j],
  split_ifs,
    { cases h_1, refl },
    { rw [h.irbs_entry, if_neg h_1] }
end

end rbs_irbs