/-
Copyright © 2020 Nicolò Cavalleri. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Nicolò Cavalleri.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.geometry.manifold.times_cont_mdiff
import Mathlib.topology.continuous_map
import Mathlib.PostPort

universes u_1 u_2 u_3 u_4 u_5 u_6 u_7 l u_10 u_8 u_9

namespace Mathlib

/-!
# Smooth bundled map

In this file we define the type `times_cont_mdiff_map` of `n` times continuously differentiable
bundled maps.
-/

/-- Bundled `n` times continuously differentiable maps. -/
structure times_cont_mdiff_map {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {E' : Type u_3} [normed_group E'] [normed_space 𝕜 E'] {H : Type u_4} [topological_space H] {H' : Type u_5} [topological_space H'] (I : model_with_corners 𝕜 E H) (I' : model_with_corners 𝕜 E' H') (M : Type u_6) [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] (M' : Type u_7) [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M'] (n : with_top ℕ)
where
  to_fun : M → M'
  times_cont_mdiff_to_fun : times_cont_mdiff I I' n to_fun

/-- Bundled smooth maps. -/
def smooth_map {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {E' : Type u_3} [normed_group E'] [normed_space 𝕜 E'] {H : Type u_4} [topological_space H] {H' : Type u_5} [topological_space H'] (I : model_with_corners 𝕜 E H) (I' : model_with_corners 𝕜 E' H') (M : Type u_6) [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] (M' : Type u_7) [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M'] :=
  times_cont_mdiff_map I I' M M' ⊤

namespace times_cont_mdiff_map

protected instance has_coe_to_fun {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {E' : Type u_3} [normed_group E'] [normed_space 𝕜 E'] {H : Type u_4} [topological_space H] {H' : Type u_5} [topological_space H'] {I : model_with_corners 𝕜 E H} {I' : model_with_corners 𝕜 E' H'} {M : Type u_6} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] {M' : Type u_7} [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M'] {n : with_top ℕ} : has_coe_to_fun (times_cont_mdiff_map I I' M M' n) :=
  has_coe_to_fun.mk (fun (x : times_cont_mdiff_map I I' M M' n) => M → M') times_cont_mdiff_map.to_fun

protected instance continuous_map.has_coe {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {E' : Type u_3} [normed_group E'] [normed_space 𝕜 E'] {H : Type u_4} [topological_space H] {H' : Type u_5} [topological_space H'] {I : model_with_corners 𝕜 E H} {I' : model_with_corners 𝕜 E' H'} {M : Type u_6} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] {M' : Type u_7} [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M'] {n : with_top ℕ} : has_coe (times_cont_mdiff_map I I' M M' n) (continuous_map M M') :=
  has_coe.mk fun (f : times_cont_mdiff_map I I' M M' n) => continuous_map.mk (times_cont_mdiff_map.to_fun f)

protected theorem times_cont_mdiff {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {E' : Type u_3} [normed_group E'] [normed_space 𝕜 E'] {H : Type u_4} [topological_space H] {H' : Type u_5} [topological_space H'] {I : model_with_corners 𝕜 E H} {I' : model_with_corners 𝕜 E' H'} {M : Type u_6} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] {M' : Type u_7} [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M'] {n : with_top ℕ} (f : times_cont_mdiff_map I I' M M' n) : times_cont_mdiff I I' n ⇑f :=
  times_cont_mdiff_map.times_cont_mdiff_to_fun f

protected theorem smooth {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {E' : Type u_3} [normed_group E'] [normed_space 𝕜 E'] {H : Type u_4} [topological_space H] {H' : Type u_5} [topological_space H'] {I : model_with_corners 𝕜 E H} {I' : model_with_corners 𝕜 E' H'} {M : Type u_6} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] {M' : Type u_7} [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M'] (f : times_cont_mdiff_map I I' M M' ⊤) : smooth I I' ⇑f :=
  times_cont_mdiff_map.times_cont_mdiff_to_fun f

theorem coe_inj {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {E' : Type u_3} [normed_group E'] [normed_space 𝕜 E'] {H : Type u_4} [topological_space H] {H' : Type u_5} [topological_space H'] {I : model_with_corners 𝕜 E H} {I' : model_with_corners 𝕜 E' H'} {M : Type u_6} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] {M' : Type u_7} [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M'] {n : with_top ℕ} {f : times_cont_mdiff_map I I' M M' n} {g : times_cont_mdiff_map I I' M M' n} (h : ⇑f = ⇑g) : f = g := sorry

theorem ext {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {E' : Type u_3} [normed_group E'] [normed_space 𝕜 E'] {H : Type u_4} [topological_space H] {H' : Type u_5} [topological_space H'] {I : model_with_corners 𝕜 E H} {I' : model_with_corners 𝕜 E' H'} {M : Type u_6} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] {M' : Type u_7} [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M'] {n : with_top ℕ} {f : times_cont_mdiff_map I I' M M' n} {g : times_cont_mdiff_map I I' M M' n} (h : ∀ (x : M), coe_fn f x = coe_fn g x) : f = g := sorry

/-- The identity as a smooth map. -/
def id {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {H : Type u_4} [topological_space H] {I : model_with_corners 𝕜 E H} {M : Type u_6} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] {n : with_top ℕ} : times_cont_mdiff_map I I M M n :=
  mk id times_cont_mdiff_id

/-- The composition of smooth maps, as a smooth map. -/
def comp {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {E' : Type u_3} [normed_group E'] [normed_space 𝕜 E'] {H : Type u_4} [topological_space H] {H' : Type u_5} [topological_space H'] {I : model_with_corners 𝕜 E H} {I' : model_with_corners 𝕜 E' H'} {M : Type u_6} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] {M' : Type u_7} [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M'] {E'' : Type u_8} [normed_group E''] [normed_space 𝕜 E''] {H'' : Type u_9} [topological_space H''] {I'' : model_with_corners 𝕜 E'' H''} {M'' : Type u_10} [topological_space M''] [charted_space H'' M''] [smooth_manifold_with_corners I'' M''] {n : with_top ℕ} (f : times_cont_mdiff_map I' I'' M' M'' n) (g : times_cont_mdiff_map I I' M M' n) : times_cont_mdiff_map I I'' M M'' n :=
  mk (fun (a : M) => coe_fn f (coe_fn g a)) sorry

@[simp] theorem comp_apply {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {E' : Type u_3} [normed_group E'] [normed_space 𝕜 E'] {H : Type u_4} [topological_space H] {H' : Type u_5} [topological_space H'] {I : model_with_corners 𝕜 E H} {I' : model_with_corners 𝕜 E' H'} {M : Type u_6} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] {M' : Type u_7} [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M'] {E'' : Type u_8} [normed_group E''] [normed_space 𝕜 E''] {H'' : Type u_9} [topological_space H''] {I'' : model_with_corners 𝕜 E'' H''} {M'' : Type u_10} [topological_space M''] [charted_space H'' M''] [smooth_manifold_with_corners I'' M''] {n : with_top ℕ} (f : times_cont_mdiff_map I' I'' M' M'' n) (g : times_cont_mdiff_map I I' M M' n) (x : M) : coe_fn (comp f g) x = coe_fn f (coe_fn g x) :=
  rfl

protected instance inhabited {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {E' : Type u_3} [normed_group E'] [normed_space 𝕜 E'] {H : Type u_4} [topological_space H] {H' : Type u_5} [topological_space H'] {I : model_with_corners 𝕜 E H} {I' : model_with_corners 𝕜 E' H'} {M : Type u_6} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] {M' : Type u_7} [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M'] {n : with_top ℕ} [Inhabited M'] : Inhabited (times_cont_mdiff_map I I' M M' n) :=
  { default := mk (fun (_x : M) => Inhabited.default) sorry }

/-- Constant map as a smooth map -/
def const {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {E' : Type u_3} [normed_group E'] [normed_space 𝕜 E'] {H : Type u_4} [topological_space H] {H' : Type u_5} [topological_space H'] {I : model_with_corners 𝕜 E H} {I' : model_with_corners 𝕜 E' H'} {M : Type u_6} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] {M' : Type u_7} [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M'] {n : with_top ℕ} (y : M') : times_cont_mdiff_map I I' M M' n :=
  mk (fun (x : M) => y) times_cont_mdiff_const

end times_cont_mdiff_map

protected instance continuous_linear_map.has_coe_to_times_cont_mdiff_map {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {E' : Type u_3} [normed_group E'] [normed_space 𝕜 E'] (n : with_top ℕ) : has_coe (continuous_linear_map 𝕜 E E')
  (times_cont_mdiff_map (model_with_corners_self 𝕜 E) (model_with_corners_self 𝕜 E') E E' n) :=
  has_coe.mk
    fun (f : continuous_linear_map 𝕜 E E') =>
      times_cont_mdiff_map.mk (linear_map.to_fun (continuous_linear_map.to_linear_map f))
        (continuous_linear_map.times_cont_mdiff f)


/-
Copyright (c) 2020 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.set.intervals.basic
import Mathlib.data.set.lattice
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# Intervals in `pi`-space

In this we prove various simple lemmas about intervals in `Π i, α i`. Closed intervals (`Ici x`,
`Iic x`, `Icc x y`) are equal to products of their projections to `α i`, while (semi-)open intervals
usually include the corresponding products as proper subsets.
-/

namespace set

@[simp] theorem pi_univ_Ici {ι : Type u_1} {α : ι → Type u_2} [(i : ι) → preorder (α i)] (x : (i : ι) → α i) : (pi univ fun (i : ι) => Ici (x i)) = Ici x := sorry

@[simp] theorem pi_univ_Iic {ι : Type u_1} {α : ι → Type u_2} [(i : ι) → preorder (α i)] (x : (i : ι) → α i) : (pi univ fun (i : ι) => Iic (x i)) = Iic x := sorry

@[simp] theorem pi_univ_Icc {ι : Type u_1} {α : ι → Type u_2} [(i : ι) → preorder (α i)] (x : (i : ι) → α i) (y : (i : ι) → α i) : (pi univ fun (i : ι) => Icc (x i) (y i)) = Icc x y := sorry

theorem pi_univ_Ioi_subset {ι : Type u_1} {α : ι → Type u_2} [(i : ι) → preorder (α i)] (x : (i : ι) → α i) [Nonempty ι] : (pi univ fun (i : ι) => Ioi (x i)) ⊆ Ioi x := sorry

theorem pi_univ_Iio_subset {ι : Type u_1} {α : ι → Type u_2} [(i : ι) → preorder (α i)] (x : (i : ι) → α i) [Nonempty ι] : (pi univ fun (i : ι) => Iio (x i)) ⊆ Iio x :=
  pi_univ_Ioi_subset x

theorem pi_univ_Ioo_subset {ι : Type u_1} {α : ι → Type u_2} [(i : ι) → preorder (α i)] (x : (i : ι) → α i) (y : (i : ι) → α i) [Nonempty ι] : (pi univ fun (i : ι) => Ioo (x i) (y i)) ⊆ Ioo x y :=
  fun (x_1 : (i : ι) → α i) (hx : x_1 ∈ pi univ fun (i : ι) => Ioo (x i) (y i)) =>
    { left := pi_univ_Ioi_subset (fun (i : ι) => x i) fun (i : ι) (hi : i ∈ univ) => and.left (hx i hi),
      right := pi_univ_Iio_subset (fun (i : ι) => y i) fun (i : ι) (hi : i ∈ univ) => and.right (hx i hi) }

theorem pi_univ_Ioc_subset {ι : Type u_1} {α : ι → Type u_2} [(i : ι) → preorder (α i)] (x : (i : ι) → α i) (y : (i : ι) → α i) [Nonempty ι] : (pi univ fun (i : ι) => Ioc (x i) (y i)) ⊆ Ioc x y :=
  fun (x_1 : (i : ι) → α i) (hx : x_1 ∈ pi univ fun (i : ι) => Ioc (x i) (y i)) =>
    { left := pi_univ_Ioi_subset (fun (i : ι) => x i) fun (i : ι) (hi : i ∈ univ) => and.left (hx i hi),
      right := fun (i : ι) => and.right (hx i trivial) }

theorem pi_univ_Ico_subset {ι : Type u_1} {α : ι → Type u_2} [(i : ι) → preorder (α i)] (x : (i : ι) → α i) (y : (i : ι) → α i) [Nonempty ι] : (pi univ fun (i : ι) => Ico (x i) (y i)) ⊆ Ico x y :=
  fun (x_1 : (i : ι) → α i) (hx : x_1 ∈ pi univ fun (i : ι) => Ico (x i) (y i)) =>
    { left := fun (i : ι) => and.left (hx i trivial),
      right := pi_univ_Iio_subset (fun (i : ι) => y i) fun (i : ι) (hi : i ∈ univ) => and.right (hx i hi) }

theorem pi_univ_Ioc_update_left {ι : Type u_1} {α : ι → Type u_2} [(i : ι) → preorder (α i)] [DecidableEq ι] {x : (i : ι) → α i} {y : (i : ι) → α i} {i₀ : ι} {m : α i₀} (hm : x i₀ ≤ m) : (pi univ fun (i : ι) => Ioc (function.update x i₀ m i) (y i)) =
  (set_of fun (z : (i : ι) → α i) => m < z i₀) ∩ pi univ fun (i : ι) => Ioc (x i) (y i) := sorry

theorem pi_univ_Ioc_update_right {ι : Type u_1} {α : ι → Type u_2} [(i : ι) → preorder (α i)] [DecidableEq ι] {x : (i : ι) → α i} {y : (i : ι) → α i} {i₀ : ι} {m : α i₀} (hm : m ≤ y i₀) : (pi univ fun (i : ι) => Ioc (x i) (function.update y i₀ m i)) =
  (set_of fun (z : (i : ι) → α i) => z i₀ ≤ m) ∩ pi univ fun (i : ι) => Ioc (x i) (y i) := sorry

theorem disjoint_pi_univ_Ioc_update_left_right {ι : Type u_1} {α : ι → Type u_2} [(i : ι) → preorder (α i)] [DecidableEq ι] {x : (i : ι) → α i} {y : (i : ι) → α i} {i₀ : ι} {m : α i₀} : disjoint (pi univ fun (i : ι) => Ioc (x i) (function.update y i₀ m i))
  (pi univ fun (i : ι) => Ioc (function.update x i₀ m i) (y i)) := sorry

theorem pi_univ_Ioc_update_union {ι : Type u_1} {α : ι → Type u_2} [DecidableEq ι] [(i : ι) → linear_order (α i)] (x : (i : ι) → α i) (y : (i : ι) → α i) (i₀ : ι) (m : α i₀) (hm : m ∈ Icc (x i₀) (y i₀)) : ((pi univ fun (i : ι) => Ioc (x i) (function.update y i₀ m i)) ∪
    pi univ fun (i : ι) => Ioc (function.update x i₀ m i) (y i)) =
  pi univ fun (i : ι) => Ioc (x i) (y i) := sorry

/-- If `x`, `y`, `x'`, and `y'` are functions `Π i : ι, α i`, then
the set difference between the box `[x, y]` and the product of the open intervals `(x' i, y' i)`
is covered by the union of the following boxes: for each `i : ι`, we take
`[x, update y i (x' i)]` and `[update x i (y' i), y]`.

E.g., if `x' = x` and `y' = y`, then this lemma states that the difference between a closed box
`[x, y]` and the corresponding open box `{z | ∀ i, x i < z i < y i}` is covered by the union
of the faces of `[x, y]`. -/
theorem Icc_diff_pi_univ_Ioo_subset {ι : Type u_1} {α : ι → Type u_2} [DecidableEq ι] [(i : ι) → linear_order (α i)] (x : (i : ι) → α i) (y : (i : ι) → α i) (x' : (i : ι) → α i) (y' : (i : ι) → α i) : (Icc x y \ pi univ fun (i : ι) => Ioo (x' i) (y' i)) ⊆
  (Union fun (i : ι) => Icc x (function.update y i (x' i))) ∪ Union fun (i : ι) => Icc (function.update x i (y' i)) y := sorry

/-- If `x`, `y`, `z` are functions `Π i : ι, α i`, then
the set difference between the box `[x, z]` and the product of the intervals `(y i, z i]`
is covered by the union of the boxes `[x, update z i (y i)]`.

E.g., if `x = y`, then this lemma states that the difference between a closed box
`[x, y]` and the product of half-open intervals `{z | ∀ i, x i < z i ≤ y i}` is covered by the union
of the faces of `[x, y]` adjacent to `x`. -/
theorem Icc_diff_pi_univ_Ioc_subset {ι : Type u_1} {α : ι → Type u_2} [DecidableEq ι] [(i : ι) → linear_order (α i)] (x : (i : ι) → α i) (y : (i : ι) → α i) (z : (i : ι) → α i) : (Icc x z \ pi univ fun (i : ι) => Ioc (y i) (z i)) ⊆ Union fun (i : ι) => Icc x (function.update z i (y i)) := sorry


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import order.category.PartialOrder
import order.hom.lattice

/-!
# The categories of semilattices

This defines `SemilatticeSup` and `SemilatticeInf`, the categories of sup-semilattices with a bottom
element and inf-semilattices with a top element.

## References

* [nLab, *semilattice*](https://ncatlab.org/nlab/show/semilattice)
-/

universes u
open category_theory

/-- The category of sup-semilattices with a bottom element. -/
structure SemilatticeSup : Type.{u+1} :=
(X : Type.{u})
[is_semilattice_sup : semilattice_sup X]
[is_order_bot : order_bot X]

/-- The category of inf-semilattices with a top element. -/
structure SemilatticeInf : Type.{u+1} :=
(X : Type.{u})
[is_semilattice_inf : semilattice_inf X]
[is_order_top : order_top X]

attribute [protected] SemilatticeSup.X SemilatticeInf.X

namespace SemilatticeSup

instance : has_coe_to_sort SemilatticeSup Type* := ⟨SemilatticeSup.X⟩
attribute [instance] is_semilattice_sup is_order_bot

/-- Construct a bundled `SemilatticeSup` from a `semilattice_sup`. -/
def of (α : Type*) [semilattice_sup α] [order_bot α] : SemilatticeSup := ⟨α⟩

@[simp] lemma coe_of (α : Type*) [semilattice_sup α] [order_bot α] : ↥(of α) = α := rfl

instance : inhabited SemilatticeSup := ⟨of punit⟩

instance : large_category.{u} SemilatticeSup :=
{ hom := λ X Y, sup_bot_hom X Y,
  id := λ X, sup_bot_hom.id X,
  comp := λ X Y Z f g, g.comp f,
  id_comp' := λ X Y, sup_bot_hom.comp_id,
  comp_id' := λ X Y, sup_bot_hom.id_comp,
  assoc' := λ W X Y Z _ _ _, sup_bot_hom.comp_assoc _ _ _ }

instance : concrete_category SemilatticeSup :=
{ forget := { obj := SemilatticeSup.X, map := λ X Y, coe_fn },
  forget_faithful := ⟨λ X Y, fun_like.coe_injective⟩ }

instance has_forget_to_PartialOrder : has_forget₂ SemilatticeSup PartialOrder :=
{ forget₂ := { obj := λ X, ⟨X⟩, map := λ X Y f, f } }

@[simp] lemma coe_forget_to_PartialOrder (X : SemilatticeSup) :
  ↥((forget₂ SemilatticeSup PartialOrder).obj X) = ↥X := rfl

end SemilatticeSup

namespace SemilatticeInf

instance : has_coe_to_sort SemilatticeInf Type* := ⟨SemilatticeInf.X⟩

attribute [instance] is_semilattice_inf is_order_top

/-- Construct a bundled `SemilatticeInf` from a `semilattice_inf`. -/
def of (α : Type*) [semilattice_inf α] [order_top α] : SemilatticeInf := ⟨α⟩

@[simp] lemma coe_of (α : Type*) [semilattice_inf α] [order_top α] : ↥(of α) = α := rfl

instance : inhabited SemilatticeInf := ⟨of punit⟩

instance : large_category.{u} SemilatticeInf :=
{ hom := λ X Y, inf_top_hom X Y,
  id := λ X, inf_top_hom.id X,
  comp := λ X Y Z f g, g.comp f,
  id_comp' := λ X Y, inf_top_hom.comp_id,
  comp_id' := λ X Y, inf_top_hom.id_comp,
  assoc' := λ W X Y Z _ _ _, inf_top_hom.comp_assoc _ _ _ }

instance : concrete_category SemilatticeInf :=
{ forget := { obj := SemilatticeInf.X, map := λ X Y, coe_fn },
  forget_faithful := ⟨λ X Y, fun_like.coe_injective⟩ }

instance has_forget_to_PartialOrder : has_forget₂ SemilatticeInf PartialOrder :=
{ forget₂ := { obj := λ X, ⟨X⟩, map := λ X Y f, f } }

@[simp] lemma coe_forget_to_PartialOrder (X : SemilatticeInf) :
  ↥((forget₂ SemilatticeInf PartialOrder).obj X) = ↥X := rfl

end SemilatticeInf

/-! ### Order dual -/

namespace SemilatticeSup

/-- Constructs an isomorphism of lattices from an order isomorphism between them. -/
@[simps] def iso.mk {α β : SemilatticeSup.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply _ },
  inv_hom_id' := by { ext, exact e.apply_symm_apply _ } }

/-- `order_dual` as a functor. -/
@[simps] def dual : SemilatticeSup ⥤ SemilatticeInf :=
{ obj := λ X, SemilatticeInf.of (order_dual X), map := λ X Y, sup_bot_hom.dual }

end SemilatticeSup

namespace SemilatticeInf

/-- Constructs an isomorphism of lattices from an order isomorphism between them. -/
@[simps] def iso.mk {α β : SemilatticeInf.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply _ },
  inv_hom_id' := by { ext, exact e.apply_symm_apply _ } }

/-- `order_dual` as a functor. -/
@[simps] def dual : SemilatticeInf ⥤ SemilatticeSup :=
{ obj := λ X, SemilatticeSup.of (order_dual X), map := λ X Y, inf_top_hom.dual }

end SemilatticeInf

/-- The equivalence between `SemilatticeSup` and `SemilatticeInf` induced by `order_dual` both ways.
-/
@[simps functor inverse]
def SemilatticeSup_equiv_SemilatticeInf : SemilatticeSup ≌ SemilatticeInf :=
equivalence.mk SemilatticeSup.dual SemilatticeInf.dual
  (nat_iso.of_components (λ X, SemilatticeSup.iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, SemilatticeInf.iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

lemma SemilatticeSup_dual_comp_forget_to_PartialOrder :
  SemilatticeSup.dual ⋙ forget₂ SemilatticeInf PartialOrder =
    forget₂ SemilatticeSup PartialOrder ⋙ PartialOrder.dual := rfl

lemma SemilatticeInf_dual_comp_forget_to_PartialOrder :
  SemilatticeInf.dual ⋙ forget₂ SemilatticeSup PartialOrder =
    forget₂ SemilatticeInf PartialOrder ⋙ PartialOrder.dual := rfl


import .core

namespace tts ------------------------------------------------------------------
namespace typing ---------------------------------------------------------------
variables {V : Type} [decidable_eq V] -- Type of variable names
variables {x y : tagged V} -- Variables
variables {e ex e₁ : exp V} -- Expressions
variables {t : typ V} -- Types
variables {s s' : sch V} -- Type schemes
variables {Γ Γ₁ Γ₂ Γ₃ : env V} -- Environments
variables {L : finset (tagged V)} -- Variable sets

open finmap occurs exp typ sch

theorem weaken_middle :
  disjoint (dom Γ₁) (dom Γ₂) →
  disjoint (dom Γ₂) (dom Γ₃) →
  disjoint (dom Γ₁) (dom Γ₃) →
  typing (Γ₁ ∪ Γ₃) e t →
  typing (Γ₁ ∪ Γ₂ ∪ Γ₃) e t :=
begin
  generalize Γeq : Γ₁ ∪ Γ₃ = Γ₁₃,
  intros dj₁₂ dj₂₃ dj₁₃ T,
  induction T generalizing Γ₁ Γ₃,
  case typing.var : Γ x s ts b ln_eq lts ls {
    induction Γeq,
    exact var (mem_union_middle_left dj₁₃ dj₂₃ b) ln_eq lts ls,
  },
  case typing.app : Γ ef ea t₁ t₂ Tf Ta ihf iha {
    exact app (ihf Γeq dj₁₂ dj₂₃ dj₁₃) (iha Γeq dj₁₂ dj₂₃ dj₁₃),
  },
  case typing.lam : v Γ eb t₁ t₂ L lt₁ Ft₂ ihb {
    apply lam (L ∪ dom (Γ₁ ∪ Γ₂ ∪ Γ₃)) lt₁,
    introv nm,
    simp [not_or_distrib, and_assoc] at nm,
    rw [←insert_union, ←insert_union],
    induction Γeq,
    exact ihb nm.1 insert_union
      (disjoint_keys_insert_left.mpr ⟨nm.2.1, dj₁₂⟩)
      dj₂₃
      (disjoint_keys_insert_left.mpr ⟨nm.2.2.2, dj₁₃⟩),
  },
  case typing.let_ : v Γ ed eb sd tb Ld Lb _ _ ihd ihb {
    apply let_ sd (Ld ∪ dom (Γ₁ ∪ Γ₂ ∪ Γ₃)) (Lb ∪ dom (Γ₁ ∪ Γ₂ ∪ Γ₃)),
    { introv ln_eq nd nm,
      simp [not_or_distrib, and_assoc] at nm,
      exact ihd ln_eq nd (λ _ h, (nm _ h).1) Γeq dj₁₂ dj₂₃ dj₁₃ },
    { introv nm,
      simp [not_or_distrib, and_assoc] at nm,
      rw [←insert_union, ←insert_union],
      induction Γeq,
      exact ihb nm.1 insert_union
        (disjoint_keys_insert_left.mpr ⟨nm.2.1, dj₁₂⟩)
        dj₂₃
        (disjoint_keys_insert_left.mpr ⟨nm.2.2.2, dj₁₃⟩) }
  }
end

theorem weaken :
  disjoint (dom Γ₁) (dom Γ₂) →
  typing Γ₂ e t →
  typing (Γ₁ ∪ Γ₂) e t :=
begin
  intros dj T,
  rw ←empty_union Γ₂ at T,
  rw ←empty_union Γ₁ at ⊢,
  exact weaken_middle (finset.disjoint_empty_left _) dj (finset.disjoint_empty_left _) T
end

lemma ne_of_nm : x ∉ L ∪ dom (Γ₁ ∪ finmap.singleton (y :~ s) ∪ Γ₂) → y ≠ x :=
by simp [not_or_distrib]; tauto

lemma nmL_of_nm : x ∉ L ∪ dom (Γ₁ ∪ finmap.singleton (y :~ s) ∪ Γ₂) → x ∉ L :=
by simp [not_or_distrib]; tauto

lemma nmΓ₂_of_nm : x ∉ L ∪ dom (Γ₁ ∪ finmap.singleton (y :~ s) ∪ Γ₂) → x ∉ dom Γ₂ :=
by simp [not_or_distrib]; tauto

lemma nm_ins : x ∉ dom (Γ₁ ∪ Γ₂) → y ∉ L ∪ dom (Γ₁ ∪ finmap.singleton (x :~ s) ∪ Γ₂) →
  x ∉ dom (insert (binding.mk y s') Γ₁ ∪ Γ₂) :=
by simp [not_or_distrib]; tauto

theorem subst_weaken :
  disjoint (dom Γ₁) (dom Γ₂) →
  x ∉ dom (Γ₁ ∪ Γ₂) →
  lc ex →
  (∀ {ts : list (typ V)}, s.arity = ts.length → (∀ (t : typ V), t ∈ ts → lc t) → typing Γ₂ ex (open_typs ts s)) →
  typing (Γ₁ ∪ finmap.singleton (x :~ s) ∪ Γ₂) e t →
  typing (Γ₁ ∪ Γ₂) (subst x ex e) t :=
begin
  generalize Γeq : Γ₁ ∪ finmap.singleton (x :~ s) ∪ Γ₂ = Γ₁₂,
  intros dj nmd lex Tex T,
  induction T generalizing Γ₁ Γ₂ x s ex,
  case typing.var : Γ y s' ts b ln_eq lts ls {
    induction Γeq,
    have b : y :~ s' ∈ Γ₁ ∨ y :~ s' ∈ finmap.singleton (x :~ s) ∨ y :~ s' ∈ Γ₂ :=
      (or_assoc _ _).mp (or.imp_left mem_of_mem_union (mem_of_mem_union b)),
    by_cases h : x = y,
    { induction h,
      simp [not_or_distrib] at nmd,
      rcases b with m | m | m,
      { exact absurd (mem_keys_of_mem m) nmd.1 },
      { simp at m, induction m, simp [weaken dj (Tex ln_eq lts)] },
      { exact absurd (mem_keys_of_mem m) nmd.2 } },
    { rcases b with m | m | m,
      { simp [h, var ((mem_union dj).mpr (or.inl m)) ln_eq lts ls] },
      { simp at m, exact absurd m.1.symm h },
      { simp [h, var ((mem_union dj).mpr (or.inr m)) ln_eq lts ls] } } },
  case typing.app : Γ ef ea t₁ t₂ Tf Ta ihf iha {
    exact app (ihf Γeq dj nmd lex @Tex) (iha Γeq dj nmd lex @Tex) },
  case typing.lam : v Γ eb t₁ t₂ L lt₁ Ft₂ ihb {
    apply lam (L ∪ dom (Γ₁ ∪ finmap.singleton (x :~ s) ∪ Γ₂)) lt₁,
    induction Γeq,
    intros y nm,
    rw ←subst_open_var lex (ne_of_nm nm),
    rw ←insert_union,
    exact ihb (nmL_of_nm nm)
      (by rw [insert_union, insert_union])
      (disjoint_keys_insert_left.mpr ⟨by exact nmΓ₂_of_nm nm, dj⟩)
      (nm_ins nmd nm)
      lex
      @Tex },
  case typing.let_ : v Γ ed eb sd tb Ld Lb _ _ ihd ihb {
    dsimp at ihd ihb,
    apply let_ sd
      (Ld ∪ dom (Γ₁ ∪ finmap.singleton (x :~ s) ∪ Γ₂))
      (Lb ∪ dom (Γ₁ ∪ finmap.singleton (x :~ s) ∪ Γ₂)),
    { intros xs ln_eq nd nm,
      exact ihd ln_eq nd (λ _ h, nmL_of_nm (nm _ h)) Γeq dj nmd lex @Tex },
    { induction Γeq,
      intros y nm,
      rw ←subst_open_var lex (ne_of_nm nm),
      rw ←insert_union,
      exact ihb (nmL_of_nm nm)
        (by rw [insert_union, insert_union])
        (disjoint_keys_insert_left.mpr ⟨by exact nmΓ₂_of_nm nm, dj⟩)
        (nm_ins nmd nm)
        lex
        @Tex } }
end

-- Expression substitution preserves typing.
theorem exp_subst_preservation :
  x ∉ dom Γ →
  lc ex →
  (∀ {ts : list (typ V)}, s.arity = ts.length → (∀ (t : typ V), t ∈ ts → lc t) → typing Γ ex (open_typs ts s)) →
  typing (finmap.singleton (x :~ s) ∪ Γ) e₁ t →
  typing Γ (subst x ex e₁) t :=
begin
  intros nm lex Tex T,
  rw ←empty_union (finmap.singleton (x :~ s)) at T,
  rw ←empty_union Γ,
  exact subst_weaken (finset.disjoint_empty_left _) (by simp [nm]) lex @Tex T
end

-- Typing implies a locally-closed expression
theorem lc_exp (T : typing Γ e t) : lc e :=
begin
  induction T,
  case typing.var { simp },
  case typing.app { simp * },
  case typing.lam { simp [exp.lc_body, *], tauto },
  case typing.let_ : v _ ed _ _ _ _ _ _ _ ihd {
    dsimp at ihd,
    have : lc ed := ihd
      ((fresh.tagged v).pgenl_length_eq _ _)
      ((fresh.tagged v).pgenl_nodup _ _)
      (λ _, (fresh.tagged v).pgenl_not_mem),
    simp [exp.lc_body, *],
    tauto
  }
end

-- Typing implies a locally-closed type
theorem lc_typ (T : typing Γ e t) : lc t :=
begin
  induction T,
  case typing.var : _ _ _ _ _ ln_eq lts ls {
    exact lc_open_typs ls ln_eq lts },
  case typing.app : Γ ef ea t₁ t₂ Tf Ta ihf iha {
    simp at ihf,
    cases ihf with _ lt₂,
    exact lt₂ },
  case typing.lam : v _ _ _ _ L lt₁ _ ihb {
    dsimp at ihb,
    simp [lt₁, ihb ((fresh.tagged v).gen_not_mem L)] },
  case typing.let_ : v _ _ _ _ _ _ Lb _ _ _ ihb {
    exact ihb ((fresh.tagged v).gen_not_mem Lb) }
end

end /- namespace -/ typing -----------------------------------------------------
end /- namespace -/ tts --------------------------------------------------------


/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author(s): Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.control.uliftable
import Mathlib.Lean3Lib.system.random
import Mathlib.system.random.basic
import Mathlib.PostPort

universes u u_1 v

namespace Mathlib

/-!
# `gen` Monad

This monad is used to formulate randomized computations with a parameter
to specify the desired size of the result.

This is a port of the Haskell QuickCheck library.

## Main definitions
  * `gen` monad

## Local notation

 * `i .. j` : `Icc i j`, the set of values between `i` and `j` inclusively;

## Tags

random testing

## References

  * https://hackage.haskell.org/package/QuickCheck

-/

namespace slim_check

/-- Monad to generate random examples to test properties with.
It has a `nat` parameter so that the caller can decide on the
size of the examples. -/
def gen (α : Type u) := reader_t (ulift ℕ) rand α

/-- Execute a `gen` inside the `io` monad using `i` as the example
size and with a fresh random number generator. -/
def io.run_gen {α : Type} (x : gen α) (i : ℕ) : io α := io.run_rand (reader_t.run x (ulift.up i))

namespace gen

/-- Lift `random.random` to the `gen` monad. -/
def choose_any (α : Type u) [random α] : gen α := reader_t.mk fun (_x : ulift ℕ) => rand.random α

/-- Lift `random.random_r` to the `gen` monad. -/
def choose {α : Type u} [preorder α] [bounded_random α] (x : α) (y : α) (p : x ≤ y) :
    gen ↥(set.Icc x y) :=
  reader_t.mk fun (_x : ulift ℕ) => rand.random_r x y p

/-- Generate a `nat` example between `x` and `y`. -/
def choose_nat (x : ℕ) (y : ℕ) (p : x ≤ y) : gen ↥(set.Icc x y) := choose x y p

/-- Generate a `nat` example between `x` and `y`. -/
def choose_nat' (x : ℕ) (y : ℕ) (p : x < y) : gen ↥(set.Ico x y) :=
  (fun (this : ∀ (i : ℕ), x < i → i ≤ y → Nat.pred i < y) =>
      subtype.map Nat.pred sorry <$> choose (x + 1) y p)
    sorry

protected instance uliftable : uliftable gen gen :=
  reader_t.uliftable' (equiv.trans equiv.ulift (equiv.symm equiv.ulift))

protected instance has_orelse : has_orelse gen :=
  has_orelse.mk
    fun (α : Type u) (x y : gen α) =>
      do
        let b ← uliftable.up (choose_any Bool)
        ite (↥(ulift.down b)) x y

/-- Get access to the size parameter of the `gen` monad. For
reasons of universe polymorphism, it is specified in
continuation passing style. -/
def sized {α : Type u} (cmd : ℕ → gen α) : gen α := reader_t.mk fun (_x : ulift ℕ) => sorry

/-- Apply a function to the size parameter. -/
def resize {α : Type u} (f : ℕ → ℕ) (cmd : gen α) : gen α := reader_t.mk fun (_x : ulift ℕ) => sorry

/-- Create `n` examples using `cmd`. -/
def vector_of {α : Type u} (n : ℕ) (cmd : gen α) : gen (vector α n) := sorry

/-- Create a list of examples using `cmd`. The size is controlled
by the size parameter of `gen`. -/
def list_of {α : Type u} (cmd : gen α) : gen (List α) :=
  sized
    fun (sz : ℕ) =>
      do
        uliftable.up (choose_nat 0 (sz + 1) sorry)
        sorry

/-- Given a list of example generators, choose one to create an example. -/
def one_of {α : Type u} (xs : List (gen α)) (pos : 0 < list.length xs) : gen α :=
  do
    uliftable.up (choose_nat' 0 (list.length xs) pos)
    sorry

/-- Given a list of example generators, choose one to create an example. -/
def elements {α : Type u} (xs : List α) (pos : 0 < list.length xs) : gen α :=
  do
    uliftable.up (choose_nat' 0 (list.length xs) pos)
    sorry

/--
`freq_aux xs i _` takes a weighted list of generator and a number meant to select one of the generators.

If we consider `freq_aux [(1, gena), (3, genb), (5, genc)] 4 _`, we choose a generator by splitting
the interval 1-9 into 1-1, 2-4, 5-9 so that the width of each interval corresponds to one of the
number in the list of generators. Then, we check which interval 4 falls into: it selects `genb`.
-/
def freq_aux {α : Type u} (xs : List (ℕ+ × gen α)) (i : ℕ) :
    i < list.sum (list.map (subtype.val ∘ prod.fst) xs) → gen α :=
  sorry

/--
`freq [(1, gena), (3, genb), (5, genc)] _` will choose one of `gena`, `genb`, `genc` with
probabiities proportional to the number accompanying them. In this example, the sum of
those numbers is 9, `gena` will be chosen with probability ~1/9, `genb` with ~3/9 (i.e. 1/3)
and `genc` with probability 5/9.
-/
def freq {α : Type u} (xs : List (ℕ+ × gen α)) (pos : 0 < list.length xs) : gen α :=
  let s : ℕ := list.sum (list.map (subtype.val ∘ prod.fst) xs);
  (fun (ha : 1 ≤ s) =>
      (fun (this : 0 ≤ s - 1) =>
          uliftable.adapt_up gen gen (choose_nat 0 (s - 1) this)
            fun (i : ↥(set.Icc 0 (s - 1))) => freq_aux xs (subtype.val i) sorry)
        sorry)
    sorry

/-- Generate a random permutation of a given list. -/
def permutation_of {α : Type u} (xs : List α) : gen (Subtype (list.perm xs)) := sorry

end Mathlib


import analysis.normed.group.SemiNormedGroup.kernels

import Lbar.basic
import normed_group.pseudo_normed_group
import combinatorial_lemma.partition
import combinatorial_lemma.lem97
import polyhedral_lattice.pseudo_normed_group
import pseudo_normed_group.splittable

import hacks_and_tricks.by_exactI_hack

/-!
In this file we state and prove 9.8 of [Analytic].
-/

noncomputable theory

open_locale nnreal big_operators

open pseudo_normed_group combinatorial_lemma

variables (Λ : Type*) (r' : ℝ≥0) (S : Type*)
variables [fintype S] [polyhedral_lattice Λ]

section

variables {S Λ r'}

-- ugly name
@[simps]
def Lbar.mk_aux'
  (x : Λ →+ Lbar r' S) (y : S → ℕ → Λ →+ ℤ)
  (h : ∀ s n l, (y s n l).nat_abs ≤ (x l s n).nat_abs) :
  Λ →+ Lbar r' S :=
add_monoid_hom.mk' (λ l,
{ to_fun := λ s n, y s n l,
  coeff_zero' := λ s,
  begin
    specialize h s 0 l,
    simpa only [int.nat_abs_eq_zero, Lbar.coeff_zero, le_zero_iff, int.nat_abs_zero] using h
  end,
  summable' :=
  begin
    intro s,
    apply nnreal.summable_of_le _ ((x l).summable s),
    intro n,
    refine mul_le_mul' _ le_rfl,
    norm_cast,
    exact (h _ _ _)
  end }) $ λ l₁ l₂, by { ext s n, exact (y s n).map_add l₁ l₂ }

-- jmc: It seems to me that we cannot easily define this using `Lbar.mk_aux'` above
@[simps]
def Lbar.mk_aux
  {ι : Type} [fintype ι] {l : ι → Λ} (hl : generates_norm l)
  (x : Λ →+ Lbar r' S) (y : S → ℕ → Λ →+ ℤ)
  (h : ∀ s n i, (y s n (l i)).nat_abs ≤ (x (l i) s n).nat_abs) :
  Λ →+ Lbar r' S :=
add_monoid_hom.mk' (λ l',
{ to_fun := λ s n, y s n l',
  coeff_zero' := λ s,
  begin
    obtain ⟨c, h1, -⟩ := hl l',
    rw [h1, add_monoid_hom.map_sum, finset.sum_eq_zero],
    rintro i -,
    suffices : y s 0 (l i) = 0,
    { rw [add_monoid_hom.map_nsmul, this, nsmul_zero] },
    specialize h s 0 i,
    simpa only [int.nat_abs_eq_zero, Lbar.coeff_zero, le_zero_iff, int.nat_abs_zero] using h
  end,
  summable' :=
  begin
    intro s,
    obtain ⟨c, h1, -⟩ := hl.generates_nnnorm l',
    rw h1,
    suffices : summable (λ n, ∑ i, c i • ↑(y s n (l i)).nat_abs * r' ^ n),
    { apply nnreal.summable_of_le _ this,
      intro n,
      rw ← finset.sum_mul,
      refine mul_le_mul' _ le_rfl,
      simp only [add_monoid_hom.map_sum, nnreal.coe_nat_abs, add_monoid_hom.map_nsmul],
      refine le_trans (nnnorm_sum_le _ _) (le_of_eq (fintype.sum_congr _ _ _)),
      intro i,
      simp only [nsmul_eq_mul, ← nnreal.coe_nat_abs,
        int.nat_abs_mul, int.nat_abs_of_nat, nat.cast_mul] },
    apply summable_sum,
    rintro i -,
    apply nnreal.summable_of_le _ ((c i • x (l i)).summable s),
    intro n,
    refine mul_le_mul' _ le_rfl,
    simp only [nsmul_eq_mul, ← nnreal.coe_nat_abs, int.nat_abs_mul,
        int.nat_abs_of_nat, ← nat.cast_mul, Lbar.coe_nsmul, pi.mul_apply, pi.nat_apply],
    norm_cast,
    exact nat.mul_le_mul le_rfl (h _ _ _)
  end }) $ λ l₁ l₂, by { ext s n, exact (y s n).map_add l₁ l₂ }

end

variables {Λ r' S}

lemma Lbar.mk_aux_mem_filtration
  (ι : Type) (c : ℝ≥0) (N : ℕ) (hN : 0 < N) [fintype ι]
  {l : ι → Λ} (hl : generates_norm l)
  {x : Λ →+ Lbar r' S}
  (hx : x ∈ filtration (Λ →+ Lbar r' S) c)
  (x₀' : S → ℕ → Λ →+ ℤ)
  (x₁' : S → ℕ → Λ →+ ℤ)
  (x' : S → ℕ → Λ →+ ℤ)
  (hx' : ∀ l s n, x l s n = x' s n l)
  (H : ∀ s n i, (x' s n (l i)).nat_abs =
    N * (x₀' s n (l i)).nat_abs + (x₁' s n (l i)).nat_abs)
  (H' : ∀ s n i, (x₀' s n (l i)).nat_abs ≤ (x (l i) s n).nat_abs) :
  Lbar.mk_aux hl x x₀' H' ∈ filtration (Λ →+ Lbar r' S) (c / ↑N) :=
begin
  set x₀ := Lbar.mk_aux hl x x₀' H',
  have aux : c = (N : ℝ≥0) * (c / N),
  { rw [mul_comm, div_mul_cancel],
    exact_mod_cast hN.ne' },
  have hN' : (0: ℝ≥0) < N,
  {  exact_mod_cast hN },
  rw hl.add_monoid_hom_mem_filtration_iff at hx ⊢,
  intro i,
  specialize hx i,
  rw Lbar.mem_filtration_iff at hx ⊢,
  rw [← mul_le_mul_left hN', ← mul_assoc, ← aux, ← nsmul_eq_mul, ← Lbar.nnnorm_nsmul],
  refine le_trans (finset.sum_le_sum _) hx,
  rintro s -,
  refine tsum_le_tsum _ (Lbar.summable _ s) ((x (l i)).summable s),
  intro n,
  refine mul_le_mul' _ le_rfl,
  norm_cast,
  convert le_trans (le_add_right le_rfl) (H s n i).ge,
  swap, { apply hx' },
  rw [← int.nat_abs_of_nat N, ← int.nat_abs_mul, int.nat_abs_of_nat, ← nsmul_eq_mul],
  congr' 1,
end

@[simps]
def Lbar.mk_of_add_monoid_hom [fact (r' < 1)] (x : S → ℕ → Λ →+ ℤ) (a : Λ →+ ℤ)
  [∀ s n, decidable (x s n = a)] :
  Lbar r' S :=
Lbar.of_mask (Lbar.geom r' S) $ λ s n, x s n = a

@[simps apply]
def Lbar.mk_tensor (a : Λ →+ ℤ) (x : Lbar r' S) : Λ →+ Lbar r' S :=
add_monoid_hom.mk' (λ l, a l • x) $ λ l₁ l₂, by rw [a.map_add, add_smul]

-- better name?
lemma lem_98_aux [fact (r' < 1)] (A : finset (Λ →+ ℤ))
  (x₁' : S → ℕ → Λ →+ ℤ) [∀ s n a, decidable (x₁' s n = a)]
  (hx₁' : ∀ s n, x₁' s n ∈ A) (x₁ : Λ →+ Lbar r' S)
  (hx₁ : ∀ l s n, x₁ l s n = x₁' s n l) (l : Λ) :
  x₁ l = ∑ a in A, a l • Lbar.mk_of_add_monoid_hom x₁' a :=
begin
  ext s n,
  simp only [finset.sum_apply, Lbar.coe_sum, pi.smul_apply, Lbar.coe_zsmul,
    Lbar.coe_mk],
  rw [finset.sum_eq_single (x₁' s n)],
  { simp only [true_and, and_congr, if_congr, eq_self_iff_true, if_true,
          Lbar.mk_of_add_monoid_hom_to_fun],
    split_ifs with hn,
    { rw [smul_eq_mul, mul_zero, hn], exact (x₁ l).coeff_zero s },
    { simp only [smul_eq_mul, mul_one, hx₁] } },
  { intros a haA ha,
    simp only [ha.symm, false_and, if_false, smul_eq_mul, mul_zero,
      Lbar.mk_of_add_monoid_hom_to_fun] },
  { intro hsn, exact (hsn (hx₁' s n)).elim }
end

lemma fintype_prod_nat_equiv_nat (S : Type*) [fintype S] [hS : nonempty S] :
  nonempty (S × ℕ ≃ ℕ) :=
begin
  classical,
  obtain e' := fintype.equiv_fin S,
  refine nonempty.intro _,
  calc S × ℕ ≃ fin (fintype.card S) × ℕ : equiv.prod_congr_left (λ _, e')
         ... ≃ ℕ : classical.choice $ cardinal.eq.1 _,
  rw [← cardinal.lift_id (cardinal.mk ℕ),
    cardinal.mk_prod, ← cardinal.aleph_0, cardinal.mul_eq_right];
  simp [le_of_lt (cardinal.nat_lt_aleph_0 _), le_refl],
  rw ← fintype.card_pos_iff at hS,
  exact_mod_cast hS.ne'
end

lemma lem98_int [fact (r' < 1)] (N : ℕ) (hN : 0 < N) (c : ℝ≥0)
  (x : Lbar r' S) (hx : x ∈ filtration (Lbar r' S) c)
  (H : ∀ s n, (x s n).nat_abs ≤ 1) :
  ∃ y : fin N → Lbar r' S, (x = ∑ i, y i) ∧
      (∀ i, y i ∈ filtration (Lbar r' S) (c/N + 1)) :=
begin
  by_cases hS : nonempty S, swap,
  { refine ⟨λ i, 0, _, _⟩,
    { ext s n, exact (hS ⟨s⟩).elim },
    { intro, exact zero_mem_filtration _ } },
  resetI,
  obtain ⟨e⟩ := fintype_prod_nat_equiv_nat S,
  let f : ℕ → ℝ≥0 :=
    λ n, ↑(x (e.symm n).1 (e.symm n).2).nat_abs * r' ^ (e.symm n).2,
  have summable_f : summable f,
  { rw [← e.summable_iff, ← (equiv.sigma_equiv_prod S ℕ).summable_iff],
    simp only [function.comp, f, e.symm_apply_apply, nnreal.summable_sigma,
      equiv.sigma_equiv_prod_apply],
    -- TODO, missing lemma `fintype.summable`
    exact ⟨x.summable, ⟨_, has_sum_fintype _⟩⟩ },
  have f_aux : ∀ n, f n ≤ 1,
  { intro n,
    calc f n ≤ 1 * 1 : mul_le_mul' _ _
    ... = 1 : mul_one 1,
    { exact_mod_cast (H _ _) },
    { have : fact (r' < 1) := ‹_›, exact pow_le_one _ zero_le' this.out.le } },
  obtain ⟨mask, h1, h2⟩ := exists_partition N hN f f_aux summable_f,
  classical,
  let y := λ i, Lbar.of_mask x (λ s n, (e (s, n)) ∈ mask i),
  have hxy : x = ∑ i, y i,
  { ext s n,
    simp only [Lbar.coe_sum, if_congr, function.curry_apply, fintype.sum_apply,
      function.comp_app, Lbar.of_mask_to_fun, finset.sum_congr],
    obtain ⟨i, hi1, hi2⟩ := h1 (e (s, n)),
    rw [finset.sum_eq_single i, if_pos hi1],
    { rintro j - hj,
      rw if_neg,
      exact mt (hi2 j) hj },
    { intro hi, exact (hi (finset.mem_univ i)).elim } },
  refine ⟨y, hxy, _⟩,
  intro i,
  rw [Lbar.mem_filtration_iff] at hx ⊢,
  suffices : ∥x∥₊ = ∑' n, f n ∧ ∥y i∥₊ = ∑' (n : ℕ), (mask i).indicator f n,
  { calc ∥y i∥₊ = ∑' (n : ℕ), (mask i).indicator f n : this.right
            ... ≤ (∑' (n : ℕ), f n) / N + 1         : h2 i
            ... ≤ c / N + 1                         : _,
    simp only [div_eq_mul_inv],
    refine add_le_add (mul_le_mul' _ le_rfl) le_rfl,
    exact this.left.ge.trans hx },
  split,
  { calc ∑ s, ∑' n, ↑(x s n).nat_abs * r' ^ n
        = ∑' s, ∑' n, ↑(x s n).nat_abs * r' ^ n : (tsum_fintype _).symm
    ... = _ : _
    ... = ∑' n, f n : e.tsum_eq _,
    rw [← (equiv.sigma_equiv_prod S ℕ).tsum_eq], swap, { apply_instance },
    dsimp only [f, equiv.sigma_equiv_prod_apply],
    simp only [equiv.symm_apply_apply],
    rw [tsum_sigma'],
    { exact x.summable },
    { rw nnreal.summable_sigma, exact ⟨x.summable, ⟨_, has_sum_fintype _⟩⟩ } },
  { calc ∑ s, ∑' n, ↑(y i s n).nat_abs * r' ^ n
        = ∑' s, ∑' n, ↑(y i s n).nat_abs * r' ^ n : (tsum_fintype _).symm
    ... = ∑' x, (mask i).indicator f (e x) : _
    ... = ∑' n, (mask i).indicator f n : e.tsum_eq _,
    rw [← (equiv.sigma_equiv_prod S ℕ).tsum_eq], swap, { apply_instance },
    have aux : ∀ i s n h1, @ite _ (e (s, n) ∈ mask i) h1 (↑(x s n).nat_abs * r' ^ n) 0 =
      ↑(@ite _ (e (s, n) ∈ mask i) h1 (x s n) 0).nat_abs * r' ^ n,
    { intros, split_ifs; simp only [int.nat_abs_zero, nat.cast_zero, zero_mul, eq_self_iff_true] },
    dsimp only [f, y, set.indicator, equiv.sigma_equiv_prod_apply],
    simp only [equiv.symm_apply_apply, Lbar.of_mask_to_fun, aux],
    rw [tsum_sigma'],
    { exact (y i).summable },
    { rw nnreal.summable_sigma,
      exact ⟨(y i).summable, ⟨_, has_sum_fintype _⟩⟩ } }
end

lemma lem98_aux' [fact (r' < 1)] (N : ℕ)
  (A : finset (Λ →+ ℤ))
  (x x₀ x₁ : Λ →+ Lbar r' S)
  (x' x₀' x₁' : S → ℕ → Λ →+ ℤ) [∀ s n a, decidable (x₁' s n = a)]
  (H : ∀ s n, x' s n = N • x₀' s n + x₁' s n)
  (hx : ∀ l s n, x l s n = x' s n l)
  (hx₀ : ∀ l s n, x₀ l s n = x₀' s n l)
  (hx₁ : ∀ l s n, x₁ l s n = x₁' s n l)
  (Hx₁ : ∀ (l : Λ), x₁ l = ∑ (a : Λ →+ ℤ) in A, a l • Lbar.mk_of_add_monoid_hom x₁' a)
  (y' : (Λ →+ ℤ) → fin N → Lbar r' S)
  (hy' : ∀ (a : Λ →+ ℤ), Lbar.mk_of_add_monoid_hom x₁' a = finset.univ.sum (y' a))
  (y : fin N → Λ →+ Lbar r' S)
  (hy : ∀ i, y i = x₀ + ∑ a in A, Lbar.mk_tensor a (y' a i)) :
  x = ∑ (i : fin N), y i :=
begin
  intros,
  ext l s n,
  simp only [hx, H, hy, ← hx₁, Hx₁, hy', Lbar.coe_add, finset.sum_apply, add_monoid_hom.add_apply,
    Lbar.coe_sum, pi.add_apply, Lbar.mk_tensor_apply, finset.sum_congr,
    add_monoid_hom.smul_apply, pi.smul_apply, add_monoid_hom.finset_sum_apply, finset.smul_sum],
  rw [finset.sum_add_distrib, finset.sum_const, finset.card_univ,
    fintype.card_fin, finset.sum_comm, ← hx₀],
end

lemma lem98_crux [fact (r' < 1)] {ι : Type} {l : ι → Λ}
  (N : ℕ) (hN : 0 < N) (A : finset (Λ →+ ℤ))
  (x x₀ x₁ : Λ →+ Lbar r' S)
  (x' x₀' x₁' : S → ℕ → Λ →+ ℤ) [∀ s n a, decidable (x₁' s n = a)]
  (xₐ : (Λ →+ ℤ) → Lbar r' S)
  (hx : ∀ l s n, x l s n = x' s n l)
  (hx₀ : ∀ l s n, x₀ l s n = x₀' s n l)
  (hx₁ : ∀ l s n, x₁ l s n = x₁' s n l)
  (hxₐ : ∀ a, xₐ a = Lbar.mk_of_add_monoid_hom x₁' a)
  (Hx₁ : ∀ (l : Λ), x₁ l = ∑ (a : Λ →+ ℤ) in A, a l • xₐ a)
  (hx₁'A : ∀ s n, x₁' s n ∈ A)
  (H : ∀ s n i, (x' s n (l i)).nat_abs =
    N * (x₀' s n (l i)).nat_abs + (x₁' s n (l i)).nat_abs)
  (i : ι) :
  ∥x (l i)∥₊ = N • ∥x₀ (l i)∥₊ + ∑ a in A, ∥a (l i)∥₊ * ∥xₐ a∥₊ :=
begin
  simp only [hx, H, ← hx₀, ← hx₁, Lbar.nnnorm_def,
    nsmul_eq_mul, mul_assoc,
    finset.smul_sum, finset.mul_sum, nat.cast_add, nat.cast_mul, add_mul],
  rw [finset.sum_comm, ← finset.sum_add_distrib],
  apply fintype.sum_congr,
  intro s,
  apply nnreal.eq,
  simp only [nnreal.coe_tsum, nnreal.coe_sum, nnreal.coe_add, nnreal.coe_mul,
    nnreal.coe_pow, nnreal.coe_nat_cast, nnreal.coe_nat_abs, coe_nnnorm],
  rw [tsum_add _ ((x₁ (l i)).summable_coe_real s)], swap,
  { rw ← summable_mul_left_iff,
    { exact (x₀ (l i)).summable_coe_real s },
    { exact_mod_cast hN.ne' } },
  simp only [← tsum_mul_left],
  rw [← tsum_sum], swap,
  { intros a ha, exact summable.mul_left _ ((xₐ a).summable_coe_real s) },
  simp only [← mul_assoc, ← finset.sum_mul, hxₐ, Hx₁],
  congr, ext n, congr,
  simp only [finset.sum_apply, Lbar.coe_sum, Lbar.mk_of_add_monoid_hom_to_fun,
    pi.smul_apply],
  rw [finset.sum_eq_single (x₁' s n), finset.sum_eq_single (x₁' s n)],
  { simp only [Lbar.coe_zsmul, Lbar.mk_of_add_monoid_hom_to_fun, if_true,
      pi.smul_apply, eq_self_iff_true, true_and, if_congr, and_congr],
    split_ifs,
    { simp only [mul_zero, norm_zero, smul_eq_mul] },
    { simp only [int.norm_eq_abs, ← abs_mul, ← int.cast_mul, smul_eq_mul] } },
  all_goals { try { intro hsnA, exact (hsnA (hx₁'A s n)).elim } },
  all_goals { intros a haA hasn },
  { simp only [hasn.symm, Lbar.mk_of_add_monoid_hom_to_fun, norm_zero,
      mul_zero, if_congr, and_congr, eq_self_iff_true, if_false, false_and] },
  { simp only [hasn.symm, Lbar.coe_zsmul, pi.smul_apply, smul_eq_mul,
      Lbar.mk_of_add_monoid_hom_to_fun, mul_zero,
      if_congr, and_congr, eq_self_iff_true, if_false, false_and] },
end
.

namespace lem98

def ι (Λ : Type*) [polyhedral_lattice Λ] : Type :=
(polyhedral_lattice.polyhedral Λ).some

instance : fintype (ι Λ) := (polyhedral_lattice.polyhedral Λ).some_spec.some

variables (Λ)

def l : ι Λ → Λ := (polyhedral_lattice.polyhedral Λ).some_spec.some_spec.some

lemma hl : generates_norm (l Λ) :=
by convert (polyhedral_lattice.polyhedral Λ).some_spec.some_spec.some_spec.1

lemma hl' : ∀ i, l Λ i ≠ 0 :=
(polyhedral_lattice.polyhedral Λ).some_spec.some_spec.some_spec.2

def A (N : ℕ) [hN : fact (0 < N)] := (lem97' N hN.1 (l Λ)).some

lemma hA (N : ℕ) [hN : fact (0 < N)] (x : Λ →+ ℤ) :
  ∃ x' (H : x' ∈ A Λ N) y, x = N • y + x' ∧
    ∀ i, (x (l Λ i)).nat_abs = N * (y (l Λ i)).nat_abs + (x' (l Λ i)).nat_abs :=
(lem97' N hN.1 (l Λ)).some_spec x

def d  (N : ℕ) [hN : fact (0 < N)] : ℝ≥0 :=
finset.univ.sup (λ i, ∑ a in A Λ N, ∥a (l Λ i)∥₊ / ∥l Λ i∥₊)

end lem98

theorem lem98_finite [fact (r' < 1)] (Λ : Type*) [polyhedral_lattice Λ] (S : Type*) [fintype S]
  (N : ℕ) [hN : fact (0 < N)] :
  pseudo_normed_group.splittable (Λ →+ Lbar r' S) N (lem98.d Λ N) :=
begin
  classical, constructor,
  let l := lem98.l Λ,
  have hl := lem98.hl Λ,
  have hl' := lem98.hl' Λ,
  let A := lem98.A Λ N,
  have hA := lem98.hA Λ N,
  let d := lem98.d Λ N,
  intros c x hx,
  -- `x` is a homomorphism `Λ →+ Lbar r' S`
  -- we split it into pieces `Λ →+ ℤ` for all coefficients indexed by `s` and `n`
  let x' : S → ℕ → Λ →+ ℤ := λ s n, (Lbar.coeff s n).comp x,
  have := λ s n, hA (x' s n), clear hA,
  choose x₁' hx₁' x₀' hx₀' H using this,
  have hx₀_aux : ∀ s n i, (x₀' s n (l i)).nat_abs ≤ (x (l i) s n).nat_abs :=
    (λ s n i, le_trans (le_add_right (nat.le_mul_of_pos_left hN.1)) (H s n i).ge),
  -- now we assemble `x₀' : S → ℕ → Λ →+ ℤ` into a homomorphism `Λ →+ Lbar r' S`
  let x₀ : Λ →+ Lbar r' S := Lbar.mk_aux hl x x₀' hx₀_aux,
  have hx₀ : x₀ ∈ filtration (Λ →+ Lbar r' S) (c / N) :=
    Lbar.mk_aux_mem_filtration _ _ _ hN.1 hl hx x₀' x₁' x' (λ _ _ _, rfl) H hx₀_aux,
  -- and similarly for `x₁'`
  let x₁ : Λ →+ Lbar r' S := Lbar.mk_aux hl x x₁'
    (λ s n i, le_trans (le_add_left le_rfl) (H s n i).ge),
  -- `x₁` can be written as a sum of tensors
  -- `x₁ = ∑ a in A, a ⊗ xₐ`, for some `xₐ : Lbar r' S`
  let xₐ : (Λ →+ ℤ) → Lbar r' S := λ a, Lbar.mk_of_add_monoid_hom x₁' a,
  have hx₁ : ∀ l, x₁ l = ∑ a in A, a l • xₐ a := lem_98_aux _ _ hx₁' _ (λ _ _ _, rfl),
  -- now it is time to start building `y`
  -- we first decompose the `xₐ a` into `N` pieces
  have hxₐ : ∀ a s n, (xₐ a s n).nat_abs ≤ 1,
  { intros a s n, dsimp [xₐ, Lbar.mk_of_add_monoid_hom_to_fun], split_ifs; simp },
  have := λ a, lem98_int N hN.1 ∥xₐ a∥₊ (xₐ a) _ (hxₐ a),
  swap 2, { rw Lbar.mem_filtration_iff },
  choose y' hy'1 hy'2 using this,
  -- the candidate `y` combines `x₀` together with the pieces `y'` of `xₐ a`
  let y : fin N → Λ →+ Lbar r' S := λ j, x₀ + ∑ a in A, Lbar.mk_tensor a (y' a j),
  have hxy : x = ∑ i, y i,
  { apply lem98_aux' N A x x₀ x₁ x' x₀' x₁' hx₀' _ _ _ hx₁ y' hy'1 y,
    all_goals { intros, refl } },
  use [y, hxy],
  intro j,
  rw hl.add_monoid_hom_mem_filtration_iff at hx ⊢,
  intro i,
  specialize hx i,
  simp only [Lbar.mem_filtration_iff] at hx hy'2 ⊢,
  have Hx : ∥x (l i)∥₊ = N • ∥x₀ (l i)∥₊ + ∑ a in A, ∥a (l i)∥₊ * ∥xₐ a∥₊,
  { apply lem98_crux N hN.1 A x x₀ x₁ x' x₀' x₁' xₐ,
    all_goals { intros, refl <|> apply_assumption } },
  calc ∥y j (l i)∥₊
      ≤ ∥x₀ (l i)∥₊ + ∑ a in A, ∥a (l i)∥₊ * ∥xₐ a∥₊ / N + d * ∥l i∥₊ : _
  ... = (N • ∥x₀ (l i)∥₊ + ∑ a in A, ∥a (l i)∥₊ * ∥xₐ a∥₊) / N + d * ∥l i∥₊ : _
  ... = ∥x (l i)∥₊ / N + d * ∥l i∥₊ : by rw Hx
  ... ≤ _ : _,
  { simp only [add_monoid_hom.add_apply, add_assoc, add_monoid_hom.finset_sum_apply,
         Lbar.mk_tensor_apply],
    refine (Lbar.nnnorm_add_le _ _).trans (add_le_add le_rfl _),
    refine (Lbar.nnnorm_sum_le _ _).trans _,
    calc ∑ a in A, ∥a (l i) • y' a j∥₊
        = ∑ a in A, ∥a (l i)∥₊ * ∥y' a j∥₊ : finset.sum_congr rfl _
    ... ≤ ∑ a in A, ∥a (l i)∥₊ * (∥xₐ a∥₊ / N + 1) : finset.sum_le_sum _
    ... = ∑ a in A, (∥a (l i)∥₊ * ∥xₐ a∥₊ / N + ∥a (l i)∥₊) : finset.sum_congr rfl _
    ... = ∑ a in A, (∥a (l i)∥₊ * ∥xₐ a∥₊ / N) + ∑ a in A, ∥a (l i)∥₊ : _
    ... ≤ ∑ a in A, (∥a (l i)∥₊ * ∥xₐ a∥₊ / N) + d * ∥l i∥₊ : add_le_add le_rfl _,
    { intros a ha, rw Lbar.nnnorm_zsmul },
    { intros a ha, exact mul_le_mul' le_rfl (hy'2 a j) },
    { intros a ha, rw [mul_add, mul_one, mul_div_assoc] },
    { rw finset.sum_add_distrib },
    { calc ∑ a in A, ∥a (l i)∥₊
          = (∑ a in A, ∥a (l i)∥₊ / ∥l i∥₊) * ∥l i∥₊ : _
      ... ≤ finset.univ.sup (λ i, ∑ a in A, ∥a (l i)∥₊ / ∥l i∥₊) * ∥l i∥₊ : _,
      { { have : ∥l i∥₊ ≠ 0, { simp only [hl' i, nnnorm_eq_zero, ne.def, not_false_iff] },
          simp only [div_eq_mul_inv, ← finset.sum_mul, inv_mul_cancel_right₀ this] } },
      { exact mul_le_mul' (finset.le_sup (finset.mem_univ i)) le_rfl } } },
  { simp only [div_eq_mul_inv, add_mul, finset.sum_mul, nsmul_eq_mul],
    congr' 2,
    rw [mul_comm, inv_mul_cancel_left₀],
    exact_mod_cast hN.1.ne' },
  { simp only [add_mul, div_eq_mul_inv],
    refine add_le_add _ le_rfl,
    rw [mul_right_comm],
    exact mul_le_mul' hx le_rfl }
end
.

#lint- only unused_arguments


import Std.Tactic.GuardExpr
import Mathlib.Tactic.SimpIntro

example : x + 0 = y → x = y := by
  simp_intro
  guard_target = x = y → x = y
  exact id

example : x + 0 = y → x = y := by simp_intro h₁
example : x + 0 ≠ y → x ≠ y := by simp_intro h₁ h₂ -- h₂ is bound but not needed
example : x + 0 ≠ y → x ≠ y := by simp_intro h₁ h₂ h₃ -- h₃ is not bound

example (h : x = z) : x + 0 = y → x = z := by simp_intro [h]

example (h : y = z) : x + 0 = y → x = z := by
  simp_intro
  guard_target = x = y → x = z
  simp_intro .. [h]

example (h : y = z) : x + 0 = y → x = z := by simp_intro _; exact h


-- import pSet_ordinal bvm bvm_extras cantor_space

-- open ordinal cardinal lattice bSet

-- noncomputable theory

-- local attribute [instance] classical.prop_decidable

-- local attribute [simp] omega_le_aleph

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

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

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

-- universe u

-- namespace bSet
-- section cardinal_preservation
-- local notation `ω` := cardinal.omega
-- variables {𝔹 : Type u} [I : nontrivial_complete_boolean_algebra 𝔹]

-- include I
-- lemma AE_of_check_larger_than_check (x y : pSet.{u}) {f : bSet 𝔹} {Γ}
--   (H : Γ ≤ (is_func f) ⊓ ⨅v, v ∈ᴮ y̌ ⟹ ⨆w, w ∈ᴮ x̌ ⊓ pair w v ∈ᴮ f) (h_nonzero : ⊥ < Γ) :
--   ∀ i : y.type, ∃ j : x.type, ⊥ < (is_func f) ⊓ (pair ((x.func j)̌ ) ((y.func i)̌ )) ∈ᴮ f :=
-- begin
--   intro i_v, bv_split_at H, replace H_1_1 := H_1_1 ((y.func i_v)̌ ), simp[check_mem'] at H_1_1,
--   have H' : Γ ≤ is_func f ⊓ ⨆ (w : bSet 𝔹), w ∈ᴮ x̌  ⊓ pair w (pSet.func y i_v̌)  ∈ᴮ f,
--     from context_and_intro ‹_› ‹_›,
--   rw[inf_supr_eq] at H',
--   replace H' := le_trans H' (by {apply supr_le, intro i, recover, show 𝔹,
--     from ⨆ (i : bSet 𝔹), i ∈ᴮ x̌ ⊓ (is_func f ⊓ pair i (pSet.func y i_v̌)  ∈ᴮ f),
--     apply bv_use i, apply le_of_eq, ac_refl}),
--   replace H' := lt_of_lt_of_le h_nonzero H',
--   have := @bounded_exists 𝔹 _ (x̌) (λ z, is_func f ⊓ pair z ((y.func i_v)̌ ) ∈ᴮ f),
--   rw[<-this] at H', swap,
--     {intros x' y',
--     apply poset_yoneda, intros Γ_1 a,
--     simp only [le_inf_iff] at a H ⊢, cases a, cases H, cases a_right, refine ⟨‹_›, _⟩,
--     have : Γ_1 ≤ pair x' ((y.func i_v)̌ ) =ᴮ pair y' ((y.func i_v)̌ ),
--      from subst_congr_pair_left' ‹_›, apply subst_congr_mem_left'; from ‹_›},
--     {cases x, cases y, convert nonzero_wit H', ext1,
--       dsimp with cleanup, rw[top_inf_eq]}
-- end

-- variables
--   (η₁ η₂ : pSet.{u}) (H_infinite : ω ≤ #(η₁.type))
--   (H_lt : #(η₁.type) < #(η₂.type))
--   (H_inj₂ : ∀ x y, x ≠ y → ¬ pSet.equiv (η₂.func x) (η₂.func y))
--   (f : bSet 𝔹) (g : η₂.type → η₁.type)
--   (H : ∀ β : η₂.type, (⊥ : 𝔹) < is_func f ⊓ pair ((η₁.func (g β)̌ ) ) ((η₂.func β)̌ )∈ᴮ f)

-- include H_infinite H_lt H_inj₂ f H
-- lemma not_CCC_of_uncountable_fiber (H_ex : ∃ ξ : η₁.type, ω < #(g⁻¹' {ξ})) : ¬ CCC 𝔹 :=
-- begin
--   cases H_ex with ξ H_ξ,
--   let 𝓐 : (g⁻¹'{ξ}) → 𝔹 :=
--     λ β, is_func f ⊓ (pair ((η₁.func (g β.val))̌ ) ((η₂.func β.val)̌ )) ∈ᴮ f,
--   have 𝓐_nontriv : ∀ β, ⊥ < 𝓐 β,
--     from λ _, by apply H,
--   have 𝓐_anti : ∀ β₁ β₂, β₁ ≠ β₂ → (𝓐 β₁) ⊓ (𝓐 β₂) ≤ ⊥,
--     by {intros β₁ β₂ h_sep, dsimp[𝓐],
--     /- `tidy_context` says -/ apply poset_yoneda, intros Γ a,
--     cases β₂, cases β₁, cases H_ξ, cases H_lt, cases β₁_property, cases β₂_property,
--     work_on_goal 0 { induction β₂_property, simp only [le_inf_iff] at a,
--                      cases a, cases a_right, cases a_left },
--     work_on_goal 1 { induction β₁_property, simp only [le_inf_iff] at a,
--                      cases a, cases a_right, cases a_left, solve_by_elim },
--     work_on_goal 1 { cases β₂_property,
--       work_on_goal 0 { induction β₂_property, simp only [le_inf_iff] at a,
--         cases a, cases a_right, cases a_left, solve_by_elim}, simp only [le_inf_iff] at a,
--         cases a, cases a_right, cases a_left, solve_by_elim},

--     rw[β₁_property] at a_left_right,
--     have H_le_eq : Γ ≤ ((η₂.func β₁_val)̌ ) =ᴮ ((η₂.func β₂_val)̌ ),
--      by {apply funext; from ‹_›},
--     from le_trans H_le_eq
--            (by {rw[le_bot_iff], apply check_bv_eq_bot_of_not_equiv, apply H_inj₂, tidy})},
--    intro H_CCC, specialize H_CCC (g⁻¹'{ξ}) ‹_› ‹_› ‹_›,
--    replace H_ξ := (lt_iff_le_and_ne.mp H_ξ),
--    from absurd (le_antisymm H_ξ.left H_CCC) H_ξ.right
-- end

-- end cardinal_preservation
-- end bSet

-- open bSet pSet

-- namespace cohen_algebra

-- section cohen_algebra
-- variables (κ : cardinal.{u})

-- instance H_nonempty' : nonempty (set $ (card_ex κ).type × ℕ) := ⟨∅⟩

-- def cohen_algebra := @regular_opens (set ((card_ex κ).type × ℕ)) (Pi.topological_space)

-- @[instance, priority 1000]def cohen_algebra_boolean_algebra : nontrivial_complete_boolean_algebra (cohen_algebra κ) :=
-- regular_open_algebra (by apply_instance)

-- lemma le_iff_subset'' {x y : (cohen_algebra κ)} : x ≤ y ↔ x.1 ⊆ y.1 := by refl

-- lemma bot_eq_empty : (⊥ : (cohen_algebra κ)) = ⟨∅, is_regular_empty⟩ := rfl

-- variable{κ}
-- lemma eq₀ : ((card_ex κ)̌  : bSet (cohen_algebra κ)).type = ((card_ex κ)).type := by cases (card_ex κ); refl

-- lemma eq₁ : ((type ((card_ex κ)̌  : bSet (cohen_algebra κ))) × ℕ) = ((type (card_ex κ)) × ℕ) :=
-- by {cases (card_ex κ), refl}

-- lemma eq₂ : set ((type ((card_ex κ)̌  : bSet (cohen_algebra κ))) × ℕ) = set ((type (card_ex κ)) × ℕ) :=
-- by {cases (card_ex κ), refl}

-- lemma eq₃ : finset ((type ((card_ex κ)̌  : bSet (cohen_algebra κ))) × ℕ) = finset (type (card_ex κ) × ℕ) :=
-- by {cases (card_ex κ), refl}

-- lemma pi₂_cast₁ {α β γ : Type*} (H' : α = β) {p : α × γ} {q : β × γ} (H : p == q) :
--   p.1 == q.1 :=
-- by {subst H', subst H}

-- lemma pi₂_cast₂ {α β γ : Type*} (H' : α = β) {p : α × γ} {q : β × γ} (H : p == q) :
--   p.2 = q.2 :=
-- by {subst H', subst H}

-- lemma compl_cast₂ {α β : Type*} {a : set α} {b : set β} (H' : α = β) (H : -a == b) : a == -b :=
-- begin
--   subst H', subst H, apply heq_of_eq, simp
-- end

-- lemma eq₁_cast (p : ((type ((card_ex κ)̌  : bSet (cohen_algebra κ))) × ℕ)) {prf : ((type ((card_ex κ)̌  : bSet (cohen_algebra κ))) × ℕ) = (((type (card_ex κ)) × ℕ))} {prf' : (type ((card_ex κ)̌  : bSet (cohen_algebra κ))) = ((card_ex κ).type)} : cast prf p = (cast prf' p.1, p.2) :=
-- begin
--   ext, swap, simp, h_generalize H_x : p == x, apply pi₂_cast₂, from (eq₀).symm, from H_x.symm,
--   h_generalize H_x : p == x, simp, h_generalize H_y : p.fst == y,
--   apply eq_of_heq, suffices : x.fst == p.fst, from heq.trans this H_y,
--   apply pi₂_cast₁, from (eq₀).symm, from H_x.symm
-- end

-- -- lemma eq₁_cast' {ξ : ((card_ex κ)̌  : bSet (cohen_algebra κ)).type} {n : ℕ} {prf : ((type ((card_ex κ)̌  : bSet (cohen_algebra κ))) × ℕ) = (((type (card_ex κ)) × ℕ))} {prf' : (type ((card_ex κ)̌  : bSet (cohen_algebra κ))) = ((card_ex κ).type)} : cast prf (ξ, n) = (cast prf' ξ, n) :=
-- -- by apply eq₁_cast

-- lemma eq₁_cast' (p : (((type (card_ex κ)) × ℕ))) {prf : ((type ((card_ex κ)̌  : bSet (cohen_algebra κ))) × ℕ) = (((type (card_ex κ)) × ℕ))} {prf' : (type ((card_ex κ)̌  : bSet (cohen_algebra κ))) = ((card_ex κ).type)} : cast prf.symm p = (cast prf'.symm p.1, p.2) :=
-- begin
--   ext, swap, simp, h_generalize H_x : p == x, apply pi₂_cast₂, from eq₀, from H_x.symm,
--   h_generalize H_x : p == x, simp, h_generalize H_y : p.fst == y,
--   apply eq_of_heq, suffices : x.fst == p.fst, from heq.trans this H_y,
--   apply pi₂_cast₁, from eq₀, from H_x.symm
-- end

-- theorem cohen_algebra_CCC : CCC (cohen_algebra κ):=
-- by { apply CCC_regular_opens, apply cantor_space.countable_chain_condition_set }

-- local notation `𝒳` := set((card_ex κ).type × ℕ)

-- open topological_space

-- /-- The principal regular open associated to a pair (ν, n) is the collection of all subsets of
--     (card_ex κ) × ℕ which contain (ν, n). -/
-- variable (κ)
-- def principal_open (ν : ((card_ex κ)̌  : bSet (cohen_algebra κ)).type) (n : ℕ) : (cohen_algebra κ) :=
-- begin
--   use (cantor_space.principal_open (cast (eq₁) (ν, n))),
--   from is_regular_of_clopen (cantor_space.is_clopen_principal_open)
-- end

-- variable {κ}
-- lemma is_clopen_principal_open {ν n} : is_clopen (principal_open κ ν n).val :=
--   cantor_space.is_clopen_principal_open

-- local postfix `ᵖ`:80 := perp

-- local notation `cl`:65 := closure

-- local notation `int`:65 := interior

-- lemma perp_eq_compl_of_clopen {β : Type*} [topological_space β] {S : set β} (H : is_clopen S) : Sᵖ = (-S) :=
-- by {unfold perp, rw[closure_eq_of_is_closed H.right]}

-- lemma mem_neg_principal_open_of_not_mem {ν n S} : (cast (eq₁) (ν,n) ∈ (-S)) → S ∈ (- (principal_open κ ν n)).val :=
-- begin
--   intro H, simp only [neg_unfold], rw[perp_eq_compl_of_clopen],
--   swap, from is_clopen_principal_open, from H
-- end

-- variable (κ)
-- structure cohen_poset  : Type u :=
-- (ins : finset (((card_ex κ) ̌ : bSet (cohen_algebra κ)).type × ℕ))
-- (out : finset (((card_ex κ) ̌ : bSet (cohen_algebra κ)).type × ℕ))
-- (H : ins ∩ out = ∅)

-- variable{κ}

-- @[reducible]def π₂ : ((card_ex κ)̌  : bSet (cohen_algebra κ)).type × ℕ → ℕ := λ x, x.snd

-- -- def nat_supp : finset (((card_ex κ) ̌ : bSet (cohen_algebra κ)).type × ℕ) → set ℕ :=
-- -- λ X, {n | ∃ (ξ : (card_ex κ).type), (cast eq₁.symm (ξ,n)) ∈ X}

-- -- lemma nat_supp_finite {X} : set.finite $ nat_supp X := sorry

-- def cohen_poset_inc : cohen_poset κ → (cohen_algebra κ) :=
-- λ p, ⟨{S | (p.ins.to_set) ⊆ (cast (eq₂).symm S) ∧
--            (p.out.to_set) ⊆ (cast (eq₂).symm (- S))},
-- is_regular_of_clopen
--      begin
--        change is_clopen
--          ({S | p.ins.to_set ⊆ cast (eq₂).symm S} ∩ {S | p.out.to_set ⊆ (cast (eq₂).symm (-S))}),
--        refine is_clopen_inter _ _,
--          have := cantor_space.is_clopen_principal_open_finset p.ins,
--          convert this, from (eq₀).symm, from (eq₀).symm, from (eq₀).symm,
--            {apply function.hfunext, from (eq₂).symm, intros a a' H_heq,
--              apply heq_of_eq, convert rfl, convert (cast_eq _ _).symm, from (eq₀).symm, refl},

--          have := cantor_space.is_clopen_co_principal_open_finset p.out,
--          convert this, from (eq₀).symm, from (eq₀).symm, from (eq₀).symm,
--          {apply function.hfunext, from (eq₂).symm, intros a a' H_heq,
--           apply heq_of_eq, convert rfl, h_generalize Hx : (-a) == x,
--           have := heq.subst H_heq, swap,
--           from λ _ y, y == -x,
--           suffices : a' = -x, by {rw[this], simp},
--           apply eq_of_heq, apply this, apply compl_cast₂, from (eq₁).symm,
--           from Hx}
--      end⟩

-- open cantor_space

-- lemma prop_decidable_cast_lemma {α β : Type*} (H : α = β) {a b : α} {a' b' : β} (H_a : a == a') (H_b : b == b') : classical.prop_decidable (a = b) == classical.prop_decidable (a' = b') :=
-- by {subst H, subst H_a, subst H_b}

-- lemma cohen_poset_dense_basis : ∀ T ∈ @standard_basis ((card_ex κ).type × ℕ), ∀ h_nonempty : T ≠ ∅,
--   ∃ p : cohen_poset κ, (cohen_poset_inc p).val ⊆ T :=
-- begin
--   intros T Ht H_nonempty, simp[standard_basis] at Ht,
--   cases Ht with H_empty Ht, contradiction,
--   rcases Ht with ⟨p_ins, p_out, H₁, H₂⟩,
--   fsplit, refine ⟨_,_,_⟩, from cast eq₃.symm p_ins,
--   from cast eq₃.symm p_out, swap, rw[<-co_principal_open_finset_eq_inter] at H₁,
--   rw[<-principal_open_finset_eq_inter] at H₁, subst H₁,
--   intros S HS, split, cases HS, dsimp at HS_left, simp[principal_open_finset],
--   {convert HS_left,
--     from eq₀.symm, from eq₀.symm, from eq₀.symm, all_goals{symmetry, from cast_heq _ _}},
--   cases HS, dsimp at HS_right, simp[principal_open_finset],
--   {convert HS_right,
--     from eq₀.symm, from eq₀.symm, from eq₀.symm, all_goals{symmetry, from cast_heq _ _}},
--   convert H₂, from eq₀, from eq₀, from eq₀,
--   apply function.hfunext, from (eq₁), intros a a' H,
--   apply function.hfunext, from (eq₁), intros b b' H',
--   from prop_decidable_cast_lemma (eq₁) ‹_› ‹_›,
--   from cast_heq _ _, from cast_heq _ _, from eq₀, from eq₀
-- end

-- lemma cohen_poset_dense {b : (cohen_algebra κ)} (H : ⊥ < b) : ∃ p : cohen_poset κ, cohen_poset_inc p ≤ b :=
-- begin
--   cases (classical.choice (classical.nonempty_of_not_empty _ H.right.symm)) with S_wit H_wit,
--   change ∃ p, (cohen_poset_inc p).val ⊆ b.val,
--   have := mem_basis_subset_of_mem_open (is_topological_basis_standard_basis) H_wit (is_open_of_is_regular b.property),
--   rcases (mem_basis_subset_of_mem_open
--            (is_topological_basis_standard_basis) H_wit (is_open_of_is_regular b.property))
--          with ⟨v, Hv₁, Hv₂, Hv₃⟩,
--   have : v ≠ ∅, by {intro H, rw[H] at Hv₂, cases Hv₂},
--   cases (cohen_poset_dense_basis ‹_› ‹_› ‹_›) with p H_p, from ⟨p, set.subset.trans H_p ‹_›⟩
-- end

-- lemma to_set_inter {α : Type*} {p₁ p₂ : finset α} : (p₁ ∩ p₂).to_set = (p₁.to_set ∩ p₂.to_set) :=
-- by {ext, split; intros; unfold finset.to_set at *, tidy}

-- @[simp]lemma to_set_empty {α : Type*} : finset.to_set (∅ : finset α) = ∅ :=
-- by {unfold finset.to_set, refl}

-- lemma not_mem_of_inter_empty_left {α : Type*} {p₁ p₂ : finset α}
--   (H : p₁ ∩ p₂ = ∅) {a : α} : a ∈ p₁.to_set → ¬ a ∈ p₂.to_set :=
-- begin
--   intro H', intro H'',
--   have this₀ : a ∈ p₁.to_set ∩ p₂.to_set := ⟨‹_›,‹_›⟩,
--   rw[<-to_set_inter] at this₀, have this₁ := congr_arg finset.to_set H,
--   rw[this₁] at this₀, cases this₀
-- end

-- lemma not_mem_of_inter_empty_right {α : Type*} {p₁ p₂ : finset α}
--   (H : p₂ ∩ p₁ = ∅) {a : α} : a ∈ p₁.to_set → ¬ a ∈ p₂.to_set :=
-- by {rw[finset.inter_comm] at H, apply not_mem_of_inter_empty_left, from ‹_›}

-- lemma cohen_poset_nonzero (p : cohen_poset κ) : ⊥ ≠ (cohen_poset_inc p) :=
-- begin
--   intro H, replace H := H.symm, rw[eq_bot_iff] at H, rw[le_iff_subset''] at H,
--   rw[bot_eq_empty] at H,
--   suffices : nonempty (cohen_poset_inc p).val,
--     by {have := classical.choice this, specialize H this.property, cases H},
--   apply nonempty.intro, fsplit, exact (cast (eq₂) p.ins.to_set),
--   split, finish, intro x, cases x with ν n, intro H,
--   suffices : cast (eq₁) (ν, n) ∈ - cast (eq₂) (p.ins).to_set,
--     {convert this, from eq₀, from eq₀, from eq₀, cc, cc},
--   suffices : (ν, n) ∈ - p.ins.to_set,
--     {convert this, from eq₀.symm, from eq₀.symm, from eq₀.symm, cc, from eq₀.symm,
--      from eq₀.symm, from eq₀.symm, from eq₀.symm, cc},
--   from not_mem_of_inter_empty_right p.H H
-- end

-- lemma subset_of_eq {α : Type*} {a b : finset α} (H : a = b) : a ⊆ b := by rw[H]; refl

-- lemma cohen_poset_disjoint_row (p : cohen_poset κ) : ∃ n : ℕ, ∀ ξ : (card_ex κ).type, (cast (eq₁).symm (ξ,n)) ∉ p.ins ∧ (cast (eq₁).symm (ξ,n)) ∉ p.out :=
-- begin
--   let Y := (finset.image π₂ p.ins) ∪ (finset.image π₂ p.out),
--   by_cases (p.ins ∪ p.out) = ∅,
--   use 0, intro ξ, split, intro x, apply (subset_of_eq h), simp, left, from x,
--   intro x, apply (subset_of_eq h), simp, right, from x,
--   let Y' := finset.image π₂ (p.ins ∪ p.out),
--   have Y'_nonempty : Y' ≠ ∅,
--     by {dsimp[Y'], intro H, apply h, ext; split; intros, swap, cases a_1,
--       have : π₂ a ∈ finset.image π₂ (p.ins ∪ p.out), simp,
--       use a.fst, simp at a_1, convert a_1, cases a, refl, cases a, refl,
--       rw[H] at this, cases this},
--   have := finset.max_of_ne_empty,
--   specialize this Y'_nonempty, cases this with N HN, swap, apply_instance,
--   use (N+1), intro ξ, split,
--     intro X, let prf := _, change cast prf (ξ, N + 1) ∈ p.ins at X,
--     rw[eq₁_cast'] at X, swap, from eq₀,
--     have : N + 1 ∈ Y',
--       by {simp, use cast eq₀.symm ξ, from or.inl X},
--     suffices : N + 1 ≤ N, by {revert this, change ¬ (N + 1 ≤ N), apply nat.not_succ_le_self},
--     apply finset.le_max_of_mem this ‹_›,
--   intro X, let prf := _, change cast prf (ξ, N + 1) ∈ p.out at X,
--     rw[eq₁_cast'] at X, swap, from eq₀,
--     have : N + 1 ∈ Y',
--       by {simp, use cast eq₀.symm ξ, from or.inr X},
--     suffices : N + 1 ≤ N, by {revert this, change ¬ (N + 1 ≤ N), apply nat.not_succ_le_self},
--     apply finset.le_max_of_mem this ‹_›
-- end

-- lemma cohen_poset_anti {p₁ p₂ : cohen_poset κ} : p₁.ins ⊆ p₂.ins → p₁.out ⊆ p₂.out → cohen_poset_inc p₂ ≤ cohen_poset_inc p₁  :=
-- by {intros H₁ H₂, rw[le_iff_subset''], tidy}

-- end cohen_algebra
-- end cohen_algebra

-- namespace cohen_real

-- section cohen_real
-- variables (κ : cardinal.{u})
-- open cohen_algebra

-- -- attribute [instance, priority 0] 𝔹_boolean_algebra

-- -- variable [σ : nontrivial_complete_boolean_algebra 𝔹]

-- -- attribute [instance, priority 1000] σ
-- -- include σ
-- /-- `cohen_real.χ ν` is the indicator function on ℕ induced by every ordinal less than (card_ex κ) -/
-- def χ (ν : ((card_ex κ)̌  : bSet (cohen_algebra κ)).type) : ℕ → (cohen_algebra κ) :=
--   λ n, principal_open κ ν n

-- /-- `cohen_real.mk ν` is the subset of (ω : bSet (cohen_algebra κ)) induced by `cohen_real.χ ν` -/
-- def mk (ν : ((card_ex κ)̌  : bSet (cohen_algebra κ)).type) : bSet (cohen_algebra κ) :=
--   @set_of_indicator (cohen_algebra κ) _ omega $ λ n, χ κ ν n.down

-- variable {κ}
-- @[simp, cleanup]lemma mk_type {ν} : (mk κ ν).type = ulift ℕ := rfl

-- @[simp, cleanup]lemma mk_func {ν} {n} : (mk κ ν).func n = bSet.of_nat (n.down) := rfl

-- @[simp, cleanup]lemma mk_bval {ν} {n} : (mk κ ν).bval n = (χ κ ν) (n.down) := rfl

-- /-- bSet (cohen_algebra κ) believes that each `mk κ ν` is a subset of omega -/
-- lemma definite {ν} {Γ} : Γ ≤ mk κ ν ⊆ᴮ omega :=
-- by simp [mk, subset_unfold]; from λ _, by rw[<-deduction]; convert omega_definite

-- /-- bSet (cohen_algebra κ) believes that each `mk κ ν` is an element of 𝒫(ω) -/
-- lemma definite' {ν} {Γ} : Γ ≤ mk κ ν ∈ᴮ bv_powerset omega := bv_powerset_spec.mp definite

-- -- TODO(jesse) refactor this proof to use axiom of extensionality instead, or prove a more general version

-- lemma sep {n} {Γ} {ν₁ ν₂} (H₁ : Γ ≤ (of_nat n) ∈ᴮ (mk κ ν₁)) (H₂ : Γ ≤ (- ((of_nat n) ∈ᴮ (mk κ ν₂)))) :
--   Γ ≤ (- ((mk κ ν₁) =ᴮ (mk κ ν₂))) :=
-- begin
--   rw[bv_eq_unfold], rw[neg_inf, neg_infi, neg_infi], simp only [neg_imp],
--   refine le_sup_left_of_le _, rw[@bounded_exists (cohen_algebra κ) _ (mk κ ν₁) (λ z, -(z ∈ᴮ mk κ ν₂)) _],
--   swap, change B_ext _, simp[-imp_bot, imp_bot.symm],
--   apply bv_use (bSet.of_nat n), bv_split_goal
-- end

-- lemma not_mem_of_not_mem {p : cohen_poset κ} {ν} {n} (H : (ν,n) ∈ p.out) : cohen_poset_inc p ≤ -( (of_nat n) ∈ᴮ (mk κ ν)) :=
-- begin
-- rw[mem_unfold, neg_supr], bv_intro k, rw[neg_inf], simp,
--        by_cases n = k.down, swap, rw[bSet.of_nat_inj ‹_›],
--        from le_sup_right_of_le (by simp),
--        refine le_sup_left_of_le _, rw[<-h],
--        rw[le_iff_subset''], unfold cohen_poset_inc χ, rintros S ⟨H_S₁, H_S₂⟩,
--        apply mem_neg_principal_open_of_not_mem, have := H_S₂ H, convert this,
--        from eq₀.symm, from eq₀.symm, from eq₀.symm,
--        from cast_heq _ _, from (cast_heq _ _).symm
-- end

-- private lemma inj_cast_lemma (ν' : type ((card_ex κ)̌  : bSet (cohen_algebra κ))) (n' : ℕ) :
--   cast eq₁.symm (cast eq₀ ν', n') = (ν', n') :=
-- begin
--   let a := _, change cast a _ = _,
--   let b := _, change cast _ (cast b _, _) = _,
--   simp[b] at a, dedup, change cast a_1 _ = _, cc
-- end

-- /-- Whenever ν₁ ≠ ν₂ < (card_ex κ), bSet (cohen_algebra κ) believes that `mk κ ν₁` and `mk κ ν₂` are distinct -/
-- lemma inj {ν₁ ν₂} (H_neq : ν₁ ≠ ν₂) : (mk κ ν₁) =ᴮ (mk κ ν₂) ≤ (⊥ : (cohen_algebra κ)) :=
-- begin
--   by_contra, replace h := (bot_lt_iff_not_le_bot.mpr ‹_›),
--   cases cohen_poset_dense h with p H_p, cases cohen_poset_disjoint_row p with n H_n,
--   let p' : cohen_poset κ := { ins := insert (ν₁,n) (p.ins),
--   out := insert (ν₂,n) p.out,
--   H := by {ext, split; intro H, swap, cases H, have := p.H, simp at H, cases a_1 with ν' n',
--            cases H with H₁ H₂, specialize H_n (cast eq₀ ν'), cases H_n, cases H₁; cases H₂, cc,
--            exfalso, apply H_n_right, convert H₂, rw[show n = n', by cc], apply inj_cast_lemma,
--            exfalso, apply H_n_left, convert H₁, rw[show n = n', by cc], apply inj_cast_lemma,
--            rw[<-this], simp[*,-this]} },
--   have this₀ : cohen_poset_inc p' ≤ cohen_poset_inc p,
--     from cohen_poset_anti (by {dsimp[p'], from λ i _, by {simp, from or.inr ‹_›}})
--                 (by {dsimp[p'], from λ i _, by {simp, from or.inr ‹_›}}),
--   have this₁ : cohen_poset_inc p' ≤ (ñ̌) ∈ᴮ (mk κ ν₁),
--     by {rw[mem_unfold], apply bv_use (ulift.up n), refine le_inf _ bv_refl,
--          {simp [le_iff_subset'', χ, principal_open, cohen_poset_inc, cantor_space.principal_open],
--          have : (ν₁, n) ∈ p'.ins,
--            by simp[p'], intros S H_S _, specialize H_S this,
--               convert H_S; [from eq₀.symm, from eq₀.symm, from eq₀.symm, cc, cc]}},
--   have this₂ : cohen_poset_inc p' ≤ - ((ñ̌) ∈ᴮ (mk κ ν₂)),
--     by {have : (ν₂, n) ∈ p'.out, by {simp[p']},
--        from not_mem_of_not_mem ‹_›},
--   have this₃ : cohen_poset_inc p' ≤ - (mk κ ν₁ =ᴮ mk κ ν₂),
--     from sep ‹_› ‹_›,
--   have this₄ : cohen_poset_inc p' ≤ (mk κ ν₁ =ᴮ mk κ ν₂),
--     from le_trans this₀ ‹_›,
--   suffices : cohen_poset_inc p' = ⊥, from absurd this.symm (cohen_poset_nonzero p'),
--   bv_and_intro this₃ this₄, simpa using H
-- end
-- end cohen_real
-- end cohen_real

-- section neg_CH
-- variables (κ₁ κ₂ : cardinal.{u}) (H_reg₁ : is_regular κ₁) (H_reg₂ : is_regular κ₂) (H_inf₁ : cardinal.omega < κ₁) (H_inf₂ : cardinal.omega < κ₂) (H_lt : κ₁ < κ₂)

-- open cohen_algebra

-- local notation `ℵ₀` := (omega : bSet (cohen_algebra κ₂))

-- local notation `𝔠` := (bv_powerset ℵ₀)

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

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

-- lemma uncountable_fiber_of_regular' (κ₁ κ₂ : cardinal) (H_inf : cardinal.omega ≤ κ₁) (H_lt : κ₁ < κ₂) (H : cof (ord κ₂) = κ₂) (α : Type u) (H_α : #α = κ₁) (β : Type u) (H_β : #β = κ₂) (g : β → α)
--   : ∃ (ξ : α), cardinal.omega < #↥(g⁻¹' {ξ}) :=
-- begin
--   have := (@cardinal.exists_aleph κ₂).mp (le_of_lt (lt_of_le_of_lt ‹_› ‹_›)), cases this with k H_k, subst H_k,
--   have := (@cardinal.exists_aleph κ₁).mp ‹_›, cases this with k' H_k', subst H_k',
--   have := infinite_pigeonhole g _ _, cases this with ξ H_ξ, use ξ, rw[H_ξ],
--   all_goals{simp*}, from lt_of_le_of_lt ‹_› ‹_›
-- end

-- lemma uncountable_fiber_of_regular (κ₁ κ₂ : cardinal) (H_inf : cardinal.omega ≤ κ₁) (H_lt : κ₁ < κ₂) (H : cof (ord κ₂) = κ₂) (g : type (pSet.ordinal.mk (ord κ₂)  : pSet.{u}) → type (pSet.ordinal.mk (ord κ₁) : pSet.{u}))
--   : ∃ (ξ : type (pSet.ordinal.mk (ord κ₁))), cardinal.omega < #↥((λ (β : type (pSet.ordinal.mk (ord κ₂))), g β)⁻¹' {ξ}) :=
-- begin
--   have := (@exists_aleph κ₁).mp ‹_›, cases this with k₁ h, subst h,
--   have := (@exists_aleph κ₂).mp (le_of_lt (lt_of_le_of_lt ‹_› ‹_›)), cases this with k₂ h,
--   subst h,
--   from uncountable_fiber_of_regular' (aleph k₁) (aleph k₂) ‹_› ‹_› ‹_› _ (mk_type_mk_eq _ ‹_›) _ (mk_type_mk_eq _ (by simp*)) g
-- end

-- lemma cardinal_inequality_of_regular (κ₁ κ₂ : cardinal) (H_reg₁ : cardinal.is_regular κ₁) (H_reg₂ : cardinal.is_regular κ₂) (H_inf : (omega : cardinal) ≤ κ₁) (H_lt : κ₁ < κ₂) : (⊤ : (cohen_algebra κ₂)) ≤ (pSet.ordinal.mk (ord κ₁))̌  ≺ (pSet.ordinal.mk (ord κ₂))̌  :=
-- begin
--   simp[larger_than, -top_le_iff], rw[<-imp_bot],
--   bv_imp_intro, bv_cases_at'' H f, by_contra,
--   have := classical.axiom_of_choice
--             (AE_of_check_larger_than_check _ _ H_1 (bot_lt_iff_not_le_bot.mpr ‹_›)),
--   cases this with g g_spec,
--   suffices : ¬ CCC (cohen_algebra κ₂), from absurd cohen_algebra_CCC this,
--   apply not_CCC_of_uncountable_fiber; try{assumption},
--     {have := (@cardinal.exists_aleph κ₁).mp ‹_›, cases this with k' H_k', subst H_k', simp*},
--     {have := (@cardinal.exists_aleph κ₁).mp ‹_›, cases this with k' H_k', subst H_k', simp*,
--      have := (@exists_aleph κ₂).mp (le_of_lt (lt_of_le_of_lt ‹_› ‹_›)), cases this with k₂ h,
--      subst h, simp*},
--     {intros i₁ i₂ H_neq, from ordinal.mk_inj _ _ _ ‹_›},
--     {dsimp at g,
--      apply uncountable_fiber_of_regular' κ₁ κ₂; try{simp*},
--      from H_reg₂.right,
--      have := (@exists_aleph κ₂).mp (le_of_lt (lt_of_le_of_lt ‹_› ‹_›)), cases this with k₂ h,
--      subst h, from mk_type_mk_eq _ ‹_›, from mk_type_mk_eq _ (le_of_lt (lt_of_le_of_lt ‹_› ‹_›))}
-- end

-- lemma cohen_real.mk_ext : ∀ (i j : type ((card_ex κ₂)̌  : bSet (cohen_algebra κ₂))), func ((card_ex κ₂)̌ ) i =ᴮ func ((card_ex κ₂)̌ ) j ≤
--   (λ (x : type ((card_ex κ₂)̌ )), cohen_real.mk κ₂ x) i =ᴮ (λ (x : type ((card_ex κ₂)̌ )), cohen_real.mk κ₂ x) j :=
-- begin
--   intros i j, by_cases i = j,
--    {simp[h]},
--    {refine poset_yoneda _, intros Γ a, simp only [le_inf_iff] at *,
--      have : func ((card_ex κ₂)̌ ) i = ((card_ex κ₂).func (check_cast i))̌ ,
--        by simp[check_func],
--      rw[this] at a,
--      have : func ((card_ex κ₂)̌ ) j = ((card_ex κ₂).func (check_cast j))̌ ,
--        by simp[check_func],
--      rw[this] at a,
--    suffices : func (card_ex κ₂) (check_cast i)̌  =ᴮ func (card_ex κ₂) (check_cast j)̌  ≤ ⊥,
--      from le_trans a (le_trans this bot_le),
--    rw[le_bot_iff], apply check_bv_eq_bot_of_not_equiv,
--    apply ordinal.mk_inj, unfold check_cast, intro H, cc}
-- end

-- noncomputable def neg_CH_func : bSet (cohen_algebra κ₂) :=
-- @function.mk _ _ ((card_ex κ₂)̌ ) (λ x, cohen_real.mk κ₂ x) (cohen_real.mk_ext κ₂)

-- variables {κ₁ κ₂}
-- -- def CH : (cohen_algebra κ₂) := - ⨆ x, ⨆y, (ℵ₀ ≺ x) ⊓ (x ≺ y) ⊓ (y ≼ 𝒫(ℵ₀))

-- include κ₁ H_reg₁ H_inf₁

-- lemma ℵ₀_lt_κ₁ : (⊤ : (cohen_algebra κ₂))  ≤ ℵ₀ ≺ (card_ex κ₁)̌  :=
-- begin
--   simp[larger_than, -top_le_iff], rw[<-imp_bot],
--   bv_imp_intro, bv_cases_at'' H f, by_contra,
--   have := classical.axiom_of_choice
--             (AE_of_check_larger_than_check _ _ H_1 (bot_lt_iff_not_le_bot.mpr ‹_›)),
--   cases this with g g_spec,
--   suffices : ¬ CCC (cohen_algebra κ₂), from absurd cohen_algebra_CCC this,
--   apply not_CCC_of_uncountable_fiber; try{assumption},
--     {from le_of_eq (by simp)},
--     {simp*},
--     {intros i₁ i₂ H_neq, from ordinal.mk_inj _ _ _ ‹_›},
--     {dsimp at g,
--      apply uncountable_fiber_of_regular' (aleph 0) κ₁; try{simp*},
--      from H_reg₁.right}
-- end
-- omit H_reg₁ H_inf₁

-- theorem κ₂_le_𝔠 : (⊤ : cohen_algebra κ₂) ≤ is_func' ((card_ex κ₂)̌ ) 𝔠 (neg_CH_func κ₂) ⊓ is_inj (neg_CH_func κ₂) :=
-- begin
-- refine le_inf _ _,

--   {unfold neg_CH_func, refine le_inf _ _, refine mk_is_func _ _,
--     bv_intro w₁, bv_imp_intro, rw[mem_unfold] at H,
--     bv_cases_at'' H ν, apply bv_use (cohen_real.mk κ₂ ν),
--     refine le_inf cohen_real.definite' _, swap,
--     rw[mem_unfold], apply bv_use ν, bv_split,
--     from le_inf ‹_› (by apply le_trans H_1_right; from subst_congr_pair_left), refl},

--   {refine mk_inj_of_inj _ _, from λ _ _ _, cohen_real.inj ‹_›},
-- end

-- include H_reg₁ H_inf₁ H_reg₂ H_inf₂ H_lt

-- /-- For every pair of infinite regular cardinals κ₁ < κ₂, the continuum in bSet (cohen_algebra κ₂) is properly larger than (card_ex κ₁)̌ . -/
-- theorem neg_CH : (⊤ : cohen_algebra κ₂) ≤ -(CH) :=
-- begin
--   dsimp [CH], rw[lattice.neg_neg], apply bv_use ((card_ex κ₁)̌ ),
--   apply bv_use ((card_ex κ₂)̌ ), simp only [lattice.le_inf_iff],
--   refine ⟨⟨ℵ₀_lt_κ₁ H_reg₁ H_inf₁,_⟩,_⟩,
--   from  cardinal_inequality_of_regular _ _ (H_reg₁)
--   (H_reg₂) (le_of_lt ‹_›) (‹_›),
--   refine le_supr_of_le (neg_CH_func κ₂) _,
--   apply κ₂_le_𝔠, from κ₂
-- end

-- end neg_CH


import Kenny.sheaf_of_rings_on_opens

universes v w u₁ v₁ u

open topological_space lattice

structure locally_ringed_space_on_opens (X : Type u) [topological_space X] (U : opens X) : Type (max u (v+1)) :=
(O : sheaf_of_rings_on_opens.{v} X U)
(Hstalks : ∀ x ∈ U, is_local_ring (O.to_sheaf_on_opens.stalk x H))

namespace locally_ringed_space_on_opens

variables {X : Type u} [topological_space X] {U : opens X}

def res_subset (OX : locally_ringed_space_on_opens X U) (V : opens X) (HVU : V ≤ U) : locally_ringed_space_on_opens X V :=
{ O := OX.O,
  Hstalks := λ x hv, OX.Hstalks x (HVU hv) }

theorem res_res_subset (OX : locally_ringed_space_on_opens X U) (V HVU S HSV T HTV HTS x) :
  (OX.res_subset V HVU).1.to_sheaf_on_opens.res S HSV T HTV HTS x =
  OX.1.to_sheaf_on_opens.res S (le_trans HSV HVU) T (le_trans HTV HVU) HTS x :=
rfl

variables {Y : Type u₁} [topological_space Y] {V : opens Y}

structure morphism (F : locally_ringed_space_on_opens.{v} X U) (G : locally_ringed_space_on_opens.{v₁} Y V) : Type (max u v u₁ v₁) :=
(f : X → Y) (hf : continuous f) (hf2 : opens.comap hf V ≤ U)
(map : ∀ W ≤ V, F.1.to_sheaf_on_opens.eval (opens.comap hf W) (le_trans (opens.comap_mono _ _ _ H) hf2) →
  G.1.to_sheaf_on_opens.eval W H)
[hom : ∀ W H, is_ring_hom (map W H)]
(hlocal : ∀ W H s, is_unit (map W H s) → is_unit s)

#exit
namespace morphism

section
variables {F : locally_ringed_space_on_opens.{v} X U} {G : locally_ringed_space_on_opens.{w} X U}
variables (η : F.morphism G) (V : opens X) (HVU : V ≤ U) (x y : F.eval V HVU) (n : ℕ)
@[simp] lemma map_add : η.map V HVU (x + y) = η.map V HVU x + η.map V HVU y := is_ring_hom.map_add _
@[simp] lemma map_zero : η.map V HVU 0 = 0 := is_ring_hom.map_zero _
@[simp] lemma map_neg : η.map V HVU (-x) = -η.map V HVU x := is_ring_hom.map_neg _
@[simp] lemma map_sub : η.map V HVU (x - y) = η.map V HVU x - η.map V HVU y := is_ring_hom.map_sub _
@[simp] lemma map_mul : η.map V HVU (x * y) = η.map V HVU x * η.map V HVU y := is_ring_hom.map_mul _
@[simp] lemma map_one : η.map V HVU 1 = 1 := is_ring_hom.map_one _
@[simp] lemma map_pow : η.map V HVU (x^n) = (η.map V HVU x)^n := is_semiring_hom.map_pow _ x n
end

def to_sheaf_on_opens {F : locally_ringed_space_on_opens.{v} X U} {G : locally_ringed_space_on_opens.{w} X U} (η : F.morphism G) :
  F.to_sheaf_on_opens.morphism G.to_sheaf_on_opens :=
{ .. η }

protected def id (F : locally_ringed_space_on_opens.{v} X U) : F.morphism F :=
{ map := λ V HV, id,
  commutes := λ V HV W HW HWV x, rfl }

def comp {F : locally_ringed_space_on_opens.{v} X U} {G : locally_ringed_space_on_opens.{w} X U} {H : locally_ringed_space_on_opens.{u₁} X U}
  (η : G.morphism H) (ξ : F.morphism G) : F.morphism H :=
{ map := λ V HV x, η.map V HV (ξ.map V HV x),
  commutes := λ V HV W HW HWV x, by rw [ξ.commutes, η.commutes] }

@[simp] lemma comp_apply {F : locally_ringed_space_on_opens.{v} X U} {G : locally_ringed_space_on_opens.{w} X U} {H : locally_ringed_space_on_opens.{u₁} X U}
  (η : G.morphism H) (ξ : F.morphism G) (V HV s) :
  (η.comp ξ).1 V HV s = η.1 V HV (ξ.1 V HV s) :=
rfl

@[extensionality] lemma ext {F : locally_ringed_space_on_opens.{v} X U} {G : locally_ringed_space_on_opens.{w} X U}
  {η ξ : F.morphism G} (H : ∀ V HV x, η.map V HV x = ξ.map V HV x) : η = ξ :=
by cases η; cases ξ; congr; ext; apply H

@[simp] lemma id_comp {F : locally_ringed_space_on_opens.{v} X U} {G : locally_ringed_space_on_opens.{w} X U} (η : F.morphism G) :
  (morphism.id G).comp η = η :=
ext $ λ V HV x, rfl

@[simp] lemma comp_id {F : locally_ringed_space_on_opens.{v} X U} {G : locally_ringed_space_on_opens.{w} X U} (η : F.morphism G) :
  η.comp (morphism.id F) = η :=
ext $ λ V HV x, rfl

@[simp] lemma comp_assoc {F : locally_ringed_space_on_opens.{v} X U} {G : locally_ringed_space_on_opens.{w} X U} {H : locally_ringed_space_on_opens.{u₁} X U} {I : locally_ringed_space_on_opens.{v₁} X U}
  (η : H.morphism I) (ξ : G.morphism H) (χ : F.morphism G) :
  (η.comp ξ).comp χ = η.comp (ξ.comp χ) :=
rfl

def res_subset {F : locally_ringed_space_on_opens.{v} X U} {G : locally_ringed_space_on_opens.{w} X U} (η : F.morphism G) (V : opens X) (HVU : V ≤ U) :
  (F.res_subset V HVU).morphism (G.res_subset V HVU) :=
{ map := λ W HWV, η.map W (le_trans HWV HVU),
  commutes := λ S HSV T HTV, η.commutes S (le_trans HSV HVU) T (le_trans HTV HVU) }

@[simp] lemma res_subset_apply {F : locally_ringed_space_on_opens.{v} X U} {G : locally_ringed_space_on_opens.{w} X U} (η : F.morphism G) (V : opens X) (HVU : V ≤ U)
  (W HWV s) : (η.res_subset V HVU).1 W HWV s = η.1 W (le_trans HWV HVU) s :=
rfl

@[simp] lemma comp_res_subset {F : locally_ringed_space_on_opens.{v} X U} {G : locally_ringed_space_on_opens.{w} X U} {H : locally_ringed_space_on_opens.{u₁} X U}
  (η : G.morphism H) (ξ : F.morphism G) (V : opens X) (HVU : V ≤ U) :
  (η.res_subset V HVU).comp (ξ.res_subset V HVU) = (η.comp ξ).res_subset V HVU :=
rfl

@[simp] lemma id_res_subset {F : locally_ringed_space_on_opens.{v} X U} (V : opens X) (HVU : V ≤ U) :
  (morphism.id F).res_subset V HVU = morphism.id (F.res_subset V HVU) :=
rfl

def stalk {F : locally_ringed_space_on_opens.{v} X U} {G : locally_ringed_space_on_opens.{w} X U} (η : F.morphism G) (x : X) (hx : x ∈ U)
  (s : F.stalk x hx) : G.stalk x hx :=
quotient.lift_on s (λ g, ⟦(⟨g.1 ⊓ U, (⟨g.2, hx⟩ : x ∈ g.1 ⊓ U),
  η.map _ inf_le_right (presheaf.res F.1.1 _ _ (set.inter_subset_left _ _) g.3)⟩ : stalk.elem _ _)⟧) $
λ g₁ g₂ ⟨V, hxV, HV1, HV2, hg⟩, quotient.sound ⟨V ⊓ U, ⟨hxV, hx⟩, set.inter_subset_inter_left _ HV1, set.inter_subset_inter_left _ HV2,
calc  G.res _ _ (V ⊓ U) inf_le_right (inf_le_inf HV1 (le_refl _)) (η.map (g₁.U ⊓ U) inf_le_right ((F.F).res (g₁.U) (g₁.U ⊓ U) (set.inter_subset_left _ _) (g₁.s)))
    = η.map (V ⊓ U) inf_le_right ((F.F).res V (V ⊓ U) (set.inter_subset_left _ _) ((F.F).res (g₁.U) V HV1 (g₁.s))) :
  by rw ← η.3; dsimp only [res, sheaf_on_opens.res, locally_ringed_space_on_opens.to_sheaf_on_opens]; rw [← presheaf.Hcomp', ← presheaf.Hcomp']
... = G.res _ _ (V ⊓ U) _ _ (η.map (g₂.U ⊓ U) inf_le_right ((F.F).res (g₂.U) (g₂.U ⊓ U) _ (g₂.s))) :
  by rw [hg, ← η.3]; dsimp only [res, sheaf_on_opens.res, locally_ringed_space_on_opens.to_sheaf_on_opens]; rw [← presheaf.Hcomp', ← presheaf.Hcomp']⟩

@[simp] lemma stalk_to_stalk {F : locally_ringed_space_on_opens.{v} X U} {G : locally_ringed_space_on_opens.{w} X U} (η : F.morphism G) (x : X) (hx : x ∈ U)
  (V : opens X) (HVU : V ≤ U) (hxV : x ∈ V) (s : F.eval V HVU) : η.stalk x hx (F.to_stalk x hx V hxV HVU s) = G.to_stalk x hx V hxV HVU (η.map V HVU s) :=
quotient.sound ⟨V, hxV, set.subset_inter (set.subset.refl _) HVU, set.subset.refl _,
calc  G.res (V ⊓ U) inf_le_right V HVU (le_inf (le_refl V) HVU) (η.map (V ⊓ U) inf_le_right (F.res V HVU (V ⊓ U) inf_le_right inf_le_left s))
    = G.res V HVU V HVU (le_refl V) (η.map V HVU s) : by rw [η.3, res_res]⟩

instance is_ring_hom_stalk {F : locally_ringed_space_on_opens.{v} X U} {G : locally_ringed_space_on_opens.{w} X U} (η : F.morphism G) (x : X) (hx : x ∈ U) :
  is_ring_hom (η.stalk x hx) :=
{ map_one := quotient.sound ⟨U, hx, set.subset_inter (set.subset_univ U.1) (set.subset.refl U.1), set.subset_univ U.1,
    by dsimp only; erw [_root_.res_one, η.map_one, _root_.res_one, _root_.res_one]⟩,
  map_mul := λ y z, stalk.induction_on₂ y z $ λ V hxV HVU s t, by rw [stalk_to_stalk, stalk_to_stalk, ← to_stalk_mul, stalk_to_stalk, η.map_mul, to_stalk_mul],
  map_add := λ y z, stalk.induction_on₂ y z $ λ V hxV HVU s t, by rw [stalk_to_stalk, stalk_to_stalk, ← to_stalk_add, stalk_to_stalk, η.map_add, to_stalk_add] }

section
variables {F : locally_ringed_space_on_opens.{v} X U} {G : locally_ringed_space_on_opens.{w} X U} (η : F.morphism G) (x : X) (hx : x ∈ U)
variables (s t : F.stalk x hx) (n : ℕ)
@[simp] lemma stalk_add : η.stalk x hx (s + t) = η.stalk x hx s + η.stalk x hx t := is_ring_hom.map_add _
@[simp] lemma stalk_zero : η.stalk x hx 0 = 0 := is_ring_hom.map_zero _
@[simp] lemma stalk_neg : η.stalk x hx (-s) = -η.stalk x hx s := is_ring_hom.map_neg _
@[simp] lemma stalk_sub : η.stalk x hx (s - t) = η.stalk x hx s - η.stalk x hx t := is_ring_hom.map_sub _
@[simp] lemma stalk_mul : η.stalk x hx (s * t) = η.stalk x hx s * η.stalk x hx t := is_ring_hom.map_mul _
@[simp] lemma stalk_one : η.stalk x hx 1 = 1 := is_ring_hom.map_one _
@[simp] lemma stalk_pow : η.stalk x hx (s^n) = (η.stalk x hx s)^n := is_semiring_hom.map_pow _ s n
end

end morphism

structure equiv (F : locally_ringed_space_on_opens.{v} X U) (G : locally_ringed_space_on_opens.{w} X U) : Type (max u v w) :=
(to_fun : F.morphism G)
(inv_fun : G.to_sheaf_on_opens.morphism F.to_sheaf_on_opens)
(left_inv : ∀ V HVU s, inv_fun.1 V HVU (to_fun.1 V HVU s) = s)
(right_inv : ∀ V HVU s, to_fun.1 V HVU (inv_fun.1 V HVU s) = s)

namespace equiv

def to_sheaf_on_opens {F : locally_ringed_space_on_opens.{v} X U} {G : locally_ringed_space_on_opens.{w} X U} (e : F.equiv G) :
  F.to_sheaf_on_opens.equiv G.to_sheaf_on_opens :=
{ to_fun := e.1.to_sheaf_on_opens, .. e }

def refl (F : locally_ringed_space_on_opens.{v} X U) : equiv F F :=
⟨morphism.id F, sheaf_on_opens.morphism.id F.to_sheaf_on_opens, λ _ _ _, rfl, λ _ _ _, rfl⟩

@[simp] lemma refl_apply (F : locally_ringed_space_on_opens.{v} X U) (V HV s) :
  (refl F).1.1 V HV s = s := rfl

def symm {F : locally_ringed_space_on_opens.{v} X U} {G : locally_ringed_space_on_opens.{v} X U} (e : equiv F G) : equiv G F :=
⟨{ hom := λ V HVU, (ring_equiv.symm { to_fun := e.1.1 V HVU, inv_fun := e.2.1 V HVU, left_inv := e.3 V HVU, right_inv := e.4 V HVU, hom := e.1.2 V HVU }).hom,
  .. e.2 },
e.1.to_sheaf_on_opens, e.4, e.3⟩

def trans {F : locally_ringed_space_on_opens.{v} X U} {G : locally_ringed_space_on_opens.{v} X U} {H : locally_ringed_space_on_opens.{u₁} X U}
  (e₁ : equiv F G) (e₂ : equiv G H) : equiv F H :=
⟨e₂.1.comp e₁.1, e₁.2.comp e₂.2,
λ _ _ _, by rw [morphism.comp_apply, sheaf_on_opens.morphism.comp_apply, e₂.3, e₁.3],
λ _ _ _, by rw [morphism.comp_apply, sheaf_on_opens.morphism.comp_apply, e₁.4, e₂.4]⟩

@[simp] lemma trans_apply {F : locally_ringed_space_on_opens.{v} X U} {G : locally_ringed_space_on_opens.{v} X U} {H : locally_ringed_space_on_opens.{u₁} X U}
  (e₁ : equiv F G) (e₂ : equiv G H) (V HV s) :
  (e₁.trans e₂).1.1 V HV s = e₂.1.1 V HV (e₁.1.1 V HV s) :=
rfl

def res_subset {F : locally_ringed_space_on_opens.{v} X U} {G : locally_ringed_space_on_opens.{w} X U} (e : equiv F G)
  (V : opens X) (HVU : V ≤ U) : equiv (F.res_subset V HVU) (G.res_subset V HVU) :=
⟨e.1.res_subset V HVU, e.2.res_subset V HVU,
λ _ _ _, by rw [morphism.res_subset_apply, sheaf_on_opens.morphism.res_subset_apply, e.3],
λ _ _ _, by rw [morphism.res_subset_apply, sheaf_on_opens.morphism.res_subset_apply, e.4]⟩

@[simp] lemma res_subset_apply {F : locally_ringed_space_on_opens.{v} X U} {G : locally_ringed_space_on_opens.{w} X U} (e : equiv F G)
  (V : opens X) (HVU : V ≤ U) (W HW s) :
  (e.res_subset V HVU).1.1 W HW s = e.1.1 W (le_trans HW HVU) s :=
rfl

def stalk {F : locally_ringed_space_on_opens.{v} X U} {G : locally_ringed_space_on_opens.{w} X U} (e : equiv F G) (x : X) (hx : x ∈ U) :
  F.stalk x hx ≃ G.stalk x hx :=
{ to_fun := e.1.stalk x hx,
  inv_fun := e.2.stalk x hx,
  left_inv := λ g, stalk.induction_on g $ λ V hxV HVU s, by rw [morphism.stalk_to_stalk, to_stalk, sheaf_on_opens.morphism.stalk_to_stalk, e.3]; refl,
  right_inv := λ g, stalk.induction_on g $ λ V hxV HVU s, by rw [to_stalk, sheaf_on_opens.morphism.stalk_to_stalk, ← to_stalk, morphism.stalk_to_stalk, e.4]; refl }

end equiv

def sheaf_glue {I : Type u} (S : I → opens X) (F : Π (i : I), locally_ringed_space_on_opens.{v} X (S i))
  (φ : Π i j, equiv ((F i).res_subset ((S i) ⊓ (S j)) inf_le_left) ((F j).res_subset ((S i) ⊓ (S j)) inf_le_right)) :
  locally_ringed_space_on_opens.{max u v} X (⋃S) :=
{ F :=
  { Fring := λ U, @subtype.comm_ring (Π (i : I), (F i).eval (S i ⊓ U) inf_le_left) _
      { f | ∀ (i j : I), (φ i j).1.map (S i ⊓ S j ⊓ U) inf_le_left
              ((F i).res (S i ⊓ U) inf_le_left (S i ⊓ S j ⊓ U) (le_trans inf_le_left inf_le_left)
                (le_inf (le_trans inf_le_left inf_le_left) inf_le_right)
                (f i)) =
            (F j).res (S j ⊓ U) inf_le_left (S i ⊓ S j ⊓ U) (le_trans inf_le_left inf_le_right)
              (by rw inf_assoc; exact inf_le_right)
              (f j) }
      { add_mem := λ f g hf hg i j, by erw [res_add, morphism.map_add, res_add, hf i j, hg i j],
        zero_mem := λ i j, by erw [res_zero, morphism.map_zero, res_zero]; refl,
        neg_mem := λ f hf i j, by erw [res_neg, morphism.map_neg, res_neg, hf i j],
        one_mem := λ i j, by erw [res_one, morphism.map_one, res_one]; refl,
        mul_mem := λ f g hf hg i j, by erw [res_mul, morphism.map_mul, res_mul, hf i j, hg i j] },
    res_is_ring_hom := λ U V HVU,
      { map_one := subtype.eq $ funext $ λ i, res_one _ _ _ _ _ _,
        map_mul := λ f g, subtype.eq $ funext $ λ i, res_mul _ _ _ _ _ _ _ _,
        map_add := λ f g, subtype.eq $ funext $ λ i, res_add _ _ _ _ _ _ _ _ },
    .. (sheaf_on_opens.sheaf_glue S (λ i, (F i).to_sheaf_on_opens) (λ i j, (φ i j).to_sheaf_on_opens)).F }
  .. sheaf_on_opens.sheaf_glue S (λ i, (F i).to_sheaf_on_opens) (λ i j, (φ i j).to_sheaf_on_opens) }

@[simp] lemma sheaf_glue_res_val {I : Type u} (S : I → opens X) (F : Π (i : I), locally_ringed_space_on_opens.{v} X (S i))
  (φ : Π i j, equiv ((F i).res_subset ((S i) ⊓ (S j)) inf_le_left) ((F j).res_subset ((S i) ⊓ (S j)) inf_le_right))
  (U HU V HV HVU s i) : ((sheaf_glue S F φ).res U HU V HV HVU s).1 i = (F i).res _ _ _ _ (inf_le_inf (le_refl _) HVU) (s.1 i) := rfl

def universal_property (I : Type u) (S : I → opens X) (F : Π (i : I), locally_ringed_space_on_opens.{v} X (S i))
  (φ : Π i j, equiv ((F i).res_subset ((S i) ⊓ (S j)) inf_le_left) ((F j).res_subset ((S i) ⊓ (S j)) inf_le_right))
  (Hφ1 : ∀ i V HV s, (φ i i).1.1 V HV s = s)
  (Hφ2 : ∀ i j k V HV1 HV2 HV3 s, (φ j k).1.1 V HV1 ((φ i j).1.1 V HV2 s) = (φ i k).1.1 V HV3 s)
  (i : I) :
  equiv (res_subset (sheaf_glue S F φ) (S i) (le_supr S i)) (F i) :=
{ to_fun :=
  { hom := λ U HU,
    { map_one := res_one _ _ _ _ _ _,
      map_mul := λ x y, res_mul _ _ _ _ _ _ _ _,
      map_add := λ x y, res_add _ _ _ _ _ _ _ _ },
    .. (sheaf_on_opens.universal_property I S (λ i, (F i).to_sheaf_on_opens) (λ i j, (φ i j).to_sheaf_on_opens) Hφ1 Hφ2 i).1 },
  .. sheaf_on_opens.universal_property I S (λ i, (F i).to_sheaf_on_opens) (λ i j, (φ i j).to_sheaf_on_opens) Hφ1 Hφ2 i }

end locally_ringed_space_on_opens