/-
Copyright (c) 2020 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.big_operators.ring
import Mathlib.number_theory.divisors
import Mathlib.algebra.squarefree
import Mathlib.algebra.invertible
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# Arithmetic Functions and Dirichlet Convolution

This file defines arithmetic functions, which are functions from `ℕ` to a specified type that map 0
to 0. In the literature, they are often instead defined as functions from `ℕ+`. These arithmetic
functions are endowed with a multiplication, given by Dirichlet convolution, and pointwise addition,
to form the Dirichlet ring.

## Main Definitions
 * `arithmetic_function R` consists of functions `f : ℕ → R` such that `f 0 = 0`.
 * An arithmetic function `f` `is_multiplicative` when `x.coprime y → f (x * y) = f x * f y`.
 * The pointwise operations `pmul` and `ppow` differ from the multiplication
  and power instances on `arithmetic_function R`, which use Dirichlet multiplication.
 * `ζ` is the arithmetic function such that `ζ x = 1` for `0 < x`.
 * `σ k` is the arithmetic function such that `σ k x = ∑ y in divisors x, y ^ k` for `0 < x`.
 * `pow k` is the arithmetic function such that `pow k x = x ^ k` for `0 < x`.
 * `id` is the identity arithmetic function on `ℕ`.
 * `ω n` is the number of distinct prime factors of `n`.
 * `Ω n` is the number of prime factors of `n` counted with multiplicity.
 * `μ` is the Möbius function.

## Main Results
 * Several forms of Möbius inversion:
 * `sum_eq_iff_sum_mul_moebius_eq` for functions to a `comm_ring`
 * `sum_eq_iff_sum_smul_moebius_eq` for functions to an `add_comm_group`
 * `prod_eq_iff_prod_pow_moebius_eq` for functions to a `comm_group`
 * `prod_eq_iff_prod_pow_moebius_eq_of_nonzero` for functions to a `comm_group_with_zero`

## Notation
The arithmetic functions `ζ` and `σ` have Greek letter names, which are localized notation in
the namespace `arithmetic_function`.

## Tags
arithmetic functions, dirichlet convolution, divisors

-/

namespace nat

/-- An arithmetic function is a function from `ℕ` that maps 0 to 0. In the literature, they are
  often instead defined as functions from `ℕ+`. Multiplication on `arithmetic_functions` is by
  Dirichlet convolution. -/
def arithmetic_function (R : Type u_1) [HasZero R] := zero_hom ℕ R

namespace arithmetic_function

@[simp] theorem to_fun_eq {R : Type u_1} [HasZero R] (f : arithmetic_function R) :
    zero_hom.to_fun f = ⇑f :=
  rfl

@[simp] theorem map_zero {R : Type u_1} [HasZero R] {f : arithmetic_function R} : coe_fn f 0 = 0 :=
  zero_hom.map_zero' f

theorem coe_inj {R : Type u_1} [HasZero R] {f : arithmetic_function R} {g : arithmetic_function R} :
    ⇑f = ⇑g ↔ f = g :=
  { mp := fun (h : ⇑f = ⇑g) => zero_hom.coe_inj h, mpr := fun (h : f = g) => h ▸ rfl }

@[simp] theorem zero_apply {R : Type u_1} [HasZero R] {x : ℕ} : coe_fn 0 x = 0 :=
  zero_hom.zero_apply x

theorem ext {R : Type u_1} [HasZero R] {f : arithmetic_function R} {g : arithmetic_function R}
    (h : ∀ (x : ℕ), coe_fn f x = coe_fn g x) : f = g :=
  zero_hom.ext h

theorem ext_iff {R : Type u_1} [HasZero R] {f : arithmetic_function R} {g : arithmetic_function R} :
    f = g ↔ ∀ (x : ℕ), coe_fn f x = coe_fn g x :=
  zero_hom.ext_iff

protected instance has_one {R : Type u_1} [HasZero R] [HasOne R] : HasOne (arithmetic_function R) :=
  { one := zero_hom.mk (fun (x : ℕ) => ite (x = 1) 1 0) sorry }

@[simp] theorem one_one {R : Type u_1} [HasZero R] [HasOne R] : coe_fn 1 1 = 1 := rfl

@[simp] theorem one_apply_ne {R : Type u_1} [HasZero R] [HasOne R] {x : ℕ} (h : x ≠ 1) :
    coe_fn 1 x = 0 :=
  if_neg h

protected instance nat_coe {R : Type u_1} [HasZero R] [HasOne R] [Add R] :
    has_coe (arithmetic_function ℕ) (arithmetic_function R) :=
  has_coe.mk fun (f : arithmetic_function ℕ) => zero_hom.mk ↑⇑f sorry

@[simp] theorem nat_coe_nat (f : arithmetic_function ℕ) : ↑f = f :=
  ext fun (_x : ℕ) => cast_id (coe_fn f _x)

@[simp] theorem nat_coe_apply {R : Type u_1} [HasZero R] [HasOne R] [Add R]
    {f : arithmetic_function ℕ} {x : ℕ} : coe_fn (↑f) x = ↑(coe_fn f x) :=
  rfl

protected instance int_coe {R : Type u_1} [HasZero R] [HasOne R] [Add R] [Neg R] :
    has_coe (arithmetic_function ℤ) (arithmetic_function R) :=
  has_coe.mk fun (f : arithmetic_function ℤ) => zero_hom.mk ↑⇑f sorry

@[simp] theorem int_coe_int (f : arithmetic_function ℤ) : ↑f = f :=
  ext fun (_x : ℕ) => int.cast_id (coe_fn f _x)

@[simp] theorem int_coe_apply {R : Type u_1} [HasZero R] [HasOne R] [Add R] [Neg R]
    {f : arithmetic_function ℤ} {x : ℕ} : coe_fn (↑f) x = ↑(coe_fn f x) :=
  rfl

@[simp] theorem coe_coe {R : Type u_1} [HasZero R] [HasOne R] [Add R] [Neg R]
    {f : arithmetic_function ℕ} : ↑↑f = ↑f :=
  sorry

protected instance has_add {R : Type u_1} [add_monoid R] : Add (arithmetic_function R) :=
  { add :=
      fun (f g : arithmetic_function R) =>
        zero_hom.mk (fun (n : ℕ) => coe_fn f n + coe_fn g n) sorry }

@[simp] theorem add_apply {R : Type u_1} [add_monoid R] {f : arithmetic_function R}
    {g : arithmetic_function R} {n : ℕ} : coe_fn (f + g) n = coe_fn f n + coe_fn g n :=
  rfl

protected instance add_monoid {R : Type u_1} [add_monoid R] : add_monoid (arithmetic_function R) :=
  add_monoid.mk Add.add sorry 0 sorry sorry

protected instance add_comm_monoid {R : Type u_1} [add_comm_monoid R] :
    add_comm_monoid (arithmetic_function R) :=
  add_comm_monoid.mk add_monoid.add sorry add_monoid.zero sorry sorry sorry

protected instance add_group {R : Type u_1} [add_group R] : add_group (arithmetic_function R) :=
  add_group.mk add_monoid.add sorry add_monoid.zero sorry sorry
    (fun (f : arithmetic_function R) => zero_hom.mk (fun (n : ℕ) => -coe_fn f n) sorry)
    (sub_neg_monoid.sub._default add_monoid.add sorry add_monoid.zero sorry sorry
      fun (f : arithmetic_function R) => zero_hom.mk (fun (n : ℕ) => -coe_fn f n) sorry)
    sorry

protected instance add_comm_group {R : Type u_1} [add_comm_group R] :
    add_comm_group (arithmetic_function R) :=
  add_comm_group.mk add_comm_monoid.add sorry add_comm_monoid.zero sorry sorry add_group.neg
    add_group.sub sorry sorry

/-- The Dirichlet convolution of two arithmetic functions `f` and `g` is another arithmetic function
  such that `(f * g) n` is the sum of `f x * g y` over all `(x,y)` such that `x * y = n`. -/
protected instance has_scalar {R : Type u_1} {M : Type u_2} [HasZero R] [add_comm_monoid M]
    [has_scalar R M] : has_scalar (arithmetic_function R) (arithmetic_function M) :=
  has_scalar.mk
    fun (f : arithmetic_function R) (g : arithmetic_function M) =>
      zero_hom.mk
        (fun (n : ℕ) =>
          finset.sum (divisors_antidiagonal n)
            fun (x : ℕ × ℕ) => coe_fn f (prod.fst x) • coe_fn g (prod.snd x))
        sorry

@[simp] theorem smul_apply {R : Type u_1} {M : Type u_2} [HasZero R] [add_comm_monoid M]
    [has_scalar R M] {f : arithmetic_function R} {g : arithmetic_function M} {n : ℕ} :
    coe_fn (f • g) n =
        finset.sum (divisors_antidiagonal n)
          fun (x : ℕ × ℕ) => coe_fn f (prod.fst x) • coe_fn g (prod.snd x) :=
  rfl

/-- The Dirichlet convolution of two arithmetic functions `f` and `g` is another arithmetic function
  such that `(f * g) n` is the sum of `f x * g y` over all `(x,y)` such that `x * y = n`. -/
protected instance has_mul {R : Type u_1} [semiring R] : Mul (arithmetic_function R) :=
  { mul := has_scalar.smul }

@[simp] theorem mul_apply {R : Type u_1} [semiring R] {f : arithmetic_function R}
    {g : arithmetic_function R} {n : ℕ} :
    coe_fn (f * g) n =
        finset.sum (divisors_antidiagonal n)
          fun (x : ℕ × ℕ) => coe_fn f (prod.fst x) * coe_fn g (prod.snd x) :=
  rfl

theorem mul_smul' {R : Type u_1} {M : Type u_2} [semiring R] [add_comm_monoid M] [semimodule R M]
    (f : arithmetic_function R) (g : arithmetic_function R) (h : arithmetic_function M) :
    (f * g) • h = f • g • h :=
  sorry

theorem one_smul' {R : Type u_1} {M : Type u_2} [semiring R] [add_comm_monoid M] [semimodule R M]
    (b : arithmetic_function M) : 1 • b = b :=
  sorry

protected instance monoid {R : Type u_1} [semiring R] : monoid (arithmetic_function R) :=
  monoid.mk Mul.mul sorry 1 sorry sorry

protected instance semiring {R : Type u_1} [semiring R] : semiring (arithmetic_function R) :=
  semiring.mk Add.add sorry 0 sorry sorry sorry Mul.mul sorry monoid.one sorry sorry sorry sorry
    sorry sorry

protected instance comm_semiring {R : Type u_1} [comm_semiring R] :
    comm_semiring (arithmetic_function R) :=
  comm_semiring.mk semiring.add sorry semiring.zero sorry sorry sorry semiring.mul sorry
    semiring.one sorry sorry sorry sorry sorry sorry sorry

protected instance comm_ring {R : Type u_1} [comm_ring R] : comm_ring (arithmetic_function R) :=
  comm_ring.mk add_comm_group.add sorry add_comm_group.zero sorry sorry add_comm_group.neg
    add_comm_group.sub sorry sorry comm_semiring.mul sorry comm_semiring.one sorry sorry sorry sorry
    sorry

protected instance semimodule {R : Type u_1} {M : Type u_2} [semiring R] [add_comm_monoid M]
    [semimodule R M] : semimodule (arithmetic_function R) (arithmetic_function M) :=
  semimodule.mk sorry sorry

/-- `ζ 0 = 0`, otherwise `ζ x = 1`. The Dirichlet Series is the Riemann ζ.  -/
def zeta : arithmetic_function ℕ := zero_hom.mk (fun (x : ℕ) => ite (x = 0) 0 1) sorry

@[simp] theorem zeta_apply {x : ℕ} : coe_fn zeta x = ite (x = 0) 0 1 := rfl

theorem zeta_apply_ne {x : ℕ} (h : x ≠ 0) : coe_fn zeta x = 1 := if_neg h

@[simp] theorem coe_zeta_mul_apply {R : Type u_1} [semiring R] {f : arithmetic_function R} {x : ℕ} :
    coe_fn (↑zeta * f) x = finset.sum (divisors x) fun (i : ℕ) => coe_fn f i :=
  sorry

theorem coe_zeta_smul_apply {R : Type u_1} {M : Type u_2} [comm_ring R] [add_comm_group M]
    [module R M] {f : arithmetic_function M} {x : ℕ} :
    coe_fn (↑zeta • f) x = finset.sum (divisors x) fun (i : ℕ) => coe_fn f i :=
  sorry

@[simp] theorem coe_mul_zeta_apply {R : Type u_1} [semiring R] {f : arithmetic_function R} {x : ℕ} :
    coe_fn (f * ↑zeta) x = finset.sum (divisors x) fun (i : ℕ) => coe_fn f i :=
  sorry

theorem zeta_mul_apply {f : arithmetic_function ℕ} {x : ℕ} :
    coe_fn (zeta * f) x = finset.sum (divisors x) fun (i : ℕ) => coe_fn f i :=
  sorry

theorem mul_zeta_apply {f : arithmetic_function ℕ} {x : ℕ} :
    coe_fn (f * zeta) x = finset.sum (divisors x) fun (i : ℕ) => coe_fn f i :=
  sorry

/-- This is the pointwise product of `arithmetic_function`s. -/
def pmul {R : Type u_1} [mul_zero_class R] (f : arithmetic_function R) (g : arithmetic_function R) :
    arithmetic_function R :=
  zero_hom.mk (fun (x : ℕ) => coe_fn f x * coe_fn g x) sorry

@[simp] theorem pmul_apply {R : Type u_1} [mul_zero_class R] {f : arithmetic_function R}
    {g : arithmetic_function R} {x : ℕ} : coe_fn (pmul f g) x = coe_fn f x * coe_fn g x :=
  rfl

theorem pmul_comm {R : Type u_1} [comm_monoid_with_zero R] (f : arithmetic_function R)
    (g : arithmetic_function R) : pmul f g = pmul g f :=
  sorry

@[simp] theorem pmul_zeta {R : Type u_1} [semiring R] (f : arithmetic_function R) :
    pmul f ↑zeta = f :=
  sorry

@[simp] theorem zeta_pmul {R : Type u_1} [semiring R] (f : arithmetic_function R) :
    pmul (↑zeta) f = f :=
  sorry

/-- This is the pointwise power of `arithmetic_function`s. -/
def ppow {R : Type u_1} [semiring R] (f : arithmetic_function R) (k : ℕ) : arithmetic_function R :=
  dite (k = 0) (fun (h0 : k = 0) => ↑zeta)
    fun (h0 : ¬k = 0) => zero_hom.mk (fun (x : ℕ) => coe_fn f x ^ k) sorry

@[simp] theorem ppow_zero {R : Type u_1} [semiring R] {f : arithmetic_function R} :
    ppow f 0 = ↑zeta :=
  sorry

@[simp] theorem ppow_apply {R : Type u_1} [semiring R] {f : arithmetic_function R} {k : ℕ} {x : ℕ}
    (kpos : 0 < k) : coe_fn (ppow f k) x = coe_fn f x ^ k :=
  sorry

theorem ppow_succ {R : Type u_1} [semiring R] {f : arithmetic_function R} {k : ℕ} :
    ppow f (k + 1) = pmul f (ppow f k) :=
  sorry

theorem ppow_succ' {R : Type u_1} [semiring R] {f : arithmetic_function R} {k : ℕ} {kpos : 0 < k} :
    ppow f (k + 1) = pmul (ppow f k) f :=
  sorry

/-- Multiplicative functions -/
def is_multiplicative {R : Type u_1} [monoid_with_zero R] (f : arithmetic_function R) :=
  coe_fn f 1 = 1 ∧ ∀ {m n : ℕ}, coprime m n → coe_fn f (m * n) = coe_fn f m * coe_fn f n

namespace is_multiplicative

@[simp] theorem map_one {R : Type u_1} [monoid_with_zero R] {f : arithmetic_function R}
    (h : is_multiplicative f) : coe_fn f 1 = 1 :=
  and.left h

@[simp] theorem map_mul_of_coprime {R : Type u_1} [monoid_with_zero R] {f : arithmetic_function R}
    (hf : is_multiplicative f) {m : ℕ} {n : ℕ} (h : coprime m n) :
    coe_fn f (m * n) = coe_fn f m * coe_fn f n :=
  and.right hf m n h

theorem nat_cast {R : Type u_1} {f : arithmetic_function ℕ} [semiring R] (h : is_multiplicative f) :
    is_multiplicative ↑f :=
  sorry

theorem int_cast {R : Type u_1} {f : arithmetic_function ℤ} [ring R] (h : is_multiplicative f) :
    is_multiplicative ↑f :=
  sorry

theorem mul {R : Type u_1} [comm_semiring R] {f : arithmetic_function R} {g : arithmetic_function R}
    (hf : is_multiplicative f) (hg : is_multiplicative g) : is_multiplicative (f * g) :=
  sorry

theorem pmul {R : Type u_1} [comm_semiring R] {f : arithmetic_function R}
    {g : arithmetic_function R} (hf : is_multiplicative f) (hg : is_multiplicative g) :
    is_multiplicative (pmul f g) :=
  sorry

end is_multiplicative

/-- The identity on `ℕ` as an `arithmetic_function`.  -/
def id : arithmetic_function ℕ := zero_hom.mk id sorry

@[simp] theorem id_apply {x : ℕ} : coe_fn id x = x := rfl

/-- `pow k n = n ^ k`, except `pow 0 0 = 0`. -/
def pow (k : ℕ) : arithmetic_function ℕ := ppow id k

@[simp] theorem pow_apply {k : ℕ} {n : ℕ} : coe_fn (pow k) n = ite (k = 0 ∧ n = 0) 0 (n ^ k) :=
  sorry

/-- `σ k n` is the sum of the `k`th powers of the divisors of `n` -/
def sigma (k : ℕ) : arithmetic_function ℕ :=
  zero_hom.mk (fun (n : ℕ) => finset.sum (divisors n) fun (d : ℕ) => d ^ k) sorry

@[simp] theorem sigma_apply {k : ℕ} {n : ℕ} :
    coe_fn (sigma k) n = finset.sum (divisors n) fun (d : ℕ) => d ^ k :=
  rfl

theorem sigma_one_apply {n : ℕ} : coe_fn (sigma 1) n = finset.sum (divisors n) fun (d : ℕ) => d :=
  sorry

theorem zeta_mul_pow_eq_sigma {k : ℕ} : zeta * pow k = sigma k := sorry

theorem is_multiplicative_zeta : is_multiplicative zeta := sorry

theorem is_multiplicative_id : is_multiplicative id :=
  { left := rfl, right := fun (_x _x_1 : ℕ) (_x_2 : coprime _x _x_1) => rfl }

theorem is_multiplicative.ppow {R : Type u_1} [comm_semiring R] {f : arithmetic_function R}
    (hf : is_multiplicative f) {k : ℕ} : is_multiplicative (ppow f k) :=
  sorry

theorem is_multiplicative_pow {k : ℕ} : is_multiplicative (pow k) :=
  is_multiplicative.ppow is_multiplicative_id

theorem is_multiplicative_sigma {k : ℕ} : is_multiplicative (sigma k) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (is_multiplicative (sigma k))) (Eq.symm zeta_mul_pow_eq_sigma)))
    (is_multiplicative.mul is_multiplicative_zeta is_multiplicative_pow)

/-- `Ω n` is the number of prime factors of `n`. -/
def card_factors : arithmetic_function ℕ :=
  zero_hom.mk (fun (n : ℕ) => list.length (factors n)) sorry

theorem card_factors_apply {n : ℕ} : coe_fn card_factors n = list.length (factors n) := rfl

@[simp] theorem card_factors_one : coe_fn card_factors 1 = 0 := rfl

theorem card_factors_eq_one_iff_prime {n : ℕ} : coe_fn card_factors n = 1 ↔ prime n := sorry

theorem card_factors_mul {m : ℕ} {n : ℕ} (m0 : m ≠ 0) (n0 : n ≠ 0) :
    coe_fn card_factors (m * n) = coe_fn card_factors m + coe_fn card_factors n :=
  sorry

theorem card_factors_multiset_prod {s : multiset ℕ} (h0 : multiset.prod s ≠ 0) :
    coe_fn card_factors (multiset.prod s) = multiset.sum (multiset.map (⇑card_factors) s) :=
  sorry

/-- `ω n` is the number of distinct prime factors of `n`. -/
def card_distinct_factors : arithmetic_function ℕ :=
  zero_hom.mk (fun (n : ℕ) => list.length (list.erase_dup (factors n))) sorry

@[simp] theorem card_distinct_factors_zero : coe_fn card_distinct_factors 0 = 0 := rfl

theorem card_distinct_factors_apply {n : ℕ} :
    coe_fn card_distinct_factors n = list.length (list.erase_dup (factors n)) :=
  rfl

theorem card_distinct_factors_eq_card_factors_iff_squarefree {n : ℕ} (h0 : n ≠ 0) :
    coe_fn card_distinct_factors n = coe_fn card_factors n ↔ squarefree n :=
  sorry

/-- `μ` is the Möbius function. If `n` is squarefree with an even number of distinct prime factors,
  `μ n = 1`. If `n` is squarefree with an odd number of distinct prime factors, `μ n = -1`.
  If `n` is not squarefree, `μ n = 0`. -/
def moebius : arithmetic_function ℤ :=
  zero_hom.mk (fun (n : ℕ) => ite (squarefree n) ((-1) ^ coe_fn card_factors n) 0) sorry

@[simp] theorem moebius_apply_of_squarefree {n : ℕ} (h : squarefree n) :
    coe_fn moebius n = (-1) ^ coe_fn card_factors n :=
  if_pos h

@[simp] theorem moebius_eq_zero_of_not_squarefree {n : ℕ} (h : ¬squarefree n) :
    coe_fn moebius n = 0 :=
  if_neg h

theorem moebius_ne_zero_iff_squarefree {n : ℕ} : coe_fn moebius n ≠ 0 ↔ squarefree n := sorry

theorem moebius_ne_zero_iff_eq_or {n : ℕ} :
    coe_fn moebius n ≠ 0 ↔ coe_fn moebius n = 1 ∨ coe_fn moebius n = -1 :=
  sorry

@[simp] theorem coe_moebius_mul_coe_zeta {R : Type u_1} [comm_ring R] : ↑moebius * ↑zeta = 1 :=
  sorry

@[simp] theorem coe_zeta_mul_coe_moebius {R : Type u_1} [comm_ring R] : ↑zeta * ↑moebius = 1 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑zeta * ↑moebius = 1)) (mul_comm ↑zeta ↑moebius)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑moebius * ↑zeta = 1)) (coe_moebius_mul_coe_zeta R _inst_1)))
      (Eq.refl 1))

@[simp] theorem moebius_mul_coe_zeta : moebius * ↑zeta = 1 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (moebius * ↑zeta = 1)) (Eq.symm (int_coe_int moebius))))
    (eq.mpr
      (id (Eq._oldrec (Eq.refl (↑moebius * ↑zeta = 1)) (coe_moebius_mul_coe_zeta ℤ int.comm_ring)))
      (Eq.refl 1))

@[simp] theorem coe_zeta_mul_moebius : ↑zeta * moebius = 1 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑zeta * moebius = 1)) (Eq.symm (int_coe_int moebius))))
    (eq.mpr
      (id (Eq._oldrec (Eq.refl (↑zeta * ↑moebius = 1)) (coe_zeta_mul_coe_moebius ℤ int.comm_ring)))
      (Eq.refl 1))

protected instance zeta.invertible {R : Type u_1} [comm_ring R] : invertible ↑zeta :=
  invertible.mk (↑moebius) (coe_moebius_mul_coe_zeta R _inst_1) (coe_zeta_mul_coe_moebius R _inst_1)

/-- A unit in `arithmetic_function R` that evaluates to `ζ`, with inverse `μ`. -/
def zeta_unit {R : Type u_1} [comm_ring R] : units (arithmetic_function R) :=
  units.mk (↑zeta) (↑moebius) (coe_zeta_mul_coe_moebius R _inst_1)
    (coe_moebius_mul_coe_zeta R _inst_1)

@[simp] theorem coe_zeta_unit {R : Type u_1} [comm_ring R] : ↑(zeta_unit R _inst_1) = ↑zeta := rfl

@[simp] theorem inv_zeta_unit {R : Type u_1} [comm_ring R] : ↑(zeta_unit R _inst_1⁻¹) = ↑moebius :=
  rfl

/-- Möbius inversion for functions to an `add_comm_group`. -/
theorem sum_eq_iff_sum_smul_moebius_eq {R : Type u_1} [add_comm_group R] {f : ℕ → R} {g : ℕ → R} :
    (∀ (n : ℕ), 0 < n → (finset.sum (divisors n) fun (i : ℕ) => f i) = g n) ↔
        ∀ (n : ℕ),
          0 < n →
            (finset.sum (divisors_antidiagonal n)
                fun (x : ℕ × ℕ) => coe_fn moebius (prod.fst x) • g (prod.snd x)) =
              f n :=
  sorry

/-- Möbius inversion for functions to a `comm_ring`. -/
theorem sum_eq_iff_sum_mul_moebius_eq {R : Type u_1} [comm_ring R] {f : ℕ → R} {g : ℕ → R} :
    (∀ (n : ℕ), 0 < n → (finset.sum (divisors n) fun (i : ℕ) => f i) = g n) ↔
        ∀ (n : ℕ),
          0 < n →
            (finset.sum (divisors_antidiagonal n)
                fun (x : ℕ × ℕ) => ↑(coe_fn moebius (prod.fst x)) * g (prod.snd x)) =
              f n :=
  sorry

/-- Möbius inversion for functions to a `comm_group`. -/
theorem prod_eq_iff_prod_pow_moebius_eq {R : Type u_1} [comm_group R] {f : ℕ → R} {g : ℕ → R} :
    (∀ (n : ℕ), 0 < n → (finset.prod (divisors n) fun (i : ℕ) => f i) = g n) ↔
        ∀ (n : ℕ),
          0 < n →
            (finset.prod (divisors_antidiagonal n)
                fun (x : ℕ × ℕ) => g (prod.snd x) ^ coe_fn moebius (prod.fst x)) =
              f n :=
  sum_eq_iff_sum_smul_moebius_eq (additive R) additive.add_comm_group (fun (i : ℕ) => f i)
    fun (n : ℕ) => g n

/-- Möbius inversion for functions to a `comm_group_with_zero`. -/
theorem prod_eq_iff_prod_pow_moebius_eq_of_nonzero {R : Type u_1} [comm_group_with_zero R]
    {f : ℕ → R} {g : ℕ → R} (hf : ∀ (n : ℕ), 0 < n → f n ≠ 0) (hg : ∀ (n : ℕ), 0 < n → g n ≠ 0) :
    (∀ (n : ℕ), 0 < n → (finset.prod (divisors n) fun (i : ℕ) => f i) = g n) ↔
        ∀ (n : ℕ),
          0 < n →
            (finset.prod (divisors_antidiagonal n)
                fun (x : ℕ × ℕ) => g (prod.snd x) ^ coe_fn moebius (prod.fst x)) =
              f n :=
  sorry

end Mathlib


lemma contra (P Q : Prop) : (P ∧ ¬ P) → Q :=
begin
-- rw not_iff_imp_false,
intro h,
exfalso,
cases h,
exact h_right(h_left),
end


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Lucas Allen, Scott Morrison

! This file was ported from Lean 3 source module tactic.converter.apply_congr
! leanprover-community/mathlib commit 3d7987cda72abc473c7cdbbb075170e9ac620042
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.Interactive
import Mathbin.Tactic.Converter.Interactive

/-!
## Introduce the `apply_congr` conv mode tactic.

`apply_congr` will apply congruence lemmas inside `conv` mode.
It is particularly useful when the automatically generated congruence lemmas
are not of the optimal shape. An example, described in the doc-string is
rewriting inside the operand of a `finset.sum`.
-/

open Tactic

namespace Conv.Interactive

open Interactive Interactive.Types Lean.Parser

-- mathport name: parser.optional
local postfix:1024 "?" => optional

/-- Apply a congruence lemma inside `conv` mode.

When called without an argument `apply_congr` will try applying all lemmas marked with `@[congr]`.
Otherwise `apply_congr e` will apply the lemma `e`.

Recall that a goal that appears as `∣ X` in `conv` mode
represents a goal of `⊢ X = ?m`,
i.e. an equation with a metavariable for the right hand side.

To successfully use `apply_congr e`, `e` will need to be an equation
(possibly after function arguments),
which can be unified with a goal of the form `X = ?m`.
The right hand side of `e` will then determine the metavariable,
and `conv` will subsequently replace `X` with that right hand side.

As usual, `apply_congr` can create new goals;
any of these which are _not_ equations with a metavariable on the right hand side
will be hard to deal with in `conv` mode.
Thus `apply_congr` automatically calls `intros` on any new goals,
and fails if they are not then equations.

In particular it is useful for rewriting inside the operand of a `finset.sum`,
as it provides an extra hypothesis asserting we are inside the domain.

For example:

```lean
example (f g : ℤ → ℤ) (S : finset ℤ) (h : ∀ m ∈ S, f m = g m) :
  finset.sum S f = finset.sum S g :=
begin
  conv_lhs
  { -- If we just call `congr` here, in the second goal we're helpless,
    -- because we are only given the opportunity to rewrite `f`.
    -- However `apply_congr` uses the appropriate `@[congr]` lemma,
    -- so we get to rewrite `f x`, in the presence of the crucial `H : x ∈ S` hypothesis.
    apply_congr,
    skip,
    simp [h, H], }
end
```

In the above example, when the `apply_congr` tactic is called it gives the hypothesis `H : x ∈ S`
which is then used to rewrite the `f x` to `g x`.
-/
unsafe def apply_congr (q : parse texpr ?) : conv Unit := do
  let congr_lemmas ←
    match q with
      |-- If the user specified a lemma, use that one,
          some
          e =>
        do
        let gs ← get_goals
        let e ← to_expr e
        -- to_expr messes with the goals? (see tests)
            set_goals
            gs
        return [e]
      |-- otherwise, look up everything tagged `@[congr]`
        none =>
        do
        let congr_lemma_names ← attribute.get_instances `congr
        congr_lemma_names mk_const
  -- For every lemma:
      congr_lemmas
      fun n =>
      -- Call tactic.eapply
        seq'
        (tactic.eapply n >> tactic.skip)
        (-- and then call `intros` on each resulting goal, and require that afterwards it's an equation.
          tactic.intros >>
          do
          let q(_ = _) ← target
          tactic.skip)
#align conv.interactive.apply_congr conv.interactive.apply_congr

add_tactic_doc
  { Name := "apply_congr"
    category := DocCategory.tactic
    declNames := [`conv.interactive.apply_congr]
    tags := ["conv", "congruence", "rewriting"] }

end Conv.Interactive


/-
Copyright (c) 2021 Jannis Limperg. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jannis Limperg
-/
import Lean.Elab.Tactic

namespace Lean.Aesop.DefaultRules

-- We define the `splitHyp` tactic, which splits hypotheses that are products
-- or existentials. It recurses into nested products, so `A ∧ B ∧ C` is split
-- into three hypotheses with types `A`, `B` and `C`. It also works under
-- binders, so `h : ∀ x, P x ∧ Q x` is split into `h₁ : ∀ x, P x` and
-- `h₂ : ∀ x, Q x`.
--
-- Exception: `Exists`, unlike `Sigma` and `PSigma`, cannot be split under
-- binders. This is unavoidable: `∀ (x : X), ∃ (y : Y), P y` does not imply
-- `∃ (f : X → Y), ∀ x, P (f x)` in Lean's logic.

-- TODO The splitHyps tactic currently does not handle existentials with
-- products nested in the witness. E.g. the hypothesis
--
--   h : ∃ (p : X × Y), P p
--
-- is decomposed into
--
--   h₁ : X × Y
--   h₂ : P h₁
--
-- when it should really be
--
--   h₁ : X
--   h₂ : Y
--   h₃ : P (h₁, h₂)
--
-- To fix this, we should canonicalise such hypotheses before splitting them.
-- The canonicalisation would make sure the witness is not a product by
-- rewriting, e.g.,
--
--   ∃ (p : X × Y), P p           ↝ ∃ (x : X) (y : Y), P (x, y)
--   ∃ (p : ∃ (x : X), P x), Q p  ↝ ∃ (x : X) (y : P x), Q (Exists.intro x y)
--
-- @[simp]
-- theorem exists_prod {X Y} (P : X × Y → Prop) :
--     (∃ (p : X × Y), P p) ↔ ∃ (x : X) (y : Y), P (x, y) :=
--   Iff.intro
--     (λ ⟨⟨x, y⟩, Pp⟩ => ⟨x, y, Pp⟩)
--     (λ ⟨x, y, Pxy⟩ => ⟨⟨x, y⟩, Pxy⟩)
--
-- We could also use this implementation strategy for splitting under binders:
-- rewrite `∀ x, P x ∧ Q x` into `(∀ x, P x) ∧ (∀ x, Q x)`. This would reduce
-- the implementation complexity a lot, though at some performance cost.

open Expr
open Lean.Meta

partial def splitHypCore (goal : MVarId) (originalUserName : Name)
    (binderFVars : Array Expr) (hyp : FVarId) (type : Expr) :
    MetaM (Array FVarId × MVarId) :=
  match type with
  | forallE .. => do
    forallTelescope type λ binders conclusion =>
      splitHypCore goal originalUserName (binderFVars ++ binders) hyp conclusion
  | app (app (const ``And lvls _) leftType _) rightType _ =>
    splitProduct goal (mkConst ``And.left lvls) (mkConst ``And.right lvls)
      leftType rightType
  | app (app (const ``Prod lvls _) leftType _) rightType _ =>
    splitProduct goal (mkConst ``Prod.fst lvls) (mkConst ``Prod.snd lvls)
      leftType rightType
  | app (app (const ``PProd lvls _) leftType _) rightType _ =>
    splitProduct goal (mkConst ``PProd.fst lvls) (mkConst ``PProd.snd lvls)
      leftType rightType
  | app (app (const ``MProd lvls _) leftType _) rightType _ =>
    splitProduct goal (mkConst ``MProd.fst lvls) (mkConst ``MProd.snd lvls)
      leftType rightType
  | app (app (const ``Sigma lvls _) witnessType _) propertyType _ => do
    splitExistential goal (mkConst ``Sigma.fst lvls) (mkConst ``Sigma.snd lvls)
      witnessType propertyType
  | app (app (const ``PSigma lvls _) witnessType _) propertyType _ => do
    splitExistential goal (mkConst ``PSigma.fst lvls) (mkConst ``PSigma.snd lvls)
      witnessType propertyType
  | app (app (const ``Exists lvls _) witnessType _) propertyType _ => do
    -- We can't eliminate Exists under binders.
    if ¬ binderFVars.isEmpty then
      return (#[], goal)
    let #[casesGoal] ← cases goal hyp
      | unreachable!
    pure (casesGoal.fields.map (·.fvarId!), casesGoal.mvarId)
  | _ => pure (#[], goal)
  where
    hypWithBinderFVars : Expr :=
      mkAppN (mkFVar hyp) binderFVars

    splitProductHalf (goal : MVarId) (left : Bool)
        (eliminator leftType rightType : Expr) : MetaM (FVarId × MVarId) := do
      let type := if left then leftType else rightType
      let newHypType ← mkForallFVars binderFVars type
      let newHypProof ← mkLambdaFVars binderFVars $
        mkAppN eliminator #[leftType, rightType, hypWithBinderFVars]
      let goal ← assert goal originalUserName newHypType newHypProof
      let (newHyp, goal) ← intro1 goal
      return (newHyp, goal)

    splitProduct (goal : MVarId)
        (leftEliminator rightEliminator leftType rightType : Expr) :
        MetaM (Array FVarId × MVarId) := do
      let (leftHyp, goal) ←
        splitProductHalf goal true  leftEliminator  leftType rightType
      let (rightHyp, goal) ←
        splitProductHalf goal false rightEliminator leftType rightType
      let (goal, cleared) :=
        match (← observing? $ clear goal hyp) with
        | none => (goal, false)
        | some goal => (goal, true)
      let (leftHyps, goal)  ←
        splitHypCore goal originalUserName binderFVars leftHyp  leftType
      let (rightHyps, goal) ←
        splitHypCore goal originalUserName binderFVars rightHyp rightType
      let newHyps := (if cleared then #[] else #[hyp]) ++ leftHyps ++ rightHyps
      return (newHyps, goal)

    splitExistential (oldGoal : MVarId)
        (witnessProjection propertyProjection witnessType propertyType : Expr) :
        MetaM (Array FVarId × MVarId) := do

      checkNotAssigned goal `splitHyp
      let tag ← getMVarTag goal
      let oldTarget ← getMVarType goal

      -- I don't see how to make `assert` work with successive dependent
      -- hypotheses, so here's a reimplementation. We assert one hypothesis for
      -- the witness and one for the property, where the property hypothesis
      -- depends on the witness hypothesis.
      let witnessHypType ← mkForallFVars binderFVars witnessType
      let newTarget ← do
        withLocalDeclD originalUserName witnessHypType λ witness => do
          let propertyHypType ←
            mkForallFVars binderFVars $
            (← headBeta (mkApp propertyType (mkAppN witness binderFVars)))
          withLocalDeclD originalUserName propertyHypType λ property =>
            mkForallFVars (#[witness, property]) oldTarget
      let goal ← withMVarContext goal $
        mkFreshExprSyntheticOpaqueMVar newTarget tag

      let witnessHypProof ← mkLambdaFVars binderFVars $
        mkAppN witnessProjection #[witnessType, propertyType, hypWithBinderFVars]
      let propertyHypProof ← mkLambdaFVars binderFVars $
        mkAppN propertyProjection #[witnessType, propertyType, hypWithBinderFVars]
      let proof := mkAppN goal #[witnessHypProof, propertyHypProof]
      assignExprMVar oldGoal proof

      let goal := goal.mvarId!
      let (#[witnessHyp, propertyHyp], goal) ← introN goal 2 | unreachable!

      let (goal, cleared) :=
        match (← observing? $ clear goal hyp) with
        | none => (goal, false)
        | some goal => (goal, true)
      let propertyHypTypeWithoutBinders ←
        headBeta (mkApp propertyType $ mkAppN (mkFVar witnessHyp) binderFVars)
      let (newHyps, goal) ←
        splitHypCore goal originalUserName binderFVars propertyHyp
          propertyHypTypeWithoutBinders
      let newHyps := (if cleared then #[] else #[hyp]) ++ newHyps
      return (newHyps, goal)

def splitHyp (goal : MVarId) (hyp : FVarId) : MetaM (Array FVarId × MVarId) :=
  withMVarContext goal do
    let decl ← getLocalDecl hyp
    splitHypCore goal decl.userName #[] hyp decl.type

def splitAllHyps (goal : MVarId) : MetaM (Array FVarId × MVarId) := do
  let lctx := (← getMVarDecl goal).lctx
  let mut goal := goal
  let mut newHyps := #[]
  for hyp in lctx do
    if hyp.isAuxDecl then continue
    let (newHyps', goal') ← splitHyp goal hyp.fvarId
    newHyps := newHyps ++ newHyps'
    goal := goal'
  return (newHyps, goal)

end Lean.Aesop.DefaultRules


/-
Copyright (c) 2022 Joël Riou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joël Riou
-/

import for_mathlib.idempotents.karoubi
import for_mathlib.functor_misc
import category_theory.natural_isomorphism

/-!
# Extension of functors to the idempotent completion

In this file, we obtain an equivalence of categories
`karoubi_universal₁ C D : (C ⥤ karoubi D) ≌ (karoubi C ⥤ karoubi D)` for
all categories `C` and `D`. The key construction is `functor_extension₁`
which extends a functor `C ⥤ karoubi D` to a functor `karoubi C ⥤ karoubi D`.

TODO : If `D` is idempotent complete, we also have
`karoubi_universal C D : C ⥤ D ≌ karoubi C ⥤ D`.

-/

open category_theory.category
open category_theory.idempotents.karoubi

namespace category_theory

namespace idempotents

variables {C D E : Type*} [category C] [category D] [category E]

lemma nat_trans_eq {F G : karoubi C ⥤ D} (φ : F ⟶ G) (P : karoubi C) :
  φ.app P = F.map (decomp_id_i P) ≫ φ.app P.X ≫ G.map (decomp_id_p P) :=
begin
  rw [← φ.naturality, ← assoc, ← F.map_comp],
  conv { to_lhs, rw [← id_comp (φ.app P), ← F.map_id], },
  congr,
  apply decomp_id,
end

lemma nat_trans_ext {F G : karoubi C ⥤ D} (φ₁ φ₂ : F ⟶ G)
  (h : (𝟙 (to_karoubi C)) ◫ φ₁ = (𝟙 (to_karoubi C)) ◫ φ₂) : φ₁ = φ₂ :=
begin
  ext P,
  rw [nat_trans_eq φ₁, nat_trans_eq φ₂],
  congr' 2,
  have eq := congr_app h P.X,
  simpa only [nat_trans.hcomp_app, nat_trans.id_app, G.map_id, comp_id] using congr_app h P.X,
end

namespace functor_extension₁

@[simps]
def obj (F : C ⥤ karoubi D) : karoubi C ⥤ karoubi D :=
{ obj := λ P, ⟨(F.obj P.X).X, (F.map P.p).f,
    by simpa only [F.map_comp, hom_ext] using F.congr_map P.idem⟩,
  map := λ P Q f, ⟨(F.map f.f).f,
    by simpa only [F.map_comp, hom_ext] using F.congr_map f.comm⟩, }

@[simps]
def map {F G : C ⥤ karoubi D} (φ : F ⟶ G) : obj F ⟶ obj G :=
{ app := λ P,
  { f := (F.map P.p).f ≫ (φ.app P.X).f,
    comm := begin
      have h := φ.naturality P.p,
      have h' := F.congr_map P.idem,
      simp only [hom_ext, karoubi.comp, F.map_comp] at h h',
      simp only [obj_obj_p, assoc, ← h],
      slice_rhs 1 3 { rw [h', h'], },
    end, },
  naturality' := λ P Q f, begin
    ext,
    dsimp [obj],
    have h := φ.naturality f.f,
    have h' := F.congr_map (comp_p f),
    have h'' := F.congr_map (p_comp f),
    simp only [hom_ext, functor.map_comp, comp] at ⊢ h h' h'',
    slice_rhs 2 3 { rw ← h, },
    slice_lhs 1 2 { rw h', },
    slice_rhs 1 2 { rw h'', },
  end }

end functor_extension₁

variables (C D E)

@[simps]
def functor_extension₁ : (C ⥤ karoubi D) ⥤ (karoubi C ⥤ karoubi D) :=
{ obj := functor_extension₁.obj,
  map := λ F G, functor_extension₁.map,
  map_id' := λ F, by { ext P, exact comp_p (F.map P.p), },
  map_comp' := λ F G H φ φ', begin
    ext P,
    simp only [comp, functor_extension₁.map_app_f, nat_trans.comp_app, assoc],
    have h := φ.naturality P.p,
    have h' := F.congr_map P.idem,
    simp only [hom_ext, comp, F.map_comp] at h h',
    slice_rhs 2 3 { rw ← h, },
    slice_rhs 1 2 { rw h', },
    simp only [assoc],
  end, }

lemma functor_extension₁_comp_whiskering_left_to_karoubi :
  functor_extension₁ C D ⋙
    (whiskering_left C (karoubi C) (karoubi D)).obj (to_karoubi C) = 𝟭 _ :=
begin
  refine functor.ext _ _,
  { intro F,
    refine functor.ext _ _,
    { intro X,
      ext,
      { dsimp,
        rw [id_comp, comp_id, F.map_id, id_eq], },
      { refl, }, },
    { intros X Y f,
      ext,
      dsimp,
      simp only [comp_id, eq_to_hom_f, eq_to_hom_refl, comp_p, functor_extension₁.obj_obj_p,
        to_karoubi_obj_p, comp],
      dsimp,
      simp only [functor.map_id, id_eq, p_comp], }, },
  { intros F G φ,
    ext X,
    dsimp,
    simp only [eq_to_hom_app, F.map_id, karoubi.comp, eq_to_hom_f, id_eq, p_comp,
      eq_to_hom_refl, comp_id, comp_p, functor_extension₁.obj_obj_p,
      to_karoubi_obj_p, F.map_id X], },
end

end idempotents

end category_theory


import ..mcrl2_basic.mcrl2_basic

open mcrl2

variable {α : Type}
variable [comm_semigroup_with_zero α]

/- Finally, the || operator.-/
inductive R_par {x₁ x₂ y₁ y₂ : mcrl2 α} (R₁ R₂ : mcrl2 α → mcrl2 α → Prop) :
mcrl2 α → mcrl2 α → Prop
| R₁ {x y} (h : R₁ x y) : R_par x y
| R₂ {x y} (h : R₂ x y) : R_par x y
| basel : R_par (x₁ || y₁) (x₂ || y₂)
| baser : R_par (x₂ || y₂) (x₁ || y₁)
| stepl {x x' y y' a z z'} (hR₁x : R₁ x x') (hR₂ : R₂ y y') (hR₁z : R₁ z z')
  (ht  : transition x  a z)
  (ht' : transition x' a z') :
  R_par (z || y) (z' || y')
| stepr {x x' y y' a z z'} (hR₁x : R₁ x x') (hR₂ : R₂ y y') (hR₁z : R₂ z z')
  (ht  : transition y  a z)
  (ht' : transition y' a z') :
  R_par (x || z) (x' || z')
| stepcomm {x x' y y' a b z₁ z₂ z₁' z₂'} (hR₁x : R₁ x x') (hR₂y : R₂ y y')
  (hR₁z : R₁ z₁ z₁' ) (hR₂z : R₂ z₂ z₂' )
  (hx  : transition x  a z₁)  (hy  : transition y  b z₂)
  (hx' : transition x' a z₁') (hy' : transition y' b z₂') :
  R_par (z₁ || z₂) (z₁' || z₂')

lemma bisim_exists_lift_par_l {x₁ x₂ y₁ y₂ x x' y y' a z} {R₁ R₂  : mcrl2 α → mcrl2 α → Prop}
 (hxz : transition x a z) (hR₁ : R₁ x x') (hR₂ : R₂ y y') :
(∃z', transition x' a z' ∧ option.rel R₁ z z') → (∃z', transition x' a z' ∧ option.rel (@R_par _ _ x₁ x₂ y₁ y₂ R₁ R₂) (par' z y) (par' z' y')) :=
begin
  intro h,
  rcases h with ⟨w, hwa, hRw⟩,
  apply exists.intro w,
  apply and.intro,
  assumption,
  cases hRw,
  { apply option.rel.some,
    apply R_par.stepl,
    exact hR₁,
    repeat {assumption}},
  { apply option.rel.some,
    apply R_par.R₂,
    assumption}
end

lemma bisim_exists_lift_par_r {x₁ x₂ y₁ y₂ x x' y y' a z} {R₁ R₂  : mcrl2 α → mcrl2 α → Prop}
 (hxz : transition y a z) (hR₁ : R₁ x x') (hR₂ : R₂ y y') :
(∃z', transition y' a z' ∧ option.rel R₂ z z') → (∃z', transition  y' a z' ∧ option.rel (@R_par _ _ x₁ x₂ y₁ y₂ R₁ R₂) (par' x z) (par' x' z')) :=
begin
  intro h,
  rcases h with ⟨w, hwa, hRw⟩,
  apply exists.intro w,
  apply and.intro,
  assumption,
  cases hRw,
  { apply option.rel.some,
    apply R_par.stepr,
    repeat {assumption}},
  { apply option.rel.some,
    apply R_par.R₁,
    assumption}
end

lemma bisim_exists_lift_par_comm {x₁ x₂ y₁ y₂ x x' y y' a b z₁ z₂} {R₁ R₂  : mcrl2 α → mcrl2 α → Prop}
 (hxz : transition x a z₁) (hyz' : transition y b z₂) (hR₁ : R₁ x x') (hR₂ : R₂ y y') (hab : a * b ≠ 0):
(∃z' , transition x' a z' ∧ option.rel R₁ z₁ z') → (∃z' , transition y' b z' ∧ option.rel R₂ z₂ z') →
(∃z', transition (x' || y') (a * b) z' ∧ option.rel (@R_par _ _ x₁ x₂ y₁ y₂ R₁ R₂) (par' z₁ z₂) z') :=
begin
  intros h₁ h₂,
  rcases h₁ with ⟨w₁, hw₁a, hRw₁⟩,
  rcases h₂ with ⟨w₂, hw₂b, hRw₂⟩,
  simp only [transition.par_iff, exists_or_distrib, or_and_distrib_right, ←exists_and_distrib_right, and_assoc, exists_eq_left],
  apply or.inr,
  apply or.inr,
  apply exists.intro (par' w₁ w₂),
  apply exists.intro w₁,
  apply exists.intro w₂,
  apply and.intro,
  refl,
  apply exists.intro a,
  apply exists.intro b,
  apply and.intro,
  assumption,
  apply and.intro,
  refl,
  apply and.intro,
  assumption,
  apply and.intro,
  assumption,
  cases hRw₂,
  { cases hRw₁,
    { apply option.rel.some,
      apply R_par.stepcomm,
      exact hR₁,
      exact hR₂,
      assumption,
      assumption,
      repeat {assumption}},
    { apply option.rel.some,
      cases hRw₂,
      apply R_par.R₂,
      assumption}},
  { cases hRw₁,
    { apply option.rel.some,
      apply R_par.R₁,
      assumption},
    { apply option.rel.none}}
end

lemma bisim_exists_lift_par {x₁ x₂ y₁ y₂ x x' y y' a z} {R₁ R₂ : mcrl2 α → mcrl2 α → Prop}
 (R₁_bisim : is_bisimulation R₁) (R₂_bisim : is_bisimulation R₂) (hR₁ : R₁ x x') (hR₂ : R₂ y y') (haz : transition (x || y) a z):
 (∃z', transition (x' || y') a z' ∧ option.rel (@R_par _ _ x₁ x₂ y₁ y₂ R₁ R₂) z z') :=
begin
  cases R₁_bisim with R₁_bisim R₁_symm,
  cases R₂_bisim with R₂_bisim R₂_symm,
  cases haz,
  { specialize R₁_bisim x x' haz_x' a hR₁ haz_h,
    simp only [transition.par_iff, exists_or_distrib, or_and_distrib_right, ←exists_and_distrib_right, and_assoc, exists_eq_left],
    apply or.inl,
    simp only [exists_comm, exists_eq_left],
    exact bisim_exists_lift_par_l haz_h hR₁ hR₂ R₁_bisim},
  { specialize R₂_bisim y y' haz_y' a hR₂ haz_h,
    simp only [transition.par_iff, exists_or_distrib, or_and_distrib_right, ←exists_and_distrib_right, and_assoc, exists_eq_left],
    apply or.inr,
    apply or.inl,
    simp only [exists_comm, exists_eq_left],
    exact bisim_exists_lift_par_r haz_h hR₁ hR₂ R₂_bisim},
  { specialize R₁_bisim x x' haz_x' haz_a hR₁ haz_h₁,
    specialize R₂_bisim y y' haz_y' haz_b hR₂ haz_h₂,
    exact bisim_exists_lift_par_comm haz_h₁ haz_h₂ hR₁ hR₂ haz_h₃ R₁_bisim R₂_bisim}

end

lemma R_par.symm {x₁ x₂ y₁ y₂ : mcrl2 α} {R₁ R₂ : mcrl2 α → mcrl2 α → Prop}
 (h₁ : symmetric R₁) (h₂ : symmetric R₂) :
symmetric (@R_par α _ x₁ x₂ y₁ y₂ R₁ R₂) :=
begin
  intros x y h,
  cases h,
  { apply R_par.R₁,
    apply h₁,
    assumption},
  { apply R_par.R₂,
    apply h₂,
    assumption},
  { exact R_par.baser},
  { exact R_par.basel},
  { apply R_par.stepl,
    exact h₁ h_hR₁x,
    apply h₂,
    assumption,
    apply h₁,
    assumption,
    repeat {assumption}},
  { apply R_par.stepr,
    apply h₁,
    exact h_hR₁x,
    exact h₂ h_hR₂,
    apply h₂,
    repeat {assumption}},
  { apply R_par.stepcomm,
    exact h₁ h_hR₁x,
    exact h₂ h_hR₂y,
    exact h₁ h_hR₁z,
    exact h₂ h_hR₂z,
    repeat {assumption}}
end

theorem bisim.par {x₁ x₂ y₁ y₂: mcrl2 α} (h₁ : x₁ ≈ x₂) (h₂ : y₁ ≈ y₂) :
x₁ || y₁ ≈ x₂ || y₂ :=
begin
  rcases h₁ with ⟨R₁, R₁x, R₁_bisim⟩,
  rcases h₂ with ⟨R₂, R₂y, R₂_bisim⟩,
  apply exists.intro (R_par R₁ R₂),
  apply and.intro,
  apply R_par.basel,
  apply and.intro,
  { intros x y x' a Rxy xax',
    cases Rxy,
    { have h: ∃y', transition y a y' ∧ option.rel R₁ x' y',
      by exact bisim_lift R₁_bisim Rxy_h xax',
      cases h with w h_w,
      cases h_w with l r,
      apply exists.intro w,
      apply and.intro,
      assumption,
      apply option.rel.mono,
      { intros x y, exact R_par.R₁},
      { assumption}},
    { have h: ∃y', transition y a y' ∧ option.rel R₂ x' y',
      by exact bisim_lift R₂_bisim Rxy_h xax',
      cases h with w h_w,
      cases h_w with l r,
      apply exists.intro w,
      apply and.intro,
      assumption,
      apply option.rel.mono,
      { intros x y, exact R_par.R₂},
      { assumption}},
    { exact bisim_exists_lift_par R₁_bisim R₂_bisim R₁x R₂y xax' },
    { exact bisim_exists_lift_par R₁_bisim R₂_bisim (R₁_bisim.right R₁x) (R₂_bisim.right R₂y) xax'},
    { apply bisim_exists_lift_par; assumption},
    { apply bisim_exists_lift_par; assumption},
    { apply bisim_exists_lift_par; assumption}},
  { exact R_par.symm R₁_bisim.right R₂_bisim.right}
end


/-
Copyright (c) 2022 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.limits.preserves.shapes.pullbacks
import category_theory.limits.shapes.zero_morphisms
import category_theory.limits.constructions.binary_products

/-!
# Pullback and pushout squares

We provide another API for pullbacks and pushouts.

`is_pullback fst snd f g` is the proposition that
```
  P --fst--> X
  |          |
 snd         f
  |          |
  v          v
  Y ---g---> Z

```
is a pullback square.

(And similarly for `is_pushout`.)

We provide the glue to go back and forth to the usual `is_limit` API for pullbacks, and prove
`is_pullback (pullback.fst : pullback f g ⟶ X) (pullback.snd : pullback f g ⟶ Y) f g`
for the usual `pullback f g` provided by the `has_limit` API.

We don't attempt to restate everything we know about pullbacks in this language,
but do restate the pasting lemmas.

## Future work
Bicartesian squares, and
show that the pullback and pushout squares for a biproduct are bicartesian.
-/

noncomputable theory

open category_theory
open category_theory.limits

universes v₁ v₂ u₁ u₂

namespace category_theory

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

/-- The proposition that a square
```
  W ---f---> X
  |          |
  g          h
  |          |
  v          v
  Y ---i---> Z

```
is a commuting square.
-/
structure comm_sq {W X Y Z : C} (f : W ⟶ X) (g : W ⟶ Y) (h : X ⟶ Z) (i : Y ⟶ Z) : Prop :=
(w : f ≫ h = g ≫ i)

attribute [reassoc] comm_sq.w

namespace comm_sq

variables {W X Y Z : C} {f : W ⟶ X} {g : W ⟶ Y} {h : X ⟶ Z} {i : Y ⟶ Z}

lemma flip (p : comm_sq f g h i) : comm_sq g f i h := ⟨p.w.symm⟩

lemma of_arrow {f g : arrow C} (h : f ⟶ g) : comm_sq f.hom h.left h.right g.hom := ⟨h.w.symm⟩

/--
The (not necessarily limiting) `pullback_cone h i` implicit in the statement
that we have `comm_sq f g h i`.
-/
def cone (s : comm_sq f g h i) : pullback_cone h i := pullback_cone.mk _ _ s.w

/--
The (not necessarily limiting) `pushout_cocone f g` implicit in the statement
that we have `comm_sq f g h i`.
-/
def cocone (s : comm_sq f g h i) : pushout_cocone f g := pushout_cocone.mk _ _ s.w

end comm_sq

/-- The proposition that a square
```
  P --fst--> X
  |          |
 snd         f
  |          |
  v          v
  Y ---g---> Z

```
is a pullback square.
-/
structure is_pullback
  {P X Y Z : C} (fst : P ⟶ X) (snd : P ⟶ Y) (f : X ⟶ Z) (g : Y ⟶ Z)
  extends comm_sq fst snd f g : Prop :=
(is_limit' : nonempty (is_limit (pullback_cone.mk _ _ w)))

/-- The proposition that a square
```
  Z ---f---> X
  |          |
  g         inl
  |          |
  v          v
  Y --inr--> P

```
is a pushout square.
-/
structure is_pushout
  {Z X Y P : C} (f : Z ⟶ X) (g : Z ⟶ Y) (inl : X ⟶ P) (inr : Y ⟶ P)
  extends comm_sq f g inl inr : Prop :=
(is_colimit' : nonempty (is_colimit (pushout_cocone.mk _ _ w)))

/-!
We begin by providing some glue between `is_pullback` and the `is_limit` and `has_limit` APIs.
(And similarly for `is_pushout`.)
-/

namespace is_pullback

variables {P X Y Z : C} {fst : P ⟶ X} {snd : P ⟶ Y} {f : X ⟶ Z} {g : Y ⟶ Z}

/--
The (limiting) `pullback_cone f g` implicit in the statement
that we have a `is_pullback fst snd f g`.
-/
def cone (h : is_pullback fst snd f g) : pullback_cone f g := h.to_comm_sq.cone

/--
The cone obtained from `is_pullback fst snd f g` is a limit cone.
-/
noncomputable def is_limit (h : is_pullback fst snd f g) : is_limit h.cone :=
h.is_limit'.some

/-- If `c` is a limiting pullback cone, then we have a `is_pullback c.fst c.snd f g`. -/
lemma of_is_limit {c : pullback_cone f g} (h : limits.is_limit c) :
  is_pullback c.fst c.snd f g :=
{ w := c.condition,
  is_limit' := ⟨is_limit.of_iso_limit h
    (limits.pullback_cone.ext (iso.refl _) (by tidy) (by tidy))⟩, }

/-- A variant of `of_is_limit` that is more useful with `apply`. -/
lemma of_is_limit' (w : comm_sq fst snd f g) (h : limits.is_limit w.cone) :
  is_pullback fst snd f g :=
of_is_limit h

/-- The pullback provided by `has_pullback f g` fits into a `is_pullback`. -/
lemma of_has_pullback (f : X ⟶ Z) (g : Y ⟶ Z) [has_pullback f g] :
  is_pullback (pullback.fst : pullback f g ⟶ X) (pullback.snd : pullback f g ⟶ Y) f g :=
of_is_limit (limit.is_limit (cospan f g))

/-- If `c` is a limiting binary product cone, and we have a terminal object,
then we have `is_pullback c.fst c.snd 0 0`
(where each `0` is the unique morphism to the terminal object). -/
lemma of_is_product {c : binary_fan X Y} (h : limits.is_limit c) (t : is_terminal Z) :
  is_pullback c.fst c.snd (t.from _) (t.from _) :=
of_is_limit (is_pullback_of_is_terminal_is_product _ _ _ _ t
  (is_limit.of_iso_limit h (limits.cones.ext (iso.refl c.X) (by rintro ⟨⟨⟩⟩; { dsimp, simp, }))))

variables (X Y)

lemma of_has_binary_product' [has_binary_product X Y] [has_terminal C] :
  is_pullback limits.prod.fst limits.prod.snd (terminal.from X) (terminal.from Y) :=
of_is_product (limit.is_limit _) terminal_is_terminal

open_locale zero_object

lemma of_has_binary_product [has_binary_product X Y] [has_zero_object C] [has_zero_morphisms C] :
  is_pullback limits.prod.fst limits.prod.snd (0 : X ⟶ 0) (0 : Y ⟶ 0) :=
by convert of_is_product (limit.is_limit _) has_zero_object.zero_is_terminal

variables {X Y}

/-- Any object at the top left of a pullback square is
isomorphic to the pullback provided by the `has_limit` API. -/
noncomputable
def iso_pullback (h : is_pullback fst snd f g) [has_pullback f g] : P ≅ pullback f g :=
(limit.iso_limit_cone ⟨_, h.is_limit⟩).symm

@[simp] lemma iso_pullback_hom_fst (h : is_pullback fst snd f g) [has_pullback f g] :
  h.iso_pullback.hom ≫ pullback.fst = fst :=
by { dsimp [iso_pullback, cone, comm_sq.cone], simp, }
@[simp] lemma iso_pullback_hom_snd (h : is_pullback fst snd f g) [has_pullback f g] :
  h.iso_pullback.hom ≫ pullback.snd = snd :=
by { dsimp [iso_pullback, cone, comm_sq.cone], simp, }
@[simp] lemma iso_pullback_inv_fst (h : is_pullback fst snd f g) [has_pullback f g] :
  h.iso_pullback.inv ≫ fst = pullback.fst :=
by simp [iso.inv_comp_eq]
@[simp] lemma iso_pullback_inv_snd (h : is_pullback fst snd f g) [has_pullback f g] :
  h.iso_pullback.inv ≫ snd = pullback.snd :=
by simp [iso.inv_comp_eq]

lemma of_iso_pullback (h : comm_sq fst snd f g) [has_pullback f g] (i : P ≅ pullback f g)
  (w₁ : i.hom ≫ pullback.fst = fst) (w₂ : i.hom ≫ pullback.snd = snd) : is_pullback fst snd f g :=
of_is_limit' h (limits.is_limit.of_iso_limit (limit.is_limit _)
  (@pullback_cone.ext _ _ _ _ _ _ _ (pullback_cone.mk _ _ _) _ i w₁.symm w₂.symm).symm)

end is_pullback

namespace is_pushout

variables {Z X Y P : C} {f : Z ⟶ X} {g : Z ⟶ Y} {inl : X ⟶ P} {inr : Y ⟶ P}

/--
The (colimiting) `pushout_cocone f g` implicit in the statement
that we have a `is_pushout f g inl inr`.
-/
def cocone (h : is_pushout f g inl inr) : pushout_cocone f g := h.to_comm_sq.cocone

/--
The cocone obtained from `is_pushout f g inl inr` is a colimit cocone.
-/
noncomputable def is_colimit (h : is_pushout f g inl inr) : is_colimit h.cocone :=
h.is_colimit'.some

/-- If `c` is a colimiting pushout cocone, then we have a `is_pushout f g c.inl c.inr`. -/
lemma of_is_colimit {c : pushout_cocone f g} (h : limits.is_colimit c) :
  is_pushout f g c.inl c.inr :=
{ w := c.condition,
  is_colimit' := ⟨is_colimit.of_iso_colimit h
    (limits.pushout_cocone.ext (iso.refl _) (by tidy) (by tidy))⟩, }

/-- A variant of `of_is_colimit` that is more useful with `apply`. -/
lemma of_is_colimit' (w : comm_sq f g inl inr) (h : limits.is_colimit w.cocone) :
  is_pushout f g inl inr :=
of_is_colimit h

/-- The pushout provided by `has_pushout f g` fits into a `is_pushout`. -/
lemma of_has_pushout (f : Z ⟶ X) (g : Z ⟶ Y) [has_pushout f g] :
  is_pushout f g (pushout.inl : X ⟶ pushout f g) (pushout.inr : Y ⟶ pushout f g) :=
of_is_colimit (colimit.is_colimit (span f g))

/-- If `c` is a colimiting binary coproduct cocone, and we have an initial object,
then we have `is_pushout 0 0 c.inl c.inr`
(where each `0` is the unique morphism from the initial object). -/
lemma of_is_coproduct {c : binary_cofan X Y} (h : limits.is_colimit c) (t : is_initial Z) :
  is_pushout (t.to _) (t.to _) c.inl c.inr :=
of_is_colimit (is_pushout_of_is_initial_is_coproduct _ _ _ _ t
  (is_colimit.of_iso_colimit h
    (limits.cocones.ext (iso.refl c.X) (by rintro ⟨⟨⟩⟩; { dsimp, simp, }))))

variables (X Y)

lemma of_has_binary_coproduct' [has_binary_coproduct X Y] [has_initial C] :
  is_pushout (initial.to _) (initial.to _) (coprod.inl : X ⟶ _) (coprod.inr : Y ⟶ _)  :=
of_is_coproduct (colimit.is_colimit _) initial_is_initial

open_locale zero_object

lemma of_has_binary_coproduct
  [has_binary_coproduct X Y] [has_zero_object C] [has_zero_morphisms C] :
  is_pushout (0 : 0 ⟶ X) (0 : 0 ⟶ Y) coprod.inl coprod.inr :=
by convert of_is_coproduct (colimit.is_colimit _) has_zero_object.zero_is_initial

variables {X Y}

/-- Any object at the top left of a pullback square is
isomorphic to the pullback provided by the `has_limit` API. -/
noncomputable
def iso_pushout (h : is_pushout f g inl inr) [has_pushout f g] : P ≅ pushout f g :=
(colimit.iso_colimit_cocone ⟨_, h.is_colimit⟩).symm

@[simp] lemma inl_iso_pushout_inv (h : is_pushout f g inl inr) [has_pushout f g] :
  pushout.inl ≫ h.iso_pushout.inv = inl :=
by { dsimp [iso_pushout, cocone, comm_sq.cocone], simp, }
@[simp] lemma inr_iso_pushout_inv (h : is_pushout f g inl inr) [has_pushout f g] :
  pushout.inr ≫ h.iso_pushout.inv = inr :=
by { dsimp [iso_pushout, cocone, comm_sq.cocone], simp, }
@[simp] lemma inl_iso_pushout_hom (h : is_pushout f g inl inr) [has_pushout f g] :
  inl ≫ h.iso_pushout.hom = pushout.inl :=
by simp [←iso.eq_comp_inv]
@[simp] lemma inr_iso_pushout_hom (h : is_pushout f g inl inr) [has_pushout f g] :
  inr ≫ h.iso_pushout.hom = pushout.inr :=
by simp [←iso.eq_comp_inv]

lemma of_iso_pushout (h : comm_sq f g inl inr) [has_pushout f g] (i : P ≅ pushout f g)
  (w₁ : inl ≫ i.hom = pushout.inl) (w₂ : inr ≫ i.hom = pushout.inr) : is_pushout f g inl inr :=
of_is_colimit' h (limits.is_colimit.of_iso_colimit (colimit.is_colimit _)
  (@pushout_cocone.ext _ _ _ _ _ _ _ (pushout_cocone.mk _ _ _) _ i w₁ w₂).symm)

end is_pushout

namespace is_pullback

variables {P X Y Z : C} {fst : P ⟶ X} {snd : P ⟶ Y} {f : X ⟶ Z} {g : Y ⟶ Z}

lemma flip (h : is_pullback fst snd f g) : is_pullback snd fst g f :=
of_is_limit (@pullback_cone.flip_is_limit _ _ _ _ _ _ _ _ _ _ h.w.symm h.is_limit)

section

variables [has_zero_object C] [has_zero_morphisms C]
open_locale zero_object

/-- The square with `0 : 0 ⟶ 0` on the left and `𝟙 X` on the right is a pullback square. -/
lemma zero_left (X : C) : is_pullback (0 : 0 ⟶ X) (0 : 0 ⟶ 0) (𝟙 X) (0 : 0 ⟶ X) :=
{ w := by simp,
  is_limit' :=
  ⟨{ lift := λ s, 0,
     fac' := λ s, by simpa using @pullback_cone.equalizer_ext _ _ _ _ _ _ _ s _ 0 (𝟙 _)
       (by simpa using (pullback_cone.condition s).symm), }⟩ }

/-- The square with `0 : 0 ⟶ 0` on the top and `𝟙 X` on the bottom is a pullback square. -/
lemma zero_top (X : C) : is_pullback (0 : 0 ⟶ 0) (0 : 0 ⟶ X) (0 : 0 ⟶ X) (𝟙 X) :=
(zero_left X).flip

end

/-- Paste two pullback squares "vertically" to obtain another pullback square. -/
-- Objects here are arranged in a 3x2 grid, and indexed by their xy coordinates.
-- Morphisms are named `hᵢⱼ` for a horizontal morphism starting at `(i,j)`,
-- and `vᵢⱼ` for a vertical morphism starting at `(i,j)`.
lemma paste_vert {X₁₁ X₁₂ X₂₁ X₂₂ X₃₁ X₃₂ : C}
  {h₁₁ : X₁₁ ⟶ X₁₂} {h₂₁ : X₂₁ ⟶ X₂₂} {h₃₁ : X₃₁ ⟶ X₃₂}
  {v₁₁ : X₁₁ ⟶ X₂₁} {v₁₂ : X₁₂ ⟶ X₂₂} {v₂₁ : X₂₁ ⟶ X₃₁} {v₂₂ : X₂₂ ⟶ X₃₂}
  (s : is_pullback h₁₁ v₁₁ v₁₂ h₂₁) (t : is_pullback h₂₁ v₂₁ v₂₂ h₃₁) :
  is_pullback h₁₁ (v₁₁ ≫ v₂₁) (v₁₂ ≫ v₂₂) h₃₁ :=
(of_is_limit
  (big_square_is_pullback _ _ _ _ _ _ _ s.w t.w t.is_limit s.is_limit))

/-- Paste two pullback squares "horizontally" to obtain another pullback square. -/
lemma paste_horiz {X₁₁ X₁₂ X₁₃ X₂₁ X₂₂ X₂₃ : C}
  {h₁₁ : X₁₁ ⟶ X₁₂} {h₁₂ : X₁₂ ⟶ X₁₃} {h₂₁ : X₂₁ ⟶ X₂₂} {h₂₂ : X₂₂ ⟶ X₂₃}
  {v₁₁ : X₁₁ ⟶ X₂₁} {v₁₂ : X₁₂ ⟶ X₂₂} {v₁₃ : X₁₃ ⟶ X₂₃}
  (s : is_pullback h₁₁ v₁₁ v₁₂ h₂₁) (t : is_pullback h₁₂ v₁₂ v₁₃ h₂₂) :
  is_pullback (h₁₁ ≫ h₁₂) v₁₁ v₁₃ (h₂₁ ≫ h₂₂) :=
(paste_vert s.flip t.flip).flip

/-- Given a pullback square assembled from a commuting square on the top and
a pullback square on the bottom, the top square is a pullback square. -/
lemma of_bot {X₁₁ X₁₂ X₂₁ X₂₂ X₃₁ X₃₂ : C}
  {h₁₁ : X₁₁ ⟶ X₁₂} {h₂₁ : X₂₁ ⟶ X₂₂} {h₃₁ : X₃₁ ⟶ X₃₂}
  {v₁₁ : X₁₁ ⟶ X₂₁} {v₁₂ : X₁₂ ⟶ X₂₂} {v₂₁ : X₂₁ ⟶ X₃₁} {v₂₂ : X₂₂ ⟶ X₃₂}
  (s : is_pullback h₁₁ (v₁₁ ≫ v₂₁) (v₁₂ ≫ v₂₂) h₃₁) (p : h₁₁ ≫ v₁₂ = v₁₁ ≫ h₂₁)
  (t : is_pullback h₂₁ v₂₁ v₂₂ h₃₁) :
  is_pullback h₁₁ v₁₁ v₁₂ h₂₁ :=
of_is_limit (left_square_is_pullback _ _ _ _ _ _ _ p _ t.is_limit s.is_limit)

/-- Given a pullback square assembled from a commuting square on the left and
a pullback square on the right, the left square is a pullback square. -/
lemma of_right {X₁₁ X₁₂ X₁₃ X₂₁ X₂₂ X₂₃ : C}
  {h₁₁ : X₁₁ ⟶ X₁₂} {h₁₂ : X₁₂ ⟶ X₁₃} {h₂₁ : X₂₁ ⟶ X₂₂} {h₂₂ : X₂₂ ⟶ X₂₃}
  {v₁₁ : X₁₁ ⟶ X₂₁} {v₁₂ : X₁₂ ⟶ X₂₂} {v₁₃ : X₁₃ ⟶ X₂₃}
  (s : is_pullback (h₁₁ ≫ h₁₂) v₁₁ v₁₃ (h₂₁ ≫ h₂₂)) (p : h₁₁ ≫ v₁₂ = v₁₁ ≫ h₂₁)
  (t : is_pullback h₁₂ v₁₂ v₁₃ h₂₂) :
  is_pullback h₁₁ v₁₁ v₁₂ h₂₁ :=
(of_bot s.flip p.symm t.flip).flip

end is_pullback

namespace is_pushout

variables {Z X Y P : C} {f : Z ⟶ X} {g : Z ⟶ Y} {inl : X ⟶ P} {inr : Y ⟶ P}

lemma flip (h : is_pushout f g inl inr) : is_pushout g f inr inl :=
of_is_colimit (@pushout_cocone.flip_is_colimit _ _ _ _ _ _ _ _ _ _ h.w.symm h.is_colimit)

section

variables [has_zero_object C] [has_zero_morphisms C]
open_locale zero_object

/-- The square with `0 : 0 ⟶ 0` on the right and `𝟙 X` on the left is a pushout square. -/
lemma zero_right (X : C) : is_pushout (0 : X ⟶ 0) (𝟙 X) (0 : 0 ⟶ 0) (0 : X ⟶ 0) :=
{ w := by simp,
  is_colimit' :=
  ⟨{ desc := λ s, 0,
     fac' := λ s, begin
       have c := @pushout_cocone.coequalizer_ext _ _ _ _ _ _ _ s _ 0 (𝟙 _) (by simp)
         (by simpa using (pushout_cocone.condition s)),
      dsimp at c,
      simpa using c,
     end }⟩ }

/-- The square with `0 : 0 ⟶ 0` on the bottom and `𝟙 X` on the top is a pushout square. -/
lemma zero_bot (X : C) : is_pushout (𝟙 X) (0 : X ⟶ 0) (0 : X ⟶ 0) (0 : 0 ⟶ 0) :=
(zero_right X).flip

end

/-- Paste two pushout squares "vertically" to obtain another pushout square. -/
-- Objects here are arranged in a 3x2 grid, and indexed by their xy coordinates.
-- Morphisms are named `hᵢⱼ` for a horizontal morphism starting at `(i,j)`,
-- and `vᵢⱼ` for a vertical morphism starting at `(i,j)`.
lemma paste_vert {X₁₁ X₁₂ X₂₁ X₂₂ X₃₁ X₃₂ : C}
  {h₁₁ : X₁₁ ⟶ X₁₂} {h₂₁ : X₂₁ ⟶ X₂₂} {h₃₁ : X₃₁ ⟶ X₃₂}
  {v₁₁ : X₁₁ ⟶ X₂₁} {v₁₂ : X₁₂ ⟶ X₂₂} {v₂₁ : X₂₁ ⟶ X₃₁} {v₂₂ : X₂₂ ⟶ X₃₂}
  (s : is_pushout h₁₁ v₁₁ v₁₂ h₂₁) (t : is_pushout h₂₁ v₂₁ v₂₂ h₃₁) :
  is_pushout h₁₁ (v₁₁ ≫ v₂₁) (v₁₂ ≫ v₂₂) h₃₁ :=
(of_is_colimit
  (big_square_is_pushout _ _ _ _ _ _ _ s.w t.w t.is_colimit s.is_colimit))

/-- Paste two pushout squares "horizontally" to obtain another pushout square. -/
lemma paste_horiz {X₁₁ X₁₂ X₁₃ X₂₁ X₂₂ X₂₃ : C}
  {h₁₁ : X₁₁ ⟶ X₁₂} {h₁₂ : X₁₂ ⟶ X₁₃} {h₂₁ : X₂₁ ⟶ X₂₂} {h₂₂ : X₂₂ ⟶ X₂₃}
  {v₁₁ : X₁₁ ⟶ X₂₁} {v₁₂ : X₁₂ ⟶ X₂₂} {v₁₃ : X₁₃ ⟶ X₂₃}
  (s : is_pushout h₁₁ v₁₁ v₁₂ h₂₁) (t : is_pushout h₁₂ v₁₂ v₁₃ h₂₂) :
  is_pushout (h₁₁ ≫ h₁₂) v₁₁ v₁₃ (h₂₁ ≫ h₂₂) :=
(paste_vert s.flip t.flip).flip

/-- Given a pushout square assembled from a pushout square on the top and
a commuting square on the bottom, the bottom square is a pushout square. -/
lemma of_bot {X₁₁ X₁₂ X₂₁ X₂₂ X₃₁ X₃₂ : C}
  {h₁₁ : X₁₁ ⟶ X₁₂} {h₂₁ : X₂₁ ⟶ X₂₂} {h₃₁ : X₃₁ ⟶ X₃₂}
  {v₁₁ : X₁₁ ⟶ X₂₁} {v₁₂ : X₁₂ ⟶ X₂₂} {v₂₁ : X₂₁ ⟶ X₃₁} {v₂₂ : X₂₂ ⟶ X₃₂}
  (s : is_pushout h₁₁ (v₁₁ ≫ v₂₁) (v₁₂ ≫ v₂₂) h₃₁) (p : h₂₁ ≫ v₂₂ = v₂₁ ≫ h₃₁)
  (t : is_pushout h₁₁ v₁₁ v₁₂ h₂₁) :
  is_pushout h₂₁ v₂₁ v₂₂ h₃₁ :=
of_is_colimit (right_square_is_pushout _ _ _ _ _ _ _ _ p t.is_colimit s.is_colimit)

/-- Given a pushout square assembled from a pushout square on the left and
a commuting square on the right, the right square is a pushout square. -/
lemma of_right {X₁₁ X₁₂ X₁₃ X₂₁ X₂₂ X₂₃ : C}
  {h₁₁ : X₁₁ ⟶ X₁₂} {h₁₂ : X₁₂ ⟶ X₁₃} {h₂₁ : X₂₁ ⟶ X₂₂} {h₂₂ : X₂₂ ⟶ X₂₃}
  {v₁₁ : X₁₁ ⟶ X₂₁} {v₁₂ : X₁₂ ⟶ X₂₂} {v₁₃ : X₁₃ ⟶ X₂₃}
  (s : is_pushout (h₁₁ ≫ h₁₂) v₁₁ v₁₃ (h₂₁ ≫ h₂₂)) (p : h₁₂ ≫ v₁₃ = v₁₂ ≫ h₂₂)
  (t : is_pushout h₁₁ v₁₁ v₁₂ h₂₁) :
  is_pushout h₁₂ v₁₂ v₁₃ h₂₂ :=
(of_bot s.flip p.symm t.flip).flip

end is_pushout

namespace functor

variables {D : Type u₂} [category.{v₂} D]
variables (F : C ⥤ D) {W X Y Z : C} {f : W ⟶ X} {g : W ⟶ Y} {h : X ⟶ Z} {i : Y ⟶ Z}

lemma map_comm_sq (s : comm_sq f g h i) : comm_sq (F.map f) (F.map g) (F.map h) (F.map i) :=
⟨by simpa using congr_arg (λ k : W ⟶ Z, F.map k) s.w⟩

lemma map_is_pullback [preserves_limit (cospan h i) F] (s : is_pullback f g h i) :
  is_pullback (F.map f) (F.map g) (F.map h) (F.map i) :=
-- This is made slightly awkward because `C` and `D` have different universes,
-- and so the relevant `walking_cospan` diagrams live in different universes too!
begin
  refine is_pullback.of_is_limit' (F.map_comm_sq s.to_comm_sq)
    (is_limit.of_whisker_equivalence walking_cospan_equiv
      (is_limit.equiv_of_nat_iso_of_iso (cospan_comp_iso F h i) _ _ (walking_cospan.ext _ _ _)
        (is_limit_of_preserves F s.is_limit))),
  { refl, },
  { dsimp, simp, refl, },
  { dsimp, simp, refl, },
end

lemma map_is_pushout [preserves_colimit (span f g) F] (s : is_pushout f g h i) :
  is_pushout (F.map f) (F.map g) (F.map h) (F.map i) :=
begin
  refine is_pushout.of_is_colimit' (F.map_comm_sq s.to_comm_sq)
    (is_colimit.of_whisker_equivalence walking_span_equiv
      (is_colimit.equiv_of_nat_iso_of_iso (span_comp_iso F f g) _ _ (walking_span.ext _ _ _)
        (is_colimit_of_preserves F s.is_colimit))),
  { refl, },
  { dsimp, simp, refl, },
  { dsimp, simp, refl, },
end

end functor

alias functor.map_comm_sq ← comm_sq.map
alias functor.map_is_pullback ← is_pullback.map
alias functor.map_is_pushout ← is_pushout.map

end category_theory


import data.real.irrational
import topology.basic
import algebra.order.floor

--OUTPUT 1
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  --Let $\alpha$ be an irrational number. Then for distinct $i, j \in \mathbb{Z}$, we must have $\{i \alpha\} \neq\{j \alpha\}$. If this were not true, then
  have h1 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by {
    assume i j : ℤ,
    assume h2 : i ≠ j,
    assume h3 : int.fract (α * ↑i) = int.fract (α * ↑j),
    have h4 : α * ↑i - ↑(int.floor (α * ↑i)) = int.fract (α * ↑i), from by {rw int.fract_eq_of_nonneg (le_of_lt (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (α * ↑i))) (int.floor_lt_iff.mpr (lt_of_le_of_lt (int.coe_nat_le_coe_nat_of_le (int.floor_nonneg (
end --Needs more than 2000 tokens!

/- FEW SHOT PROMPTS TO CODEX(START)
/--`theorem`
Power Set is Closed under Intersection
Let $S$ be a set.

Let $\powerset S$ be the power set of $S$.

Then:
:$\forall A, B \in \powerset S: A \cap B \in \powerset S$
`proof`
Let $A, B \in \powerset S$.

Then by the definition of power set, $A \subseteq S$ and $B \subseteq S$.

From Intersection is Subset we have that $A \cap B \subseteq A$.

It follows from Subset Relation is Transitive that $A \cap B \subseteq S$.

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  -- $A$ and $B$ are sets. $A$ and $B$ belong to power set of $S$
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  -- Then $A ⊆ S$ and $B ⊆ S$, by power set definition
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from by {split,apply set.subset_of_mem_powerset,exact hA,apply set.subset_of_mem_powerset,exact hB},
  -- Then $(A ∩ B) ⊆ A$, by intersection of set is a subset
  have h2 : (A ∩ B) ⊆ A, from by apply set.inter_subset_left,
  -- Then $(A ∩ B) ⊆ S$, by subset relation is transitive
  have h3 : (A ∩ B) ⊆ S, from by {apply set.subset.trans h2 h1.left},
  -- Hence $(A ∩ B) ∈  𝒫 S$, by power set definition
  show (A ∩ B) ∈  𝒫 S, from by {apply set.mem_powerset h3},
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  -- expand the power
  calc (x + y)^2 = (x+y)*(x+y) : by rw sq
  -- distributive property of multiplication over addition gives:
  ... = x*(x+y) + y*(x+y) : by rw add_mul
  -- applying the above property further gives:
  ... = x*x + x*y + y*x + y*y : by {rw [mul_comm x (x+y),mul_comm y (x+y)], rw [add_mul,add_mul], ring}
  -- rearranging the terms using commutativity and adding gives:
  ... = x^2 + 2*x*y + y^2 : by {repeat {rw ← sq}, rw mul_comm y x, ring}
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  -- Group has Latin Square Property
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from by {
    assume a b : G, use a⁻¹ * b, obviously, },
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from by {
    assume a b : G, use b * a⁻¹, obviously, },

  -- Setting $b = a$, this becomes:
  have h3 : ∀ a : G, ∃! x : G, a * x = a, from
    assume a : G, h1 a a,
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from
    assume a : G, h2 a a,

  -- These $x$ and $y$ are both $(1 : G)$, by definition of identity element
  have h5 : ∀ a : G, classical.some (h3 a).exists = (1 : G), from assume a :G,
    exists_unique.unique (h3 a) (classical.some_spec (exists_unique.exists (h3 a)))
    (mul_one a),
  have h6 : ∀ a : G, classical.some (h4 a).exists = (1 : G), from assume a : G,
    exists_unique.unique (h4 a) (classical.some_spec (exists_unique.exists (h4 a))) (one_mul a),

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by {
    use (1 : G),
    have h7 : ∀ e : G, (∀ a : G, e * a = a ∧ a * e = a) → e = 1, from by {
      assume (e : G) (hident : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a).exists, from assume (a : G),
        exists_unique.unique (h3 a) (hident a).right
        (classical.some_spec (exists_unique.exists (h3 a))),
      have h9 : ∀ a : G, e = classical.some (h4 a).exists, from assume (a : G),
        exists_unique.unique (h4 a) (hident a).left
        (classical.some_spec (exists_unique.exists (h4 a))),
      show e = (1 : G), from eq.trans (h9 e) (h6 _),
    },
    exact ⟨by obviously, h7⟩,
  }
end

/--`theorem`
Squeeze Theorem for Real Numbers
Let $\sequence {x_n}$, $\sequence {y_n}$ and $\sequence {z_n}$ be sequences in $\R$.

Let $\sequence {y_n}$ and $\sequence {z_n}$ both be convergent to the following limit:
:$\ds \lim_{n \mathop \to \infty} y_n = l, \lim_{n \mathop \to \infty} z_n = l$

Suppose that:
:$\forall n \in \N: y_n \le x_n \le z_n$

Then:
:$x_n \to l$ as $n \to \infty$
that is:
:$\ds \lim_{n \mathop \to \infty} x_n = l$

`proof`
From Negative of Absolute Value:
:$\size {x - l} < \epsilon \iff l - \epsilon < x < l + \epsilon$

Let $\epsilon > 0$.

We need to prove that:
:$\exists N: \forall n > N: \size {x_n - l} < \epsilon$

As $\ds \lim_{n \mathop \to \infty} y_n = l$ we know that:
:$\exists N_1: \forall n > N_1: \size {y_n - l} < \epsilon$

As $\ds \lim_{n \mathop \to \infty} z_n = l$ we know that:
:$\exists N_2: \forall n > N_2: \size {z_n - l} < \epsilon$

Let $N = \max \set {N_1, N_2}$.

Then if $n > N$, it follows that $n > N_1$ and $n > N_2$.

So:
:$\forall n > N: l - \epsilon < y_n < l + \epsilon$
:$\forall n > N: l - \epsilon < z_n < l + \epsilon$

But:
:$\forall n \in \N: y_n \le x_n \le z_n$

So:
:$\forall n > N: l - \epsilon < y_n \le x_n \le z_n < l + \epsilon$

and so:
:$\forall n > N: l - \epsilon < x_n < l + \epsilon$

So:
:$\forall n > N: \size {x_n - l} < \epsilon$

Hence the result.
{{qed}}

-/
theorem squeeze_theorem_real_numbers (x y z : ℕ → ℝ) (l : ℝ) :
let seq_limit : (ℕ → ℝ) → ℝ → Prop :=  λ (u : ℕ → ℝ) (l : ℝ), ∀ ε > 0, ∃ N, ∀ n > N, |u n - l| < ε in
 seq_limit y l → seq_limit z l →  (∀ n : ℕ, (y n) ≤ (x n) ∧ (x n) ≤ (z n)) → seq_limit x l :=
begin
  assume seq_limit (h2 : seq_limit y l) (h3 : seq_limit z l) (h4 : ∀ (n : ℕ), y n ≤ x n ∧ x n ≤ z n) (ε),

  --From Negative of Absolute Value: $\size {x - l} < \epsilon \iff l - \epsilon < x < l + \epsilon$
  have h5 : ∀ x, |x - l| < ε ↔ (((l - ε) < x) ∧ (x < (l + ε))),
  from by
  {
    intro x0,
    have h6 : |x0 - l| < ε ↔ ((x0 - l) < ε) ∧ ((l - x0) < ε),
    from abs_sub_lt_iff, rw h6,
    split,
    rintro ⟨ S_1, S_2 ⟩,
    split; linarith,
    rintro ⟨ S_3, S_4 ⟩,
    split; linarith,
    },

  --Let $\epsilon > 0$.
  assume (h7 : ε > 0),

  --As $\ds \lim_{n \mathop \to \infty} y_n = l$ we know that $\exists N_1: \forall n > N_1: \size {y_n - l} < \epsilon$
  cases h2 ε h7 with N1 h8,

  --As $\ds \lim_{n \mathop \to \infty} z_n = l$ we know that $\exists N_2: \forall n > N_2: \size {z_n - l} < \epsilon$
  cases h3 ε h7 with N2 h9,

  --Let $N = \max \set {N_1, N_2}$.
  let N := max N1 N2,
  use N,

  --Then if $n > N$, it follows that $n > N_1$ and $n > N_2$.
  have h10 : ∀ n > N, n > N1 ∧ n > N2 := by {
    assume n h,
    split,
    exact lt_of_le_of_lt (le_max_left N1 N2) h,
    exact lt_of_le_of_lt (le_max_right N1 N2) h,
  },

  --$\forall n > N: l - \epsilon < y_n < l + \epsilon$
  --$\forall n > N: l - \epsilon < z_n < l + \epsilon$
  --$\forall n \in \N: y_n \le x_n \le z_n$
  --So $\forall n > N: l - \epsilon < y_n \le x_n \le z_n < l + \epsilon$
  have h11 : ∀ n > N, (((l - ε) < (y n)) ∧ ((y n) ≤ (x n))) ∧ (((x n) ≤ (z n)) ∧ ((z n) < l+ε)),
  from by {
    intros n h12,
    split,
    {

      have h13 := (h8 n (h10 n h12).left), rw h5 (y n) at h13,
      split,
      exact h13.left,
      exact (h4 n).left,
    },
    {
      have h14 := (h9 n (h10 n h12).right),rw h5 (z n) at h14,
      split,
      exact (h4 n).right,
      exact h14.right,
    },

  },

  --$\forall n > N: l - \epsilon < x_n < l + \epsilon$
  have h15 : ∀ n > N, ((l - ε) < (x n)) ∧ ((x n) < (l+ε)),
  from by {
    intros n1 h16, cases (h11 n1 h16);
    split; linarith,
  },

  --So $\forall n > N: \size {x_n - l} < \epsilon$
  --Hence the result
  show  ∀ (n : ℕ), n > N → |x n - l| < ε,
  from by {
    intros n h17,
    cases h5 (x n) with h18 h19,
    apply h19, exact h15 n h17,
  },
end

/--`theorem`
Density of irrational orbit
The fractional parts of the integer multiples of an irrational number form a dense subset of the unit interval
`proof`
Let $\alpha$ be an irrational number. Then for distinct $i, j \in \mathbb{Z}$, we must have $\{i \alpha\} \neq\{j \alpha\}$. If this were not true, then
$$
i \alpha-\lfloor i \alpha\rfloor=\{i \alpha\}=\{j \alpha\}=j \alpha-\lfloor j \alpha\rfloor,
$$
which yields the false statement $\alpha=\frac{\lfloor i \alpha\rfloor-\lfloor j \alpha\rfloor}{i-j} \in \mathbb{Q}$. Hence,
$$
S:=\{\{i \alpha\} \mid i \in \mathbb{Z}\}
$$
is an infinite subset of $\left[0,1\right]$.

By the Bolzano-Weierstrass theorem, $S$ has a limit point in $[0, 1]$. One can thus find pairs of elements of $S$ that are arbitrarily close. Since (the absolute value of) the difference of any two elements of $S$ is also an element of $S$, it follows that $0$ is a limit point of $S$.

To show that $S$ is dense in $[0, 1]$, consider $y \in[0,1]$, and $\epsilon>0$. Then by selecting $x \in S$ such that $\{x\}<\epsilon$ (which exists as $0$ is a limit point), and $N$ such that $N \cdot\{x\} \leq y<(N+1) \cdot\{x\}$, we get: $|y-\{N x\}|<\epsilon$.

QED
-/
theorem  irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
FEW SHOT PROMPTS TO CODEX(END)-/


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

Authors: Jesse Han, Floris van Doorn
-/
import .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

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

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

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_nonzero : ⊥ < Γ)
  (H : Γ ≤ is_surj_onto x̌ y̌ f) (H_nonempty : ∃ z, z ∈ y) : ∀ 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_right := H_right (y.func i_v)̌ , simp [check_mem'] at H_right,
  replace H_right := exists_convert H_right _, cases H_right with w Hw, bv_split_at Hw,
  rcases eq_check_of_mem_check ‹_› Hw_left with ⟨j,Γ',HΓ'₁,HΓ'₂,H_eq⟩,
  use j, refine lt_of_lt_of_le HΓ'₁ (le_inf _ _),
    { exact le_trans HΓ'₂ (is_func_of_is_func' ‹_›) },
    { apply @bv_rw' _ _ _ _ _ (bv_symm H_eq) (λ z, pair z (y.func i_v)̌  ∈ᴮ f), exact B_ext_pair_mem_left,
      from le_trans ‹_› ‹_› },
  exact B_ext_inf (by simp) B_ext_pair_mem_left
end

lemma AE_of_check_larger_than_check' {x y : pSet.{u}} {Γ : 𝔹} (H_nonzero : ⊥ < Γ)
  (H : Γ ≤ surjects_onto x̌ y̌) (H_mem : ∃ z, z ∈ y) : ∃ f : bSet 𝔹, ∀ i : y.type, ∃ j : x.type, ⊥ < (is_func f) ⊓ (pair (x.func j)̌  (y.func i)̌  ∈ᴮ f) :=
begin
  unfold surjects_onto at H, have := maximum_principle (λ w, is_func' x̌ y̌ w ⊓ is_surj x̌ (y̌ : bSet 𝔹) w) _,
  cases this with f Hf, rw Hf at H, swap, {simp},
  exact ⟨f, AE_of_check_larger_than_check'' ‹_› ‹_› ‹_› ‹_›⟩
end

lemma AE_of_check_larger_than_check {x y : pSet.{u}} {Γ : 𝔹} (H_nonzero : ⊥ < Γ)
  (H : Γ ≤ larger_than x̌ y̌) (H_mem : ∃ z, z ∈ y) : ∃ f : bSet 𝔹, ∀ i : y.type, ∃ j : x.type, ⊥ < (is_func f) ⊓ (pair (x.func j)̌  (y.func i)̌  ∈ᴮ f) :=
AE_of_check_larger_than_check'
  ‹_› (surjects_onto_of_larger_than_and_exists_mem ‹_› $ by simp*) ‹_›

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 eq_of_is_func_of_eq, from a_right_left, tactic.rotate 1,
         from ‹_›, from ‹_›, from bv_refl },
    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

namespace pSet

@[reducible]noncomputable def ℵ₁ : pSet.{0} := ordinal.mk (aleph 1).ord

@[reducible]noncomputable def ℵ₂ : pSet.{0} := ordinal.mk (aleph 2).ord

lemma ℵ₂_unfold : ℵ₂ = ⟨ℵ₂.type, ℵ₂.func⟩ := by cases ℵ₂; refl

@[simp, cleanup]lemma Union_type {x : pSet} : (type (Union x)) = Σ(a:x.type), (x.func a).type :=
by induction x; refl

@[simp, cleanup]lemma Union_type' {α : Type u} {A : α → pSet.{u}} :
  (Union (mk α A)).type = Σa, (A a).type := rfl

end pSet

open pSet

def 𝔹_cohen : Type := @regular_opens (set(ℵ₂.type × ℕ)) (Pi.topological_space)

local notation `𝔹` := 𝔹_cohen

instance H_nonempty : nonempty (set $ ℵ₂.type × ℕ) := ⟨∅⟩

@[instance, priority 1000]def 𝔹_boolean_algebra : nontrivial_complete_boolean_algebra 𝔹 :=
regular_open_algebra

lemma le_iff_subset' {x y : 𝔹} : x ≤ y ↔ x.1 ⊆ y.1 := by refl

lemma bot_eq_empty : (⊥ : 𝔹) = ⟨∅, is_regular_empty⟩ := rfl

private lemma eq₀ : (ℵ₂̌  : bSet 𝔹).type = (ℵ₂).type := by cases ℵ₂; refl

private lemma eq₁ : ((type (ℵ₂̌  : bSet 𝔹)) × ℕ) = ((type ℵ₂) × ℕ) :=
by {cases ℵ₂, refl}

private lemma eq₂ : set ((type (ℵ₂̌  : bSet 𝔹)) × ℕ) = set ((type ℵ₂) × ℕ) :=
by {cases ℵ₂, refl}

private lemma eq₃ : finset ((type (ℵ₂̌  : bSet 𝔹)) × ℕ) = finset (type ℵ₂ × ℕ) :=
by {cases ℵ₂, 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 (ℵ₂̌  : bSet 𝔹)) × ℕ)) {prf : ((type (ℵ₂̌  : bSet 𝔹)) × ℕ) = (((type ℵ₂) × ℕ))} {prf' : (type (ℵ₂̌  : bSet 𝔹)) = (ℵ₂.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' (p : (((type ℵ₂) × ℕ))) {prf : ((type (ℵ₂̌  : bSet 𝔹)) × ℕ) = (((type ℵ₂) × ℕ))} {prf' : (type (ℵ₂̌  : bSet 𝔹)) = (ℵ₂.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 𝔹_CCC : CCC 𝔹 :=
by { apply CCC_regular_opens, apply cantor_space.countable_chain_condition_set }

local notation `𝒳` := set(ℵ₂.type × ℕ)

open topological_space

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

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

structure 𝒞 : Type :=
(ins : finset ((ℵ₂ ̌ : bSet 𝔹).type × ℕ))
(out : finset ((ℵ₂ ̌ : bSet 𝔹).type × ℕ))
(H : ins ∩ out = ∅)

@[reducible]def π₂ : (ℵ₂̌  : bSet 𝔹).type × ℕ → ℕ := λ x, x.snd

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

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

private def ι : 𝒞 → 𝔹 :=
λ 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 𝒞_dense_basis : ∀ T ∈ @standard_basis (ℵ₂.type × ℕ), ∀ h_nonempty : T ≠ ∅,
  ∃ p : 𝒞, (ι 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 𝒞_dense {b : 𝔹} (H : ⊥ < b) : ∃ p : 𝒞, (ι p) ≤ b :=
begin
  cases (classical.choice (classical.nonempty_of_not_empty _ H.right.symm)) with S_wit H_wit,
  change ∃ p, (ι 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 (𝒞_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 𝒞_nonzero (p : 𝒞) : ⊥ ≠ (ι 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 (ι 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, 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 𝒞_disjoint_row (p : 𝒞) : ∃ n : ℕ, ∀ ξ : ℵ₂.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 𝒞_anti {p₁ p₂ : 𝒞} : p₁.ins ⊆ p₂.ins → p₁.out ⊆ p₂.out → ι p₂ ≤ ι p₁  :=
by {intros H₁ H₂, rw[le_iff_subset'], tidy}

namespace cohen_real
section cohen_real

/-- `cohen_real.χ ν` is the indicator function on ℕ induced by every ordinal less than ℵ₂ -/
def χ (ν : (ℵ₂̌  : bSet 𝔹).type) : ℕ → 𝔹 :=
  λ n, principal_open ν n

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

@[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 𝔹 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 𝔹 believes that each `mk ν` is an element of 𝒫(ω) -/
lemma definite' {ν} {Γ} : Γ ≤ mk ν ∈ᴮ bv_powerset omega := bv_powerset_spec.mp definite

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 [lattice.neg_imp],
  refine le_sup_left_of_le _, rw[@bounded_exists 𝔹 _ (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 : 𝒞} {ν} {n} (H : (ν,n) ∈ p.out) : ι p ≤ -( (of_nat n) ∈ᴮ (mk ν)) :=
begin
rw[bSet.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 ι χ, 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 (ℵ₂̌  : bSet 𝔹)) (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 ν₁ ≠ ν₂ < ℵ₂, bSet 𝔹 believes that `mk ν₁` and `mk ν₂` are distinct -/
lemma inj {ν₁ ν₂} (H_neq : ν₁ ≠ ν₂) : (mk ν₁) =ᴮ (mk ν₂) ≤ (⊥ : 𝔹) :=
begin
  by_contra, replace h := (bot_lt_iff_not_le_bot.mpr ‹_›),
  cases 𝒞_dense h with p H_p, cases 𝒞_disjoint_row p with n H_n,
  let p' : 𝒞 := { 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₀ : ι p' ≤ ι p,
    from 𝒞_anti (by {dsimp[p'], from λ i _, by {simp, from or.inr ‹_›}})
                (by {dsimp[p'], from λ i _, by {simp, from or.inr ‹_›}}),
  have this₁ : ι p' ≤ (ñ̌) ∈ᴮ (cohen_real.mk ν₁),
    by {rw[bSet.mem_unfold], apply bv_use (ulift.up n), refine le_inf _ bv_refl,
         {simp [le_iff_subset', χ, _root_.principal_open, ι, 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₂ : ι p' ≤ - ((ñ̌) ∈ᴮ (cohen_real.mk ν₂)),
    by {have : (ν₂, n) ∈ p'.out, by {simp[p']},
       from not_mem_of_not_mem ‹_›},
  have this₃ : ι p' ≤ - (mk ν₁ =ᴮ mk ν₂),
    from sep ‹_› ‹_›,
  have this₄ : ι p' ≤ (mk ν₁ =ᴮ mk ν₂),
    from le_trans this₀ ‹_›,
  suffices : ι p' = ⊥, from absurd this.symm (𝒞_nonzero p'),
  bv_and_intro this₃ this₄, simpa using H
end

end cohen_real
end cohen_real

section neg_CH

local attribute [irreducible] regular_opens 𝔹_cohen

local notation `ℵ₀` := (omega : bSet 𝔹)
local notation `𝔠` := (bv_powerset ℵ₀ : bSet 𝔹)

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₂) ‹_› ‹_› ‹_› _ (by simp) _ (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 : κ₁ < κ₂) {Γ : 𝔹} : Γ ≤ (card_ex κ₁)̌  ≺ (card_ex κ₂)̌  :=
begin
  dsimp only, rw ←imp_bot, bv_imp_intro H_larger_than,
  by_contra H_nonzero, rw ←bot_lt_iff_not_le_bot at H_nonzero,
  rcases AE_of_check_larger_than_check H_nonzero ‹_› (exists_mem_of_regular ‹_›) with ⟨f,Hf⟩,
  rcases classical.axiom_of_choice Hf with ⟨g, g_spec⟩,
    suffices : ¬ CCC 𝔹, from absurd 𝔹_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; apply mk_type_mk_eq, from ‹_›, apply mk_type_mk_eq,
     from le_of_lt (lt_of_le_of_lt ‹_› ‹_›)}
end

lemma ℵ₀_lt_ℵ₁ : (⊤ : 𝔹)  ≤ ℵ₀ ≺ ℵ₁̌  :=
begin
  dsimp only, rw ←imp_bot, bv_imp_intro H_larger_than,
  by_contra H_nonzero, rw ←bot_lt_iff_not_le_bot at H_nonzero,
  rcases AE_of_check_larger_than_check ‹_› ‹_› _ with ⟨f,Hf⟩,
  rcases (classical.axiom_of_choice Hf) with ⟨g,g_spec⟩,
  suffices : ¬ CCC 𝔹, from absurd 𝔹_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) (aleph 1); try{simp*},
     from is_regular_aleph_one.right},
  from exists_mem_of_regular is_regular_aleph_one
end

lemma ℵ₁_lt_ℵ₂ : (⊤ : 𝔹) ≤ ℵ₁̌  ≺ ℵ₂̌  :=
cardinal_inequality_of_regular _ _ (is_regular_aleph_one)
  (is_regular_aleph_two) (by simp) (by simp)

lemma ℵ₁_lt_ℵ₂' {Γ : 𝔹} : Γ ≤ ℵ₁̌  ≺ ℵ₂̌  := le_trans (le_top) ℵ₁_lt_ℵ₂

lemma cohen_real.mk_ext : ∀ (i j : type (ℵ₂̌  : bSet 𝔹)), func (ℵ₂̌ ) i =ᴮ func (ℵ₂̌ ) j ≤
  (λ (x : type (ℵ₂̌ )), cohen_real.mk x) i =ᴮ (λ (x : type (ℵ₂̌ )), 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 (ℵ₂̌ ) i = (ℵ₂.func (check_cast i))̌ ,
       by simp[check_func],
     rw[this] at a,
     have : func (ℵ₂̌ ) j = (ℵ₂.func (check_cast j))̌ ,
       by simp[check_func],
     rw[this] at a,
   suffices : (ℵ₂.func (check_cast i))̌   =ᴮ (ℵ₂.func (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 𝔹 :=
@function.mk _ _ (ℵ₂̌ ) (λ x, cohen_real.mk x) cohen_real.mk_ext

theorem ℵ₂_le_𝔠 : ⊤ ≤ is_func' (ℵ₂̌ ) 𝔠 (neg_CH_func) ⊓ bSet.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[bSet.mem_unfold] at H,
    bv_cases_at'' H ν, apply bv_use (cohen_real.mk ν),
    refine le_inf cohen_real.definite' _, swap,
    rw[bSet.mem_unfold], apply bv_use ν, bv_split,
    from le_inf ‹_› (by apply le_trans H_1_right; from subst_congr_pair_left)},

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

lemma ℵ₁_Ord {Γ : 𝔹} : Γ ≤ Ord (ℵ₁̌ ) := by simp

lemma ℵ₂_Ord {Γ : 𝔹} : Γ ≤ Ord (ℵ₂̌ ) := by simp

theorem neg_CH : (⊤ : 𝔹) ≤ -CH :=
begin
  dsimp [CH], rw[lattice.neg_neg],
  apply bv_use (ℵ₁̌ ),
  refine le_inf (ℵ₁_Ord) _,
  apply bv_use (ℵ₂̌ ),
  refine le_inf (le_inf _ _) _,
  { from ℵ₀_lt_ℵ₁ },
  { from ℵ₁_lt_ℵ₂ },
  { apply bv_use neg_CH_func, from ℵ₂_le_𝔠 }
end

theorem neg_CH₂ : (⊤ : 𝔹) ≤ -CH₂ :=
(bv_iff.neg $ @CH_iff_CH₂ _ _).mp neg_CH

end neg_CH