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


universe u v

theorem eqLitOfSize0 {α : Type u} (a : Array α) (hsz : a.size = 0) : a = #[] :=
a.toArrayLitEq 0 hsz

theorem eqLitOfSize1 {α : Type u} (a : Array α) (hsz : a.size = 1) : a = #[a.getLit 0 hsz (ofDecideEqTrue rfl)] :=
a.toArrayLitEq 1 hsz

theorem eqLitOfSize2 {α : Type u} (a : Array α) (hsz : a.size = 2) : a = #[a.getLit 0 hsz (ofDecideEqTrue rfl), a.getLit 1 hsz (ofDecideEqTrue rfl)] :=
a.toArrayLitEq 2 hsz

theorem eqLitOfSize3 {α : Type u} (a : Array α) (hsz : a.size = 3) :
  a = #[a.getLit 0 hsz (ofDecideEqTrue rfl), a.getLit 1 hsz (ofDecideEqTrue rfl), a.getLit 2 hsz (ofDecideEqTrue rfl)] :=
a.toArrayLitEq 3 hsz

/-
Matcher for the following patterns
```
| #[]           => _
| #[a₁]         => _
| #[a₁, a₂, a₃] => _
| a             => _
``` -/
def matchArrayLit {α : Type u} (C : Array α → Sort v) (a : Array α)
    (h₁ : Unit →      C #[])
    (h₂ : ∀ a₁,       C #[a₁])
    (h₃ : ∀ a₁ a₂ a₃, C #[a₁, a₂, a₃])
    (h₄ : ∀ a,        C a)
    : C a :=
if h : a.size = 0 then
  @Eq.rec _ _ (fun x _ => C x) (h₁ ()) _ (a.toArrayLitEq 0 h).symm
else if h : a.size = 1 then
  @Eq.rec _ _ (fun x _ => C x) (h₂ (a.getLit 0 h (ofDecideEqTrue rfl))) _ (a.toArrayLitEq 1 h).symm
else if h : a.size = 3 then
  @Eq.rec _ _ (fun x _ => C x) (h₃ (a.getLit 0 h (ofDecideEqTrue rfl)) (a.getLit 1 h (ofDecideEqTrue rfl)) (a.getLit 2 h (ofDecideEqTrue rfl))) _ (a.toArrayLitEq 3 h).symm
else
  h₄ a

/- Equational lemmas that should be generated automatically. -/
theorem matchArrayLit.eq1 {α : Type u} (C : Array α → Sort v)
    (h₁ : Unit →      C #[])
    (h₂ : ∀ a₁,       C #[a₁])
    (h₃ : ∀ a₁ a₂ a₃, C #[a₁, a₂, a₃])
    (h₄ : ∀ a,        C a)
    : matchArrayLit C #[] h₁ h₂ h₃ h₄ = h₁ () :=
rfl

theorem matchArrayLit.eq2 {α : Type u} (C : Array α → Sort v)
    (h₁ : Unit →      C #[])
    (h₂ : ∀ a₁,       C #[a₁])
    (h₃ : ∀ a₁ a₂ a₃, C #[a₁, a₂, a₃])
    (h₄ : ∀ a,        C a)
    (a₁ : α)
    : matchArrayLit C #[a₁] h₁ h₂ h₃ h₄ = h₂ a₁ :=
rfl

theorem matchArrayLit.eq3 {α : Type u} (C : Array α → Sort v)
    (h₁ : Unit →      C #[])
    (h₂ : ∀ a₁,       C #[a₁])
    (h₃ : ∀ a₁ a₂ a₃, C #[a₁, a₂, a₃])
    (h₄ : ∀ a,        C a)
    (a₁ a₂ a₃ : α)
    : matchArrayLit C #[a₁, a₂, a₃] h₁ h₂ h₃ h₄ = h₃ a₁ a₂ a₃ :=
rfl


/-
Copyright (c) 2020 Gabriel Ebner, Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner, Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.ext
import Mathlib.Lean3Lib.data.stream
import Mathlib.data.list.basic
import Mathlib.data.list.range
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Additional instances and attributes for streams
-/

protected instance stream.inhabited {α : Type u_1} [Inhabited α] : Inhabited (stream α) :=
  { default := stream.const Inhabited.default }

namespace stream

/-- `take s n` returns a list of the `n` first elements of stream `s` -/
def take {α : Type u_1} (s : stream α) (n : ℕ) : List α := list.map s (list.range n)

theorem length_take {α : Type u_1} (s : stream α) (n : ℕ) : list.length (take s n) = n := sorry

/-- Use a state monad to generate a stream through corecursion -/
def corec_state {σ : Type u_1} {α : Type u_1} (cmd : state σ α) (s : σ) : stream α :=
  corec prod.fst (state_t.run cmd ∘ prod.snd) (state_t.run cmd s)

end Mathlib


/-
Copyright (c) 2020 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Robert Y. Lewis
-/

import tactic.core
import mathematica
import data.complex.exponential
import data.real.pi
import tactic.interactive_expr

/-!

This demo shows how we can mimic a Mathematica notebook from within Lean.

The syntax here is somewhat hackish; better syntax will be possible in Lean 4.

A section of Mathematica code is entered between `begin_mm_block` and `end_mm_block`.
Mathematica commands are entered in quotes `""`, with each line terminated by a semicolon `;`
corresponding to a `shift-enter` in the standard notebook frontend.
Lean expressions can be inserted as antiquotes between quoted Mathematica expressions.
For parsing reasons, compound Lean expressions must appear in parentheses `()`.

The evaluation of these commands will happen sequentially in the same Mathematica environment.

By default, the output of a line will be translated to a Lean expression and traced.
To display the output as an image instead,
prefix the line with `as image`.

Since Mathematica has no access to Lean's definitional reduction, it is sometimes necessary
to unfold definitions before sending them to Mathematica.
You can begin the block with `begin_mm_block (unfolding f g)` to unfold `f` and `g`
in all antiquoted Lean expressions.

-/

reserve notation `begin_mm_block`
reserve notation `end_mm_block`
reserve notation `as`
reserve notation `image`
reserve notation `unfolding`

@[sym_to_expr]
meta def pi_to_expr : mathematica.sym_trans_expr_rule :=
⟨"Pi", `(real.pi)⟩

@[sym_to_expr]
meta def null_to_expr : mathematica.sym_trans_expr_rule :=
⟨"Null", `(())⟩

/-!
This section develops the widgets for displaying results from Mathematica as images.
-/

section
open widget

meta def component.stateless' {π α} (view : π → list (html α)) : component π α :=
component.with_should_update (λ _ _, tt) $ component.pure view

meta def url_component (src : string) : component tactic_state empty :=
component.stateless' $ λ ts,
  [h "h1" [] ["Mathematica output"],
    h "img" [attr.val "src" src] []
  ]

meta def expr_widget (src : expr) : tactic (component tactic_state empty) :=
do s ← tactic.pp src,
  return $ component.stateless' $ λ ts,
    [h "h1" [] ["Mathematica output"],
    h "p" [] [s]
  ]

end

/-!
This section develops the parser for Mathematica blocks.
-/

section
setup_tactic_parser
open tactic

meta inductive command_comp
| cmd : string → command_comp
| antiquot : expr → command_comp

meta def command_comp.to_string : command_comp → string
| (command_comp.cmd s) := "command: " ++ s
| (command_comp.antiquot s) := "antiquot: " ++ to_string s

meta instance : has_repr command_comp :=
⟨command_comp.to_string⟩

meta def parse_string_component : lean.parser string :=
do s ← parser.pexpr 10000,
   to_expr s >>= ↑(eval_expr string)

meta def parse_antiquote : lean.parser pexpr :=
parser.pexpr 10000

meta def parse_component : lean.parser command_comp :=
do pe ← parser.pexpr 10000,
   e ← to_expr pe,
   tpe ← infer_type e,
   if tpe = `(string) then do  s ← eval_expr' string e, return $ command_comp.cmd s
   else return $ command_comp.antiquot e

meta def parse_cmd_list_aux : lean.parser $ list command_comp :=
tk ";" >> return  [] <|>
do c ← parse_component, cs ← parse_cmd_list_aux, return (c::cs)

meta def parse_cmd_list : lean.parser $ bool × pos × list command_comp :=
do pos ← cur_pos,
   is_img ← option.is_some <$> (tk "as" >> tk "image")?,
   prod.mk is_img <$> prod.mk pos <$> parse_cmd_list_aux

/-!
This section translates, evaluates, and displays the result of a parsed Mathematica command.
-/

meta def command_comp.translate (to_unfold : list name) : command_comp → tactic string
| (command_comp.cmd s) := return s
| (command_comp.antiquot p) :=
  do s ← mathematica.form_of_expr <$> dunfold to_unfold p {fail_if_unchanged := ff},
     return $ "Activate[LeanForm[" ++ s ++ "]]"

meta def execute_list (to_unfold : list name) (is_img : bool) (l : list command_comp) : tactic pexpr :=
do l ← l.mmap (command_comp.translate to_unfold), --tactic.trace $ string.join l,
   let cmd := if is_img then "MakeDataUrlFromImage[" ++ string.join l ++ "]" else string.join l,
   s ← mathematica.execute_global cmd >>= parse_mmexpr_tac,
   mathematica.pexpr_of_mmexpr mathematica.trans_env.empty s

meta def string_of_pos_comp (to_unfold : list name) :
  bool × pos × list command_comp → tactic (pos × (string ⊕ expr))
| ⟨is_img, p, c⟩ :=
do e ← execute_list to_unfold is_img c >>= to_expr,
   prod.mk p <$> if is_img then  sum.inl <$> eval_expr string e else return (sum.inr e)

meta def make_widget (to_unfold : list name) (p : bool × pos × list command_comp) :
  tactic $ pos × (widget.component tactic_state empty) :=
do (loc, data) ← string_of_pos_comp to_unfold p,
match data with
| sum.inl s := return $ ⟨loc, url_component s⟩
| sum.inr e := prod.mk loc <$> expr_widget e
end

@[user_command] meta def parse_mm_block (_ : parse (tk "begin_mm_block")) : lean.parser unit :=
do to_unfold ← (tk "(" >> tk "unfolding" >> ident* <* tk ")")?,
   l ← parse_cmd_list*,
   tk "end_mm_block",
   l ← l.mmap (λ e, make_widget (to_unfold.get_or_else []) e),
   l.mmap' $ λ ⟨⟨ln, c⟩, w⟩, save_widget ⟨ln, c - ("begin_mm_block".length - 1)⟩  w
end

/-!
In this example we show a Mathematica block with three image plots.
Put the cursor on the first characters of the `as image` lines to see the output.

In the second line, we plot a Lean function given as a lambda expression.
In the third, we plot a Lean definition, that we have marked to unfold at the beginning.
-/

open real
noncomputable def f : ℝ → ℝ := λ x, sin x + cos x

begin_mm_block (unfolding f)

as image
"Plot3D[x^2-y, {x,-3,3}, {y,-3,3}]";

as image
"Plot["(λ y, (sin y)^2 - y^2)"[x], {x,-10,10}]";

as image
"Plot["f"[y], {y,-2,2}]";

end_mm_block

/-!
This example gets output from Mathematica as expressions instead of images.

First, we define a symbol `MyPoly` as a Lean expression and factor it.

Then we directly factor a Lean expression.

Uncommenting the `pp` line above shows that we really are seeing full Lean expressions in the output.
-/

-- set_option pp.all true

constants y z : ℝ

begin_mm_block

"MyPoly ="(z^2-2*z+1);
"Factor[MyPoly]";

"Factor["(y^10-z^10)"]";

end_mm_block


import category_theory.category
import category_theory.colimit_lemmas
import .definitions

open category_theory
open category_theory.category
local notation f ` ∘ `:80 g:80 := g ≫ f
local notation t ` @> `:90 X:90 := t.app X

universes v u

namespace homotopy_theory.cylinder

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

-- Homotopy with respect to a given cylinder functor.
structure homotopy {x y : C} (f₀ f₁ : x ⟶ y) :=
(H : I.obj x ⟶ y)
(Hi₀ : H ∘ i 0 @> x = f₀)
(Hi₁ : H ∘ i 1 @> x = f₁)

-- The constant homotopy on a map.
def homotopy.refl {x y : C} (f : x ⟶ y) : homotopy f f :=
by refine { H := f ∘ p @> x, Hi₀ := _, Hi₁ := _ };
   rw [←assoc]; dsimp; simp

-- The image of a homotopy under a map.
def homotopy.congr_left {x y y' : C} (g : y ⟶ y') {f₀ f₁ : x ⟶ y} (H : homotopy f₀ f₁) :
  homotopy (g ∘ f₀) (g ∘ f₁) :=
{ H := g ∘ H.H,
  Hi₀ := by rw [←assoc, H.Hi₀],
  Hi₁ := by rw [←assoc, H.Hi₁] }

-- The precomposition of a homotopy by a map.
def homotopy.congr_right {x' x y : C} (g : x' ⟶ x) {f₀ f₁ : x ⟶ y} (H : homotopy f₀ f₁) :
  homotopy (f₀ ∘ g) (f₁ ∘ g) :=
{ H := H.H ∘ I &> g,
  Hi₀ := by erw [←assoc, ←(i _).naturality]; simp; erw H.Hi₀,
  Hi₁ := by erw [←assoc, ←(i _).naturality]; simp; erw H.Hi₁ }

-- Annoying equality stuff.
-- If we rewrite the starting point of the homotopy by an equality, it doesn't change H.
lemma homotopy.eq_rec_on_left {x y : C} {f₀ f₀' f₁ : x ⟶ y} (H : homotopy f₀ f₁)
  (e : f₀ = f₀') : (eq.rec_on e H : homotopy f₀' f₁).H = H.H :=
by cases e; refl

section rel
variables {a x y : C} (j : a ⟶ x) {f₀ f₁ : x ⟶ y}

-- The property of a homotopy leaving fixed a subspace, or more
-- generally the "image" of any map j : A → X. In order for the
-- homotopy to be rel u, we must first have f₀ ∘ j = f₁ ∘ j. This
-- condition is not encoded in the type.
def homotopy.is_rel (H : homotopy f₀ f₁) : Prop :=
H.H ∘ I &> j = f₀ ∘ j ∘ p @> a

variables {j}
lemma agree_of_is_rel {H : homotopy f₀ f₁} (h : H.is_rel j) : f₀ ∘ j = f₁ ∘ j :=
calc
  f₀ ∘ j
    = (f₀ ∘ j) ∘ (p @> a ∘ i 1 @> a) : by simp
... = f₀ ∘ j ∘ p @> a ∘ i 1 @> a     : by rw assoc
... = H.H ∘ I &> j ∘ i 1 @> a        : by unfold homotopy.is_rel at h; simp [h]
... = H.H ∘ (I &> j ∘ i 1 @> a)      : by simp
... = H.H ∘ (i 1 @> x ∘ j)           : by erw ←(i 1).naturality; refl
... = f₁ ∘ j                         : by simp; erw H.Hi₁

lemma homotopy.refl_is_rel {f : x ⟶ y} : (homotopy.refl f).is_rel j :=
show f ∘ p @> x ∘ I &> j = f ∘ j ∘ p @> a,
by erw [←assoc, ←assoc, p.naturality]; refl

lemma homotopy.congr_left_is_rel {f₀ f₁ : x ⟶ y} {H : homotopy f₀ f₁}
  {z} (g : y ⟶ z) (h : H.is_rel j) : (H.congr_left g).is_rel j :=
begin
  unfold homotopy.is_rel at ⊢ h, dsimp [homotopy.congr_left] { iota := tt },
  rw [←assoc, h], simp
end

lemma homotopy.congr_right_is_rel {f₀ f₁ : x ⟶ y} {H : homotopy f₀ f₁}
  {x'} {j' : a ⟶ x'} (g : x' ⟶ x) (h : H.is_rel (g ∘ j')) : (H.congr_right g).is_rel j' :=
begin
  unfold homotopy.is_rel at ⊢ h, dsimp [homotopy.congr_right] { iota := tt },
  rw [←assoc, ←I.map_comp, h], simp
end

-- In practice, `a` is initial and `I` preserves initial objects.
lemma homotopy.is_rel_initial (Iai : Is_initial_object.{v} (I.obj a))
  (H : homotopy f₀ f₁) : H.is_rel j :=
Iai.uniqueness _ _

end rel

section dir
-- A technical contrivance to let us abstract over the direction of a
-- homotopy.
def homotopy_dir (ε : endpoint) {x y : C} (fε fεv : x ⟶ y) : Type v :=
match ε with
| 0 := homotopy fε fεv
| 1 := homotopy fεv fε
end

def homotopy_dir.H {ε} {x y : C} {fε fεv : x ⟶ y} (H : homotopy_dir ε fε fεv) :
  I.obj x ⟶ y :=
match ε, H with
| 0, H := homotopy.H H
| 1, H := homotopy.H H
end

lemma homotopy_dir.Hiε {ε} {x y : C} {fε fεv : x ⟶ y} (H : homotopy_dir ε fε fεv) :
  H.H ∘ i ε @> x = fε :=
match ε, H with
| 0, H := homotopy.Hi₀ H
| 1, H := homotopy.Hi₁ H
end

lemma homotopy_dir.Hiεv {ε} {x y : C} {fε fεv : x ⟶ y} (H : homotopy_dir ε fε fεv) :
  H.H ∘ i ε.v @> x = fεv :=
match ε, H with
| 0, H := homotopy.Hi₁ H
| 1, H := homotopy.Hi₀ H
end

def homotopy_dir.mk (ε : endpoint) {x y : C} {fε fεv : x ⟶ y}
  (H : I.obj x ⟶ y) (Hiε : H ∘ i ε @> x = fε) (Hiεv : H ∘ i ε.v @> x = fεv) :
  homotopy_dir ε fε fεv :=
match ε, H, Hiε, Hiεv with
| 0, H, Hiε, Hiεv := { H := H, Hi₀ := Hiε, Hi₁ := Hiεv }
| 1, H, Hiε, Hiεv := { H := H, Hi₀ := Hiεv, Hi₁ := Hiε }
end

end dir

-- The homotopy relation with respect to the given cylinder functor.
def homotopic {x y : C} (f₀ f₁ : x ⟶ y) : Prop := nonempty (homotopy f₀ f₁)

notation f₀ ` ≃ `:50 f₁:50 := homotopic f₀ f₁

@[refl] lemma homotopic.refl {x y : C} (f : x ⟶ y) : f ≃ f :=
⟨homotopy.refl f⟩

lemma homotopic.congr_left {x y y' : C} (g : y ⟶ y') {f₀ f₁ : x ⟶ y} (h : f₀ ≃ f₁) :
  g ∘ f₀ ≃ g ∘ f₁ :=
let ⟨H⟩ := h in ⟨H.congr_left g⟩

lemma homotopic.congr_right {x' x y : C} (g : x' ⟶ x) {f₀ f₁ : x ⟶ y} (h : f₀ ≃ f₁) :
  f₀ ∘ g ≃ f₁ ∘ g :=
let ⟨H⟩ := h in ⟨H.congr_right g⟩

-- The relation of being homotopic rel a fixed map j : A → X.
def homotopic_rel {a x y : C} (j : a ⟶ x) (f₀ f₁ : x ⟶ y) : Prop :=
∃ H : homotopy f₀ f₁, H.is_rel j

notation f₀ ` ≃ `:50 f₁:50 ` rel `:50 j:50 := homotopic_rel j f₀ f₁

@[refl] lemma homotopic_rel.refl {a x y : C} {j : a ⟶ x} (f : x ⟶ y) : f ≃ f rel j :=
⟨homotopy.refl f, homotopy.refl_is_rel⟩

lemma homotopic_rel.congr_left {a x y y' : C} {j : a ⟶ x} (g : y ⟶ y') {f₀ f₁ : x ⟶ y} :
  f₀ ≃ f₁ rel j → g ∘ f₀ ≃ g ∘ f₁ rel j :=
assume ⟨H, h⟩, ⟨H.congr_left g, homotopy.congr_left_is_rel g h⟩

lemma homotopic_rel.congr_right {a x' x y : C} {j' : a ⟶ x'} (g : x' ⟶ x) {f₀ f₁ : x ⟶ y} :
  f₀ ≃ f₁ rel (g ∘ j') → f₀ ∘ g ≃ f₁ ∘ g rel j' :=
assume ⟨H, h⟩, ⟨H.congr_right g, homotopy.congr_right_is_rel g h⟩

lemma homotopic_rel.forget_rel {a x y : C} {j : a ⟶ x} {f₀ f₁ : x ⟶ y} : f₀ ≃ f₁ rel j → f₀ ≃ f₁ :=
assume ⟨H, h⟩, ⟨H⟩

lemma homotopic_rel_initial {a x y : C} (Iai : Is_initial_object.{v} (I.obj a))
  (j : a ⟶ x) (f₀ f₁ : x ⟶ y) : (f₀ ≃ f₁ rel j) = (f₀ ≃ f₁) :=
propext $ iff.intro
  (assume ⟨H, _⟩, ⟨H⟩)
  (assume ⟨H⟩, ⟨H, H.is_rel_initial Iai⟩)

end homotopy_theory.cylinder


import Mathlib.Tactic.Basic
import Mathlib.Tactic.Cases
import Mathlib.Init.Data.Nat.Basic

/-!
## Structures

Lean provides a convenient syntax for defining records, or _structures_ as they are
also called. These are essentially nonrecursive, single-constructor inductive types,
but with some syntactic sugar.

The definition below introduces a structure called `rgb` with three fields of type
Nat called `red`, `green`, and `blue`:
-/
structure rgb where
  (red green blue : ℕ)
  deriving Repr
/-!
The additional `deriving Repr` clause tells Lean to automatically generate a
`repr` function for this structure so that `#eval` can print the structure.

This definition has roughly the same effect as the following commands:
-/
inductive rgb₁ : Type
| mk : ℕ → ℕ → ℕ → rgb₁

def rgb₁.red : rgb₁ → ℕ
| (rgb₁.mk r _ _) => r

def rgb₁.green : rgb₁ → ℕ
| (rgb₁.mk _ g _) => g

def rgb₁.blue : rgb₁ → ℕ
| (rgb₁.mk _ _ b) => b

/-!
We can define a new structure as the extension of an existing structure. The
definition below extends `rgb` with a fourth field, called `alpha`:
-/
structure rgba extends rgb where
  (alpha : ℕ)
  deriving Repr
/-!
The general syntax to define structures is
```lean
structure structure-name (params₁ : type₁) . . . (paramsₖ : typeₖ )
  [extends structure₁, . . ., structureₘ] where
  [constructor ::]
  <fields>
```
Where each fields is either
```
(field-names₁ : field-type₁) ... (field-namesₙ : field-typeₙ)
```
Or one field per line where you can drop the parens:
```
  field-names₁ : field-type₁
  ...
  field-namesₙ : field-typeₙ
```
So `rgb` can also be defined like this:
-/
structure rgb₂ where
  red : ℕ
  green : ℕ
  blue : ℕ
/-!
The parameters `params₁, . . . , paramsₖ` are effectively additional fields, but unlike
the fields `field-names₁, . . . , field-namesₙ`, they are also stored in the type, as
arguments to the type constructor (structure-name).

Values can be created using a variety of syntaxes:
-/
def black : rgb := rgb.mk 0 0 0
/-!
Notice the structure has a default constructor named 'mk'.  You can rename this by
providing a name before the fields followed by `::` then the fields, for example:
-/
structure rgb₃ where
  foo :: (red green blue : ℕ)
  deriving Repr

#eval rgb₃.foo 1 2 3 -- { red := 1, green := 2, blue := 3 }
/-!

The special brackets `⟨ ... ⟩` is general notation that means call the default constructor,
and in this case there is only one contructor, so it knows what to do:
-/
def red : rgb := ⟨255, 0, 0⟩
def red₃ : rgb₃ := ⟨255, 0, 0⟩
/-!
You can also construct object using an object syntax where you name the fields:
-/
def green  : rgb := { red := 0, green := 255, blue := 0 }

def blue  : rgb := { black with blue := 255 }

def yellow := { red := 255, green := 255, blue := 0 : rgb }

def semitransparent_red : rgba := { red with alpha := 0x7f }
/-!

Notice that the `with` clause allows you to copy the values from another object and override
just a subset of fields that you want to change and this works with base types
as shown in `semitransparent_red`.

Values can be also extracted using dot notation:
-/
#eval yellow.green   -- 255
/-!
Next, we define an operation called shuffle:
-/
def shuffle (c : rgb) := {
  c with
    red := c.green,
    green := c.blue,
    blue := c.red
}

#eval shuffle yellow  -- { red := 255, green := 0, blue := 255 }
/-!
Applying shuffle three times in a row is the same as not applying it at all:
-/
lemma shuffle_shuffle_shuffle (c : rgb) :
  shuffle (shuffle (shuffle c)) = c := by
    cases c
    rfl

/-!
The proof relies on the `cases` tactic, a close relative of `induction`. It performs a
case distinction on its argument, but it does not generate induction hypotheses.
For `rgb`, the invocation `cases c` transforms a goal `⊢ P[c]` into a subgoal
`r g b : ℕ ⊢ P[rgb.mk r g b]`. We could also have used `induction c`.

In a structured proof, we can use `match` expressions to perform a case distinction.
For example:
-/
lemma shuffle_shuffle_shuffle₂ (c : rgb) :
  shuffle (shuffle (shuffle c)) = c :=
  match c with
  | rgb.mk _ _ _ => Eq.refl _

/-!
Recall from [Section 2.4](../BackwardProofs/Equality.lean.md) that `Eq.refl` is the property
`∀a, a = a`.
-/


import data.fintype.basic
import category_theory.Fintype

open_locale classical

universe u

-- This is an awkward hybrid: we should state the induction principle for unbundled fintype
-- and then if it is necessary provide an interface for using it with `Fintype`.

lemma Fintype.induction_empty_sum {P : Fintype.{u} → Prop}
  (of_equiv : ∀ {α β : Fintype.{u}}, α ≃ β → P α → P β)
  (h_empty : P (Fintype.of pempty))
  (h_option : ∀ {α : Fintype.{u}}, P α → P (Fintype.of (α ⊕ (punit : Type u))))
  (α : Fintype.{u}) : P α :=
begin
  let Q : Π (α : Type u) [fintype α], Prop := λ a h, P ⟨a,h⟩,
  have H := @fintype.induction_empty_option' Q _ _ _ α α.str,
  { cases α, exact H },
  { introsI α β _ e h,
    haveI : fintype α := fintype.of_equiv _ e.symm,
    let e' : Fintype.of α ≃ Fintype.of β := e,
    apply of_equiv e',
    convert h },
  { assumption },
  { introsI α _ h,
    let e : option α ≃ α ⊕ (punit : Type u) := equiv.option_equiv_sum_punit _,
    let e' : Fintype.of (option α) ≃ Fintype.of (α ⊕ punit) := e,
    apply of_equiv e'.symm,
    exact h_option h }
end


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Mario Carneiro, Johan Commelin, Amelia Livingston, Anne Baanen
-/
import ring_theory.localization.away
import ring_theory.localization.fraction_ring
import ring_theory.localization.integer
import ring_theory.unique_factorization_domain

/-!
# Numerator and denominator in a localization

## Implementation notes

-- See `src/ring_theory/localization/basic.lean` for a design overview.

-- ## Tags
-- localization, ring localization, commutative ring localization, characteristic predicate,
-- commutative ring, field of fractions
-- -/
-- variables {R : Type*} [comm_ring R] (M : submonoid R) {S : Type*} [comm_ring S]
-- variables [algebra R S] {P : Type*} [comm_ring P]

-- namespace is_fraction_ring

-- open is_localization

-- section num_denom

-- variables (A : Type*) [comm_ring A] [is_domain A] [unique_factorization_monoid A]
-- variables {K : Type*} [field K] [algebra A K] [is_fraction_ring A K]

-- lemma exists_reduced_fraction (x : K) :
--   ∃ (a : A) (b : non_zero_divisors A),
--   (∀ {d}, d ∣ a → d ∣ b → is_unit d) ∧ mk' K a b = x :=
-- begin
--   obtain ⟨⟨b, b_nonzero⟩, a, hab⟩ := exists_integer_multiple (non_zero_divisors A) x,
--   obtain ⟨a', b', c', no_factor, rfl, rfl⟩ :=
--     unique_factorization_monoid.exists_reduced_factors' a b
--       (mem_non_zero_divisors_iff_ne_zero.mp b_nonzero),
--   obtain ⟨c'_nonzero, b'_nonzero⟩ := mul_mem_non_zero_divisors.mp b_nonzero,
--   refine ⟨a', ⟨b', b'_nonzero⟩, @no_factor, _⟩,
--   refine mul_left_cancel₀
--     (is_fraction_ring.to_map_ne_zero_of_mem_non_zero_divisors b_nonzero) _,
--   simp only [subtype.coe_mk, ring_hom.map_mul, algebra.smul_def] at *,
--   erw [←hab, mul_assoc, mk'_spec' _ a' ⟨b', b'_nonzero⟩],
-- end

-- /-- `f.num x` is the numerator of `x : f.codomain` as a reduced fraction. -/
-- noncomputable def num (x : K) : A :=
-- classical.some (exists_reduced_fraction A x)

-- /-- `f.num x` is the denominator of `x : f.codomain` as a reduced fraction. -/
-- noncomputable def denom (x : K) : non_zero_divisors A :=
-- classical.some (classical.some_spec (exists_reduced_fraction A x))

-- lemma num_denom_reduced (x : K) {d} : d ∣ num A x → d ∣ denom A x → is_unit d :=
-- (classical.some_spec (classical.some_spec (exists_reduced_fraction A x))).1

-- @[simp] lemma mk'_num_denom (x : K) : mk' K (num A x) (denom A x) = x :=
-- (classical.some_spec (classical.some_spec (exists_reduced_fraction A x))).2

-- variables {A}

-- lemma num_mul_denom_eq_num_iff_eq {x y : K} :
--   x * algebra_map A K (denom A y) = algebra_map A K (num A y) ↔ x = y :=
-- ⟨λ h, by simpa only [mk'_num_denom] using eq_mk'_iff_mul_eq.mpr h,
--  λ h, eq_mk'_iff_mul_eq.mp (by rw [h, mk'_num_denom])⟩

-- lemma num_mul_denom_eq_num_iff_eq' {x y : K} :
--   y * algebra_map A K (denom A x) = algebra_map A K (num A x) ↔ x = y :=
-- ⟨λ h, by simpa only [eq_comm, mk'_num_denom] using eq_mk'_iff_mul_eq.mpr h,
--  λ h, eq_mk'_iff_mul_eq.mp (by rw [h, mk'_num_denom])⟩

-- lemma num_mul_denom_eq_num_mul_denom_iff_eq {x y : K} :
--   num A y * denom A x = num A x * denom A y ↔ x = y :=
-- ⟨λ h, by simpa only [mk'_num_denom] using mk'_eq_of_eq h,
--  λ h, by rw h⟩

-- lemma eq_zero_of_num_eq_zero {x : K} (h : num A x = 0) : x = 0 :=
-- num_mul_denom_eq_num_iff_eq'.mp (by rw [zero_mul, h, ring_hom.map_zero])

-- lemma is_integer_of_is_unit_denom {x : K} (h : is_unit (denom A x : A)) : is_integer A x :=
-- begin
--   cases h with d hd,
--   have d_ne_zero : algebra_map A K (denom A x) ≠ 0 :=
--     is_fraction_ring.to_map_ne_zero_of_mem_non_zero_divisors (denom A x).2,
--   use ↑d⁻¹ * num A x,
--   refine trans _ (mk'_num_denom A x),
--   rw [map_mul, map_units_inv, hd],
--   apply mul_left_cancel₀ d_ne_zero,
--   rw [←mul_assoc, mul_inv_cancel d_ne_zero, one_mul, mk'_spec']
-- end

-- lemma is_unit_denom_of_num_eq_zero {x : K} (h : num A x = 0) : is_unit (denom A x : A) :=
-- num_denom_reduced A x (h.symm ▸ dvd_zero _) dvd_rfl

-- end num_denom

-- -- variables (S)
universes u v

-- -- section away

-- -- variables {A : Type u} [decidable_eq A]
-- -- variables [cancel_comm_monoid_with_zero A] [normalization_monoid A] [unique_factorization_monoid A]
-- -- variables [dec_dvd : decidable_rel (has_dvd.dvd : A → A → Prop)]
-- -- variable {x : A}
-- -- variable (hx : irreducible x)
-- -- open multiplicity unique_factorization_monoid

-- -- end away

section away

open multiplicity unique_factorization_monoid is_localization

variables {A : Type u} [comm_ring A] [is_domain A] [decidable_eq A] [normalization_monoid A] [unique_factorization_monoid A]
variables [dec_dvd : decidable_rel (has_dvd.dvd : A → A → Prop)]
variable (x : A)

-- variable (n : ℕ)

-- #where

include dec_dvd

lemma uno_remarkable (a₀ : A) (h : a₀ ≠ 0) [nontrivial A] (hx : irreducible x) :
  ∃ n : ℕ, ∃ a : A, ¬ x ∣ a ∧ a₀ = x ^ n * a :=
begin
  let n := (normalized_factors a₀).count (normalize x),
  obtain ⟨a, ha1, ha2⟩ := (@exists_eq_pow_mul_and_not_dvd A _ _ x a₀
    (ne_top_iff_finite.mp (part_enat.ne_top_iff.mpr _))),
  simp_rw [← (multiplicity_eq_count_normalized_factors hx h).symm] at ha1,
  use [n, a, ha2, ha1],
  use [n, (multiplicity_eq_count_normalized_factors hx h)],
end

-- lemma due_remarkable (a : A) (m n : ℕ) :
--   (mk' B a ⟨x^n, (submonoid.mem_powers_iff (x^n) x).mpr ⟨n, rfl⟩⟩) =
--   (mk' B (a * x^m) ⟨x^(n), (submonoid.mem_powers_iff (x^n) x).mpr ⟨n, rfl⟩⟩) :=
-- begin
-- sorry
-- end

-- include x

-- noncomputable def inv_self.unit : Bˣ :=
--   ⟨away.inv_self x, algebra_map _ _ x, by {rw mul_comm, exact away.mul_inv_self _},
--     away.mul_inv_self _⟩

variables (B : Type v) [comm_ring B] [algebra A B] [is_localization.away x B]
variable (hx' : irreducible x)

noncomputable def self_as_unit : Bˣ :=
  ⟨algebra_map _ _ x, away.inv_self x, away.mul_inv_self _,
    by {rw mul_comm, exact away.mul_inv_self _}⟩

lemma due_remarkable' (a : A) (b : B) (m d : ℤ) :
  (((self_as_unit x B ^ (m - d)) : Bˣ ) : B) * mk' B a (1 : submonoid.powers x) = b ↔
  (((self_as_unit x B ^ m) : Bˣ) : B) * mk' B a (1 : submonoid.powers x) =
    (((self_as_unit x B ^ d) : Bˣ) : B) * b := by {simp only [zpow_sub, units.coe_mul,
    mul_comm (((self_as_unit x B ^ m) : Bˣ) : B) _,  mul_assoc, units.inv_mul_eq_iff_eq_mul]}

lemma aux (d : ℕ) : (((self_as_unit x B)^(d : ℤ) : Bˣ) : B) = (algebra_map A B x)^d :=
  by {simp only [self_as_unit, zpow_coe_nat, units.coe_pow, units.coe_mk]}

include hx'

lemma exists_reduced_fraction (b : B) (hb : b ≠ 0) :
  ∃ (a : A) (n : ℤ), ¬ x ∣ a ∧
  (((self_as_unit x B)^n : Bˣ) : B) * mk' B a (1 : submonoid.powers x) = b :=
  -- (mk' B a (1 : (submonoid.powers x))) * (((away.inv_self x) : Bˣ ) : B)= b :=
  -- (∀ {d}, d ∣ a → d ∣ b → is_unit d) ∧ mk' K a b = x :=
begin
  obtain ⟨⟨a₀, y⟩, H⟩ := is_localization.surj (submonoid.powers x) b,
  obtain ⟨d, hy⟩ := (submonoid.mem_powers_iff y.1 x).mp y.2,
    have ha₀ : a₀ ≠ 0,
    { --have : (y : A) ≠ 0,
      -- rw coe_zero,
      -- by_contra,
      have h_inj := @is_localization.injective A _ (submonoid.powers x) B _ _ _
        (powers_le_non_zero_divisors_of_no_zero_divisors (hx'.ne_zero)),
      haveI := @is_domain_of_le_non_zero_divisors B _ A _ _ _ (submonoid.powers x) _
       (powers_le_non_zero_divisors_of_no_zero_divisors hx'.ne_zero),
      simp only [map_zero, ← subtype.val_eq_coe, ← hy, map_pow] at H,
      apply ((injective_iff_map_eq_zero' (algebra_map A B)).mp (h_inj) a₀).mpr.mt,
      rw ← H,
      apply mul_ne_zero hb,
      apply pow_ne_zero,
      apply @is_localization.to_map_ne_zero_of_mem_non_zero_divisors
        A _ (submonoid.powers x) B _ _ _ _ _ x _,
      apply powers_le_non_zero_divisors_of_no_zero_divisors (hx'.ne_zero),
      exact mem_non_zero_divisors_iff_ne_zero.mpr hx'.ne_zero,
    },
    simp only [← subtype.val_eq_coe, ← hy] at H,--needed?
    obtain ⟨m, a, hyp1, hyp2⟩ := uno_remarkable x a₀ ha₀ hx',
    use a,
    use m - d,
    rw due_remarkable' x B a b m d, --replace?
    rw [aux x B d, mul_comm _ b, ← map_pow, H, hyp2, aux x B m,
      map_mul, map_pow],
    -- rw [due_remarkable' x B a b m d, aux x B d, mul_comm _ b, ← map_pow, H, hyp2, aux x B m,
    --   map_mul, map_pow],
    exact ⟨hyp1, (congr_arg _ (is_localization.mk'_one _ _))⟩,
end

end away


-- Copyright 2022-2023 VMware, Inc.
-- SPDX-License-Identifier: BSD-2-Clause

import .relational
import .incremental

open zset

variables {A B C: Type}.
variables [decidable_eq A] [decidable_eq B] [decidable_eq C].

def distinct_H_at (i d: Z[A]) : A → ℤ :=
  λ x, if 0 < i x ∧ (i + d) x ≤ 0
       then -1 else
        if i x ≤ 0 ∧ 0 < (i + d) x
        then 1 else 0.

def distinct_H (i d: Z[A]) : Z[A] :=
  dfinsupp.mk (i.support ∪ d.support)
    (λ x, distinct_H_at i d x).

@[simp]
lemma distinct_H_apply (i d: Z[A]) (x: A) :
  distinct_H i d x = distinct_H_at i d x :=
begin
  unfold distinct_H, simp,
  push_neg,
  intros h, cases h with h1 h2,
  simp [distinct_H_at], rw [h1, h2],
  rw [if_neg, if_neg]; simp,
end

def distinct_incremental : stream Z[A] → stream Z[A] :=
  λ d, (↑² distinct_H) (z⁻¹ (I d)) d.

theorem distinct_incremental_ok :
  (↑↑ distinct)^Δ = @distinct_incremental A _ :=
begin
  funext d,
  unfold incremental distinct_incremental,
  unfold D,
  conv_lhs {
    congr, { rw integral_unfold, skip}, { skip }
  },
  rw<- lifting_time_invariant, swap, simp,
  repeat { rw<- integral_time_invariant },
  ext t a, unfold lifting2, simp,
  generalize hi : I (z⁻¹ d) t = i,
  generalize hd : d t = d_t,
  clear hi hd d t,
  unfold distinct_H_at,
  simp,
  -- canonicalize the tests a little bit so splitting produces fewer cases
  rw (add_comm (i a) (d_t a)),
  repeat { rw <- ite_ite },
  split_ifs; refl <|> { exfalso, omega },
end

@[simp]
lemma flatmap_incremental (f: A → Z[B]) :
  ↑↑(zset.flatmap f)^Δ = ↑↑(zset.flatmap f) :=
begin
  apply lti_incremental,
  apply lifting_lti,
  apply flatmap_linear,
end

@[simp]
lemma map_incremental (f: A → B) :
  ↑↑(zset.map f)^Δ = ↑↑(zset.map f) :=
  flatmap_incremental _.

@[simp]
lemma lifting_map_incremental {A B} [decidable_eq A] [decidable_eq B] (f: A → B) :
  ↑↑(↑↑(zset.map f))^Δ = ↑↑(↑↑(zset.map f)) :=
begin
  rw lti_incremental,
  apply lifting_lti,
  intros x y, rw lifting_linear, apply map_linear,
end

@[simp]
lemma map_incremental_unfolded (f: A → B) (s: stream Z[A]) :
  D (↑↑(zset.map f) (I s)) = ↑↑(zset.map f) s :=
begin
  conv_rhs {
    rw<- map_incremental,
  },
  rw incremental_unfold,
end

theorem equi_join_incremental (π1: A → C) (π2: B → C) :
  ↑²(equi_join π1 π2)^Δ2 =
    times_incremental ↑²(equi_join π1 π2) :=
begin
  rw (bilinear_incremental (↑²(equi_join π1 π2))),
  { rw lifting2_time_invariant,
    refl, },
  { apply lifting_bilinear,
    apply equi_join_bilinear,
  },
end

@[simp]
lemma filter_incremental (p: A → Prop) [decidable_pred p] :
  ↑↑(filter p)^Δ = ↑↑(filter p) :=
begin
  apply lti_incremental,
  apply lifting_lti,
  apply filter_linear,
end