/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz, Scott Morrison
-/
import category_theory.limits.exact_functor
import category_theory.limits.preserves.finite
import category_theory.preadditive.biproducts
import category_theory.preadditive.functor_category

/-!
# Additive Functors

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

A functor between two preadditive categories is called *additive*
provided that the induced map on hom types is a morphism of abelian
groups.

An additive functor between preadditive categories creates and preserves biproducts.
Conversely, if `F : C ⥤ D` is a functor between preadditive categories, where `C` has binary
biproducts, and if `F` preserves binary biproducts, then `F` is additive.

We also define the category of bundled additive functors.

# Implementation details

`functor.additive` is a `Prop`-valued class, defined by saying that for every two objects `X` and
`Y`, the map `F.map : (X ⟶ Y) → (F.obj X ⟶ F.obj Y)` is a morphism of abelian groups.

-/

universes v₁ v₂ u₁ u₂

namespace category_theory

/-- A functor `F` is additive provided `F.map` is an additive homomorphism. -/
class functor.additive {C D : Type*} [category C] [category D]
  [preadditive C] [preadditive D] (F : C ⥤ D) : Prop :=
(map_add' : Π {X Y : C} {f g : X ⟶ Y}, F.map (f + g) = F.map f + F.map g . obviously)

section preadditive

namespace functor

section
variables {C D : Type*} [category C] [category D] [preadditive C]
  [preadditive D] (F : C ⥤ D) [functor.additive F]

@[simp]

/-- `F.map_add_hom` is an additive homomorphism whose underlying function is `F.map`. -/
@[simps {fully_applied := ff}]
def map_add_hom {X Y : C} : (X ⟶ Y) →+ (F.obj X ⟶ F.obj Y) :=
add_monoid_hom.mk' (λ f, F.map f) (λ f g, F.map_add)

lemma coe_map_add_hom {X Y : C} : ⇑(F.map_add_hom : (X ⟶ Y) →+ _) = @map C _ D _ F X Y := rfl

@[priority 100]
instance preserves_zero_morphisms_of_additive : preserves_zero_morphisms F :=
{ map_zero' := λ X Y, F.map_add_hom.map_zero }

instance : additive (𝟭 C) :=
{}

instance {E : Type*} [category E] [preadditive E] (G : D ⥤ E) [functor.additive G] :
  additive (F ⋙ G) :=
{}

@[simp]
lemma map_neg {X Y : C} {f : X ⟶ Y} : F.map (-f) = - F.map f :=
(F.map_add_hom : (X ⟶ Y) →+ (F.obj X ⟶ F.obj Y)).map_neg _

@[simp]
lemma map_sub {X Y : C} {f g : X ⟶ Y} : F.map (f - g) = F.map f - F.map g :=
(F.map_add_hom : (X ⟶ Y) →+ (F.obj X ⟶ F.obj Y)).map_sub _ _

lemma map_nsmul {X Y : C} {f : X ⟶ Y} {n : ℕ} : F.map (n • f) = n • F.map f :=
(F.map_add_hom : (X ⟶ Y) →+ (F.obj X ⟶ F.obj Y)).map_nsmul _ _

-- You can alternatively just use `functor.map_smul` here, with an explicit `(r : ℤ)` argument.
lemma map_zsmul {X Y : C} {f : X ⟶ Y} {r : ℤ} : F.map (r • f) = r • F.map f :=
(F.map_add_hom : (X ⟶ Y) →+ (F.obj X ⟶ F.obj Y)).map_zsmul _ _

open_locale big_operators

@[simp]
lemma map_sum {X Y : C} {α : Type*} (f : α → (X ⟶ Y)) (s : finset α) :
  F.map (∑ a in s, f a) = ∑ a in s, F.map (f a) :=
(F.map_add_hom : (X ⟶ Y) →+ _).map_sum f s

end

section induced_category
variables {C : Type*} {D : Type*} [category D] [preadditive D] (F : C → D)

instance induced_functor_additive : functor.additive (induced_functor F) := {}

end induced_category

instance full_subcategory_inclusion_additive
  {C : Type*} [category C] [preadditive C] (Z : C → Prop) :
  (full_subcategory_inclusion Z).additive := {}

section
-- To talk about preservation of biproducts we need to specify universes explicitly.

noncomputable theory

variables {C : Type u₁} {D : Type u₂} [category.{v₁} C] [category.{v₂} D]
  [preadditive C] [preadditive D] (F : C ⥤ D)

open category_theory.limits
open category_theory.preadditive

@[priority 100]
instance preserves_finite_biproducts_of_additive [additive F] : preserves_finite_biproducts F :=
{ preserves := λ J _,
  { preserves := λ f,
    { preserves := λ b hb, by exactI is_bilimit_of_total _
      begin
        simp_rw [F.map_bicone_π, F.map_bicone_ι, ← F.map_comp, ← F.map_sum],
        dsimp only [map_bicone_X],
        simp_rw [← F.map_id],
        refine congr_arg _ (hb.is_limit.hom_ext (λ j, hb.is_colimit.hom_ext (λ j', _))),
        cases j, cases j',
        dsimp only [limits.bicone.to_cone_π_app],
        simp [sum_comp, comp_sum, bicone.ι_π, comp_dite, dite_comp],
      end } } }

lemma additive_of_preserves_binary_biproducts [has_binary_biproducts C] [preserves_zero_morphisms F]
  [preserves_binary_biproducts F] : additive F :=
{ map_add' := λ X Y f g, by rw [biprod.add_eq_lift_id_desc, F.map_comp, ← biprod.lift_map_biprod,
    ← biprod.map_biprod_hom_desc, category.assoc, iso.inv_hom_id_assoc, F.map_id,
    biprod.add_eq_lift_id_desc] }

end

end functor

namespace equivalence

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

instance inverse_additive (e : C ≌ D) [e.functor.additive] : e.inverse.additive :=
{ map_add' := λ X Y f g, by { apply e.functor.map_injective, simp, }, }

end equivalence

section
variables (C D : Type*) [category C] [category D] [preadditive C] [preadditive D]

/-- Bundled additive functors. -/
@[derive category, nolint has_nonempty_instance]
def AdditiveFunctor :=
full_subcategory (λ (F : C ⥤ D), F.additive)

infixr ` ⥤+ `:26 := AdditiveFunctor

instance : preadditive (C ⥤+ D) :=
preadditive.induced_category _

/-- An additive functor is in particular a functor. -/
@[derive full, derive faithful]
def AdditiveFunctor.forget : (C ⥤+ D) ⥤ (C ⥤ D) :=
full_subcategory_inclusion _

variables {C D}

/-- Turn an additive functor into an object of the category `AdditiveFunctor C D`. -/
def AdditiveFunctor.of (F : C ⥤ D) [F.additive] : C ⥤+ D :=
⟨F, infer_instance⟩

@[simp]
lemma AdditiveFunctor.of_fst (F : C ⥤ D) [F.additive] : (AdditiveFunctor.of F).1 = F :=
rfl

@[simp]
lemma AdditiveFunctor.forget_obj (F : C ⥤+ D) : (AdditiveFunctor.forget C D).obj F = F.1 :=
rfl

lemma AdditiveFunctor.forget_obj_of (F : C ⥤ D) [F.additive] :
  (AdditiveFunctor.forget C D).obj (AdditiveFunctor.of F) = F :=
rfl

@[simp]
lemma AdditiveFunctor.forget_map (F G : C ⥤+ D) (α : F ⟶ G) :
  (AdditiveFunctor.forget C D).map α = α :=
rfl

instance : functor.additive (AdditiveFunctor.forget C D) :=
{ map_add' := λ F G α β, rfl }

instance (F : C ⥤+ D) : functor.additive F.1 :=
F.2

end

section exact
open category_theory.limits

variables (C : Type u₁) (D : Type u₂) [category.{v₁} C] [category.{v₂} D] [preadditive C]
variables [preadditive D] [has_zero_object C] [has_zero_object D] [has_binary_biproducts C]

section
local attribute [instance] preserves_binary_biproducts_of_preserves_binary_products
local attribute [instance] preserves_binary_biproducts_of_preserves_binary_coproducts

/-- Turn a left exact functor into an additive functor. -/
@[derive full, derive faithful]
def AdditiveFunctor.of_left_exact : (C ⥤ₗ D) ⥤ (C ⥤+ D) :=
full_subcategory.map (λ F h, let hF := classical.choice h in
    by exactI functor.additive_of_preserves_binary_biproducts F)

/-- Turn a right exact functor into an additive functor. -/
@[derive full, derive faithful]
def AdditiveFunctor.of_right_exact : (C ⥤ᵣ D) ⥤ (C ⥤+ D) :=
full_subcategory.map (λ F h, let hF := classical.choice h in
  by exactI functor.additive_of_preserves_binary_biproducts F)

/-- Turn an exact functor into an additive functor. -/
@[derive full, derive faithful]
def AdditiveFunctor.of_exact : (C ⥤ₑ D) ⥤ (C ⥤+ D) :=
full_subcategory.map (λ F h, let hF := classical.choice h.1 in
  by exactI functor.additive_of_preserves_binary_biproducts F)

end

variables {C D}

@[simp] lemma AdditiveFunctor.of_left_exact_obj_fst (F : C ⥤ₗ D) :
  ((AdditiveFunctor.of_left_exact C D).obj F).obj = F.obj := rfl
@[simp] lemma AdditiveFunctor.of_right_exact_obj_fst (F : C ⥤ᵣ D) :
  ((AdditiveFunctor.of_right_exact C D).obj F).obj = F.obj := rfl
@[simp] lemma AdditiveFunctor.of_exact_obj_fst (F : C ⥤ₑ D) :
  ((AdditiveFunctor.of_exact C D).obj F).obj = F.obj := rfl

@[simp] lemma Additive_Functor.of_left_exact_map {F G : C ⥤ₗ D} (α : F ⟶ G) :
  (AdditiveFunctor.of_left_exact C D).map α = α := rfl
@[simp] lemma Additive_Functor.of_right_exact_map {F G : C ⥤ᵣ D} (α : F ⟶ G) :
  (AdditiveFunctor.of_right_exact C D).map α = α := rfl
@[simp] lemma Additive_Functor.of_exact_map {F G : C ⥤ₑ D} (α : F ⟶ G) :
  (AdditiveFunctor.of_exact C D).map α = α := rfl

end exact

end preadditive

end category_theory


import Std.Classes.BEq

namespace MWE_eq1

example [BEq α] [LawfulBEq α] {x y : α} (h : ¬(x = y))
  : (match x == y with | true => 0 | false => 1) = 1 := by
  have : (x == y) = false := by simp [beq_eq_false_iff_ne, h]
  simp [this]

end MWE_eq1


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import category_theory.adjunction.reflective
import category_theory.monad.algebra

namespace category_theory
open category

universes v₁ v₂ u₁ u₂ -- morphism levels before object levels. See note [category_theory universes].

variables {C : Type u₁} [category.{v₁} C] {D : Type u₂} [category.{v₂} D]
variables {L : C ⥤ D} {R : D ⥤ C}

namespace adjunction

/--
For a pair of functors `L : C ⥤ D`, `R : D ⥤ C`, an adjunction `h : L ⊣ R` induces a monad on
the category `C`.
-/
@[simps]
def to_monad (h : L ⊣ R) : monad C :=
{ to_functor := L ⋙ R,
  η' := h.unit,
  μ' := whisker_right (whisker_left L h.counit) R,
  assoc' := λ X, by { dsimp, rw [←R.map_comp], simp },
  right_unit' := λ X, by { dsimp, rw [←R.map_comp], simp } }

/--
For a pair of functors `L : C ⥤ D`, `R : D ⥤ C`, an adjunction `h : L ⊣ R` induces a comonad on
the category `D`.
-/
@[simps]
def to_comonad (h : L ⊣ R) : comonad D :=
{ to_functor := R ⋙ L,
  ε' := h.counit,
  δ' := whisker_right (whisker_left R h.unit) L,
  coassoc' := λ X, by { dsimp, rw ← L.map_comp, simp },
  right_counit' := λ X, by { dsimp, rw ← L.map_comp, simp } }

/-- The monad induced by the Eilenberg-Moore adjunction is the original monad.  -/
@[simps]
def adj_to_monad_iso (T : monad C) : T.adj.to_monad ≅ T :=
monad_iso.mk (nat_iso.of_components (λ X, iso.refl _) (by tidy))
  (λ X, by { dsimp, simp })
  (λ X, by { dsimp, simp })

/-- The comonad induced by the Eilenberg-Moore adjunction is the original comonad. -/
@[simps]
def adj_to_comonad_iso (G : comonad C) : G.adj.to_comonad ≅ G :=
comonad_iso.mk (nat_iso.of_components (λ X, iso.refl _) (by tidy))
  (λ X, by { dsimp, simp })
  (λ X, by { dsimp, simp })

end adjunction

/--
Gven any adjunction `L ⊣ R`, there is a comparison functor `category_theory.monad.comparison R`
sending objects `Y : D` to Eilenberg-Moore algebras for `L ⋙ R` with underlying object `R.obj X`.

We later show that this is full when `R` is full, faithful when `R` is faithful,
and essentially surjective when `R` is reflective.
-/
@[simps]
def monad.comparison (h : L ⊣ R) : D ⥤ h.to_monad.algebra :=
{ obj := λ X,
  { A := R.obj X,
    a := R.map (h.counit.app X),
    assoc' := by { dsimp, rw [← R.map_comp, ← adjunction.counit_naturality, R.map_comp], refl } },
  map := λ X Y f,
  { f := R.map f,
    h' := by { dsimp, rw [← R.map_comp, adjunction.counit_naturality, R.map_comp] } } }.

/--
The underlying object of `(monad.comparison R).obj X` is just `R.obj X`.
-/
@[simps]
def monad.comparison_forget (h : L ⊣ R) :
  monad.comparison h ⋙ h.to_monad.forget ≅ R :=
{ hom := { app := λ X, 𝟙 _, },
  inv := { app := λ X, 𝟙 _, } }

lemma monad.left_comparison (h : L ⊣ R) : L ⋙ monad.comparison h = h.to_monad.free := rfl

instance [faithful R] (h : L ⊣ R) :
  faithful (monad.comparison h) :=
{ map_injective' := λ X Y f g w, R.map_injective (congr_arg monad.algebra.hom.f w : _) }

instance (T : monad C) : full (monad.comparison T.adj) :=
{ preimage := λ X Y f, ⟨f.f, by simpa using f.h⟩ }

instance (T : monad C) : ess_surj (monad.comparison T.adj) :=
{ mem_ess_image := λ X,
  ⟨{ A := X.A, a := X.a, unit' := by simpa using X.unit, assoc' := by simpa using X.assoc },
    ⟨monad.algebra.iso_mk (iso.refl _) (by simp)⟩⟩ }

/--
Gven any adjunction `L ⊣ R`, there is a comparison functor `category_theory.comonad.comparison L`
sending objects `X : C` to Eilenberg-Moore coalgebras for `L ⋙ R` with underlying object
`L.obj X`.
-/
@[simps]
def comonad.comparison (h : L ⊣ R) : C ⥤ h.to_comonad.coalgebra :=
{ obj := λ X,
  { A := L.obj X,
    a := L.map (h.unit.app X),
    coassoc' := by { dsimp, rw [← L.map_comp, ← adjunction.unit_naturality, L.map_comp], refl } },
  map := λ X Y f,
  { f := L.map f,
    h' := by { dsimp, rw ← L.map_comp, simp } } }

/--
The underlying object of `(comonad.comparison L).obj X` is just `L.obj X`.
-/
@[simps]
def comonad.comparison_forget {L : C ⥤ D} {R : D ⥤ C} (h : L ⊣ R) :
  comonad.comparison h ⋙ h.to_comonad.forget ≅ L :=
{ hom := { app := λ X, 𝟙 _, },
  inv := { app := λ X, 𝟙 _, } }

lemma comonad.left_comparison (h : L ⊣ R) : R ⋙ comonad.comparison h = h.to_comonad.cofree := rfl

instance comonad.comparison_faithful_of_faithful [faithful L] (h : L ⊣ R) :
  faithful (comonad.comparison h) :=
{ map_injective' := λ X Y f g w, L.map_injective (congr_arg comonad.coalgebra.hom.f w : _) }

instance (G : comonad C) : full (comonad.comparison G.adj) :=
{ preimage := λ X Y f, ⟨f.f, by simpa using f.h⟩ }

instance (G : comonad C) : ess_surj (comonad.comparison G.adj) :=
{ mem_ess_image := λ X,
  ⟨{ A := X.A, a := X.a, counit' := by simpa using X.counit, coassoc' := by simpa using X.coassoc },
    ⟨comonad.coalgebra.iso_mk (iso.refl _) (by simp)⟩⟩ }

/--
A right adjoint functor `R : D ⥤ C` is *monadic* if the comparison functor `monad.comparison R`
from `D` to the category of Eilenberg-Moore algebras for the adjunction is an equivalence.
-/
class monadic_right_adjoint (R : D ⥤ C) extends is_right_adjoint R :=
(eqv : is_equivalence (monad.comparison (adjunction.of_right_adjoint R)))

/--
A left adjoint functor `L : C ⥤ D` is *comonadic* if the comparison functor `comonad.comparison L`
from `C` to the category of Eilenberg-Moore algebras for the adjunction is an equivalence.
-/
class comonadic_left_adjoint (L : C ⥤ D) extends is_left_adjoint L :=
(eqv : is_equivalence (comonad.comparison (adjunction.of_left_adjoint L)))

noncomputable instance (T : monad C) : monadic_right_adjoint T.forget :=
⟨(equivalence.of_fully_faithfully_ess_surj _ : is_equivalence (monad.comparison T.adj))⟩

noncomputable instance (G : comonad C) : comonadic_left_adjoint G.forget :=
⟨(equivalence.of_fully_faithfully_ess_surj _ : is_equivalence (comonad.comparison G.adj))⟩

-- TODO: This holds more generally for idempotent adjunctions, not just reflective adjunctions.
instance μ_iso_of_reflective [reflective R] : is_iso (adjunction.of_right_adjoint R).to_monad.μ :=
by { dsimp, apply_instance }

attribute [instance] monadic_right_adjoint.eqv
attribute [instance] comonadic_left_adjoint.eqv

namespace reflective

instance [reflective R] (X : (adjunction.of_right_adjoint R).to_monad.algebra) :
  is_iso ((adjunction.of_right_adjoint R).unit.app X.A) :=
⟨⟨X.a, ⟨X.unit, begin
    dsimp only [functor.id_obj],
    rw ← (adjunction.of_right_adjoint R).unit_naturality,
    dsimp only [functor.comp_obj, adjunction.to_monad_coe],
    rw [unit_obj_eq_map_unit, ←functor.map_comp, ←functor.map_comp],
    erw X.unit,
    simp,
  end⟩⟩⟩

instance comparison_ess_surj [reflective R] :
  ess_surj (monad.comparison (adjunction.of_right_adjoint R)) :=
begin
  refine ⟨λ X, ⟨(left_adjoint R).obj X.A, ⟨_⟩⟩⟩,
  symmetry,
  refine monad.algebra.iso_mk _ _,
  { exact as_iso ((adjunction.of_right_adjoint R).unit.app X.A) },
  dsimp only [functor.comp_map, monad.comparison_obj_a, as_iso_hom, functor.comp_obj,
    monad.comparison_obj_A, monad_to_functor_eq_coe, adjunction.to_monad_coe],
  rw [←cancel_epi ((adjunction.of_right_adjoint R).unit.app X.A), adjunction.unit_naturality_assoc,
      adjunction.right_triangle_components, comp_id],
  apply (X.unit_assoc _).symm,
end

instance comparison_full [full R] [is_right_adjoint R] :
  full (monad.comparison (adjunction.of_right_adjoint R)) :=
{ preimage := λ X Y f, R.preimage f.f }

end reflective

-- It is possible to do this computably since the construction gives the data of the inverse, not
-- just the existence of an inverse on each object.
/-- Any reflective inclusion has a monadic right adjoint.
    cf Prop 5.3.3 of [Riehl][riehl2017] -/
@[priority 100] -- see Note [lower instance priority]
noncomputable instance monadic_of_reflective [reflective R] : monadic_right_adjoint R :=
{ eqv := equivalence.of_fully_faithfully_ess_surj _ }

end category_theory


/-
Copyright (c) 2022 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import category_theory.epi_mono
import category_theory.limits.shapes.strong_epi
import category_theory.lifting_properties.adjunction

/-!
# Preservation and reflection of monomorphisms and epimorphisms

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

We provide typeclasses that state that a functor preserves or reflects monomorphisms or
epimorphisms.
-/

open category_theory

universes v₁ v₂ v₃ u₁ u₂ u₃

namespace category_theory.functor
variables {C : Type u₁} [category.{v₁} C] {D : Type u₂} [category.{v₂} D]
  {E : Type u₃} [category.{v₃} E]

/-- A functor preserves monomorphisms if it maps monomorphisms to monomorphisms. -/
class preserves_monomorphisms (F : C ⥤ D) : Prop :=
(preserves : ∀ {X Y : C} (f : X ⟶ Y) [mono f], mono (F.map f))

instance map_mono (F : C ⥤ D) [preserves_monomorphisms F] {X Y : C} (f : X ⟶ Y) [mono f] :
  mono (F.map f) :=
preserves_monomorphisms.preserves f

/-- A functor preserves epimorphisms if it maps epimorphisms to epimorphisms. -/
class preserves_epimorphisms (F : C ⥤ D) : Prop :=
(preserves : ∀ {X Y : C} (f : X ⟶ Y) [epi f], epi (F.map f))

instance map_epi (F : C ⥤ D) [preserves_epimorphisms F] {X Y : C} (f : X ⟶ Y) [epi f] :
  epi (F.map f) :=
preserves_epimorphisms.preserves f

/-- A functor reflects monomorphisms if morphisms that are mapped to monomorphisms are themselves
    monomorphisms. -/
class reflects_monomorphisms (F : C ⥤ D) : Prop :=
(reflects : ∀ {X Y : C} (f : X ⟶ Y), mono (F.map f) → mono f)

lemma mono_of_mono_map (F : C ⥤ D) [reflects_monomorphisms F] {X Y : C} {f : X ⟶ Y}
  (h : mono (F.map f)) : mono f :=
reflects_monomorphisms.reflects f h

/-- A functor reflects epimorphisms if morphisms that are mapped to epimorphisms are themselves
    epimorphisms. -/
class reflects_epimorphisms (F : C ⥤ D) : Prop :=
(reflects : ∀ {X Y : C} (f : X ⟶ Y), epi (F.map f) → epi f)

lemma epi_of_epi_map (F : C ⥤ D) [reflects_epimorphisms F] {X Y : C} {f : X ⟶ Y}
  (h : epi (F.map f)) : epi f :=
reflects_epimorphisms.reflects f h

instance preserves_monomorphisms_comp (F : C ⥤ D) (G : D ⥤ E) [preserves_monomorphisms F]
  [preserves_monomorphisms G] : preserves_monomorphisms (F ⋙ G) :=
{ preserves := λ X Y f h, by { rw comp_map, exactI infer_instance } }

instance preserves_epimorphisms_comp (F : C ⥤ D) (G : D ⥤ E) [preserves_epimorphisms F]
  [preserves_epimorphisms G] : preserves_epimorphisms (F ⋙ G) :=
{ preserves := λ X Y f h, by { rw comp_map, exactI infer_instance } }

instance reflects_monomorphisms_comp (F : C ⥤ D) (G : D ⥤ E) [reflects_monomorphisms F]
  [reflects_monomorphisms G] : reflects_monomorphisms (F ⋙ G) :=
{ reflects := λ X Y f h, (F.mono_of_mono_map (G.mono_of_mono_map h)) }

instance reflects_epimorphisms_comp (F : C ⥤ D) (G : D ⥤ E) [reflects_epimorphisms F]
  [reflects_epimorphisms G] : reflects_epimorphisms (F ⋙ G) :=
{ reflects := λ X Y f h, (F.epi_of_epi_map (G.epi_of_epi_map h)) }

lemma preserves_epimorphisms_of_preserves_of_reflects (F : C ⥤ D) (G : D ⥤ E)
  [preserves_epimorphisms (F ⋙ G)] [reflects_epimorphisms G] : preserves_epimorphisms F :=
⟨λ X Y f hf, G.epi_of_epi_map $ show epi ((F ⋙ G).map f), by exactI infer_instance⟩

lemma preserves_monomorphisms_of_preserves_of_reflects (F : C ⥤ D) (G : D ⥤ E)
  [preserves_monomorphisms (F ⋙ G)] [reflects_monomorphisms G] : preserves_monomorphisms F :=
⟨λ X Y f hf, G.mono_of_mono_map $ show mono ((F ⋙ G).map f), by exactI infer_instance⟩

lemma reflects_epimorphisms_of_preserves_of_reflects (F : C ⥤ D) (G : D ⥤ E)
  [preserves_epimorphisms G] [reflects_epimorphisms (F ⋙ G)] : reflects_epimorphisms F :=
⟨λ X Y f hf, (F ⋙ G).epi_of_epi_map $ show epi (G.map (F.map f)), by exactI infer_instance⟩

lemma reflects_monomorphisms_of_preserves_of_reflects (F : C ⥤ D) (G : D ⥤ E)
  [preserves_monomorphisms G] [reflects_monomorphisms (F ⋙ G)] : reflects_monomorphisms F :=
⟨λ X Y f hf, (F ⋙ G).mono_of_mono_map $ show mono (G.map (F.map f)), by exactI infer_instance⟩

lemma preserves_monomorphisms.of_iso {F G : C ⥤ D} [preserves_monomorphisms F] (α : F ≅ G) :
  preserves_monomorphisms G :=
{ preserves := λ X Y f h,
  begin
    haveI : mono (F.map f ≫ (α.app Y).hom) := by exactI mono_comp _ _,
    convert (mono_comp _ _ : mono ((α.app X).inv ≫ F.map f ≫ (α.app Y).hom)),
    rw [iso.eq_inv_comp, iso.app_hom, iso.app_hom, nat_trans.naturality]
  end }

lemma preserves_monomorphisms.iso_iff {F G : C ⥤ D} (α : F ≅ G) :
  preserves_monomorphisms F ↔ preserves_monomorphisms G :=
⟨λ h, by exactI preserves_monomorphisms.of_iso α,
 λ h, by exactI preserves_monomorphisms.of_iso α.symm⟩

lemma preserves_epimorphisms.of_iso {F G : C ⥤ D} [preserves_epimorphisms F] (α : F ≅ G) :
  preserves_epimorphisms G :=
{ preserves := λ X Y f h,
  begin
    haveI : epi (F.map f ≫ (α.app Y).hom) := by exactI epi_comp _ _,
    convert (epi_comp _ _ : epi ((α.app X).inv ≫ F.map f ≫ (α.app Y).hom)),
    rw [iso.eq_inv_comp, iso.app_hom, iso.app_hom, nat_trans.naturality]
  end }

lemma preserves_epimorphisms.iso_iff {F G : C ⥤ D} (α : F ≅ G) :
  preserves_epimorphisms F ↔ preserves_epimorphisms G :=
⟨λ h, by exactI preserves_epimorphisms.of_iso α,
 λ h, by exactI preserves_epimorphisms.of_iso α.symm⟩

lemma reflects_monomorphisms.of_iso {F G : C ⥤ D} [reflects_monomorphisms F] (α : F ≅ G) :
  reflects_monomorphisms G :=
{ reflects := λ X Y f h,
  begin
    apply F.mono_of_mono_map,
    haveI : mono (G.map f ≫ (α.app Y).inv) := by exactI mono_comp _ _,
    convert (mono_comp _ _ : mono ((α.app X).hom ≫ G.map f ≫ (α.app Y).inv)),
    rw [← category.assoc, iso.eq_comp_inv, iso.app_hom, iso.app_hom, nat_trans.naturality]
  end }

lemma reflects_monomorphisms.iso_iff {F G : C ⥤ D} (α : F ≅ G) :
  reflects_monomorphisms F ↔ reflects_monomorphisms G :=
⟨λ h, by exactI reflects_monomorphisms.of_iso α,
 λ h, by exactI reflects_monomorphisms.of_iso α.symm⟩

lemma reflects_epimorphisms.of_iso {F G : C ⥤ D} [reflects_epimorphisms F] (α : F ≅ G) :
  reflects_epimorphisms G :=
{ reflects := λ X Y f h,
  begin
    apply F.epi_of_epi_map,
    haveI : epi (G.map f ≫ (α.app Y).inv) := by exactI epi_comp _ _,
    convert (epi_comp _ _ : epi ((α.app X).hom ≫ G.map f ≫ (α.app Y).inv)),
    rw [← category.assoc, iso.eq_comp_inv, iso.app_hom, iso.app_hom, nat_trans.naturality]
  end }

lemma reflects_epimorphisms.iso_iff {F G : C ⥤ D} (α : F ≅ G) :
  reflects_epimorphisms F ↔ reflects_epimorphisms G :=
⟨λ h, by exactI reflects_epimorphisms.of_iso α, λ h, by exactI reflects_epimorphisms.of_iso α.symm⟩

lemma preserves_epimorphsisms_of_adjunction {F : C ⥤ D} {G : D ⥤ C} (adj : F ⊣ G) :
 preserves_epimorphisms F :=
{ preserves := λ X Y f hf,
  ⟨begin
    introsI Z g h H,
    replace H := congr_arg (adj.hom_equiv X Z) H,
    rwa [adj.hom_equiv_naturality_left, adj.hom_equiv_naturality_left, cancel_epi,
      equiv.apply_eq_iff_eq] at H
  end⟩ }

@[priority 100]
instance preserves_epimorphisms_of_is_left_adjoint (F : C ⥤ D) [is_left_adjoint F] :
  preserves_epimorphisms F :=
preserves_epimorphsisms_of_adjunction (adjunction.of_left_adjoint F)

@[priority 100]
instance preserves_monomorphisms_of_is_right_adjoint (F : C ⥤ D) [is_right_adjoint F] :
  preserves_monomorphisms F :=
preserves_monomorphisms_of_adjunction (adjunction.of_right_adjoint F)

@[priority 100]
instance reflects_monomorphisms_of_faithful (F : C ⥤ D) [faithful F] : reflects_monomorphisms F :=
{ reflects := λ X Y f hf, ⟨λ Z g h hgh, by exactI F.map_injective ((cancel_mono (F.map f)).1
    (by rw [← F.map_comp, hgh, F.map_comp]))⟩ }

@[priority 100]
instance reflects_epimorphisms_of_faithful (F : C ⥤ D) [faithful F] : reflects_epimorphisms F :=
{ reflects := λ X Y f hf, ⟨λ Z g h hgh, by exactI F.map_injective ((cancel_epi (F.map f)).1
    (by rw [← F.map_comp, hgh, F.map_comp]))⟩ }

section

variables (F : C ⥤ D) {X Y : C} (f : X ⟶ Y)

/-- If `F` is a fully faithful functor, split epimorphisms are preserved and reflected by `F`. -/
def split_epi_equiv [full F] [faithful F] : split_epi f ≃ split_epi (F.map f) :=
{ to_fun := λ f, f.map F,
  inv_fun := λ s, begin
    refine ⟨F.preimage s.section_, _⟩,
    apply F.map_injective,
    simp only [map_comp, image_preimage, map_id],
    apply split_epi.id,
  end,
  left_inv := by tidy,
  right_inv := by tidy, }

@[simp]
lemma is_split_epi_iff [full F] [faithful F] : is_split_epi (F.map f) ↔ is_split_epi f :=
begin
  split,
  { intro h, exact is_split_epi.mk' ((split_epi_equiv F f).inv_fun h.exists_split_epi.some), },
  { intro h, exact is_split_epi.mk' ((split_epi_equiv F f).to_fun h.exists_split_epi.some), },
end

/-- If `F` is a fully faithful functor, split monomorphisms are preserved and reflected by `F`. -/
def split_mono_equiv [full F] [faithful F] : split_mono f ≃ split_mono (F.map f) :=
{ to_fun := λ f, f.map F,
  inv_fun := λ s, begin
    refine ⟨F.preimage s.retraction, _⟩,
    apply F.map_injective,
    simp only [map_comp, image_preimage, map_id],
    apply split_mono.id,
  end,
  left_inv := by tidy,
  right_inv := by tidy, }

@[simp]
lemma is_split_mono_iff [full F] [faithful F] : is_split_mono (F.map f) ↔ is_split_mono f :=
begin
  split,
  { intro h, exact is_split_mono.mk' ((split_mono_equiv F f).inv_fun h.exists_split_mono.some), },
  { intro h, exact is_split_mono.mk' ((split_mono_equiv F f).to_fun h.exists_split_mono.some), },
end

@[simp]
lemma epi_map_iff_epi [hF₁ : preserves_epimorphisms F] [hF₂ : reflects_epimorphisms F] :
  epi (F.map f) ↔ epi f :=
begin
  split,
  { exact F.epi_of_epi_map, },
  { introI h,
    exact F.map_epi f, },
end

@[simp]
lemma mono_map_iff_mono [hF₁ : preserves_monomorphisms F] [hF₂ : reflects_monomorphisms F] :
  mono (F.map f) ↔ mono f :=
begin
  split,
  { exact F.mono_of_mono_map, },
  { introI h,
    exact F.map_mono f, },
end

/-- If `F : C ⥤ D` is an equivalence of categories and `C` is a `split_epi_category`,
then `D` also is. -/
def split_epi_category_imp_of_is_equivalence [is_equivalence F] [split_epi_category C] :
  split_epi_category D :=
⟨λ X Y f, begin
  introI,
  rw ← F.inv.is_split_epi_iff f,
  apply is_split_epi_of_epi,
end⟩

end

end category_theory.functor

namespace category_theory.adjunction

variables {C D : Type*} [category C] [category D] {F : C ⥤ D} {F' : D ⥤ C} {A B : C}

lemma strong_epi_map_of_strong_epi (adj : F ⊣ F') (f : A ⟶ B)
  [h₁ : F'.preserves_monomorphisms] [h₂ : F.preserves_epimorphisms] [strong_epi f] :
  strong_epi (F.map f) :=
⟨infer_instance, λ X Y Z, by { introI, rw adj.has_lifting_property_iff, apply_instance, }⟩

instance strong_epi_map_of_is_equivalence [is_equivalence F] (f : A ⟶ B) [h : strong_epi f] :
  strong_epi (F.map f) :=
F.as_equivalence.to_adjunction.strong_epi_map_of_strong_epi f

end category_theory.adjunction

namespace category_theory.functor

variables {C D : Type*} [category C] [category D] {F : C ⥤ D} {A B : C} (f : A ⟶ B)

@[simp]
lemma strong_epi_map_iff_strong_epi_of_is_equivalence [is_equivalence F] :
  strong_epi (F.map f) ↔ strong_epi f  :=
begin
  split,
  { introI,
    have e : arrow.mk f ≅ arrow.mk (F.inv.map (F.map f)) :=
      arrow.iso_of_nat_iso F.as_equivalence.unit_iso (arrow.mk f),
    rw strong_epi.iff_of_arrow_iso e,
    apply_instance, },
  { introI,
    apply_instance, },
end

end category_theory.functor


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

/-!
# Presheafed spaces

Introduces the category of topological spaces equipped with a presheaf (taking values in an
arbitrary target category `C`.)

We further describe how to apply functors and natural transformations to the values of the
presheaves.
-/

universes v u

open category_theory
open Top
open topological_space
open opposite
open category_theory.category category_theory.functor

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

local attribute [tidy] tactic.op_induction'

namespace algebraic_geometry

/-- A `PresheafedSpace C` is a topological space equipped with a presheaf of `C`s. -/
structure PresheafedSpace :=
(carrier : Top)
(presheaf : carrier.presheaf C)

variables {C}

namespace PresheafedSpace

attribute [protected] presheaf

instance coe_carrier : has_coe (PresheafedSpace C) Top :=
{ coe := λ X, X.carrier }

@[simp] lemma as_coe (X : PresheafedSpace C) : X.carrier = (X : Top.{v}) := rfl
@[simp] lemma mk_coe (carrier) (presheaf) : (({ carrier := carrier, presheaf := presheaf } :
  PresheafedSpace.{v} C) : Top.{v}) = carrier := rfl

instance (X : PresheafedSpace.{v} C) : topological_space X := X.carrier.str

/-- The constant presheaf on `X` with value `Z`. -/
def const (X : Top) (Z : C) : PresheafedSpace C :=
{ carrier := X,
  presheaf :=
  { obj := λ U, Z,
    map := λ U V f, 𝟙 Z, } }

instance [inhabited C] : inhabited (PresheafedSpace C) := ⟨const (Top.of pempty) (default C)⟩

/-- A morphism between presheafed spaces `X` and `Y` consists of a continuous map
    `f` between the underlying topological spaces, and a (notice contravariant!) map
    from the presheaf on `Y` to the pushforward of the presheaf on `X` via `f`. -/
structure hom (X Y : PresheafedSpace C) :=
(base : (X : Top.{v}) ⟶ (Y : Top.{v}))
(c : Y.presheaf ⟶ base _* X.presheaf)

@[ext] lemma ext {X Y : PresheafedSpace C} (α β : hom X Y)
  (w : α.base = β.base)
  (h : α.c ≫ (whisker_right (nat_trans.op (opens.map_iso _ _ w).inv) X.presheaf) = β.c) :
  α = β :=
begin
  cases α, cases β,
  dsimp [presheaf.pushforward_obj] at *,
  tidy, -- TODO including `injections` would make tidy work earlier.
end
.

/-- The identity morphism of a `PresheafedSpace`. -/
def id (X : PresheafedSpace C) : hom X X :=
{ base := 𝟙 (X : Top.{v}),
  c := (functor.left_unitor _).inv ≫ whisker_right (nat_trans.op (opens.map_id X.carrier).hom) _ }

instance hom_inhabited (X : PresheafedSpace C) : inhabited (hom X X) := ⟨id X⟩

/-- Composition of morphisms of `PresheafedSpace`s. -/
def comp {X Y Z : PresheafedSpace C} (α : hom X Y) (β : hom Y Z) : hom X Z :=
{ base := α.base ≫ β.base,
  c := β.c ≫ (whisker_left (opens.map β.base).op α.c) ≫ (Top.presheaf.pushforward.comp _ _ _).inv }

variables (C)

section
local attribute [simp] id comp

/- The proofs below can be done by `tidy`, but it is too slow,
   and we don't have a tactic caching mechanism. -/
/-- The category of PresheafedSpaces. Morphisms are pairs, a continuous map and a presheaf map
    from the presheaf on the target to the pushforward of the presheaf on the source. -/
instance category_of_PresheafedSpaces : category (PresheafedSpace C) :=
{ hom := hom,
  id := id,
  comp := λ X Y Z f g, comp f g,
  id_comp' := λ X Y f,
  begin
    ext1, swap,
    { dsimp, simp only [id_comp] },  -- See note [dsimp, simp].
    { ext U, op_induction, cases U,
      dsimp,
      simp only [presheaf.pushforward.comp_inv_app, opens.map_iso_inv_app],
      dsimp,
      simp only [comp_id, comp_id, map_id], },
  end,
  comp_id' := λ X Y f,
  begin
    ext1, swap,
    { dsimp, simp only [comp_id] },
    { ext U, op_induction, cases U,
      dsimp,
      simp only [presheaf.pushforward.comp_inv_app, opens.map_iso_inv_app],
      dsimp,
      simp only [id_comp, comp_id, map_id], }
  end,
  assoc' := λ W X Y Z f g h,
  begin
     ext1, swap,
     refl,
     { ext U, op_induction, cases U,
       dsimp,
       simp only [assoc, presheaf.pushforward.comp_inv_app, opens.map_iso_inv_app],
       dsimp,
       simp only [comp_id, id_comp, map_id], }
  end }

end

variables {C}

@[simp] lemma id_base (X : PresheafedSpace C) :
  ((𝟙 X) : X ⟶ X).base = (𝟙 (X : Top.{v})) := rfl

lemma id_c (X : PresheafedSpace C) :
  ((𝟙 X) : X ⟶ X).c =
  (functor.left_unitor _).inv ≫ whisker_right (nat_trans.op (opens.map_id X.carrier).hom) _ := rfl

@[simp] lemma id_c_app (X : PresheafedSpace C) (U) :
  ((𝟙 X) : X ⟶ X).c.app U = eq_to_hom (by { op_induction U, cases U, refl }) :=
by { op_induction U, cases U, simp only [id_c], dsimp, simp, }

@[simp] lemma comp_base {X Y Z : PresheafedSpace C} (f : X ⟶ Y) (g : Y ⟶ Z) :
  (f ≫ g).base = f.base ≫ g.base := rfl

@[simp] lemma comp_c_app {X Y Z : PresheafedSpace C} (α : X ⟶ Y) (β : Y ⟶ Z) (U) :
  (α ≫ β).c.app U = (β.c).app U ≫ (α.c).app (op ((opens.map (β.base)).obj (unop U))) ≫
    (Top.presheaf.pushforward.comp _ _ _).inv.app U := rfl

lemma congr_app {X Y : PresheafedSpace C} {α β : X ⟶ Y} (h : α = β) (U) :
  α.c.app U = β.c.app U ≫ X.presheaf.map (eq_to_hom (by subst h)) :=
by { subst h, dsimp, simp, }

section
variables (C)

/-- The forgetful functor from `PresheafedSpace` to `Top`. -/
@[simps]
def forget : PresheafedSpace C ⥤ Top :=
{ obj := λ X, (X : Top.{v}),
  map := λ X Y f, f.base }

end

/--
The restriction of a presheafed space along an open embedding into the space.
-/
@[simps]
def restrict {U : Top} (X : PresheafedSpace C)
  (f : U ⟶ (X : Top.{v})) (h : open_embedding f) : PresheafedSpace C :=
{ carrier := U,
  presheaf := h.is_open_map.functor.op ⋙ X.presheaf }

/--
The map from the restriction of a presheafed space.
-/
@[simps]
def of_restrict (U : Top) (X : PresheafedSpace C)
  (f : U ⟶ (X : Top.{v})) (h : open_embedding f) :
  X.restrict f h ⟶ X :=
{ base := f,
  c := { app := λ V, X.presheaf.map $
      ((h.is_open_map.adjunction.hom_equiv _ _).symm (𝟙 $ (opens.map f).obj $ unop V)).op,
    naturality':= λ U V f, show _ = _ ≫ X.presheaf.map _,
      by { rw [← map_comp, ← map_comp], refl } } }

/--
The map to the restriction of a presheafed space along the canonical inclusion from the top
subspace.
-/
@[simps]
def to_restrict_top (X : PresheafedSpace C) :
  X ⟶ X.restrict (opens.inclusion ⊤) (opens.open_embedding ⊤) :=
{ base := ⟨λ x, ⟨x, trivial⟩, continuous_def.2 $ λ U ⟨S, hS, hSU⟩, hSU ▸ hS⟩,
  c := { app := λ U, X.presheaf.map $ (hom_of_le $ λ x hxU, ⟨⟨x, trivial⟩, hxU, rfl⟩ :
      (opens.map (⟨λ x, ⟨x, trivial⟩, continuous_def.2 $ λ U ⟨S, hS, hSU⟩, hSU ▸ hS⟩ :
          X.1 ⟶ (opens.to_Top X.1).obj ⊤)).obj (unop U) ⟶
        (opens.open_embedding ⊤).is_open_map.functor.obj (unop U)).op,
    naturality':= λ U V f, show X.presheaf.map _ ≫ _ = _ ≫ X.presheaf.map _,
      by { rw [← map_comp, ← map_comp], refl } } }

/--
The isomorphism from the restriction to the top subspace.
-/
@[simps]
def restrict_top_iso (X : PresheafedSpace C) :
  X.restrict (opens.inclusion ⊤) (opens.open_embedding ⊤) ≅ X :=
{ hom := X.of_restrict _ _ _,
  inv := X.to_restrict_top,
  hom_inv_id' := ext _ _ (concrete_category.hom_ext _ _ $ λ ⟨x, _⟩, rfl) $
    nat_trans.ext _ _ $ funext $ λ U, by { op_induction U,
      dsimp only [nat_trans.comp_app, comp_c_app, to_restrict_top, of_restrict,
          whisker_right_app, comp_base, nat_trans.op_app, opens.map_iso_inv_app],
      erw [presheaf.pushforward.comp_inv_app, comp_id, ← X.presheaf.map_comp,
          ← X.presheaf.map_comp, id_c_app],
      exact X.presheaf.map_id _ },
  inv_hom_id' := ext _ _ rfl $ nat_trans.ext _ _ $ funext $ λ U, by { op_induction U,
    dsimp only [nat_trans.comp_app, comp_c_app, of_restrict, to_restrict_top,
        whisker_right_app, comp_base, nat_trans.op_app, opens.map_iso_inv_app],
    erw [← X.presheaf.map_comp, ← X.presheaf.map_comp, ← X.presheaf.map_comp, id_c_app],
    convert eq_to_hom_map X.presheaf _,
    erw [op_obj, id_base, opens.map_id_obj], refl } }

/--
The global sections, notated Gamma.
-/
@[simps]
def Γ : (PresheafedSpace C)ᵒᵖ ⥤ C :=
{ obj := λ X, (unop X).presheaf.obj (op ⊤),
  map := λ X Y f, f.unop.c.app (op ⊤) ≫ (unop Y).presheaf.map (opens.le_map_top _ _).op,
  map_id' := λ X, begin
    op_induction X,
    erw [unop_id_op, id_c_app, eq_to_hom_refl, id_comp],
    exact X.presheaf.map_id _
  end,
  map_comp' := λ X Y Z f g, begin
    rw [unop_comp, comp_c_app],
    simp_rw category.assoc,
    erw [nat_trans.naturality_assoc, presheaf.pushforward.comp_inv_app, id_comp,
        category_theory.functor.comp_map, ← map_comp],
    refl
  end }

lemma Γ_obj_op (X : PresheafedSpace C) : Γ.obj (op X) = X.presheaf.obj (op ⊤) := rfl

lemma Γ_map_op {X Y : PresheafedSpace C} (f : X ⟶ Y) :
  Γ.map f.op = f.c.app (op ⊤) ≫ X.presheaf.map (opens.le_map_top _ _).op := rfl

end PresheafedSpace

end algebraic_geometry

open algebraic_geometry algebraic_geometry.PresheafedSpace

variables {C}

namespace category_theory

variables {D : Type u} [category.{v} D]

local attribute [simp] presheaf.pushforward_obj

namespace functor

/-- We can apply a functor `F : C ⥤ D` to the values of the presheaf in any `PresheafedSpace C`,
    giving a functor `PresheafedSpace C ⥤ PresheafedSpace D` -/
def map_presheaf (F : C ⥤ D) : PresheafedSpace C ⥤ PresheafedSpace D :=
{ obj := λ X, { carrier := X.carrier, presheaf := X.presheaf ⋙ F },
  map := λ X Y f, { base := f.base, c := whisker_right f.c F }, }

@[simp] lemma map_presheaf_obj_X (F : C ⥤ D) (X : PresheafedSpace C) :
  ((F.map_presheaf.obj X) : Top.{v}) = (X : Top.{v}) := rfl
@[simp] lemma map_presheaf_obj_presheaf (F : C ⥤ D) (X : PresheafedSpace C) :
  (F.map_presheaf.obj X).presheaf = X.presheaf ⋙ F := rfl
@[simp] lemma map_presheaf_map_f (F : C ⥤ D) {X Y : PresheafedSpace C} (f : X ⟶ Y) :
  (F.map_presheaf.map f).base = f.base := rfl
@[simp] lemma map_presheaf_map_c (F : C ⥤ D) {X Y : PresheafedSpace C} (f : X ⟶ Y) :
  (F.map_presheaf.map f).c = whisker_right f.c F := rfl

end functor

namespace nat_trans

/--
A natural transformation induces a natural transformation between the `map_presheaf` functors.
-/
def on_presheaf {F G : C ⥤ D} (α : F ⟶ G) : G.map_presheaf ⟶ F.map_presheaf :=
{ app := λ X,
  { base := 𝟙 _,
    c := whisker_left X.presheaf α ≫ (functor.left_unitor _).inv ≫
           whisker_right (nat_trans.op (opens.map_id X.carrier).hom) _ }, }

-- TODO Assemble the last two constructions into a functor
--   `(C ⥤ D) ⥤ (PresheafedSpace C ⥤ PresheafedSpace D)`
end nat_trans

end category_theory


example : ∀ a b c : α, a = b → b = c → a = c :=
  fun a b c h1 h2 =>
    match b, h1 with
    | _, Eq.refl a => h2

example : ∀ a b c : α, a = b → b = c → a = c :=
  fun a b c h1 h2 =>
    match h1 with
    | Eq.refl a => h2

example : ∀ a b c : α, a = b → b = c → a = c :=
  fun a b c (Eq.refl a) => fun h2 => h2

example : ∀ a b c : α, a = b → b = c → a = c :=
  fun a b c (Eq.refl a) h2 => h2


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.seq.seq
import Mathlib.Lean3Lib.data.dlist
import Mathlib.PostPort

universes u_1 u v w

namespace Mathlib

/-
coinductive wseq (α : Type u) : Type u
| nil : wseq α
| cons : α → wseq α → wseq α
| think : wseq α → wseq α
-/

/-- Weak sequences.

  While the `seq` structure allows for lists which may not be finite,
  a weak sequence also allows the computation of each element to
  involve an indeterminate amount of computation, including possibly
  an infinite loop. This is represented as a regular `seq` interspersed
  with `none` elements to indicate that computation is ongoing.

  This model is appropriate for Haskell style lazy lists, and is closed
  under most interesting computation patterns on infinite lists,
  but conversely it is difficult to extract elements from it. -/
def wseq (α : Type u_1) :=
  seq (Option α)

namespace wseq

/-- Turn a sequence into a weak sequence -/
def of_seq {α : Type u} : seq α → wseq α :=
  Functor.map some

/-- Turn a list into a weak sequence -/
def of_list {α : Type u} (l : List α) : wseq α :=
  of_seq ↑l

/-- Turn a stream into a weak sequence -/
def of_stream {α : Type u} (l : stream α) : wseq α :=
  of_seq ↑l

protected instance coe_seq {α : Type u} : has_coe (seq α) (wseq α) :=
  has_coe.mk of_seq

protected instance coe_list {α : Type u} : has_coe (List α) (wseq α) :=
  has_coe.mk of_list

protected instance coe_stream {α : Type u} : has_coe (stream α) (wseq α) :=
  has_coe.mk of_stream

/-- The empty weak sequence -/
def nil {α : Type u} : wseq α :=
  seq.nil

protected instance inhabited {α : Type u} : Inhabited (wseq α) :=
  { default := nil }

/-- Prepend an element to a weak sequence -/
def cons {α : Type u} (a : α) : wseq α → wseq α :=
  seq.cons (some a)

/-- Compute for one tick, without producing any elements -/
def think {α : Type u} : wseq α → wseq α :=
  seq.cons none

/-- Destruct a weak sequence, to (eventually possibly) produce either
  `none` for `nil` or `some (a, s)` if an element is produced. -/
def destruct {α : Type u} : wseq α → computation (Option (α × wseq α)) :=
  computation.corec fun (s : wseq α) => sorry

def cases_on {α : Type u} {C : wseq α → Sort v} (s : wseq α) (h1 : C nil) (h2 : (x : α) → (s : wseq α) → C (cons x s)) (h3 : (s : wseq α) → C (think s)) : C s :=
  seq.cases_on s h1 fun (o : Option α) => option.cases_on o h3 h2

protected def mem {α : Type u} (a : α) (s : wseq α) :=
  seq.mem (some a) s

protected instance has_mem {α : Type u} : has_mem α (wseq α) :=
  has_mem.mk wseq.mem

theorem not_mem_nil {α : Type u} (a : α) : ¬a ∈ nil :=
  seq.not_mem_nil ↑a

/-- Get the head of a weak sequence. This involves a possibly
  infinite computation. -/
def head {α : Type u} (s : wseq α) : computation (Option α) :=
  computation.map (Functor.map prod.fst) (destruct s)

/-- Encode a computation yielding a weak sequence into additional
  `think` constructors in a weak sequence -/
def flatten {α : Type u} : computation (wseq α) → wseq α :=
  seq.corec fun (c : computation (wseq α)) => sorry

/-- Get the tail of a weak sequence. This doesn't need a `computation`
  wrapper, unlike `head`, because `flatten` allows us to hide this
  in the construction of the weak sequence itself. -/
def tail {α : Type u} (s : wseq α) : wseq α :=
  flatten ((fun (o : Option (α × wseq α)) => option.rec_on o nil prod.snd) <$> destruct s)

/-- drop the first `n` elements from `s`. -/
@[simp] def drop {α : Type u} (s : wseq α) : ℕ → wseq α :=
  sorry

/-- Get the nth element of `s`. -/
def nth {α : Type u} (s : wseq α) (n : ℕ) : computation (Option α) :=
  head (drop s n)

/-- Convert `s` to a list (if it is finite and completes in finite time). -/
def to_list {α : Type u} (s : wseq α) : computation (List α) :=
  computation.corec (fun (_x : List α × wseq α) => sorry) ([], s)

/-- Get the length of `s` (if it is finite and completes in finite time). -/
def length {α : Type u} (s : wseq α) : computation ℕ :=
  computation.corec (fun (_x : ℕ × wseq α) => sorry) (0, s)

/-- A weak sequence is finite if `to_list s` terminates. Equivalently,
  it is a finite number of `think` and `cons` applied to `nil`. -/
def is_finite {α : Type u} (s : wseq α) :=
  computation.terminates (to_list s)

protected instance to_list_terminates {α : Type u} (s : wseq α) [h : is_finite s] : computation.terminates (to_list s) :=
  h

/-- Get the list corresponding to a finite weak sequence. -/
def get {α : Type u} (s : wseq α) [is_finite s] : List α :=
  computation.get (to_list s)

/-- A weak sequence is *productive* if it never stalls forever - there are
 always a finite number of `think`s between `cons` constructors.
 The sequence itself is allowed to be infinite though. -/
def productive {α : Type u} (s : wseq α) :=
  ∀ (n : ℕ), computation.terminates (nth s n)

protected instance nth_terminates {α : Type u} (s : wseq α) [h : productive s] (n : ℕ) : computation.terminates (nth s n) :=
  h

protected instance head_terminates {α : Type u} (s : wseq α) [h : productive s] : computation.terminates (head s) :=
  h 0

/-- Replace the `n`th element of `s` with `a`. -/
def update_nth {α : Type u} (s : wseq α) (n : ℕ) (a : α) : wseq α :=
  seq.corec (fun (_x : ℕ × wseq α) => sorry) (n + 1, s)

/-- Remove the `n`th element of `s`. -/
def remove_nth {α : Type u} (s : wseq α) (n : ℕ) : wseq α :=
  seq.corec (fun (_x : ℕ × wseq α) => sorry) (n + 1, s)

/-- Map the elements of `s` over `f`, removing any values that yield `none`. -/
def filter_map {α : Type u} {β : Type v} (f : α → Option β) : wseq α → wseq β :=
  seq.corec fun (s : wseq α) => sorry

/-- Select the elements of `s` that satisfy `p`. -/
def filter {α : Type u} (p : α → Prop) [decidable_pred p] : wseq α → wseq α :=
  filter_map fun (a : α) => ite (p a) (some a) none

-- example of infinite list manipulations

/-- Get the first element of `s` satisfying `p`. -/
def find {α : Type u} (p : α → Prop) [decidable_pred p] (s : wseq α) : computation (Option α) :=
  head (filter p s)

/-- Zip a function over two weak sequences -/
def zip_with {α : Type u} {β : Type v} {γ : Type w} (f : α → β → γ) (s1 : wseq α) (s2 : wseq β) : wseq γ :=
  seq.corec (fun (_x : wseq α × wseq β) => sorry) (s1, s2)

/-- Zip two weak sequences into a single sequence of pairs -/
def zip {α : Type u} {β : Type v} : wseq α → wseq β → wseq (α × β) :=
  zip_with Prod.mk

/-- Get the list of indexes of elements of `s` satisfying `p` -/
def find_indexes {α : Type u} (p : α → Prop) [decidable_pred p] (s : wseq α) : wseq ℕ :=
  filter_map (fun (_x : α × ℕ) => sorry) (zip s ↑stream.nats)

/-- Get the index of the first element of `s` satisfying `p` -/
def find_index {α : Type u} (p : α → Prop) [decidable_pred p] (s : wseq α) : computation ℕ :=
  (fun (o : Option ℕ) => option.get_or_else o 0) <$> head (find_indexes p s)

/-- Get the index of the first occurrence of `a` in `s` -/
def index_of {α : Type u} [DecidableEq α] (a : α) : wseq α → computation ℕ :=
  find_index (Eq a)

/-- Get the indexes of occurrences of `a` in `s` -/
def indexes_of {α : Type u} [DecidableEq α] (a : α) : wseq α → wseq ℕ :=
  find_indexes (Eq a)

/-- `union s1 s2` is a weak sequence which interleaves `s1` and `s2` in
  some order (nondeterministically). -/
def union {α : Type u} (s1 : wseq α) (s2 : wseq α) : wseq α :=
  seq.corec (fun (_x : wseq α × wseq α) => sorry) (s1, s2)

/-- Returns `tt` if `s` is `nil` and `ff` if `s` has an element -/
def is_empty {α : Type u} (s : wseq α) : computation Bool :=
  computation.map option.is_none (head s)

/-- Calculate one step of computation -/
def compute {α : Type u} (s : wseq α) : wseq α :=
  sorry

/-- Get the first `n` elements of a weak sequence -/
def take {α : Type u} (s : wseq α) (n : ℕ) : wseq α :=
  seq.corec (fun (_x : ℕ × wseq α) => sorry) (n, s)

/-- Split the sequence at position `n` into a finite initial segment
  and the weak sequence tail -/
def split_at {α : Type u} (s : wseq α) (n : ℕ) : computation (List α × wseq α) :=
  computation.corec (fun (_x : ℕ × List α × wseq α) => sorry) (n, [], s)

/-- Returns `tt` if any element of `s` satisfies `p` -/
def any {α : Type u} (s : wseq α) (p : α → Bool) : computation Bool :=
  computation.corec (fun (s : wseq α) => sorry) s

/-- Returns `tt` if every element of `s` satisfies `p` -/
def all {α : Type u} (s : wseq α) (p : α → Bool) : computation Bool :=
  computation.corec (fun (s : wseq α) => sorry) s

/-- Apply a function to the elements of the sequence to produce a sequence
  of partial results. (There is no `scanr` because this would require
  working from the end of the sequence, which may not exist.) -/
def scanl {α : Type u} {β : Type v} (f : α → β → α) (a : α) (s : wseq β) : wseq α :=
  cons a (seq.corec (fun (_x : α × wseq β) => sorry) (a, s))

/-- Get the weak sequence of initial segments of the input sequence -/
def inits {α : Type u} (s : wseq α) : wseq (List α) :=
  cons [] (seq.corec (fun (_x : dlist α × wseq α) => sorry) (dlist.empty, s))

/-- Like take, but does not wait for a result. Calculates `n` steps of
  computation and returns the sequence computed so far -/
def collect {α : Type u} (s : wseq α) (n : ℕ) : List α :=
  list.filter_map id (seq.take n s)

/-- Append two weak sequences. As with `seq.append`, this may not use
  the second sequence if the first one takes forever to compute -/
def append {α : Type u} : wseq α → wseq α → wseq α :=
  seq.append

/-- Map a function over a weak sequence -/
def map {α : Type u} {β : Type v} (f : α → β) : wseq α → wseq β :=
  seq.map (option.map f)

/-- Flatten a sequence of weak sequences. (Note that this allows
  empty sequences, unlike `seq.join`.) -/
def join {α : Type u} (S : wseq (wseq α)) : wseq α :=
  seq.join ((fun (o : Option (wseq α)) => sorry) <$> S)

/-- Monadic bind operator for weak sequences -/
def bind {α : Type u} {β : Type v} (s : wseq α) (f : α → wseq β) : wseq β :=
  join (map f s)

@[simp] def lift_rel_o {α : Type u} {β : Type v} (R : α → β → Prop) (C : wseq α → wseq β → Prop) : Option (α × wseq α) → Option (β × wseq β) → Prop :=
  sorry

theorem lift_rel_o.imp {α : Type u} {β : Type v} {R : α → β → Prop} {S : α → β → Prop} {C : wseq α → wseq β → Prop} {D : wseq α → wseq β → Prop} (H1 : ∀ (a : α) (b : β), R a b → S a b) (H2 : ∀ (s : wseq α) (t : wseq β), C s t → D s t) {o : Option (α × wseq α)} {p : Option (β × wseq β)} : lift_rel_o R C o p → lift_rel_o S D o p := sorry

theorem lift_rel_o.imp_right {α : Type u} {β : Type v} (R : α → β → Prop) {C : wseq α → wseq β → Prop} {D : wseq α → wseq β → Prop} (H : ∀ (s : wseq α) (t : wseq β), C s t → D s t) {o : Option (α × wseq α)} {p : Option (β × wseq β)} : lift_rel_o R C o p → lift_rel_o R D o p :=
  lift_rel_o.imp (fun (_x : α) (_x_1 : β) => id) H

@[simp] def bisim_o {α : Type u} (R : wseq α → wseq α → Prop) : Option (α × wseq α) → Option (α × wseq α) → Prop :=
  lift_rel_o Eq R

theorem bisim_o.imp {α : Type u} {R : wseq α → wseq α → Prop} {S : wseq α → wseq α → Prop} (H : ∀ (s t : wseq α), R s t → S s t) {o : Option (α × wseq α)} {p : Option (α × wseq α)} : bisim_o R o p → bisim_o S o p :=
  lift_rel_o.imp_right Eq H

/-- Two weak sequences are `lift_rel R` related if they are either both empty,
  or they are both nonempty and the heads are `R` related and the tails are
  `lift_rel R` related. (This is a coinductive definition.) -/
def lift_rel {α : Type u} {β : Type v} (R : α → β → Prop) (s : wseq α) (t : wseq β) :=
  ∃ (C : wseq α → wseq β → Prop),
    C s t ∧ ∀ {s : wseq α} {t : wseq β}, C s t → computation.lift_rel (lift_rel_o R C) (destruct s) (destruct t)

/-- If two sequences are equivalent, then they have the same values and
  the same computational behavior (i.e. if one loops forever then so does
  the other), although they may differ in the number of `think`s needed to
  arrive at the answer. -/
def equiv {α : Type u} : wseq α → wseq α → Prop :=
  lift_rel Eq

theorem lift_rel_destruct {α : Type u} {β : Type v} {R : α → β → Prop} {s : wseq α} {t : wseq β} : lift_rel R s t → computation.lift_rel (lift_rel_o R (lift_rel R)) (destruct s) (destruct t) := sorry

theorem lift_rel_destruct_iff {α : Type u} {β : Type v} {R : α → β → Prop} {s : wseq α} {t : wseq β} : lift_rel R s t ↔ computation.lift_rel (lift_rel_o R (lift_rel R)) (destruct s) (destruct t) := sorry

infixl:50 " ~ " => Mathlib.wseq.equiv

theorem destruct_congr {α : Type u} {s : wseq α} {t : wseq α} : s ~ t → computation.lift_rel (bisim_o equiv) (destruct s) (destruct t) :=
  lift_rel_destruct

theorem destruct_congr_iff {α : Type u} {s : wseq α} {t : wseq α} : s ~ t ↔ computation.lift_rel (bisim_o equiv) (destruct s) (destruct t) :=
  lift_rel_destruct_iff

theorem lift_rel.refl {α : Type u} (R : α → α → Prop) (H : reflexive R) : reflexive (lift_rel R) := sorry

theorem lift_rel_o.swap {α : Type u} {β : Type v} (R : α → β → Prop) (C : wseq α → wseq β → Prop) : function.swap (lift_rel_o R C) = lift_rel_o (function.swap R) (function.swap C) := sorry

theorem lift_rel.swap_lem {α : Type u} {β : Type v} {R : α → β → Prop} {s1 : wseq α} {s2 : wseq β} (h : lift_rel R s1 s2) : lift_rel (function.swap R) s2 s1 := sorry

theorem lift_rel.swap {α : Type u} {β : Type v} (R : α → β → Prop) : function.swap (lift_rel R) = lift_rel (function.swap R) :=
  funext fun (x : wseq β) => funext fun (y : wseq α) => propext { mp := lift_rel.swap_lem, mpr := lift_rel.swap_lem }

theorem lift_rel.symm {α : Type u} (R : α → α → Prop) (H : symmetric R) : symmetric (lift_rel R) := sorry

theorem lift_rel.trans {α : Type u} (R : α → α → Prop) (H : transitive R) : transitive (lift_rel R) := sorry

theorem lift_rel.equiv {α : Type u} (R : α → α → Prop) : equivalence R → equivalence (lift_rel R) := sorry

theorem equiv.refl {α : Type u} (s : wseq α) : s ~ s :=
  lift_rel.refl Eq Eq.refl

theorem equiv.symm {α : Type u} {s : wseq α} {t : wseq α} : s ~ t → t ~ s :=
  lift_rel.symm Eq Eq.symm

theorem equiv.trans {α : Type u} {s : wseq α} {t : wseq α} {u : wseq α} : s ~ t → t ~ u → s ~ u :=
  lift_rel.trans Eq Eq.trans

theorem equiv.equivalence {α : Type u} : equivalence equiv :=
  { left := equiv.refl, right := { left := equiv.symm, right := equiv.trans } }

@[simp] theorem destruct_nil {α : Type u} : destruct nil = computation.return none :=
  computation.destruct_eq_ret rfl

@[simp] theorem destruct_cons {α : Type u} (a : α) (s : wseq α) : destruct (cons a s) = computation.return (some (a, s)) := sorry

@[simp] theorem destruct_think {α : Type u} (s : wseq α) : destruct (think s) = computation.think (destruct s) := sorry

@[simp] theorem seq_destruct_nil {α : Type u} : seq.destruct nil = none :=
  seq.destruct_nil

@[simp] theorem seq_destruct_cons {α : Type u} (a : α) (s : wseq α) : seq.destruct (cons a s) = some (some a, s) :=
  seq.destruct_cons (some a) s

@[simp] theorem seq_destruct_think {α : Type u} (s : wseq α) : seq.destruct (think s) = some (none, s) :=
  seq.destruct_cons none s

@[simp] theorem head_nil {α : Type u} : head nil = computation.return none := sorry

@[simp] theorem head_cons {α : Type u} (a : α) (s : wseq α) : head (cons a s) = computation.return (some a) := sorry

@[simp] theorem head_think {α : Type u} (s : wseq α) : head (think s) = computation.think (head s) := sorry

@[simp] theorem flatten_ret {α : Type u} (s : wseq α) : flatten (computation.return s) = s := sorry

@[simp] theorem flatten_think {α : Type u} (c : computation (wseq α)) : flatten (computation.think c) = think (flatten c) := sorry

@[simp] theorem destruct_flatten {α : Type u} (c : computation (wseq α)) : destruct (flatten c) = c >>= destruct := sorry

theorem head_terminates_iff {α : Type u} (s : wseq α) : computation.terminates (head s) ↔ computation.terminates (destruct s) :=
  computation.terminates_map_iff (Functor.map prod.fst) (destruct s)

@[simp] theorem tail_nil {α : Type u} : tail nil = nil := sorry

@[simp] theorem tail_cons {α : Type u} (a : α) (s : wseq α) : tail (cons a s) = s := sorry

@[simp] theorem tail_think {α : Type u} (s : wseq α) : tail (think s) = think (tail s) := sorry

@[simp] theorem dropn_nil {α : Type u} (n : ℕ) : drop nil n = nil := sorry

@[simp] theorem dropn_cons {α : Type u} (a : α) (s : wseq α) (n : ℕ) : drop (cons a s) (n + 1) = drop s n := sorry

@[simp] theorem dropn_think {α : Type u} (s : wseq α) (n : ℕ) : drop (think s) n = think (drop s n) := sorry

theorem dropn_add {α : Type u} (s : wseq α) (m : ℕ) (n : ℕ) : drop s (m + n) = drop (drop s m) n := sorry

theorem dropn_tail {α : Type u} (s : wseq α) (n : ℕ) : drop (tail s) n = drop s (n + 1) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (drop (tail s) n = drop s (n + 1))) (add_comm n 1))) (Eq.symm (dropn_add s 1 n))

theorem nth_add {α : Type u} (s : wseq α) (m : ℕ) (n : ℕ) : nth s (m + n) = nth (drop s m) n :=
  congr_arg head (dropn_add s m n)

theorem nth_tail {α : Type u} (s : wseq α) (n : ℕ) : nth (tail s) n = nth s (n + 1) :=
  congr_arg head (dropn_tail s n)

@[simp] theorem join_nil {α : Type u} : join nil = nil :=
  seq.join_nil

@[simp] theorem join_think {α : Type u} (S : wseq (wseq α)) : join (think S) = think (join S) := sorry

@[simp] theorem join_cons {α : Type u} (s : wseq α) (S : wseq (wseq α)) : join (cons s S) = think (append s (join S)) := sorry

@[simp] theorem nil_append {α : Type u} (s : wseq α) : append nil s = s :=
  seq.nil_append s

@[simp] theorem cons_append {α : Type u} (a : α) (s : wseq α) (t : wseq α) : append (cons a s) t = cons a (append s t) :=
  seq.cons_append (some a) s t

@[simp] theorem think_append {α : Type u} (s : wseq α) (t : wseq α) : append (think s) t = think (append s t) :=
  seq.cons_append none s t

@[simp] theorem append_nil {α : Type u} (s : wseq α) : append s nil = s :=
  seq.append_nil s

@[simp] theorem append_assoc {α : Type u} (s : wseq α) (t : wseq α) (u : wseq α) : append (append s t) u = append s (append t u) :=
  seq.append_assoc s t u

@[simp] def tail.aux {α : Type u} : Option (α × wseq α) → computation (Option (α × wseq α)) :=
  sorry

theorem destruct_tail {α : Type u} (s : wseq α) : destruct (tail s) = destruct s >>= tail.aux := sorry

@[simp] def drop.aux {α : Type u} : ℕ → Option (α × wseq α) → computation (Option (α × wseq α)) :=
  sorry

theorem drop.aux_none {α : Type u} (n : ℕ) : drop.aux n none = computation.return none := sorry

theorem destruct_dropn {α : Type u} (s : wseq α) (n : ℕ) : destruct (drop s n) = destruct s >>= drop.aux n := sorry

theorem head_terminates_of_head_tail_terminates {α : Type u} (s : wseq α) [T : computation.terminates (head (tail s))] : computation.terminates (head s) := sorry

theorem destruct_some_of_destruct_tail_some {α : Type u} {s : wseq α} {a : α × wseq α} (h : some a ∈ destruct (tail s)) : ∃ (a' : α × wseq α), some a' ∈ destruct s := sorry

theorem head_some_of_head_tail_some {α : Type u} {s : wseq α} {a : α} (h : some a ∈ head (tail s)) : ∃ (a' : α), some a' ∈ head s := sorry

theorem head_some_of_nth_some {α : Type u} {s : wseq α} {a : α} {n : ℕ} (h : some a ∈ nth s n) : ∃ (a' : α), some a' ∈ head s := sorry

protected instance productive_tail {α : Type u} (s : wseq α) [productive s] : productive (tail s) :=
  fun (n : ℕ) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (computation.terminates (nth (tail s) n))) (nth_tail s n)))
      (wseq.nth_terminates s (n + 1))

protected instance productive_dropn {α : Type u} (s : wseq α) [productive s] (n : ℕ) : productive (drop s n) :=
  fun (m : ℕ) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (computation.terminates (nth (drop s n) m))) (Eq.symm (nth_add s n m))))
      (wseq.nth_terminates s (n + m))

/-- Given a productive weak sequence, we can collapse all the `think`s to
  produce a sequence. -/
def to_seq {α : Type u} (s : wseq α) [productive s] : seq α :=
  { val := fun (n : ℕ) => computation.get (nth s n), property := sorry }

theorem nth_terminates_le {α : Type u} {s : wseq α} {m : ℕ} {n : ℕ} (h : m ≤ n) : computation.terminates (nth s n) → computation.terminates (nth s m) := sorry

theorem head_terminates_of_nth_terminates {α : Type u} {s : wseq α} {n : ℕ} : computation.terminates (nth s n) → computation.terminates (head s) :=
  nth_terminates_le (nat.zero_le n)

theorem destruct_terminates_of_nth_terminates {α : Type u} {s : wseq α} {n : ℕ} (T : computation.terminates (nth s n)) : computation.terminates (destruct s) :=
  iff.mp (head_terminates_iff s) (head_terminates_of_nth_terminates T)

theorem mem_rec_on {α : Type u} {C : wseq α → Prop} {a : α} {s : wseq α} (M : a ∈ s) (h1 : ∀ (b : α) (s' : wseq α), a = b ∨ C s' → C (cons b s')) (h2 : ∀ (s : wseq α), C s → C (think s)) : C s := sorry

@[simp] theorem mem_think {α : Type u} (s : wseq α) (a : α) : a ∈ think s ↔ a ∈ s := sorry

theorem eq_or_mem_iff_mem {α : Type u} {s : wseq α} {a : α} {a' : α} {s' : wseq α} : some (a', s') ∈ destruct s → (a ∈ s ↔ a = a' ∨ a ∈ s') := sorry

@[simp] theorem mem_cons_iff {α : Type u} (s : wseq α) (b : α) {a : α} : a ∈ cons b s ↔ a = b ∨ a ∈ s := sorry

theorem mem_cons_of_mem {α : Type u} {s : wseq α} (b : α) {a : α} (h : a ∈ s) : a ∈ cons b s :=
  iff.mpr (mem_cons_iff s b) (Or.inr h)

theorem mem_cons {α : Type u} (s : wseq α) (a : α) : a ∈ cons a s :=
  iff.mpr (mem_cons_iff s a) (Or.inl rfl)

theorem mem_of_mem_tail {α : Type u} {s : wseq α} {a : α} : a ∈ tail s → a ∈ s := sorry

theorem mem_of_mem_dropn {α : Type u} {s : wseq α} {a : α} {n : ℕ} : a ∈ drop s n → a ∈ s := sorry

theorem nth_mem {α : Type u} {s : wseq α} {a : α} {n : ℕ} : some a ∈ nth s n → a ∈ s := sorry

theorem exists_nth_of_mem {α : Type u} {s : wseq α} {a : α} (h : a ∈ s) : ∃ (n : ℕ), some a ∈ nth s n := sorry

theorem exists_dropn_of_mem {α : Type u} {s : wseq α} {a : α} (h : a ∈ s) : ∃ (n : ℕ), ∃ (s' : wseq α), some (a, s') ∈ destruct (drop s n) := sorry

theorem lift_rel_dropn_destruct {α : Type u} {β : Type v} {R : α → β → Prop} {s : wseq α} {t : wseq β} (H : lift_rel R s t) (n : ℕ) : computation.lift_rel (lift_rel_o R (lift_rel R)) (destruct (drop s n)) (destruct (drop t n)) := sorry

theorem exists_of_lift_rel_left {α : Type u} {β : Type v} {R : α → β → Prop} {s : wseq α} {t : wseq β} (H : lift_rel R s t) {a : α} (h : a ∈ s) : Exists fun {b : β} => b ∈ t ∧ R a b := sorry

theorem exists_of_lift_rel_right {α : Type u} {β : Type v} {R : α → β → Prop} {s : wseq α} {t : wseq β} (H : lift_rel R s t) {b : β} (h : b ∈ t) : Exists fun {a : α} => a ∈ s ∧ R a b :=
  exists_of_lift_rel_left
    (eq.mp (Eq._oldrec (Eq.refl (lift_rel R s t)) (Eq.symm (lift_rel.swap fun (x : β) (y : α) => R y x))) H) h

theorem head_terminates_of_mem {α : Type u} {s : wseq α} {a : α} (h : a ∈ s) : computation.terminates (head s) := sorry

theorem of_mem_append {α : Type u} {s₁ : wseq α} {s₂ : wseq α} {a : α} : a ∈ append s₁ s₂ → a ∈ s₁ ∨ a ∈ s₂ :=
  seq.of_mem_append

theorem mem_append_left {α : Type u} {s₁ : wseq α} {s₂ : wseq α} {a : α} : a ∈ s₁ → a ∈ append s₁ s₂ :=
  seq.mem_append_left

theorem exists_of_mem_map {α : Type u} {β : Type v} {f : α → β} {b : β} {s : wseq α} : b ∈ map f s → ∃ (a : α), a ∈ s ∧ f a = b := sorry

@[simp] theorem lift_rel_nil {α : Type u} {β : Type v} (R : α → β → Prop) : lift_rel R nil nil := sorry

@[simp] theorem lift_rel_cons {α : Type u} {β : Type v} (R : α → β → Prop) (a : α) (b : β) (s : wseq α) (t : wseq β) : lift_rel R (cons a s) (cons b t) ↔ R a b ∧ lift_rel R s t := sorry

@[simp] theorem lift_rel_think_left {α : Type u} {β : Type v} (R : α → β → Prop) (s : wseq α) (t : wseq β) : lift_rel R (think s) t ↔ lift_rel R s t := sorry

@[simp] theorem lift_rel_think_right {α : Type u} {β : Type v} (R : α → β → Prop) (s : wseq α) (t : wseq β) : lift_rel R s (think t) ↔ lift_rel R s t := sorry

theorem cons_congr {α : Type u} {s : wseq α} {t : wseq α} (a : α) (h : s ~ t) : cons a s ~ cons a t := sorry

theorem think_equiv {α : Type u} (s : wseq α) : think s ~ s :=
  eq.mpr (id (congr_fun (congr_fun equiv.equations._eqn_1 (think s)) s))
    (eq.mpr (id (propext (lift_rel_think_left Eq s s))) (equiv.refl s))

theorem think_congr {α : Type u} {s : wseq α} {t : wseq α} (a : α) (h : s ~ t) : think s ~ think t :=
  eq.mpr (id (congr_fun (congr_fun equiv.equations._eqn_1 (think s)) (think t)))
    (eq.mpr (id (Eq.trans (propext (lift_rel_think_right Eq (think s) t)) (propext (lift_rel_think_left Eq s t)))) h)

theorem head_congr {α : Type u} {s : wseq α} {t : wseq α} : s ~ t → head s ~ head t := sorry

theorem flatten_equiv {α : Type u} {c : computation (wseq α)} {s : wseq α} (h : s ∈ c) : flatten c ~ s := sorry

theorem lift_rel_flatten {α : Type u} {β : Type v} {R : α → β → Prop} {c1 : computation (wseq α)} {c2 : computation (wseq β)} (h : computation.lift_rel (lift_rel R) c1 c2) : lift_rel R (flatten c1) (flatten c2) := sorry

theorem flatten_congr {α : Type u} {c1 : computation (wseq α)} {c2 : computation (wseq α)} : computation.lift_rel equiv c1 c2 → flatten c1 ~ flatten c2 :=
  lift_rel_flatten

theorem tail_congr {α : Type u} {s : wseq α} {t : wseq α} (h : s ~ t) : tail s ~ tail t := sorry

theorem dropn_congr {α : Type u} {s : wseq α} {t : wseq α} (h : s ~ t) (n : ℕ) : drop s n ~ drop t n := sorry

theorem nth_congr {α : Type u} {s : wseq α} {t : wseq α} (h : s ~ t) (n : ℕ) : nth s n ~ nth t n :=
  head_congr (dropn_congr h n)

theorem mem_congr {α : Type u} {s : wseq α} {t : wseq α} (h : s ~ t) (a : α) : a ∈ s ↔ a ∈ t := sorry

theorem productive_congr {α : Type u} {s : wseq α} {t : wseq α} (h : s ~ t) : productive s ↔ productive t :=
  forall_congr fun (n : ℕ) => computation.terminates_congr (nth_congr h n)

theorem equiv.ext {α : Type u} {s : wseq α} {t : wseq α} (h : ∀ (n : ℕ), nth s n ~ nth t n) : s ~ t := sorry

theorem length_eq_map {α : Type u} (s : wseq α) : length s = computation.map list.length (to_list s) := sorry

@[simp] theorem of_list_nil {α : Type u} : of_list [] = nil :=
  rfl

@[simp] theorem of_list_cons {α : Type u} (a : α) (l : List α) : of_list (a :: l) = cons a (of_list l) := sorry

@[simp] theorem to_list'_nil {α : Type u} (l : List α) : computation.corec to_list._match_2 (l, nil) = computation.return (list.reverse l) :=
  computation.destruct_eq_ret rfl

@[simp] theorem to_list'_cons {α : Type u} (l : List α) (s : wseq α) (a : α) : computation.corec to_list._match_2 (l, cons a s) = computation.think (computation.corec to_list._match_2 (a :: l, s)) := sorry

@[simp] theorem to_list'_think {α : Type u} (l : List α) (s : wseq α) : computation.corec to_list._match_2 (l, think s) = computation.think (computation.corec to_list._match_2 (l, s)) := sorry

theorem to_list'_map {α : Type u} (l : List α) (s : wseq α) : computation.corec to_list._match_2 (l, s) = append (list.reverse l) <$> to_list s := sorry

@[simp] theorem to_list_cons {α : Type u} (a : α) (s : wseq α) : to_list (cons a s) = computation.think (List.cons a <$> to_list s) := sorry

@[simp] theorem to_list_nil {α : Type u} : to_list nil = computation.return [] :=
  computation.destruct_eq_ret rfl

theorem to_list_of_list {α : Type u} (l : List α) : l ∈ to_list (of_list l) := sorry

@[simp] theorem destruct_of_seq {α : Type u} (s : seq α) : destruct (of_seq s) = computation.return (option.map (fun (a : α) => (a, of_seq (seq.tail s))) (seq.head s)) := sorry

@[simp] theorem head_of_seq {α : Type u} (s : seq α) : head (of_seq s) = computation.return (seq.head s) := sorry

@[simp] theorem tail_of_seq {α : Type u} (s : seq α) : tail (of_seq s) = of_seq (seq.tail s) := sorry

@[simp] theorem dropn_of_seq {α : Type u} (s : seq α) (n : ℕ) : drop (of_seq s) n = of_seq (seq.drop s n) := sorry

theorem nth_of_seq {α : Type u} (s : seq α) (n : ℕ) : nth (of_seq s) n = computation.return (seq.nth s n) := sorry

protected instance productive_of_seq {α : Type u} (s : seq α) : productive (of_seq s) :=
  fun (n : ℕ) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (computation.terminates (nth (of_seq s) n))) (nth_of_seq s n)))
      (computation.ret_terminates (seq.nth s n))

theorem to_seq_of_seq {α : Type u} (s : seq α) : to_seq (of_seq s) = s := sorry

/-- The monadic `return a` is a singleton list containing `a`. -/
def ret {α : Type u} (a : α) : wseq α :=
  of_list [a]

@[simp] theorem map_nil {α : Type u} {β : Type v} (f : α → β) : map f nil = nil :=
  rfl

@[simp] theorem map_cons {α : Type u} {β : Type v} (f : α → β) (a : α) (s : wseq α) : map f (cons a s) = cons (f a) (map f s) :=
  seq.map_cons (option.map f) (some a) s

@[simp] theorem map_think {α : Type u} {β : Type v} (f : α → β) (s : wseq α) : map f (think s) = think (map f s) :=
  seq.map_cons (option.map f) none s

@[simp] theorem map_id {α : Type u} (s : wseq α) : map id s = s := sorry

@[simp] theorem map_ret {α : Type u} {β : Type v} (f : α → β) (a : α) : map f (ret a) = ret (f a) := sorry

@[simp] theorem map_append {α : Type u} {β : Type v} (f : α → β) (s : wseq α) (t : wseq α) : map f (append s t) = append (map f s) (map f t) :=
  seq.map_append (option.map f) s t

theorem map_comp {α : Type u} {β : Type v} {γ : Type w} (f : α → β) (g : β → γ) (s : wseq α) : map (g ∘ f) s = map g (map f s) := sorry

theorem mem_map {α : Type u} {β : Type v} (f : α → β) {a : α} {s : wseq α} : a ∈ s → f a ∈ map f s :=
  seq.mem_map (option.map f)

-- The converse is not true without additional assumptions

theorem exists_of_mem_join {α : Type u} {a : α} {S : wseq (wseq α)} : a ∈ join S → ∃ (s : wseq α), s ∈ S ∧ a ∈ s := sorry

theorem exists_of_mem_bind {α : Type u} {β : Type v} {s : wseq α} {f : α → wseq β} {b : β} (h : b ∈ bind s f) : ∃ (a : α), ∃ (H : a ∈ s), b ∈ f a := sorry

theorem destruct_map {α : Type u} {β : Type v} (f : α → β) (s : wseq α) : destruct (map f s) = computation.map (option.map (prod.map f (map f))) (destruct s) := sorry

theorem lift_rel_map {α : Type u} {β : Type v} {γ : Type w} {δ : Type u_1} (R : α → β → Prop) (S : γ → δ → Prop) {s1 : wseq α} {s2 : wseq β} {f1 : α → γ} {f2 : β → δ} (h1 : lift_rel R s1 s2) (h2 : ∀ {a : α} {b : β}, R a b → S (f1 a) (f2 b)) : lift_rel S (map f1 s1) (map f2 s2) := sorry

theorem map_congr {α : Type u} {β : Type v} (f : α → β) {s : wseq α} {t : wseq α} (h : s ~ t) : map f s ~ map f t :=
  lift_rel_map Eq Eq h fun (_x _x_1 : α) => congr_arg fun (_x : α) => f _x

@[simp] def destruct_append.aux {α : Type u} (t : wseq α) : Option (α × wseq α) → computation (Option (α × wseq α)) :=
  sorry

theorem destruct_append {α : Type u} (s : wseq α) (t : wseq α) : destruct (append s t) = computation.bind (destruct s) (destruct_append.aux t) := sorry

@[simp] def destruct_join.aux {α : Type u} : Option (wseq α × wseq (wseq α)) → computation (Option (α × wseq α)) :=
  sorry

theorem destruct_join {α : Type u} (S : wseq (wseq α)) : destruct (join S) = computation.bind (destruct S) destruct_join.aux := sorry

theorem lift_rel_append {α : Type u} {β : Type v} (R : α → β → Prop) {s1 : wseq α} {s2 : wseq α} {t1 : wseq β} {t2 : wseq β} (h1 : lift_rel R s1 t1) (h2 : lift_rel R s2 t2) : lift_rel R (append s1 s2) (append t1 t2) := sorry

theorem lift_rel_join.lem {α : Type u} {β : Type v} (R : α → β → Prop) {S : wseq (wseq α)} {T : wseq (wseq β)} {U : wseq α → wseq β → Prop} (ST : lift_rel (lift_rel R) S T) (HU : ∀ (s1 : wseq α) (s2 : wseq β),
  (∃ (s : wseq α),
      ∃ (t : wseq β),
        ∃ (S : wseq (wseq α)),
          ∃ (T : wseq (wseq β)),
            s1 = append s (join S) ∧ s2 = append t (join T) ∧ lift_rel R s t ∧ lift_rel (lift_rel R) S T) →
    U s1 s2) {a : Option (α × wseq α)} (ma : a ∈ destruct (join S)) : Exists fun {b : Option (β × wseq β)} => b ∈ destruct (join T) ∧ lift_rel_o R U a b := sorry

theorem lift_rel_join {α : Type u} {β : Type v} (R : α → β → Prop) {S : wseq (wseq α)} {T : wseq (wseq β)} (h : lift_rel (lift_rel R) S T) : lift_rel R (join S) (join T) := sorry

theorem join_congr {α : Type u} {S : wseq (wseq α)} {T : wseq (wseq α)} (h : lift_rel equiv S T) : join S ~ join T :=
  lift_rel_join Eq h

theorem lift_rel_bind {α : Type u} {β : Type v} {γ : Type w} {δ : Type u_1} (R : α → β → Prop) (S : γ → δ → Prop) {s1 : wseq α} {s2 : wseq β} {f1 : α → wseq γ} {f2 : β → wseq δ} (h1 : lift_rel R s1 s2) (h2 : ∀ {a : α} {b : β}, R a b → lift_rel S (f1 a) (f2 b)) : lift_rel S (bind s1 f1) (bind s2 f2) :=
  lift_rel_join S (lift_rel_map R (lift_rel S) h1 h2)

theorem bind_congr {α : Type u} {β : Type v} {s1 : wseq α} {s2 : wseq α} {f1 : α → wseq β} {f2 : α → wseq β} (h1 : s1 ~ s2) (h2 : ∀ (a : α), f1 a ~ f2 a) : bind s1 f1 ~ bind s2 f2 :=
  lift_rel_bind Eq Eq h1
    fun (a b : α) (h : a = b) => eq.mpr (id (Eq._oldrec (Eq.refl (lift_rel Eq (f1 a) (f2 b))) h)) (h2 b)

@[simp] theorem join_ret {α : Type u} (s : wseq α) : join (ret s) ~ s := sorry

@[simp] theorem join_map_ret {α : Type u} (s : wseq α) : join (map ret s) ~ s := sorry

@[simp] theorem join_append {α : Type u} (S : wseq (wseq α)) (T : wseq (wseq α)) : join (append S T) ~ append (join S) (join T) := sorry

@[simp] theorem bind_ret {α : Type u} {β : Type v} (f : α → β) (s : wseq α) : bind s (ret ∘ f) ~ map f s :=
  id (eq.mpr (id (Eq._oldrec (Eq.refl (join (map (ret ∘ f) s) ~ map f s)) (map_comp f ret s))) (join_map_ret (map f s)))

@[simp] theorem ret_bind {α : Type u} {β : Type v} (a : α) (f : α → wseq β) : bind (ret a) f ~ f a := sorry

@[simp] theorem map_join {α : Type u} {β : Type v} (f : α → β) (S : wseq (wseq α)) : map f (join S) = join (map (map f) S) := sorry

@[simp] theorem join_join {α : Type u} (SS : wseq (wseq (wseq α))) : join (join SS) ~ join (map join SS) := sorry

@[simp] theorem bind_assoc {α : Type u} {β : Type v} {γ : Type w} (s : wseq α) (f : α → wseq β) (g : β → wseq γ) : bind (bind s f) g ~ bind s fun (x : α) => bind (f x) g := sorry

protected instance monad : Monad wseq :=
  { toApplicative :=
      { toFunctor := { map := map, mapConst := fun (α β : Type u_1) => map ∘ function.const β },
        toPure := { pure := ret },
        toSeq := { seq := fun (α β : Type u_1) (f : wseq (α → β)) (x : wseq α) => bind f fun (_x : α → β) => map _x x },
        toSeqLeft :=
          { seqLeft :=
              fun (α β : Type u_1) (a : wseq α) (b : wseq β) =>
                (fun (α β : Type u_1) (f : wseq (α → β)) (x : wseq α) => bind f fun (_x : α → β) => map _x x) β α
                  (map (function.const β) a) b },
        toSeqRight :=
          { seqRight :=
              fun (α β : Type u_1) (a : wseq α) (b : wseq β) =>
                (fun (α β : Type u_1) (f : wseq (α → β)) (x : wseq α) => bind f fun (_x : α → β) => map _x x) β β
                  (map (function.const α id) a) b } },
    toBind := { bind := bind } }


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 auto [int.fract_eq_iff, hα_irrat, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_
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 auto [set.subset_of_mem_powerset, set.subset_of_mem_powerset],
  -- Then $(A ∩ B) ⊆ A$, by intersection of set is a subset
  have h2 : (A ∩ B) ⊆ A, from by auto [set.inter_subset_left],
  -- Then $(A ∩ B) ⊆ S$, by subset relation is transitive
  have h3 : (A ∩ B) ⊆ S, from by auto [set.subset.trans],
  -- Hence $(A ∩ B) ∈  𝒫 S$, by power set definition
  show (A ∩ B) ∈  𝒫 S, from by auto [set.mem_powerset],
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 auto [sq]
  -- distributive property of multiplication over addition gives:
  ... = x*(x+y) + y*(x+y) : by auto [add_mul]
  -- applying the above property further gives:
  ... = x*x + x*y + y*x + y*y : by auto [mul_comm, add_mul] using [ring]
  -- rearranging the terms using commutativity and adding gives:
  ... = x^2 + 2*x*y + y^2 : by auto [sq, mul_comm] using [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 auto using [use (a⁻¹ * b)],
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from by auto using [use b * a⁻¹],

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

  -- 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 by auto [exists_unique.unique, h3, classical.some_spec, exists_unique.exists, mul_one],
  have h6 : ∀ a : G, classical.some (h4 a).exists = (1 : G), from by auto [exists_unique.unique, h4, classical.some_spec, exists_unique.exists, one_mul],

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by auto [h3, h4, exists_unique.unique, classical.some_spec, exists_unique.exists] using [use (1 : G)],
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 auto [abs_sub_lt_iff] using [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 auto [lt_of_le_of_lt, le_max_left, le_max_right],

  --$\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 auto [h8, h10, h5, h9],

  --$\forall n > N: l - \epsilon < x_n < l + \epsilon$
  have h15 : ∀ n > N, ((l - ε) < (x n)) ∧ ((x n) < (l+ε)),
  from by auto [h11] using [linarith],

  --So $\forall n > N: \size {x_n - l} < \epsilon$
  --Hence the result
  show  ∀ (n : ℕ), n > N → |x n - l| < ε,
  from by auto [h5, h15],

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) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro
-/
import topology.metric_space.basic
import topology.algebra.uniform_group
import topology.algebra.uniform_mul_action
import topology.algebra.ring.basic
import topology.algebra.star
import topology.algebra.order.field
import ring_theory.subring.basic
import group_theory.archimedean
import algebra.order.group.bounds
import algebra.periodic
import topology.instances.int

/-!
# Topological properties of ℝ

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

noncomputable theory
open classical filter int metric set topological_space
open_locale classical topology filter uniformity interval

universes u v w
variables {α : Type u} {β : Type v} {γ : Type w}

instance : noncompact_space ℝ := int.closed_embedding_coe_real.noncompact_space

theorem real.uniform_continuous_add : uniform_continuous (λp : ℝ × ℝ, p.1 + p.2) :=
metric.uniform_continuous_iff.2 $ λ ε ε0,
let ⟨δ, δ0, Hδ⟩ := rat_add_continuous_lemma abs ε0 in
⟨δ, δ0, λ a b h, let ⟨h₁, h₂⟩ := max_lt_iff.1 h in Hδ h₁ h₂⟩

theorem real.uniform_continuous_neg : uniform_continuous (@has_neg.neg ℝ _) :=
metric.uniform_continuous_iff.2 $ λ ε ε0, ⟨_, ε0, λ a b h,
  by rw dist_comm at h; simpa [real.dist_eq] using h⟩

instance : has_continuous_star ℝ := ⟨continuous_id⟩

instance : uniform_add_group ℝ :=
uniform_add_group.mk' real.uniform_continuous_add real.uniform_continuous_neg

 -- short-circuit type class inference
instance : topological_add_group ℝ := by apply_instance

instance : proper_space ℝ :=
{ is_compact_closed_ball := λx r, by { rw real.closed_ball_eq_Icc, apply is_compact_Icc } }

instance : second_countable_topology ℝ := second_countable_of_proper

lemma real.is_topological_basis_Ioo_rat :
  @is_topological_basis ℝ _ (⋃(a b : ℚ) (h : a < b), {Ioo a b}) :=
is_topological_basis_of_open_of_nhds
  (by simp [is_open_Ioo] {contextual:=tt})
  (assume a v hav hv,
    let ⟨l, u, ⟨hl, hu⟩, h⟩ := mem_nhds_iff_exists_Ioo_subset.mp (is_open.mem_nhds hv hav),
        ⟨q, hlq, hqa⟩ := exists_rat_btwn hl,
        ⟨p, hap, hpu⟩ := exists_rat_btwn hu in
    ⟨Ioo q p,
      by { simp only [mem_Union], exact ⟨q, p, rat.cast_lt.1 $ hqa.trans hap, rfl⟩ },
      ⟨hqa, hap⟩, assume a' ⟨hqa', ha'p⟩, h ⟨hlq.trans hqa', ha'p.trans hpu⟩⟩)

@[simp] lemma real.cocompact_eq : cocompact ℝ = at_bot ⊔ at_top :=
by simp only [← comap_dist_right_at_top_eq_cocompact (0 : ℝ), real.dist_eq, sub_zero,
  comap_abs_at_top]

/- TODO(Mario): Prove that these are uniform isomorphisms instead of uniform embeddings
lemma uniform_embedding_add_rat {r : ℚ} : uniform_embedding (λp:ℚ, p + r) :=
_

lemma uniform_embedding_mul_rat {q : ℚ} (hq : q ≠ 0) : uniform_embedding ((*) q) :=
_ -/

lemma real.mem_closure_iff {s : set ℝ} {x : ℝ} :
  x ∈ closure s ↔ ∀ ε > 0, ∃ y ∈ s, |y - x| < ε :=
by simp [mem_closure_iff_nhds_basis nhds_basis_ball, real.dist_eq]

lemma real.uniform_continuous_inv (s : set ℝ) {r : ℝ} (r0 : 0 < r) (H : ∀ x ∈ s, r ≤ |x|) :
  uniform_continuous (λp:s, p.1⁻¹) :=
metric.uniform_continuous_iff.2 $ λ ε ε0,
let ⟨δ, δ0, Hδ⟩ := rat_inv_continuous_lemma abs ε0 r0 in
⟨δ, δ0, λ a b h, Hδ (H _ a.2) (H _ b.2) h⟩

lemma real.uniform_continuous_abs : uniform_continuous (abs : ℝ → ℝ) :=
metric.uniform_continuous_iff.2 $ λ ε ε0,
  ⟨ε, ε0, λ a b, lt_of_le_of_lt (abs_abs_sub_abs_le_abs_sub _ _)⟩

lemma real.tendsto_inv {r : ℝ} (r0 : r ≠ 0) : tendsto (λq, q⁻¹) (𝓝 r) (𝓝 r⁻¹) :=
by rw ← abs_pos at r0; exact
tendsto_of_uniform_continuous_subtype
  (real.uniform_continuous_inv {x | |r| / 2 < |x|} (half_pos r0) (λ x h, le_of_lt h))
  (is_open.mem_nhds ((is_open_lt' (|r| / 2)).preimage continuous_abs) (half_lt_self r0))

lemma real.continuous_inv : continuous (λa:{r:ℝ // r ≠ 0}, a.val⁻¹) :=
continuous_iff_continuous_at.mpr $ assume ⟨r, hr⟩,
  tendsto.comp (real.tendsto_inv hr) (continuous_iff_continuous_at.mp continuous_subtype_val _)

lemma real.continuous.inv [topological_space α] {f : α → ℝ} (h : ∀a, f a ≠ 0) (hf : continuous f) :
  continuous (λa, (f a)⁻¹) :=
show continuous ((has_inv.inv ∘ @subtype.val ℝ (λr, r ≠ 0)) ∘ λa, ⟨f a, h a⟩),
  from real.continuous_inv.comp (hf.subtype_mk _)

lemma real.uniform_continuous_const_mul {x : ℝ} : uniform_continuous ((*) x) :=
uniform_continuous_const_smul x

lemma real.uniform_continuous_mul (s : set (ℝ × ℝ))
  {r₁ r₂ : ℝ} (H : ∀ x ∈ s, |(x : ℝ × ℝ).1| < r₁ ∧ |x.2| < r₂) :
  uniform_continuous (λp:s, p.1.1 * p.1.2) :=
metric.uniform_continuous_iff.2 $ λ ε ε0,
let ⟨δ, δ0, Hδ⟩ := rat_mul_continuous_lemma abs ε0 in
⟨δ, δ0, λ a b h,
  let ⟨h₁, h₂⟩ := max_lt_iff.1 h in Hδ (H _ a.2).1 (H _ b.2).2 h₁ h₂⟩

protected lemma real.continuous_mul : continuous (λp : ℝ × ℝ, p.1 * p.2) :=
continuous_iff_continuous_at.2 $ λ ⟨a₁, a₂⟩,
tendsto_of_uniform_continuous_subtype
  (real.uniform_continuous_mul
    ({x | |x| < |a₁| + 1} ×ˢ {x | |x| < |a₂| + 1})
    (λ x, id))
  (is_open.mem_nhds
    (((is_open_gt' (|a₁| + 1)).preimage continuous_abs).prod
      ((is_open_gt' (|a₂| + 1)).preimage continuous_abs ))
    ⟨lt_add_one (|a₁|), lt_add_one (|a₂|)⟩)

instance : topological_ring ℝ :=
{ continuous_mul := real.continuous_mul, ..real.topological_add_group }

instance : complete_space ℝ :=
begin
  apply complete_of_cauchy_seq_tendsto,
  intros u hu,
  let c : cau_seq ℝ abs := ⟨u, metric.cauchy_seq_iff'.1 hu⟩,
  refine ⟨c.lim, λ s h, _⟩,
  rcases metric.mem_nhds_iff.1 h with ⟨ε, ε0, hε⟩,
  have := c.equiv_lim ε ε0,
  simp only [mem_map, mem_at_top_sets, mem_set_of_eq],
  refine this.imp (λ N hN n hn, hε (hN n hn))
end

lemma real.totally_bounded_ball (x ε : ℝ) : totally_bounded (ball x ε) :=
by rw real.ball_eq_Ioo; apply totally_bounded_Ioo

section

lemma closure_of_rat_image_lt {q : ℚ} : closure ((coe:ℚ → ℝ) '' {x | q < x}) = {r | ↑q ≤ r} :=
subset.antisymm
  ((is_closed_ge' _).closure_subset_iff.2
    (image_subset_iff.2 $ λ p h, le_of_lt $ (@rat.cast_lt ℝ _ _ _).2 h)) $
λ x hx, mem_closure_iff_nhds.2 $ λ t ht,
let ⟨ε, ε0, hε⟩ := metric.mem_nhds_iff.1 ht in
let ⟨p, h₁, h₂⟩ := exists_rat_btwn ((lt_add_iff_pos_right x).2 ε0) in
⟨_, hε (show abs _ < _,
    by rwa [abs_of_nonneg (le_of_lt $ sub_pos.2 h₁), sub_lt_iff_lt_add']),
  p, rat.cast_lt.1 (@lt_of_le_of_lt ℝ _ _ _ _ hx h₁), rfl⟩

/- TODO(Mario): Put these back only if needed later
lemma closure_of_rat_image_le_eq {q : ℚ} : closure ((coe:ℚ → ℝ) '' {x | q ≤ x}) = {r | ↑q ≤ r} :=
_

lemma closure_of_rat_image_le_le_eq {a b : ℚ} (hab : a ≤ b) :
  closure (of_rat '' {q:ℚ | a ≤ q ∧ q ≤ b}) = {r:ℝ | of_rat a ≤ r ∧ r ≤ of_rat b} :=
_-/

lemma real.bounded_iff_bdd_below_bdd_above {s : set ℝ} : bounded s ↔ bdd_below s ∧ bdd_above s :=
⟨begin
  assume bdd,
  rcases (bounded_iff_subset_ball 0).1 bdd with ⟨r, hr⟩, -- hr : s ⊆ closed_ball 0 r
  rw real.closed_ball_eq_Icc at hr, -- hr : s ⊆ Icc (0 - r) (0 + r)
  exact ⟨bdd_below_Icc.mono hr, bdd_above_Icc.mono hr⟩
end,
λ h, bounded_of_bdd_above_of_bdd_below h.2 h.1⟩

lemma real.subset_Icc_Inf_Sup_of_bounded {s : set ℝ} (h : bounded s) :
  s ⊆ Icc (Inf s) (Sup s) :=
subset_Icc_cInf_cSup (real.bounded_iff_bdd_below_bdd_above.1 h).1
  (real.bounded_iff_bdd_below_bdd_above.1 h).2

end

section periodic

namespace function

lemma periodic.compact_of_continuous' [topological_space α] {f : ℝ → α} {c : ℝ}
  (hp : periodic f c) (hc : 0 < c) (hf : continuous f) :
  is_compact (range f) :=
begin
  convert is_compact_Icc.image hf,
  ext x,
  refine ⟨_, mem_range_of_mem_image f (Icc 0 c)⟩,
  rintros ⟨y, h1⟩,
  obtain ⟨z, hz, h2⟩ := hp.exists_mem_Ico₀ hc y,
  exact ⟨z, mem_Icc_of_Ico hz, h2.symm.trans h1⟩,
end

/-- A continuous, periodic function has compact range. -/
lemma periodic.compact_of_continuous [topological_space α] {f : ℝ → α} {c : ℝ}
  (hp : periodic f c) (hc : c ≠ 0) (hf : continuous f) :
  is_compact (range f) :=
begin
  cases lt_or_gt_of_ne hc with hneg hpos,
  exacts [hp.neg.compact_of_continuous' (neg_pos.mpr hneg) hf, hp.compact_of_continuous' hpos hf],
end

/-- A continuous, periodic function is bounded. -/
lemma periodic.bounded_of_continuous [pseudo_metric_space α] {f : ℝ → α} {c : ℝ}
  (hp : periodic f c) (hc : c ≠ 0) (hf : continuous f) :
  bounded (range f) :=
(hp.compact_of_continuous hc hf).bounded

end function

end periodic

section subgroups

namespace int
open metric

/-- Under the coercion from `ℤ` to `ℝ`, inverse images of compact sets are finite. -/
lemma tendsto_coe_cofinite : tendsto (coe : ℤ → ℝ) cofinite (cocompact ℝ) :=
begin
  refine tendsto_cocompact_of_tendsto_dist_comp_at_top (0 : ℝ) _,
  simp only [filter.tendsto_at_top, eventually_cofinite, not_le, ← mem_ball],
  change ∀ r : ℝ, (coe ⁻¹' (ball (0 : ℝ) r)).finite,
  simp [real.ball_eq_Ioo, set.finite_Ioo],
end

/-- For nonzero `a`, the "multiples of `a`" map `zmultiples_hom` from `ℤ` to `ℝ` is discrete, i.e.
inverse images of compact sets are finite. -/
lemma tendsto_zmultiples_hom_cofinite {a : ℝ} (ha : a ≠ 0) :
  tendsto (zmultiples_hom ℝ a) cofinite (cocompact ℝ) :=
begin
  convert (tendsto_cocompact_mul_right₀ ha).comp int.tendsto_coe_cofinite,
  ext n,
  simp,
end

end int

namespace add_subgroup

/-- The subgroup "multiples of `a`" (`zmultiples a`) is a discrete subgroup of `ℝ`, i.e. its
intersection with compact sets is finite. -/
lemma tendsto_zmultiples_subtype_cofinite (a : ℝ) :
  tendsto (zmultiples a).subtype cofinite (cocompact ℝ) :=
begin
  rcases eq_or_ne a 0 with rfl | ha,
  { rw add_subgroup.zmultiples_zero_eq_bot,
    intros K hK,
    rw [filter.mem_map, mem_cofinite],
    apply set.to_finite },
  intros K hK,
  have H := int.tendsto_zmultiples_hom_cofinite ha hK,
  simp only [filter.mem_map, mem_cofinite, ← preimage_compl] at ⊢ H,
  rw [← (zmultiples_hom ℝ a).range_restrict_surjective.image_preimage
    ((zmultiples a).subtype ⁻¹' Kᶜ), ← preimage_comp, ← add_monoid_hom.coe_comp_range_restrict],
  exact finite.image _ H,
end

end add_subgroup

/-- Given a nontrivial subgroup `G ⊆ ℝ`, if `G ∩ ℝ_{>0}` has no minimum then `G` is dense. -/
lemma real.subgroup_dense_of_no_min {G : add_subgroup ℝ} {g₀ : ℝ} (g₀_in : g₀ ∈ G) (g₀_ne : g₀ ≠ 0)
  (H' : ¬ ∃ a : ℝ, is_least {g : ℝ | g ∈ G ∧ 0 < g} a) :
  dense (G : set ℝ) :=
begin
  let G_pos := {g : ℝ | g ∈ G ∧ 0 < g},
  push_neg at H',
  intros x,
  suffices : ∀ ε > (0 : ℝ), ∃ g ∈ G, |x - g| < ε,
    by simpa only [real.mem_closure_iff, abs_sub_comm],
  intros ε ε_pos,
  obtain ⟨g₁, g₁_in, g₁_pos⟩ : ∃ g₁ : ℝ, g₁ ∈ G ∧ 0 < g₁,
  { cases lt_or_gt_of_ne g₀_ne with Hg₀ Hg₀,
    { exact ⟨-g₀, G.neg_mem g₀_in, neg_pos.mpr Hg₀⟩ },
    { exact ⟨g₀, g₀_in, Hg₀⟩ } },
  obtain ⟨a, ha⟩ : ∃ a, is_glb G_pos a :=
    ⟨Inf G_pos, is_glb_cInf ⟨g₁, g₁_in, g₁_pos⟩ ⟨0, λ _ hx, le_of_lt hx.2⟩⟩,
  have a_notin : a ∉ G_pos,
  { intros H,
    exact H' a ⟨H, ha.1⟩ },
  obtain ⟨g₂, g₂_in, g₂_pos, g₂_lt⟩ : ∃ g₂ : ℝ, g₂ ∈ G ∧ 0 < g₂ ∧ g₂ < ε,
  { obtain ⟨b, hb, hb', hb''⟩ := ha.exists_between_self_add' a_notin ε_pos,
    obtain ⟨c, hc, hc', hc''⟩ := ha.exists_between_self_add' a_notin (sub_pos.2 hb'),
    refine ⟨b - c, G.sub_mem hb.1 hc.1, _, _⟩ ;
    linarith },
  refine ⟨floor (x/g₂) * g₂, _, _⟩,
  { exact add_subgroup.int_mul_mem _ g₂_in },
  { rw abs_of_nonneg (sub_floor_div_mul_nonneg x g₂_pos),
    linarith [sub_floor_div_mul_lt x g₂_pos] }
end

/-- Subgroups of `ℝ` are either dense or cyclic. See `real.subgroup_dense_of_no_min` and
`subgroup_cyclic_of_min` for more precise statements. -/
lemma real.subgroup_dense_or_cyclic (G : add_subgroup ℝ) :
  dense (G : set ℝ) ∨ ∃ a : ℝ, G = add_subgroup.closure {a} :=
begin
  cases add_subgroup.bot_or_exists_ne_zero G with H H,
  { right,
    use 0,
    rw [H, add_subgroup.closure_singleton_zero] },
  { let G_pos := {g : ℝ | g ∈ G ∧ 0 < g},
    by_cases H' : ∃ a, is_least G_pos a,
    { right,
      rcases H' with ⟨a, ha⟩,
      exact ⟨a, add_subgroup.cyclic_of_min ha⟩ },
    { left,
      rcases H with ⟨g₀, g₀_in, g₀_ne⟩,
      exact real.subgroup_dense_of_no_min g₀_in g₀_ne H' } }
end

end subgroups