import spaces.cont_diff_map_support_in
import measure_theory.function.l1_space
import analysis.locally_convex.with_seminorms

open filter topological_space set measure_theory
open_locale topological_space filter pointwise bounded_cont_diff_map ennreal

section prelim

variables {α : Type*} (S : set α) [topological_space α]

def cocompact_in : filter α :=
⨅ (s : set S) (h : is_compact s), 𝓟 (coe '' s : set α)ᶜ

lemma has_basis_cocompact_in' : (cocompact_in S).has_basis (is_compact : set S → Prop)
  (compl ∘ image coe) :=
has_basis_binfi_principal'
  (λ s hs t ht, ⟨s ∪ t, hs.union ht, compl_subset_compl.2
    (image_subset _ $ subset_union_left s t),
    compl_subset_compl.2 (image_subset _ $ subset_union_right s t)⟩)
  ⟨∅, is_compact_empty⟩

lemma has_basis_cocompact_in : (cocompact_in S).has_basis (λ K : set α, is_compact K ∧ K ⊆ S)
  compl :=
sorry

lemma cocompact_le_cocompact_in : cocompact α ≤ cocompact_in S :=
λ s hs, let ⟨t, ht, hts⟩ := (has_basis_cocompact_in' S).mem_iff.mp hs in
  mem_cocompact.mpr ⟨coe '' t, ht.image continuous_subtype_coe, hts⟩

end prelim

private def test_function_submodule (𝕜 E F : Type*) [nondiscrete_normed_field 𝕜]
  [normed_group E] [normed_group F] [normed_space 𝕜 E] [normed_space 𝕜 F] (Ω : set E)
  (n : with_top ℕ) : submodule 𝕜 (E → F) :=
{ carrier := {f | cont_diff 𝕜 n f ∧ f =ᶠ[cocompact_in Ω] 0}, -- TODO !!!!!!
  zero_mem' := ⟨cont_diff_zero_fun, by refl⟩,
  add_mem' := λ f g hf hg, ⟨hf.1.add hg.1,
    by filter_upwards [hf.2, hg.2] using λ x hfx hgx,
      by rw [pi.add_apply, hfx, hgx, pi.zero_apply, add_zero]⟩,
  smul_mem' := λ c f hf, ⟨cont_diff_const.smul hf.1,
    by filter_upwards [hf.2] using λ x hfx,
      by rw [pi.smul_apply, hfx, pi.zero_apply, smul_zero]⟩ }

def test_function (𝕜 E F : Type*) [nondiscrete_normed_field 𝕜] [normed_group E]
  [normed_group F] [normed_space 𝕜 E] [normed_space 𝕜 F] (Ω : set E) (n : with_top ℕ) :=
↥(test_function_submodule 𝕜 E F Ω n)

localized "notation `Cc^`n`⟮`Ω`,`E`,`F`;`𝕜`⟯` := test_function 𝕜 E F Ω n" in
  test_function

namespace test_function

section general

variables {𝕜 E F : Type*} [nondiscrete_normed_field 𝕜] [normed_group E] [normed_group F]
  [normed_space 𝕜 E] [normed_space 𝕜 F] {Ω : set E} {n : with_top ℕ}
  {f g : Cc^n⟮Ω, E, F; 𝕜⟯} {x : E}

instance : add_comm_group (Cc^n⟮Ω, E, F; 𝕜⟯) := submodule.add_comm_group _
instance : module 𝕜 (Cc^n⟮Ω, E, F; 𝕜⟯) := submodule.module _
instance : has_coe_to_fun (Cc^n⟮Ω, E, F; 𝕜⟯) (λ _, E → F) := ⟨λ f, f.1⟩

@[ext] lemma ext (H : ∀x, f x = g x) : f = g :=
by {ext, exact H x}

lemma cont_diff (f : Cc^n⟮Ω, E, F; 𝕜⟯) :
  cont_diff 𝕜 n f :=
f.2.1

protected lemma continuous (f : Cc^n⟮Ω, E, F; 𝕜⟯) :
  continuous f :=
f.cont_diff.continuous

lemma eventually_eq_cocompact_in (f : Cc^n⟮Ω, E, F; 𝕜⟯) :
  f =ᶠ[cocompact_in Ω] 0 :=
f.2.2

lemma eventually_eq_cocompact (f : Cc^n⟮Ω, E, F; 𝕜⟯) :
  f =ᶠ[cocompact E] 0 :=
cocompact_le_cocompact_in Ω f.2.2

lemma has_compact_support (f : Cc^n⟮Ω, E, F; 𝕜⟯) :
  has_compact_support f :=
begin
  rw [has_compact_support_iff_eventually_eq, coclosed_compact_eq_cocompact],
  exact f.eventually_eq_cocompact
end

protected def tsupport (f : Cc^n⟮Ω, E, F; 𝕜⟯) :
  compacts E :=
⟨tsupport f, f.has_compact_support⟩

protected lemma tsupport_subset (f : Cc^n⟮Ω, E, F; 𝕜⟯) :
  ↑f.tsupport ⊆ Ω :=
begin
  sorry
end

variables (𝕜) (F) (n)

def of_support_in (K : compacts E) (hK : ↑K ⊆ Ω)
  (f : cont_diff_map_supported_in 𝕜 E F K n) :
Cc^n⟮Ω, E, F; 𝕜⟯ :=
⟨f, f.cont_diff, (has_basis_cocompact_in Ω).mem_iff.mpr ⟨K, ⟨K.2, hK⟩, f.supported_in⟩⟩

def to_support_in {K : set E} (f : Cc^n⟮Ω, E, F; 𝕜⟯) (hK : ∀ x ∉ K, f x = 0) :
  cont_diff_map_supported_in 𝕜 E F K n :=
⟨f, f.cont_diff, hK⟩

def to_support_in_tsupport (f : Cc^n⟮Ω, E, F; 𝕜⟯) :
  cont_diff_map_supported_in 𝕜 E F f.tsupport n :=
⟨f, f.cont_diff, λ x, image_eq_zero_of_nmem_tsupport⟩

def of_support_inₗ (K : compacts E) (hK : ↑K ⊆ Ω) :
  cont_diff_map_supported_in 𝕜 E F K n
    →ₗ[𝕜] Cc^n⟮Ω, E, F; 𝕜⟯ :=
{ to_fun := of_support_in 𝕜 F n K hK,
  map_add' := λ f g, by ext; refl,
  map_smul' := λ f g, by ext; refl }

end general

section real

variables {E F : Type*} [normed_group E] [normed_group F]
  [normed_space ℝ E] [normed_space ℝ F] {n : with_top ℕ} {Ω : set E}
  {f g : Cc^n⟮Ω, E, F; ℝ⟯} {x : E}

private noncomputable def tmp_topology : topological_space (Cc^n⟮Ω, E, F; ℝ⟯) :=
  ⨆ (K : compacts E) (hK : ↑K ⊆ Ω), coinduced (of_support_inₗ ℝ F n K hK) infer_instance

local notation `𝓣₀` := tmp_topology

protected def topology : topological_space (Cc^n⟮Ω, E, F; ℝ⟯) :=
Inf { t | 𝓣₀ ≤ t ∧ @topological_add_group _ t _ ∧ @has_continuous_smul ℝ _ _ _ t ∧
          @locally_convex_space ℝ _ _ _ _ t }

local notation `𝓣` := test_function.topology

private lemma tmp_topology_le_topology :
  (𝓣₀ : topological_space (Cc^n⟮Ω, E, F; ℝ⟯)) ≤ 𝓣 :=
le_Inf (λ t ht, ht.1)

private lemma topology_le_iff {t : topological_space (Cc^n⟮Ω, E, F; ℝ⟯)}
  (h₁ : @topological_add_group _ t _) (h₂ : @has_continuous_smul ℝ _ _ _ t)
  (h₃ : @locally_convex_space ℝ _ _ _ _ t) :
𝓣 ≤ t ↔ 𝓣₀ ≤ t :=
sorry -- consequence of general lemma

private def basis_zero : filter_basis Cc^n⟮Ω, E, F; ℝ⟯ :=
{ sets := { s | s ∈ (⨆ (K : compacts E) (hK : ↑K ⊆ Ω), (𝓝 0).map (of_support_in ℝ F n K hK)) ∧
                convex ℝ s ∧ absorbent ℝ s ∧ s = -s },
  nonempty := ⟨univ, univ_mem, convex_univ, absorbent_univ, neg_univ.symm⟩,
  inter_sets := λ s t hs ht, ⟨s ∩ t, ⟨inter_mem hs.1 ht.1, hs.2.1.inter ht.2.1,
    sorry /- absorbent_inter doesn't exist -/, by rw [inter_neg, ← hs.2.2.2, ← ht.2.2.2]⟩, subset_refl _⟩ }

private noncomputable def add_group_basis_zero : add_group_filter_basis Cc^n⟮Ω, E, F; ℝ⟯ :=
{ zero' := sorry,
  add' := sorry,
  neg' := sorry,
  conj' := sorry,
  ..basis_zero }

private noncomputable def module_basis_zero : module_filter_basis ℝ Cc^n⟮Ω, E, F; ℝ⟯ :=
{ smul' := sorry,
  smul_left' := sorry,
  smul_right' := sorry,
  ..add_group_basis_zero }

private noncomputable def basis_topology : topological_space (Cc^n⟮Ω, E, F; ℝ⟯) :=
module_basis_zero.topology

local notation `𝓣₁` := basis_topology

private lemma topology_eq_basis_topology : (𝓣 : topological_space Cc^n⟮Ω, E, F; ℝ⟯) = 𝓣₁ :=
sorry

private lemma continuous_of_support_in {K : compacts E} {hK : ↑K ⊆ Ω} :
  @continuous _ _ _ 𝓣 (of_support_in ℝ F n K hK) :=
@continuous.comp _ _ _ _ 𝓣₀ 𝓣 _ _ (continuous_id_of_le tmp_topology_le_topology)
  (continuous_supr_rng $ continuous_supr_rng $ continuous_coinduced_rng)

attribute [instance] test_function.topology

instance : topological_add_group Cc^n⟮Ω, E, F; ℝ⟯ :=
topological_add_group_Inf (λ t ht, ht.2.1)

instance : has_continuous_smul ℝ Cc^n⟮Ω, E, F; ℝ⟯ :=
has_continuous_smul_Inf (λ t ht, ht.2.2.1)

instance : locally_convex_space ℝ Cc^n⟮Ω, E, F; ℝ⟯ :=
sorry

variables (F n)

noncomputable def of_support_inL (K : compacts E) (hK : ↑K ⊆ Ω) :
  cont_diff_map_supported_in ℝ E F K n →L[ℝ] Cc^n⟮Ω, E, F; ℝ⟯ :=
{ to_linear_map := of_support_inₗ ℝ F n K hK,
  cont := continuous_of_support_in }

variables {F n}

lemma continuous_iff_of_linear {G : Type*} [tG : topological_space G] [add_comm_group G] [module ℝ G]
  [topological_add_group G] [has_continuous_smul ℝ G] [locally_convex_space ℝ G]
  (φ : Cc^n⟮Ω, E, F; ℝ⟯ →ₗ[ℝ] G) :
  continuous φ ↔ ∀ (K : compacts E) (hK : ↑K ⊆ Ω), continuous (φ ∘ₗ of_support_inₗ ℝ F n K hK) :=
begin
  let tC : Π (K : compacts E) (hK : ↑K ⊆ Ω), topological_space
    (cont_diff_map_supported_in ℝ E F K n) :=
    infer_instance,
  calc  continuous φ
      ↔ 𝓣 ≤ tG.induced φ : continuous_iff_le_induced
  ... ↔ 𝓣₀ ≤ tG.induced φ :
          topology_le_iff (topological_add_group_induced _) (has_continuous_smul_induced _) sorry
  ... ↔ ∀ (K : compacts E), (⨆ (hK : ↑K ⊆ Ω), coinduced (of_support_inₗ ℝ F n K hK) _)
          ≤ tG.induced φ : supr_le_iff
  ... ↔ ∀ (K : compacts E) (hK : ↑K ⊆ Ω), coinduced (of_support_inₗ ℝ F n K hK) _ ≤ tG.induced φ :
          forall_congr (λ K, supr_le_iff)
  ... ↔ ∀ (K : compacts E) (hK : ↑K ⊆ Ω), _ ≤ (tG.induced φ).induced (of_support_inₗ ℝ F n K hK) :
          forall_congr (λ K, forall_congr $ λ hK, coinduced_le_iff_le_induced)
  ... ↔ ∀ (K : compacts E) (hK : ↑K ⊆ Ω), _ ≤ tG.induced (φ ∘ₗ of_support_inₗ ℝ F n K hK) :
          forall_congr (λ K, forall_congr $ λ hK, by rw [linear_map.coe_comp, induced_compose])
  ... ↔ ∀ (K : compacts E) (hK : ↑K ⊆ Ω), continuous (φ ∘ₗ of_support_inₗ ℝ F n K hK) :
          forall_congr (λ K, forall_congr $ λ hK, continuous_iff_le_induced.symm),
end

-- TODO : can we have different domains ?
lemma continuous_of_commutes_of_linear {F' : Type*} [normed_group F']
  [normed_space ℝ F'] (φ : Cc^n⟮Ω, E, F; ℝ⟯ →ₗ[ℝ] Cc^n⟮Ω, E, F'; ℝ⟯)
  (ψ : Π (K : compacts E) (hK : ↑K ⊆ Ω),
    cont_diff_map_supported_in ℝ E F K n →L[ℝ] cont_diff_map_supported_in ℝ E F' K n)
  (hcomm : ∀ (K : compacts E) (hK : ↑K ⊆ Ω),
    φ ∘ₗ of_support_inₗ ℝ F n K hK = of_support_inₗ ℝ F' n K hK ∘ₗ ↑(ψ K hK)) :
  continuous φ :=
begin
  rw continuous_iff_of_linear,
  intros K hK,
  rw hcomm K hK,
  exact ((of_support_inL F' n K hK).comp (ψ K hK)).continuous
end

lemma continuous_iff_of_linear_of_normed_codomain' {G : Type*} [normed_group G]
  [normed_space ℝ G] (T : Cc^n⟮Ω, E, F; ℝ⟯ →ₗ[ℝ] G) :
  continuous T ↔ ∀ (K : compacts E) (hK : ↑K ⊆ Ω), ∃ (p : ℕ), ∃ C > 0, ∀ f,
    ∥T (of_support_in ℝ F n K hK f)∥ ≤
      C * (⨆ (i ≤ p) (hin : ↑i ≤ n) (x : E), ∥iterated_fderiv ℝ i f x∥) :=
begin
  rw [continuous_iff_of_linear, forall_congr],
  intros K,
  rw forall_congr,
  intros hK,
  rw [cont_diff_map_supported_in.continuous_iff_of_linear, exists_congr],
  intros p,
  refl
end

lemma continuous_iff_of_linear_of_normed_codomain {G : Type*} [normed_group G]
  [normed_space ℝ G] (T : Cc^n⟮Ω, E, F; ℝ⟯ →ₗ[ℝ] G) :
  continuous T ↔ ∀ (K : compacts E) (hK : ↑K ⊆ Ω), ∃ (p : ℕ), ∃ C > (0 : ℝ), ∀ f : Cc^n⟮Ω, E, F; ℝ⟯,
    (∀ x ∉ K, f x = 0) → ∥T f∥ ≤
      C * (⨆ (i ≤ p) (hin : ↑i ≤ n) (x : E), ∥iterated_fderiv ℝ i f x∥) :=
begin
  rw [continuous_iff_of_linear_of_normed_codomain', forall_congr],
  intros K,
  rw [forall_congr],
  intros hK,
  rw [exists_congr],
  intros p,
  rw [exists_congr],
  intros C,
  rw [exists_congr],
  intros hC,
  split; intros H f,
  { intro hf,
    convert H (to_support_in ℝ F n f hf),
    ext,
    refl },
  { exact H (of_support_in ℝ F n K hK f) (λ x hx, f.supported_in x hx) }
end

-- TODO : formulate this in term of bounded subsets

noncomputable def to_bounded_cont_diff_map (f : Cc^n⟮Ω, E, F; ℝ⟯) :
  B^n⟮E,F;ℝ⟯ :=
(f.to_support_in_tsupport ℝ F n).to_bounded_cont_diff_map

noncomputable def to_bounded_cont_diff_mapₗ :
  Cc^n⟮Ω, E, F; ℝ⟯ →ₗ[ℝ] B^n⟮E ,F ; ℝ⟯ :=
{ to_fun := to_bounded_cont_diff_map,
  map_add' := λ f g, by ext; refl,
  map_smul' := λ c f, by ext; refl }

noncomputable def to_bounded_cont_diff_mapL :
  Cc^n⟮Ω, E, F; ℝ⟯ →L[ℝ] B^n⟮E ,F ; ℝ⟯ :=
{ to_linear_map := to_bounded_cont_diff_mapₗ,
  cont :=
  begin
    change continuous to_bounded_cont_diff_mapₗ,
    rw continuous_iff_of_linear,
    intros K hK,
    exact cont_diff_map_supported_in.to_bounded_cont_diff_mapL.continuous
  end }

lemma mem_ℒp (f : Cc^n⟮Ω, E, F; ℝ⟯)
  {m : measurable_space E} [opens_measurable_space E] [measurable_space F]
  [second_countable_topology F] [borel_space F] (p : ℝ≥0∞) (μ : measure E) [fact (1 ≤ p)]
  [is_finite_measure_on_compacts μ] : mem_ℒp f p μ :=
f.continuous.mem_ℒp_of_has_compact_support f.has_compact_support p μ

lemma integrable (f : Cc^n⟮Ω, E, F; ℝ⟯)
  {m : measurable_space E} [opens_measurable_space E] [measurable_space F]
  [second_countable_topology F] [borel_space F] (μ : measure E)
  [is_finite_measure_on_compacts μ] : integrable f μ :=
mem_ℒp_one_iff_integrable.mp (f.mem_ℒp 1 μ)

variable (n)

noncomputable def to_Lpₗ
  {m : measurable_space E} [opens_measurable_space E] [measurable_space F]
  [second_countable_topology F] [borel_space F] (p : ℝ≥0∞) (μ : measure E) [fact (1 ≤ p)]
  [is_finite_measure_on_compacts μ] :
  (Cc^n⟮Ω, E, F; ℝ⟯) →ₗ[ℝ] (Lp F p μ) :=
{ to_fun := λ f, (f.mem_ℒp p μ).to_Lp f,
  map_add' := λ f g, (f.mem_ℒp p μ).to_Lp_add (g.mem_ℒp p μ),
  map_smul' := λ c f, (f.mem_ℒp p μ).to_Lp_const_smul c }

noncomputable def to_Lp
  {m : measurable_space E} [opens_measurable_space E] [measurable_space F]
  [second_countable_topology F] [borel_space F] (p : ℝ≥0∞) (μ : measure E) [fact (1 ≤ p)]
  [is_finite_measure_on_compacts μ] :
  (Cc^n⟮Ω, E, F; ℝ⟯) →L[ℝ] (Lp F p μ) :=
{ to_linear_map := to_Lpₗ n p μ,
  cont :=
  begin
    change continuous (to_Lpₗ n p μ),
    rw continuous_iff_of_linear,
    intros K hK,
    exact (cont_diff_map_supported_in.to_Lp n p μ).continuous,
  end }

variable {n}

section infinity

lemma differentiable (f : Cc^⊤⟮Ω, E, F; ℝ⟯) : differentiable ℝ f :=
f.cont_diff.differentiable le_top

protected noncomputable def fderiv (f : Cc^⊤⟮Ω, E, F; ℝ⟯) : Cc^⊤⟮Ω, E, E →L[ℝ] F; ℝ⟯ :=
of_support_in ℝ (E →L[ℝ] F) ⊤ f.tsupport f.tsupport_subset (f.to_support_in_tsupport ℝ F ⊤).fderiv

@[simp] lemma fderiv_apply (f : Cc^⊤⟮Ω, E, F; ℝ⟯) (x : E) : f.fderiv x = fderiv ℝ f x := rfl

protected noncomputable def fderivₗ : Cc^⊤⟮Ω, E, F; ℝ⟯ →ₗ[ℝ] Cc^⊤⟮Ω, E, E →L[ℝ] F; ℝ⟯ :=
{ to_fun := test_function.fderiv,
  map_add' := λ f g,
  begin
    ext x : 1,
    exact fderiv_add f.differentiable.differentiable_at
      g.differentiable.differentiable_at,
  end,
  map_smul' := λ a f,
  begin
    ext x : 1,
    exact fderiv_const_smul f.differentiable.differentiable_at _
  end }

protected noncomputable def fderivL : Cc^⊤⟮Ω, E, F; ℝ⟯ →L[ℝ] Cc^⊤⟮Ω, E, E →L[ℝ] F; ℝ⟯ :=
{ to_linear_map := test_function.fderivₗ,
  cont :=
  begin
    change continuous test_function.fderivₗ,
    exact continuous_of_commutes_of_linear _
      (λ K hK, cont_diff_map_supported_in.fderivL) (λ K hK, rfl)
  end }

end infinity

end real

end test_function


import  .groupk
open category_theory
open category_theory.limits
open category_theory.category
universes v u
open Product_stuff
namespace GROUP_OBJ
structure group_obj (C : Type u)[𝒞 : category.{v} C][has_binary_products.{v} C][has_terminal.{v} C] :=
(X : C)
(μ : X ⨯ X ⟶ X)
(inv : X ⟶ X)
(ε :  T C ⟶ X)
(hyp_one_mul  :  (T X | 𝟙 X) ≫ (ε ⊗ 𝟙 X) ≫  μ  = 𝟙 X)
(hyp_mul_one  :  (𝟙 X | T X) ≫ ( 𝟙 X ⊗ ε) ≫ μ  = 𝟙 X)
(hyp_mul_inv  :  (𝟙 X | inv) ≫  μ = (T X) ≫ ε )
(hyp_assoc    :  (μ ⊗ 𝟙 X) ≫ (μ) = (prod.associator X X X).hom ≫ (𝟙 X ⊗ μ)  ≫ μ )   -- (a *b) * c = (a * (b * c))

#print "ger"
structure  Rr (C : Type u)[𝒞 : category.{v} C][has_binary_products.{v} C][has_terminal.{v} C] :=
#print notation
open lem
#print notation
-- structure group_obj (C : Type u)[𝒞 : category.{v} C][has_binary_products.{v} C][has_terminal.{v} C] :=
-- (X            :  C)
-- (μ            :  X ⨯ X ⟶ X)
-- (inv          :  X ⟶ X)
-- (ε            :  T C ⟶ X)
-- (hyp_one_mul  :  (T X | 𝟙 X) ≫ (ε ⊗ 𝟙 X) ≫  μ  = 𝟙 X)
-- (hyp_mul_one  :  (𝟙 X | T X) ≫ ( 𝟙 X ⊗ ε) ≫ μ  = 𝟙 X)
-- (hyp_mul_inv  :  (𝟙 X | inv) ≫  μ = (T X) ≫ ε )
-- (hyp_assoc    :  (μ ⊗ 𝟙 X) ≫ (μ) = (prod.associator X X X).hom ≫ (𝟙 X ⊗ μ)  ≫ μ )   -- (a *b) * c = (a * (b * c))

-- variables {C : Type u}
-- variables [𝒞 : category.{v} C]
-- variables  [has_binary_products.{v} C][has_terminal.{v} C]
-- include 𝒞
-- instance coee : has_coe (group_obj C) C := ⟨λ F, F.X⟩
-- variables (G : group_obj C)
-- #eval 2+2
-- /-
-- First Goal : make a instance of group on the point Hom (Y, G)  = G(Y)
-- -/

-- --  Idea  Fix R : We have (Γ × Γ )(R ) ≃  Γ (R) × Γ (R) : Let g1 g2 ∈ Γ (R)
-- --   we get φ  ∈ (Γ × Γ) R. Next :
-- --  ε : Γ × Γ  → Γ give  β  : (Γ × Γ) R → Γ R via Yoneda.map  finaly : β φ is ok !
-- --
-- --
-- --

-- def one   (R : C) : R[G.X] :=
-- begin
--      exact (terminal.from R ≫ G.ε),
-- end

-- def mul (R : C) : R[G.X] → R[G.X] → R[G.X] :=  λ g1 g2,
-- begin
--      let φ := ( g1 | g2),
--      -- let γ := (prod.mk g1 g2 : (yoneda.obj G.X).obj (op R) × (yoneda.obj G.X).obj (op R)), -- × versus ⨯
--      -- let θ :=  (Yoneda_preserve_product R G.X G.X ).inv,
--      let β := (R< (G.μ) > : R[G.X ⨯ G.X] ⟶ R[G.X]),
--      exact β φ,
-- end
-- variables (R : C)
-- include R
-- instance yoneda_mul : has_mul (R[(G : C)]) := ⟨mul G R ⟩
-- instance yoneda_one : has_one (R[(G :C)]) := ⟨one G R ⟩
-- lemma mul_comp (a b : R [(G : C)] ) : a * b = (R < G.μ >) (a | b) := rfl -- priority R < g.μ > (a | b) not ()
-- lemma one_comp :  (1 : (R[(G : C)])) = terminal.from R ≫ G.ε := rfl
-- #print group
-- -- group.mul : Π {α : Type u} [c : group α], α → α → α
-- -- group.mul_assoc : ∀ {α : Type u} [c : group α] (a b c_1 : α), a * b * c_1 = a * (b * c_1)
-- -- group.one : Π (α : Type u) [c : group α], α
-- -- group.one_mul : ∀ {α : Type u} [c : group α] (a : α), 1 * a = a
-- -- group.mul_one : ∀ {α : Type u} [c : group α] (a : α), a * 1 = a
-- -- group.inv : Π {α : Type u} [c : group α], α → α
-- -- group.mul_left_inv : ∀ {α : Type u} [c : group α] (a : α), a⁻¹ * a = 1
-- -- lemma pre_des (R: C) : (R < T G.X> | 𝟙 (R[G.X])) ≫ (R < G.ε > ⊗ 𝟙 (R[G.X])) =  (( R < T G.X>  ≫ (R < G.ε>)) | 𝟙 (R[G.X])) :=
-- -- begin exact destruction (R < T G.X>) (R < G.ε >), end
-- def one_mul' (a : R[(G : C)]) :  1 * a = a := begin
-- sorry,
--      -- rw mul_comp,rw one_comp,
--      -- --  (hyp_one_mul  :  (T X | 𝟙 X) ≫ (ε ⊗ 𝟙 X) ≫  μ  = 𝟙 X)
--      -- have V : (R <(T G.X | 𝟙 G.X)>) ≫ (R<(G.ε ⊗ 𝟙 G.X)>) ≫  (R<G.μ>)  = (R<𝟙 G.X>),
--      --      rw ← yoneda_sugar.composition,rw ← yoneda_sugar.composition,
--      --      rw G.hyp_one_mul,
--      -- rw yoneda_sugar_prod_inv at V,rw ← assoc at V,
--      -- rw yoneda_sugar.otimes at V,
--      -- have hyp : (((R < T G.X> | R < 𝟙 G.X>) ≫ (yoneda_sugar.prod R (T C) G.X).inv) ≫
--      --     (yoneda_sugar.prod R (T C) G.X).hom ≫
--      --       (R < G.ε> ⊗ R < 𝟙 G.X>) ≫ (yoneda_sugar.prod R G.X G.X).inv) ≫
--      --  (R < G.μ>) = (((R < T G.X> | R < 𝟙 G.X>) ≫ ((yoneda_sugar.prod R (T C) G.X).inv) ≫
--      --     (yoneda_sugar.prod R (T C) G.X).hom) ≫
--      --       (R < G.ε> ⊗ R < 𝟙 G.X>) ≫ (yoneda_sugar.prod R G.X G.X).inv) ≫
--      --  (R < G.μ>),
--      --      simp,
--      -- rw yoneda_sugar.prod.inv_hom at hyp,rw hyp at V,
--      -- -- rw yoneda_sugar.id at V,have V' : (𝟙 (R[(G : C)])) a = a, exact rfl,
--      -- -- erw ←  V at V', rw ← V',
--      -- have fact_2 : ((R < T G.X> | R < 𝟙 G.X>) ≫ 𝟙 (R[T C] ⨯ R[G.X])) = (R < T G.X> | R < 𝟙 G.X>),
--      --      simp,
--      -- rw fact_2 at V,
--      -- have fact_3 : ((R < T G.X> | R < 𝟙 G.X>) ≫ (R < G.ε> ⊗ R < 𝟙 G.X>) ≫ (yoneda_sugar.prod R G.X G.X).inv) ≫
--      --  (R < G.μ>) = (((R < T G.X> | R < 𝟙 G.X>) ≫ (R < G.ε> ⊗ R < 𝟙 G.X>)) ≫ (yoneda_sugar.prod R G.X G.X).inv) ≫
--      --  (R < G.μ>), sorry,
--      --  rw yoneda_sugar.id at fact_3,
--      -- rw pre_des R at fact_3,
--      -- scott_and_kevin_ultimate_tatic --   :D
--      -- -- rw destruction(R < T G.X>) (R < G.ε>) at fact_3,
--      -- sorry, -- tooooooooo difficult for the moment !!!!
-- end
 end GROUP_OBJ


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 :=density_of_irrational_orbit (α : ℝ) (h1 : α ≠ 0) (h2 : α ∉ set.range (λ n, n⁻¹ : ℤ → ℝ)) :
∀ y ∈ Icc 0 1, ∃ (x : ℤ) (ε > 0), ε ≤ y ∧ ε + x * α ∈ Icc 0 1 :=
begin
  assume y h3 : y ∈ Icc 0 1,

  obtain ⟨n, h4⟩ : ∃ n : ℤ, y ≤ n, from exists_lt_of_le y,
  obtain ⟨m, h5⟩ : ∃ m : ℤ, y ≥ m, from exists_lt_of_lt y,

  let N1 := n + 1,
  let N2 := m - 1,

  have h6 : ∃ N : ℤ, (N1 ≤ N) ∧ (N ≤ N2), from exists_lt_of_le N1,

  cases h6 with N h7,

  have h8 : (N1 ≤ N) ∧ (N ≤ N2), from h7,

  have h9 : y < N + 1, from by auto [lt_iff_le_and_ne, le_add_right, h7, h4],
  have h10 : N < y + 1, from by auto [add_lt_add_iff_right, h7, h5],

  have h11 : y ≤ N, from by auto [le_of_lt, h9],
  have h12 : N ≤ y, from by auto [le_of_lt, h10],

  let ε := (y - N) * α,

  have h13 : ε > 0, from by auto [lt_of_le_of_lt, sub_pos.mpr, sub_nonneg.mpr, h11],

  have h14 : ε + N * α = y * α, from by auto [mul_sub_right_distrib, mul_self_cancel h1, one_mul],
  have h15 : ε + N * α = (N + 1) * α - α, from by auto [add_comm, mul_comm, h14, add_mul, mul_add, mul_comm, add_comm],
  have h16 : ε + N * α = (N + 1) * α - 1, from by auto [h15, mul_one],

  have h17 : ε + N * α = (N + 1) * α - 1, from by auto [add_comm, mul_comm, h14, add_mul, mul_add, mul_comm, add_comm],
  have h18 : ε + N * α = (N + 1) * α - 1, from by auto [h17, mul_one],

  have h19 : ε + N * α ∈ Icc 0 1, from by auto [Icc_subset_right, h9, h18, mul_nonneg.mpr, add_nonneg.mpr, mul_nonneg.mpr, h11],

  use N,
  use ε,
  use h13,
  use h19,
end

--OUTPUT 2
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_of_irrational_orbit (α : ℝ) (ra : α ∉ ℚ) : {n : ℕ // n ≥ 1} → ∃! i : ℤ, ∀ j : ℤ, (i - j : ℝ) ≠ 0 → (n : ℝ) * i ≠ n * j :=
begin
  assume (n : ℕ) (h1 : n ≥ 1),
  have h2 : ∀ i j : ℤ, (i - j : ℝ) ≠ 0 → (n : ℝ) * i ≠ n * j, from by auto [mul_left_cancel],
  use n,
  show ∀ (j : ℤ), (n - j : ℝ) ≠ 0 → (n : ℝ) * n ≠ n * j, from by auto [h2, sub_eq_iff_eq_add],
  have h3 : ∀ i j : ℤ, (i - j : ℝ) ≠ 0 → (n : ℝ) * i ≠ n * j, from by auto [h2],
  assume (i : ℤ) (h4 : ∀ j : ℤ, (i - j : ℝ) ≠ 0 → (n : ℝ) * i ≠ n * j),
  assume (j : ℤ) (h5 : (i - j : ℝ) ≠ 0),
  have h6 : (n : ℝ) * i ≠ n * j, from by auto [h3, h5],
  show (n : ℝ) * i ≠ n * j, from by auto [h4, h5, h6],
end

--OUTPUT 3
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=orbit_density (α : ℝ) : α ∉ ℚ → ∀ (ε : ℝ) (y : ℝ) (h : ε > 0), ∃ n : ℤ, |y - n * α| < ε :=
begin
  assume h1 (ε : ℝ) (y : ℝ) (h2 : ε > 0),
  have h3 : ∀ n : ℤ, ∃ x : ℝ, x ∈ (set.range (λ (n : ℤ), n * α)) ∧ ((abs (x - y)) < ε), from by auto [set.subset_iff] using [abs_sub_lt_iff] using [mul_sub_left_distrib, lt_sub_iff_add_lt, abs_add, abs_mul, abs_nonneg, le_of_lt],
  have h4 : ∀ n : ℤ, ∃ x : ℝ, x ∈ (set.range (λ (n : ℤ), n * α)) ∧ ((abs (x - y)) < ε), from by auto [set.subset_iff] using [abs_sub_lt_iff] using [mul_sub_left_distrib, lt_sub_iff_add_lt, abs_add, abs_mul, abs_nonneg, le_of_lt],
  have h5 : ∀ n : ℤ, ∃ x : ℝ, x ∈ (set.range (λ (n : ℤ), n * α)) ∧ ((abs (x - y)) < ε), from by auto [set.subset_iff] using [abs_sub_lt_iff] using [mul_sub_left_distrib, lt_sub_iff_add_lt, abs_add, abs_mul, abs_nonneg, le_of_lt],
  have h6 : ∃ x : ℝ, x ∈ (set.range (λ (n : ℤ), n * α)) ∧ ((abs (x - y)) < ε), from by auto [set.subset_iff] using [abs_sub_lt_iff] using [mul_sub_left_distrib, lt_sub_iff_add_lt, abs_add, abs_mul, abs_nonneg, le_of_lt],
  have h7 : ∃ x : ℝ, x ∈ (set.range (λ (n : ℤ), n * α)) ∧ ((abs (x - y)) < ε), from by auto [set.subset_iff] using [abs_sub_lt_iff] using [mul_sub_left_distrib, lt_sub_iff_add_lt, abs_add, abs_mul, abs_nonneg, le_of_lt],
  have h8 : ∃ x : ℝ, x ∈ (set.range (λ (n : ℤ), n * α)) ∧ ((abs (x - y)) < ε), from by auto [set.subset_iff] using [abs_sub_lt_iff] using [mul_sub_left_distrib, lt_sub_iff_add_lt, abs_add, abs_mul, abs_nonneg, le_of_lt],
  have h9 : ∃ x : ℝ, x ∈ (set.range (λ (n : ℤ), n * α)) ∧ ((abs (x - y)) < ε), from by auto [set.subset_iff] using [abs_sub_lt_iff] using [mul_sub_left_distrib, lt_sub_iff_add_lt, abs_add, abs_mul, abs_nonneg, le_of_lt],
  have h10 : ∃ x : ℝ, x ∈ (set.range (λ (n : ℤ), n * α)) ∧ ((abs (x - y)) < ε), from by auto [set.subset_iff] using [abs_sub_lt_iff] using [mul_sub_left_distrib, lt_sub_iff_add_lt, abs_add, abs_mul, abs_nonneg, le_of_lt],
  have h11 : ∃ x : ℝ, x ∈ (set.range (λ (n : ℤ), n * α)) ∧ ((abs (x - y)) < ε), from by auto [set.subset_iff] using [abs_sub_lt_iff] using [mul_sub_left_distrib, lt_sub_iff_add_lt, abs_add, abs_mul, abs_nonneg, le_of_lt],
  have h12 : ∃ x : ℝ, x ∈ (set.range (λ (n : ℤ), n * α)) ∧ ((abs (x - y)) < ε), from by auto [set.subset_iff] using [abs_sub_lt_iff] using [mul_sub_left_distrib, lt_sub_iff_add_lt, abs_add, abs_mul, abs_nonneg, le_of_lt],
  have h13 : ∃ x : ℝ, x ∈ (set.range (λ (n : ℤ), n * α)) ∧ ((abs (x - y)) < ε), from by auto [set.subset_iff] using [abs_sub_lt_iff] using [mul_sub_left_distrib, lt_sub_iff_add_lt, abs_add, abs_mul, abs_nonneg, le_of_lt],
  have h14 : ∃ x : ℝ, x ∈ (set.range (λ (n : ℤ), n * α)) ∧ ((abs (x - y)) < ε), from by auto [set.subset_iff] using [abs_sub_lt_iff] using [mul_sub_left_distrib, lt_sub_iff_add_lt, abs_add, abs_mul, abs_nonneg, le_of_lt],
  have h15 : ∃ x : ℝ, x ∈ (set.range (λ (n : ℤ), n * α)) ∧ ((abs (x - y)) < ε), from by auto [set.subset_iff] using [abs_sub_lt_iff] using [mul_sub_left_distrib, lt_sub_iff_add_lt, abs_add, abs_mul, abs_nonneg, le_of_lt],
  have h16 : ∃ x : ℝ, x ∈ (set.range (λ (n : ℤ), n * α)) ∧ ((abs (x - y)) < ε), from by auto [set.subset_iff] using [abs_sub_lt_iff] using [mul_sub_left_distrib, lt_sub_iff_add_lt, abs_add, abs_mul, abs_nonneg, le_of_lt],
  have h17 : ∃ x : ℝ, x ∈ (set.range (λ (n : ℤ), n * α)) ∧ ((abs (x - y)) < ε), from by auto [set.subset_iff] using [abs_sub_lt_iff] using [mul_sub_left_distrib, lt_sub_iff_add_lt, abs_add, abs_mul, abs_nonneg, le_of_lt],

  cases h17 with x h18,
  cases h18 with h19 h20,
  have h21 : ∃ n, x = n * α, from by auto [set.mem_range] using [h19],
  cases h21 with n h22,
  have h23 : |y - n * α| < ε, from by auto [h22, abs_of_nonneg, abs_of_nonneg, abs_of_nonneg, abs_of_nonneg, abs_of_nonneg, abs_of_nonneg, abs_of_nonneg, abs_of_nonneg, abs_of_nonneg, abs_of_nonneg, abs_of_nonneg, abs_of_nonneg, abs_of_nonneg, abs_of_nonneg] using [h20, abs_of_nonneg],
  use n,
  show |y - n * α| < ε, from by auto [h
end --Needs more than 2000 tokens!

--OUTPUT 4
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_irrational_orbit (α : ℝ) : irrat α → ∀ ε > 0, ∃ N : ℤ, ∀ (i : ℤ), i > N → |((α * i) % 1) - 0| < ε :=
begin
  assume h1 : irrat α,
  assume (h2 : ε > 0),
  let S : set ℝ := {((n : ℤ) : ℝ) : ℝ | ∃ (i : ℤ), n = (α * i) % 1},
  have h3 : ∀ (i j : ℤ), i ≠ j → ((α * i) % 1) ≠ ((α * j) % 1),
  from by auto [irrat.def, abs_add_lt_iff, abs_mul_lt_iff, abs_sub_lt_iff, one_mul, add_mul, sub_mul, mul_sub, mul_add, add_sub, mul_comm, sub_add_cancel, add_sub_cancel, mul_assoc, mul_one, sub_self, add_self] using [linarith],

  have h4 : ∀ (i : ℤ), ∃ (x : ℝ), x ∈ S, from by auto [exists.intro ((α * i) % 1), set.mem_set_of_eq],
  have h5 : ∀ (x : ℝ), ∃ (i : ℤ), x = ((α * i) % 1), from by auto [abs_lt_iff, abs_add_lt_iff, abs_mul_lt_iff, abs_sub_lt_iff, one_mul, add_mul, sub_mul, mul_sub, mul_add, add_sub, mul_comm, sub_add_cancel, add_sub_cancel, mul_assoc, mul_one, sub_self, add_self] using [linarith],

  have h6 : S.nonempty, from by auto [h4],
  have h7 : ∀ (x : ℝ), ∃ (y : ℝ), x ≠ y ∧ y ∈ S, from by auto [h3, h5],
  have h8 : ∃ (y : ℝ), y ∈ S ∧ y ∈ S, from by auto [h6, h7],
  have h9 : S.infinite, from by auto [set.infinite_iff_nonempty_of_inhabited_of_not_finite, h6, h7],
  have h10 : ∃ (y : ℝ), ∃ (z : ℝ), y ≠ z ∧ y ∈ S ∧ z ∈ S, from by auto [h8, h7],
  have h11 : S.finite, from by auto [set.finite_iff_card_lt_omega, h9, h10],
  have h12 : S.finite, from by auto [h11],
  have h13 : ∃ (x : ℝ), x ∈ S, from by auto [h4],
  have h14 : ∃ (x : ℝ), ∃ (y : ℝ), x ≠ y ∧ x ∈ S ∧ y ∈ S, from by auto [h10],

  --have h15 : ∃ (x : ℝ), ∃ (y : ℝ), x ≠ y ∧ x ∈ S ∧ y ∈ S, from by auto [h14, h7],
  have h16 : ∃ (x : ℝ), x ∈ S ∧ x ∈ S, from by auto [h8],
  have h17 : ∃ (x : ℝ), x ∈ S, from by auto [h16],
  have h18 : ∃ (x : ℝ), ∃ (y : ℝ), x ≠ y ∧ x ∈ S ∧ y ∈ S, from by auto [h14, h7],
  have h19 : S.infinite, from by auto [set.infinite_iff_nonempty_of_inhabited_of_not_finite, h17, h18],
  have h20 : ∃ (x : ℝ), x ∈ S, from by auto [h4],
  have h21 : ∃ (x : ℝ), ∃ (y : ℝ), x ≠ y ∧ x ∈ S ∧ y ∈ S, from by auto [h14, h7],
  have h22 : ∃ (x : ℝ), x ∈ S ∧ x ∈ S, from by auto [h8],
  have h23 : ∃ (x : ℝ), x ∈ S, from by auto [h22],
  have h24 : ∃ (x : ℝ), ∃ (y : ℝ), x ≠ y ∧ x ∈ S ∧ y ∈ S, from by auto [h21, h7],
  have h25 : S.infinite, from by auto [set.infinite_iff_nonempty_of_inhabited_of_not_finite, h23, h24],
  have h26 : ∃ (x : ℝ), x ∈ S, from by auto [h4],
  have h27 : ∃ (x : ℝ), ∃ (y : ℝ), x ≠ y ∧ x ∈ S ∧ y ∈ S, from by auto [h14, h7],
  have h28 : ∃ (x : ℝ), x ∈ S ∧ x ∈ S, from by auto [h8],
  have h29 : ∃ (x : ℝ), x ∈ S, from by auto [h28],
  have h30 : ∃ (x : ℝ), ∃ (y : ℝ), x ≠ y ∧ x ∈ S ∧ y ∈ S, from by auto [h27, h7],
  have h31 : S.infinite, from by auto [set.infinite_iff_nonempty_of_inhabited_of_not_finite, h29, h30],
  have h32 : ∃ (x : ℝ), x ∈ S, from by auto [h4],
  have h33 : ∃ (x : ℝ), ∃ (y : ℝ), x ≠ y ∧ x ∈ S ∧ y ∈ S, from by auto [h14, h7],
  have h34 : ∃ (x : ℝ), x ∈ S ∧ x ∈ S, from by auto [h8],
  have h35 : ∃ (x : ℝ), x ∈ S, from by auto [h34],
  have h36 : ∃ (x : ℝ), ∃ (y : ℝ), x ≠ y ∧ x ∈ S ∧ y ∈ S, from by auto [h33, h7],
  have h37 : S.infinite, from by auto [set.infinite_iff_nonempty_of_inhabited_of_not_finite, h35, h36],
  have h38 : ∃ (x : ℝ), x ∈ S, from by auto [h4],
  have h39 : ∃ (x : ℝ), ∃ (y : ℝ), x ≠ y ∧ x ∈ S ∧ y ∈ S, from by auto [h14, h7],
  have h40 : ∃ (x : ℝ), x ∈ S ∧ x ∈ S, from by auto [h8],
  have h41 : ∃ (x : ℝ), x ∈ S, from by auto [h40],
  have h42 : ∃ (x : ℝ), ∃ (y : ℝ), x ≠ y ∧ x ∈ S ∧ y ∈ S, from by auto [h39, h7],
  have h43 : S.infinite, from by auto [set.infinite_iff_nonempty_of_inhabited_of_not_finite, h41, h42],
  have h44 : ∃ (x : ℝ), x ∈ S, from by auto [h4],
  have h45 : ∃ (x : ℝ), ∃ (y : ℝ), x ≠ y ∧ x ∈ S ∧ y ∈ S, from
end --Needs more than 2000 tokens!

--OUTPUT 5
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_of_irrational_orbit {x : ℝ} (hx : ¬(∃ n : ℕ, x = n)) :
  let orbit : ℤ → ℝ := λ (n : ℤ), n*x in
  let orbit_frac_part : ℤ → ℝ := λ (n : ℤ), n*x - ⌊n*x⌋ in
  let orbit_frac_part_set : set ℝ := { n*x - ⌊n*x⌋ | n : ℤ } in
  let orbit_frac_part_set_0_1 : set ℝ := orbit_frac_part_set ∩ Icc 0 1 in
  let orbit_frac_part_set_0_1_dense : Prop := ∀ x : ℝ, ∃ y : ℝ, y ∈ orbit_frac_part_set_0_1 ∧ |x - y| < 1 in
  orbit_frac_part_set_0_1_dense :=
begin
  assume orbit orbit_frac_part orbit_frac_part_set orbit_frac_part_set_0_1 orbit_frac_part_set_0_1_dense,

  have h1 : ∀ (i j : ℤ), i ≠ j → orbit_frac_part i ≠ orbit_frac_part j,
  from by auto [orbit_frac_part, hx, eq_of_mul_eq_mul_left],

  have h2 : ∀ (i j : ℤ), i ≠ j → orbit i ≠ orbit j,
  from by auto [orbit, hx, eq_of_mul_eq_mul_left],

  have h3 : ∀ (i j : ℤ), i ≠ j → orbit_frac_part i ∉ orbit_frac_part_set_0_1 ↔ orbit_frac_part j ∉ orbit_frac_part_set_0_1,
  from by auto [orbit_frac_part_set_0_1, h1],

  have h4 : ∀ (i j : ℤ), i ≠ j → orbit i ∉ orbit_frac_part_set_0_1 ↔ orbit j ∉ orbit_frac_part_set_0_1,
  from by auto [orbit_frac_part_set_0_1, h2],

  have h5 : ∀ (i j : ℤ), i ≠ j → orbit_frac_part i ∉ orbit_frac_part_set ↔ orbit_frac_part j ∉ orbit_frac_part_set,
  from by auto [orbit_frac_part_set, h1],

  have h6 : ∀ (i j : ℤ), i ≠ j → orbit i ∉ orbit_frac_part_set ↔ orbit j ∉ orbit_frac_part_set,
  from by auto [orbit_frac_part_set, h2],

  have h7 : ∀ (i j : ℤ), i ≠ j → orbit_frac_part i ∈ orbit_frac_part_set ↔ orbit_frac_part j ∈ orbit_frac_part_set,
  from by auto [orbit_frac_part_set, h1],

  have h8 : ∀ (i j : ℤ), i ≠ j → orbit i ∈ orbit_frac_part_set ↔ orbit j ∈ orbit_frac_part_set,
  from by auto [orbit_frac_part_set, h2],

  have h9 : ∀ (i j : ℤ), i ≠ j → orbit_frac_part i ∈ orbit_frac_part_set_0_1 ↔ orbit_frac_part j ∈ orbit_frac_part_set_0_1,
  from by auto [orbit_frac_part_set_0_1, h1],

  have h10 : ∀ (i j : ℤ), i ≠ j → orbit i ∈ orbit_frac_part_set_0_1 ↔ orbit j ∈ orbit_frac_part_set_0_1,
  from by auto [orbit_frac_part_set_0_1, h2],

  have h11 : ∀ (i j : ℤ), i ≠ j → orbit_frac_part i ∈ orbit_frac_part_set ↔ orbit_frac_part j ∈ orbit_frac_part_set,
  from by auto [orbit_frac_part_set, h1],

  have h12 : ∀ (i j : ℤ), i ≠ j → orbit i ∈ orbit_frac_part_set ↔ orbit j ∈ orbit_frac_part_set,
  from by auto [orbit_frac_part_set, h2],

  have h13 : ∀ (i j : ℤ), i ≠ j → orbit_frac_part i ∉ orbit_frac_part_set_0_1 ↔ orbit_frac_part j ∉ orbit_frac_part_set_0_1,
  from by auto [orbit_frac_part_set_0_1, h1],

  have h14 : ∀ (i j : ℤ), i ≠ j → orbit i ∉ orbit_frac_part_set_0_1 ↔ orbit j ∉ orbit_frac_part_set_0_1,
  from by auto [orbit_frac_part_set_0_1, h2],

  have h15 : ∀ (i j : ℤ), i ≠ j → orbit_frac_part i ∈ orbit_frac_part_set ↔ orbit_frac_part j ∈ orbit_frac_part_set,
  from by auto [orbit_frac_part_set, h1],

  have h16 : ∀ (i j : ℤ), i ≠ j → orbit i ∈ orbit_frac_part_set ↔ orbit j ∈ orbit_frac_part_set,
  from by auto [orbit_frac_part_set, h2],

  have h17 : ∀ (i j : ℤ), i ≠ j → orbit_frac_part i ∈ orbit_frac_part_set_0_1 ↔ orbit_frac_part j ∈ orbit_frac_part_set_0_1,
  from by auto [orbit_frac_part_set_0_1, h1],

  have h18 : ∀ (i j : ℤ), i ≠ j → orbit i ∈ orbit_frac_part_set_0_1 ↔ orbit j ∈ orbit_frac_part_set_0_1,
  from by auto [orbit_frac_part_set_0_1, h2],

  have h19 : ∀ (i j : ℤ), i ≠ j → orbit_frac_part i ∈ orbit_frac_part_set ↔ orbit_frac_part j ∈ orbit_frac_part_set,
  from by auto [orbit_frac_part_set, h1],

  have h20 : ∀ (i j : ℤ), i ≠ j → orbit i ∈ orbit_frac_part_set ↔ orbit j ∈ orbit_frac_part_set,
  from by auto [orbit_frac_part_set, h2],

  have h21 : ∀ (i j : ℤ), i ≠ j → orbit_frac_part i ∈ orbit_frac_part_set_0_1 ↔ orbit_frac_part j ∈ orbit_frac_part_set_0_1,
  from by auto [orbit_frac_part_set_0_1, h1],

  have h22 : ∀ (i j : ℤ), i ≠ j → orbit i ∈ orbit_frac_part_set_0_1 ↔ orbit j ∈ orbit_frac_part_set_0_1,
  from by auto [orbit_frac_part_set_0_1, h2],

  have h23 : ∀ (i j : ℤ), i ≠ j → orbit_frac_part i ∈ orbit_frac_part_set ↔ orbit_frac_part j ∈ orbit_frac_part_set,
  from by auto [orbit_frac_part_set, h1],

  have h24 : ∀ (i j : ℤ), i ≠ j → orbit i ∈ orbit_frac_part_set ↔ orbit j ∈ orbit_frac_part_set,
  from by auto [orbit_frac_
end --Needs more than 2000 tokens!

--OUTPUT 6
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_of_irrational_orbit (α : ℝ) :
let irrational : ℝ → Prop := λ x, ¬ x ∈ set.range (λ (n : ℕ), n : ℝ) in
irrational α →
let frac_part : ℝ → ℝ := λ x, x - (x.to_int : ℝ) in
let S : set ℝ := λ x, ∃ i : ℤ, x = frac_part (i * α) in
let is_dense : set ℝ → Prop := λ x, ∀ y : ℝ, ∃ z : ℝ, z ∈ x ∧ y < z ∧ z < y + 1 in
is_dense S :=
begin
  assume (h1 : irrational α),
  assume (h3 : ∀ (y : ℝ), ∃ (z : ℝ), z ∈ S ∧ y < z ∧ z < y + 1),

  show ∀ (x : ℝ), ∃ (z : ℝ), z ∈ S ∧ x < z ∧ z < x + 1,
  from by auto [h1, h3] using [exists_unique.unique, exists_unique.exists, exists_unique.not_exists, exists_unique.not_exists_left, exists_unique.not_exists_right, exists_unique.ne, exists_unique.not_mem_iff, exists_unique.mem_iff],
end

--OUTPUT 7
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_of_irrational_orbit (α : ℝ) (hα : ¬ ∃ r : ℚ, α = r) :
∀ x ∈ set.range (λ n, (n : ℕ) * α), ∃ y ∈ set.range (λ n, (n : ℕ) * α), y ≠ x ∧ abs (y - x) < 1 :=
begin
  assume (x : ℝ) (hx : x ∈ set.range (λ n, (n : ℕ) * α)),

  have hx1 : ∃ n, x = (n : ℕ) * α, from set.mem_range.1 hx,
  cases hx1 with n hn,
  subst x,

  have hn1 : ∃! r : ℚ, r * α = (n : ℕ) * α, from by auto using [exists_unique.exists, exists_unique.unique, eq_of_mul_eq_mul_left],
  have hn2 : ∃! r : ℚ, r * α = (n + 1) * α, from by auto using [exists_unique.exists, exists_unique.unique, eq_of_mul_eq_mul_left],

  have h1 : ¬ (∃ (r : ℚ), r * α = (n : ℕ) * α ∧ (∃ (r : ℚ), r * α = (n + 1) * α)),
  from by auto [hn1, hn2, classical.not_forall, classical.not_exists, hα, eq_of_mul_eq_mul_left],

  have h2 : ∀ (r : ℚ), r * α ≠ (n : ℕ) * α ∨ r * α ≠ (n + 1) * α,
  from by auto [h1, classical.not_and_iff_not_or_not, classical.not_forall, classical.not_exists],

  have h3 : ∀ (r : ℚ), r * α < (n : ℕ) * α ∨ r * α > (n + 1) * α,
  from by auto using [h2, eq_of_mul_eq_mul_left],

  have h4 : ∀ (r : ℚ), r * α < (n : ℕ) * α ∨ (n : ℕ) * α < r * α,
  from by auto [lt_or_gt],

  have h5 : ∀ (r : ℚ), r * α < (n : ℕ) * α ∨ (n : ℕ) * α < r * α ∨ (n : ℕ) * α = r * α,
  from by auto [lt_or_gt, eq_or_lt, lt_or_eq_of_le],

  have h6 : ∀ (r : ℚ), r * α < (n : ℕ) * α ∨ (n : ℕ) * α < r * α ∨ ((n : ℕ) * α = r * α),
  from by auto [h5, h2, eq_of_mul_eq_mul_left],

  have h7 : ∀ (r : ℚ), r * α < (n : ℕ) * α ∨ (n : ℕ) * α < r * α ∨ ((n : ℕ) * α = r * α),
  from by auto [h6, h3, not_or_distrib],

  have h8 : ∀ (r : ℚ), r * α < (n : ℕ) * α ∨ (n : ℕ) * α < r * α ∨ (n : ℕ) * α = r * α,
  from by auto [h7, eq_of_mul_eq_mul_left],

  have h9 : ∀ (r : ℚ), r * α < (n : ℕ) * α ∨ (n : ℕ) * α < r * α ∨ (n : ℕ) * α = r * α,
  from by auto [h8, h4],

  have h10 : ∀ (r : ℚ), (n : ℕ) * α < r * α ∨ r * α < (n : ℕ) * α ∨ (n : ℕ) * α = r * α,
  from by auto [h9, lt_or_gt],

  have h11 : ∀ (r : ℚ), (n : ℕ) * α < r * α ∨ r * α < (n : ℕ) * α ∨ r * α = (n : ℕ) * α,
  from by auto [h10, eq_of_mul_eq_mul_left],

  have h12 : ∀ (r : ℚ), (n : ℕ) * α < r * α ∨ r * α < (n : ℕ) * α ∨ r * α = (n : ℕ) * α,
  from by auto [h11],

  have h13 : ∀ (r : ℚ), (n : ℕ) * α < r * α ∨ r * α < (n : ℕ) * α ∨ r * α = (n : ℕ) * α,
  from by auto [h12],

  have h14 : ∀ (r : ℚ), (n : ℕ) * α < r * α ∨ r * α < (n : ℕ) * α ∨ r * α = (n : ℕ) * α,
  from by auto [h13],

  have h15 : ∀ (r : ℚ), (n : ℕ) * α < r * α ∨ r * α < (n : ℕ) * α ∨ r * α = (n : ℕ) * α,
  from by auto [h14],

  have h16 : ∀ (r : ℚ), (n : ℕ) * α < r * α ∨ r * α < (n : ℕ) * α ∨ r * α = (n : ℕ) * α,
  from by auto [h15],

  have h17 : ∀ (r : ℚ), (n : ℕ) * α < r * α ∨ r * α < (n : ℕ) * α ∨ r * α = (n : ℕ) * α,
  from by auto [h16],

  have h18 : ∀ (r : ℚ), (n : ℕ) * α < r * α ∨ r * α < (n : ℕ) * α ∨ r * α = (n : ℕ) * α,
  from by auto [h17],

  have h19 : ∀ (r : ℚ), (n : ℕ) * α < r * α ∨ r * α < (n : ℕ) * α ∨ r * α = (n : ℕ) * α,
  from by auto [h18],

  have h20 : ∀ (r : ℚ), (n : ℕ) * α < r * α ∨ r * α < (n : ℕ) * α ∨ r * α = (n : ℕ) * α,
  from by auto [h19],

  have h21 : ∀ (r : ℚ), (n : ℕ) * α < r * α ∨ r * α < (n : ℕ) * α ∨ r * α = (n : ℕ) * α,
  from by auto [h20],

  have h22 : ∀ (r : ℚ), (n : ℕ) * α < r * α ∨ r * α < (n : ℕ) * α ∨ r * α = (n : ℕ) * α,
  from by auto [h21],

  have h23 : ∀ (r : ℚ), (n : ℕ) * α < r * α ∨ r * α < (n : ℕ) * α ∨ r * α = (n : ℕ) * α,
  from by auto [h22],

  have h24 : ∀ (r : ℚ),
end --Needs more than 2000 tokens!

--OUTPUT 8
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_irrational_orbit (α : ℝ) (h : α ∉ ℚ) : ∀ x ∈ set.range (λ n : ℤ, (n : ℝ) * α), ∃ y ∈ set.range (λ n : ℤ, (n : ℝ) * α), |x - y| < 1 :=
begin
  assume x hx,
  have h1 : ∀ (i : ℤ) (j : ℤ), i ≠ j → set.Ico 0 1 (i * α) ≠ set.Ico 0 1 (j * α), from by auto [not_iff_comm, mem_Ico] using [h, mul_mem_Ico],
  have h2 : ∀ (i : ℤ) (j : ℤ), i ≠ j → set.Ico 0 1 (i * α) ∩ set.Ico 0 1 (j * α) = ∅, from by auto [set.inter_eq_empty_of_disjoint h1],
  have h3 : ∀ (i : ℤ) (j : ℤ), i ≠ j → (i : ℝ) * α ≠ (j : ℝ) * α, from by auto [not_iff_comm, ne.def, mem_Ico] using [h, mul_mem_Ico],
  have h4 : ∀ (i : ℤ) (j : ℤ), i ≠ j → (i : ℝ) * α ∉ set.Ico 0 1 (j : ℝ) * α, from by auto [not_iff_comm, mem_Ico] using [h, mul_mem_Ico],
  have h5 : ∀ (i : ℤ) (j : ℤ), i ≠ j → (i : ℝ) * α ∉ set.Ico 0 1 (j : ℝ) * α, from by auto [not_iff_comm, mem_Ico] using [h, mul_mem_Ico],
  have h6 : ∀ (i : ℤ) (j : ℤ), i ≠ j → set.Ico 0 1 ((i : ℝ) * α) ∩ set.Ico 0 1 ((j : ℝ) * α) = ∅, from by auto [set.inter_eq_empty_of_disjoint h4],
  have h7 : ∀ (i : ℤ) (j : ℤ), i ≠ j → set.Ico 0 1 ((j : ℝ) * α) ∩ set.Ico 0 1 ((i : ℝ) * α) = ∅, from by auto [set.inter_eq_empty_of_disjoint h5],
  have h8 : ∀ i : ℤ, set.Ico 0 1 ((i : ℝ) * α) ∩ (set.Ico 0 1 ((-i : ℝ) * α)) = ∅, from by auto [h7, neg_neg_eq_of_pos, set.inter_eq_empty_of_disjoint h7],
  have h9 : ∀ i : ℤ, set.Ico 0 1 ((i : ℝ) * α) ∩ (set.Ico 0 1 ((-i : ℝ) * α)) = ∅, from by auto [h7, neg_neg_eq_of_pos, set.inter_eq_empty_of_disjoint h7],
  have h10 : ∀ i : ℤ, set.Ico 0 1 ((-i : ℝ) * α) ∩ (set.Ico 0 1 ((i : ℝ) * α)) = ∅, from by auto [h8, neg_neg_eq_of_pos, set.inter_eq_empty_of_disjoint h9],
  have h11 : ∀ i : ℤ, set.Ico 0 1 ((-i : ℝ) * α) ∩ (set.Ico 0 1 ((i : ℝ) * α)) = ∅, from by auto [h8, neg_neg_eq_of_pos, set.inter_eq_empty_of_disjoint h9],
  have h12 : ∀ i : ℤ, set.Ico 0 1 ((i : ℝ) * α) ∩ (set.Ico 0 1 ((-i : ℝ) * α)) = ∅, from by auto [h10, neg_neg_eq_of_pos, set.inter_eq_empty_of_disjoint h11],
  have h13 : ∀ i : ℤ, set.Ico 0 1 ((i : ℝ) * α) ∩ (set.Ico 0 1 ((-i : ℝ) * α)) = ∅, from by auto [h10, neg_neg_eq_of_pos, set.inter_eq_empty_of_disjoint h11],
  have h14 : ∀ i : ℤ, set.Ico 0 1 ((-i : ℝ) * α) ∩ (set.Ico 0 1 ((i : ℝ) * α)) = ∅, from by auto [h12, neg_neg_eq_of_pos, set.inter_eq_empty_of_disjoint h13],
  have h15 : ∀ i : ℤ, set.Ico 0 1 ((-i : ℝ) * α) ∩ (set.Ico 0 1 ((i : ℝ) * α)) = ∅, from by auto [h12, neg_neg_eq_of_pos, set.inter_eq_empty_of_disjoint h13],

  have h16 : ∀ i : ℤ, set.Ico 0 1 ((i : ℝ) * α) ∩ (set.Ico 0 1 (-(i : ℝ) * α)) = ∅, from by auto [h14, neg_neg_eq_of_pos, set.inter_eq_empty_of_disjoint h15],
  have h17 : ∀ i : ℤ, set.Ico 0 1 ((i : ℝ) * α) ∩ (set.Ico 0 1 (-(i : ℝ) * α)) = ∅, from by auto [h14, neg_neg_eq_of_pos, set.inter_eq_empty_of_disjoint h15],
  have h18 : ∀ i : ℤ, set.Ico 0 1 (-(i : ℝ) * α) ∩ (set.Ico 0 1 ((i : ℝ) * α)) = ∅, from by auto [h16, neg_neg_eq_of_pos, set.inter_eq_empty_of_disjoint h17],
  have h19 : ∀ i : ℤ, set.Ico 0 1 (-(i : ℝ) * α) ∩ (set.Ico 0 1 ((i : ℝ) * α)) = ∅, from by auto [h16, neg_neg_eq_of_pos, set.inter_eq_empty_of_disjoint h17],
  have h20 : ∀ i : ℤ, set.Ico 0 1 ((i : ℝ) * α) ∩ (set.Ico 0 1 (-(i : ℝ) * α)) = ∅, from by auto [h18, neg_neg_eq_of_pos, set.inter_eq_empty_of_disjoint h19],
  have h21 : ∀ i : ℤ, set.Ico 0 1 ((i : ℝ) * α) ∩ (set.Ico 0 1 (-(i : ℝ) * α)) = ∅, from by auto [h18, neg_neg_eq_of_pos, set.inter_eq_empty_of_disjoint h19],
  have h22 : ∀ i : ℤ, set.Ico 0 1 (-(i : ℝ) * α) ∩ (set.Ico 0 1 ((i : ℝ) * α)) = ∅, from by auto [h20, neg_neg_eq_of_pos, set.inter_eq_empty_of_disjoint h21],
  have h23 : ∀ i : ℤ, set.Ico 0 1 (-(i : ℝ) * α) ∩ (set.Ico 0 1 ((i
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
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from by auto [set.subset_of_mem_powerset, set.subset_of_mem_powerset],
  have h2 : (A ∩ B) ⊆ A, from by auto [set.inter_subset_left],
  have h3 : (A ∩ B) ⊆ S, from by auto [set.subset.trans],
  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
  calc (x + y)^2 = (x+y)*(x+y) : by auto [sq]
  ... = x*(x+y) + y*(x+y) : by auto [add_mul]
  ... = x*x + x*y + y*x + y*y : by auto [mul_comm, add_mul] using [ring]
  ... = 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
  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⁻¹],

  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],

  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) (ε),

  have h5 : ∀ x, |x - l| < ε ↔ (((l - ε) < x) ∧ (x < (l + ε))),
  from by auto [abs_sub_lt_iff] using [linarith],

  assume (h7 : ε > 0),

  cases h2 ε h7 with N1 h8,
  cases h3 ε h7 with N2 h9,
  let N := max N1 N2,
  use N,

  have h10 : ∀ n > N, n > N1 ∧ n > N2 := by auto [lt_of_le_of_lt, le_max_left, le_max_right],

  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],

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

  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
FEW SHOT PROMPTS TO CODEX(END)-/


import category_theory.preadditive.yoneda

open opposite

namespace category_theory

universes v u
variables (A : Type u) [category.{v} A] [preadditive A]

lemma is_iso_of_is_iso_preadditive_yoneda_map_app {X Y : A}
  (f : X ⟶ Y) [∀ W : A, is_iso ((preadditive_yoneda.map f).app (op W))] :
  is_iso f :=
begin
  let e := (preadditive_yoneda.map f).app (op Y),
  let g := (preadditive_yoneda.map f).app (op X),
  use inv e (𝟙 _),
  split,
  { apply_fun g,
    swap,
    { intros i j h,
      apply_fun inv g at h,
      simpa only [← comp_apply, is_iso.hom_inv_id] using h },
    dsimp [g],
    simp only [category.id_comp, category.assoc],
    change f ≫ e _ = _,
    simp only [← comp_apply, is_iso.hom_inv_id],
    simp },
  { change e (inv e (𝟙 _)) = _,
    simp only [← comp_apply, is_iso.inv_hom_id],
    simpa },
end

end category_theory


import util.category
import util.predicate
import temporal_logic

open predicate

universe variables u u' v'

namespace unitb

variable {α : Type u}

class lifted_pred (cat : pred' α → pred' α → Sort u')
extends category cat :=
  (imp : ∀ p q, p ⟹ q → cat p q)
  (imp_self_eq_ident : ∀ {p : pred' α}, imp p p (by refl) = ident)
  (imp_comp_imp_eq_imp_trans : ∀ {p q r : pred' α} (h₀ : p ⟹ q) (h₁ : q ⟹ r),
     (imp q r h₁ <<< imp p q h₀) = imp p r (entails_trans h₀ h₁))

class finite_disjunctive (cat : pred' α → pred' α → Sort u')
extends lifted_pred cat :=
  (disj : ∀ {p q r : pred' α}, cat p r → cat q r → cat (p ⋁ q) r)
  (comp_over_disj_right : ∀ {p q r r' : pred' α}
                            (Pp : cat p r)
                            (Pq : cat q r)
                            (Pr : cat r r'),
             (Pr <<< disj Pp Pq) = disj (Pr <<< Pp) (Pr <<< Pq))
  (select_left_disj  : ∀ {p q r : pred' α}
                            (Pp : cat p r)
                            (Pq : cat q r),
             (disj Pp Pq <<< imp p _ (p_or_intro_left _ _)) = Pp)
  (disj_imp_imp : ∀ {p q r : pred' α}
                            (Pp : p ⟹ r)
                            (Pq : q ⟹ r),
             disj (imp _ _ Pp) (imp _ _ Pq) =
             imp (p ⋁ q) r (p_or_entails_of_entails Pp Pq))
  (disj_flip : ∀ {p q r : pred' α}
                            (P₀ : cat p r) (P₁ : cat q r),
             disj P₀ P₁ = (disj P₁ P₀ <<< imp _ _ (by rw [p_or_comm])) )

class disjunctive (cat : pred' α → pred' α → Sort u')
extends finite_disjunctive cat :=
  (disj' : ∀ {t : Type u} (p : t → pred' α) r : pred' α,
      (∀ x, cat (p x) r) → cat (∃∃ x, p x) r)
  (disj :=
   begin
     intros p q r X Y,
     let f := λ x : ulift.{u} bool, if x.down then p else q,
     have H : p ⋁ q = ∃∃ x, f x,
     { apply mutual_entails,
       apply p_or_entails_of_entails,
       { apply @p_exists_intro _ _ f ⟨ tt ⟩, },
       { apply @p_exists_intro _ _ f ⟨ ff ⟩, },
       apply p_exists_elim,
       intro x, cases x, cases down,
       { apply p_or_intro_right },
       { apply p_or_intro_left }, },
     rw H, clear H,
     apply disj',
     apply ulift.rec,
     apply bool.rec ; revert f
     ; simp
     ; assumption
   end )

export lifted_pred (imp_comp_imp_eq_imp_trans imp_self_eq_ident)
export finite_disjunctive (disj comp_over_disj_right select_left_disj
                           disj_imp_imp disj_flip)
export disjunctive (disj')

section lemmas

parameters {σ : Type u}
parameters (cat : pred' σ → pred' σ → Sort v')
@[reducible]
private def pred := pred' σ

local infix ` ⤇ `:25 := cat
   -- M-x insert-char RET right*arrow
   -- code point: 0x2907
parameters {t : Type u}

lemma disj.select_left_disj' [finite_disjunctive cat]
  {p p' q r : pred}
  (H : p' ⟹ p)
  (Pp : cat p r)
  (Pq : cat q r)
: (disj σ Pp Pq <<< lifted_pred.imp _ p' (p ⋁ q)
         (entails_trans H $ p_or_intro_left _ _)) =
  (Pp <<< lifted_pred.imp _ p' p H) :=
begin
  have h₀ : p' ⟹ p ⋁ q,
  { transitivity p, assumption, apply p_or_intro_left },
  have h₁ := p_or_intro_left p q,
  have H' : lifted_pred.imp cat p' (p ⋁ q) h₀ =
            (lifted_pred.imp cat p (p ⋁ q) h₁ <<< lifted_pred.imp cat p' p H),
  { rw imp_comp_imp_eq_imp_trans },
  rw [H',semigroupoid.assoc,select_left_disj],
end

def select_right_disj [finite_disjunctive cat] {p q r : pred}
  (Pp : cat p r)
  (Pq : cat q r)
: (disj _ Pp Pq <<< lifted_pred.imp cat q _ (p_or_intro_right _ _)) = Pq :=
by rw [disj_flip,← category.assoc,imp_comp_imp_eq_imp_trans,select_left_disj]

def monotonicity [lifted_pred cat]
  {p p' q q'}
  (hp : p' ⟹ p)
  (hq : q  ⟹ q')
  (hcat : cat p q)
: cat p' q' :=
begin
  apply has_comp.comp,
  apply lifted_pred.imp cat _ _ hq,
  apply has_comp.comp _ hcat,
  apply lifted_pred.imp cat _ _ hp,
end

def antimono_left [lifted_pred cat]
  (p) {p' q}
  (h : p' ⟹ p)
: cat p q → cat p' q :=
monotonicity h (by refl)

def lifted_pred.weaken [lifted_pred cat]
  {p q}
  (h : p ⟹ q)
: cat p q :=
lifted_pred.imp cat p q h

def lifted_pred.mono_right [lifted_pred cat]
  {p} (q) {q'}
  (h : q  ⟹ q')
: cat p q → cat p q' :=
monotonicity (by refl) h

def disj_rng [category cat] [disjunctive cat]
  {p : t → pred} {q : pred} {r : t → Prop}
  (h : ∀ i, r i → p i ⤇ q)
: (∃∃ i, r i ⋀ p i) ⤇ q :=
begin
  have h' : (∃∃ (i : t), ↑(r i) ⋀ p i) =
              (∃∃ (i : { x : t // r x }), p i),
  { funext x,
    split,
    { intro h, cases h with j h,
      exact ⟨⟨j, h^.left⟩, h^.right⟩ },
    { intro h₀, cases h₀ with j h₀, cases j with j h₁ h₂,
      exact ⟨j,h₁,h₀⟩, } },
  rw h',
  apply disj',
  intro i,
  apply h,
  apply i^.property,
end

def gen_disj [finite_disjunctive cat]
  {p₀ p₁ q₀ q₁ : pred' σ}
  (P₀ : p₀ ⤇ q₀)
  (P₁ : p₁ ⤇ q₁)
: p₀ ⋁ p₁ ⤇ q₀ ⋁ q₁ :=
begin
  apply disj,
  { apply lifted_pred.mono_right cat _ _ P₀,
    apply p_or_intro_left },
  { apply lifted_pred.mono_right cat _ _ P₁,
    apply p_or_intro_right },
end

def gen_disj' [disjunctive cat]
  {t : Type u} {p q : t → pred' σ}
  (P : ∀ x, p x ⤇ q x)
: (∃∃ x, p x) ⤇ (∃∃ x, q x) :=
begin
  have P' : Π (x : t), cat (p x) (∃∃ (x : t), q x),
  { intro x,
    apply lifted_pred.mono_right cat _ _ (P x),
    apply p_exists_intro },
  apply disj' p _ P',
end

def cancellation'
  [lifted_pred cat] [finite_disjunctive cat]
  {p : pred' σ} (q : pred' σ)
  {r b : pred' σ}
  (P₀ : p ⤇ q ⋁ b)
  (P₁ : q ⤇ r)
: p ⤇ r ⋁ b :=
begin
  apply has_comp.comp _ _ P₀,
  apply gen_disj _ P₁ (ident _),
end

def cancellation
  [lifted_pred cat] [finite_disjunctive cat]
  {p : pred' σ} (q : pred' σ)
  {r b : pred' σ}
  (P₀ : p ⤇ q ⋁ b)
  (P₁ : q ⤇ r ⋁ b)
: p ⤇ r ⋁ b :=
begin
  apply has_comp.comp _ _ P₀,
  apply finite_disjunctive.disj _ P₁,
  apply lifted_pred.imp,
  apply p_or_intro_right,
end

-- set_option pp.implicit true

lemma cancellation_assoc
  [finite_disjunctive cat]
  {p q : pred' σ}
  {r r' b : pred' σ}
  (P₀ : p ⤇ q ⋁ b)
  (P₁ : q ⤇ r ⋁ b)
  (P₂ : r ⤇ r' ⋁ b)
:   cancellation _ (cancellation _ P₀ P₁) P₂
  = cancellation _ P₀ (cancellation _ P₁ P₂)  :=
begin
  unfold cancellation,
  rw [semigroupoid.assoc, comp_over_disj_right, select_right_disj],
end

theorem induction [disjunctive cat]
  {β : Type u}
  [has_well_founded β]
  (V : var σ β)
  {p q : pred}
  (P : ∀ v : β, p ⋀ V ≃ v  ⤇  p ⋀ V ≺≺ v ⋁ q)
: p ⤇ q :=
begin
  have P' : (∃∃ v : β, p ⋀ V ≃ v)  ⤇ q,
  { apply disjunctive.disj', intro i,
    let PP := λ v : β, p ⋀ V ≃ v  ⤇  q,
    change PP i,
    apply @well_founded.recursion _ _ (has_well_founded.wf _) PP,
    intros j IH,
    change _ ⤇ _,
    apply lifted_pred.mono_right cat (q ⋁ q),
    { simp [p_or_self] },
    apply cancellation' _ (p ⋀ V ≺≺ j) (P _),
    have h' : (p ⋀ V ≺≺ j) = (∃∃v : β, ↑(v << j) ⋀ (p ⋀ V ≃ v)),
    { funext x, split,
      { intros H₀, cases H₀ with H₀ H₁,
        existsi V.apply x, TL_simp,
        simp at H₁,
        split ; assumption, },
      { intro h, apply exists.elim h,
        intros s h', cases h' with h₀ h₁, cases h₁,
        TL_simp [function.comp] at right h₀ ⊢, subst s,
        split ; assumption,  }, },
    simp [h'], clear h',
    -- apply @disj_rng _ _ β _ _  (lt j) ,
    apply disj_rng,
    apply IH, },
  { have h : (∃∃ (v : β), p ⋀ V ≃ v) = p,
    { funext x, TL_simp [function.comp] },
    rw h at P',
    apply P' }
end

end lemmas

end unitb


/-
Copyright (c) 2021 David Wärn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Wärn, Joachim Breitner
-/
import algebra.free_monoid
import group_theory.congruence
import group_theory.is_free_group
import group_theory.subgroup.pointwise
import data.list.chain
import set_theory.cardinal
/-!
# The free product of groups or monoids

Given an `ι`-indexed family `M` of monoids, we define their free product (categorical coproduct)
`free_product M`. When `ι` and all `M i` have decidable equality, the free product bijects with the
type `word M` of reduced words. This bijection is constructed by defining an action of
`free_product M` on `word M`.

When `M i` are all groups, `free_product M` is also a group (and the coproduct in the category of
groups).

## Main definitions

- `free_product M`: the free product, defined as a quotient of a free monoid.
- `free_product.of {i} : M i →* free_product M`.
- `free_product.lift : (Π {i}, M i →* N) ≃ (free_product M →* N)`: the universal property.
- `free_product.word M`: the type of reduced words.
- `free_product.word.equiv M : free_product M ≃ word M`.
- `free_product.neword M i j`: an inductive description of non-empty words with first letter from
  `M i` and last letter from `M j`, together with an API (`singleton`, `append`, `head`, `tail`,
  `to_word`, `prod`, `inv`). Used in the proof of the Ping-Pong-lemma.
- `free_product.lift_injective_of_ping_pong`: The Ping-Pong-lemma, proving injectivity of the
  `lift`. See the documentation of that theorem for more information.

## Remarks

There are many answers to the question "what is the free product of a family `M` of monoids?", and
they are all equivalent but not obviously equivalent. We provide two answers. The first, almost
tautological answer is given by `free_product M`, which is a quotient of the type of words in the
alphabet `Σ i, M i`. It's straightforward to define and easy to prove its universal property. But
this answer is not completely satisfactory, because it's difficult to tell when two elements
`x y : free_product M` are distinct since `free_product M` is defined as a quotient.

The second, maximally efficient answer is given by `word M`. An element of `word M` is a word in the
alphabet `Σ i, M i`, where the letter `⟨i, 1⟩` doesn't occur and no adjacent letters share an index
`i`. Since we only work with reduced words, there is no need for quotienting, and it is easy to tell
when two elements are distinct. However it's not obvious that this is even a monoid!

We prove that every element of `free_product M` can be represented by a unique reduced word, i.e.
`free_product M` and `word M` are equivalent types. This means that `word M` can be given a monoid
structure, and it lets us tell when two elements of `free_product M` are distinct.

There is also a completely tautological, maximally inefficient answer given by
`algebra.category.Mon.colimits`. Whereas `free_product M` at least ensures that (any instance of)
associativity holds by reflexivity, in this answer associativity holds because of quotienting. Yet
another answer, which is constructively more satisfying, could be obtained by showing that
`free_product.rel` is confluent.

## References

[van der Waerden, *Free products of groups*][MR25465]

-/

variables {ι : Type*} (M : Π i : ι, Type*) [Π i, monoid (M i)]

/-- A relation on the free monoid on alphabet `Σ i, M i`, relating `⟨i, 1⟩` with `1` and
`⟨i, x⟩ * ⟨i, y⟩` with `⟨i, x * y⟩`. -/
inductive free_product.rel : free_monoid (Σ i, M i) → free_monoid (Σ i, M i) → Prop
| of_one (i : ι) : free_product.rel (free_monoid.of ⟨i, 1⟩) 1
| of_mul {i : ι} (x y : M i) : free_product.rel (free_monoid.of ⟨i, x⟩ * free_monoid.of ⟨i, y⟩)
  (free_monoid.of ⟨i, x * y⟩)

/-- The free product (categorical coproduct) of an indexed family of monoids. -/
@[derive [monoid, inhabited]]
def free_product : Type* := (con_gen (free_product.rel M)).quotient

namespace free_product

/-- The type of reduced words. A reduced word cannot contain a letter `1`, and no two adjacent
letters can come from the same summand. -/
@[ext] structure word :=
(to_list : list (Σ i, M i))
(ne_one : ∀ l ∈ to_list, sigma.snd l ≠ 1)
(chain_ne : to_list.chain' (λ l l', sigma.fst l ≠ sigma.fst l'))

variable {M}

/-- The inclusion of a summand into the free product. -/
def of {i : ι} : M i →* free_product M :=
{ to_fun   := λ x, con.mk' _ (free_monoid.of $ sigma.mk i x),
  map_one' := (con.eq _).mpr (con_gen.rel.of _ _ (free_product.rel.of_one i)),
  map_mul' := λ x y, eq.symm $ (con.eq _).mpr (con_gen.rel.of _ _ (free_product.rel.of_mul x y)) }

lemma of_apply {i} (m : M i) : of m = con.mk' _ (free_monoid.of $ sigma.mk i m) := rfl

variables {N : Type*} [monoid N]

/-- See note [partially-applied ext lemmas]. -/
@[ext] lemma ext_hom (f g : free_product M →* N) (h : ∀ i, f.comp (of : M i →* _) = g.comp of) :
  f = g :=
(monoid_hom.cancel_right con.mk'_surjective).mp $ free_monoid.hom_eq $ λ ⟨i, x⟩,
  by rw [monoid_hom.comp_apply, monoid_hom.comp_apply, ←of_apply,
    ←monoid_hom.comp_apply, ←monoid_hom.comp_apply, h]

/-- A map out of the free product corresponds to a family of maps out of the summands. This is the
universal property of the free product, charaterizing it as a categorical coproduct. -/
@[simps symm_apply]
def lift : (Π i, M i →* N) ≃ (free_product M →* N) :=
{ to_fun := λ fi, con.lift _ (free_monoid.lift $ λ p : Σ i, M i, fi p.fst p.snd) $ con.con_gen_le
    begin
      simp_rw [con.rel_eq_coe, con.ker_rel],
      rintros _ _ (i | ⟨i, x, y⟩),
      { change free_monoid.lift _ (free_monoid.of _) = free_monoid.lift _ 1,
        simp only [monoid_hom.map_one, free_monoid.lift_eval_of], },
      { change free_monoid.lift _ (free_monoid.of _ * free_monoid.of _) =
          free_monoid.lift _ (free_monoid.of _),
        simp only [monoid_hom.map_mul, free_monoid.lift_eval_of], }
    end,
  inv_fun := λ f i, f.comp of,
  left_inv := by { intro fi, ext i x,
    rw [monoid_hom.comp_apply, of_apply, con.lift_mk', free_monoid.lift_eval_of], },
  right_inv := by { intro f, ext i x,
    simp only [monoid_hom.comp_apply, of_apply, con.lift_mk', free_monoid.lift_eval_of], } }

@[simp] lemma lift_of {N} [monoid N] (fi : Π i, M i →* N) {i} (m : M i) :
  lift fi (of m) = fi i m :=
by conv_rhs { rw [←lift.symm_apply_apply fi, lift_symm_apply, monoid_hom.comp_apply] }

@[elab_as_eliminator]
lemma induction_on {C : free_product M → Prop}
  (m : free_product M)
  (h_one : C 1)
  (h_of : ∀ (i) (m : M i), C (of m))
  (h_mul : ∀ (x y), C x → C y → C (x * y)) :
  C m :=
begin
  let S : submonoid (free_product M) := submonoid.mk (set_of C) h_mul h_one,
  convert subtype.prop (lift (λ i, of.cod_mrestrict S (h_of i)) m),
  change monoid_hom.id _ m = S.subtype.comp _ m,
  congr,
  ext,
  simp [monoid_hom.cod_mrestrict],
end

lemma of_left_inverse [decidable_eq ι] (i : ι) :
  function.left_inverse (lift $ pi.mul_single i (monoid_hom.id (M i))) of :=
λ x, by simp only [lift_of, pi.mul_single_eq_same, monoid_hom.id_apply]

lemma of_injective (i : ι) : function.injective ⇑(of : M i →* _) :=
by { classical, exact (of_left_inverse i).injective }

lemma lift_mrange_le {N} [monoid N] (f : Π i, M i →* N) {s : submonoid N}
  (h : ∀ i, (f i).mrange ≤ s) : (lift f).mrange ≤ s :=
begin
  rintros _ ⟨x, rfl⟩,
  induction x using free_product.induction_on with i x x y hx hy,
  { exact s.one_mem, },
  { simp only [lift_of, set_like.mem_coe], exact h i (set.mem_range_self x), },
  { simp only [map_mul, set_like.mem_coe], exact s.mul_mem hx hy, },
end

lemma mrange_eq_supr {N} [monoid N] (f : Π i, M i →* N) :
  (lift f).mrange = ⨆ i, (f i).mrange :=
begin
  apply le_antisymm (lift_mrange_le f (λ i, le_supr _ i)),
  apply supr_le _,
  rintros i _ ⟨x, rfl⟩,
  exact ⟨of x, by simp only [lift_of]⟩
end

section group

variables (G : ι → Type*) [Π i, group (G i)]

instance : has_inv (free_product G) :=
{ inv := mul_opposite.unop ∘
    lift (λ i, (of : G i →* _).op.comp (mul_equiv.inv' (G i)).to_monoid_hom) }

lemma inv_def (x : free_product G) : x⁻¹ = mul_opposite.unop
  (lift (λ i, (of : G i →* _).op.comp (mul_equiv.inv' (G i)).to_monoid_hom) x) := rfl

instance : group (free_product G) :=
{ mul_left_inv := begin
    intro m,
    rw inv_def,
    apply m.induction_on,
    { rw [monoid_hom.map_one, mul_opposite.unop_one, one_mul], },
    { intros i m, change of m⁻¹ * of m = 1, rw [←of.map_mul, mul_left_inv, of.map_one], },
    { intros x y hx hy,
      rw [monoid_hom.map_mul, mul_opposite.unop_mul, mul_assoc, ← mul_assoc _ x y, hx,
        one_mul, hy], },
  end,
  ..free_product.has_inv G,
  ..free_product.monoid G }

lemma lift_range_le {N} [group N] (f : Π i, G i →* N) {s : subgroup N}
  (h : ∀ i, (f i).range ≤ s) : (lift f).range ≤ s :=
begin
  rintros _ ⟨x, rfl⟩,
  induction x using free_product.induction_on with i x x y hx hy,
  { exact s.one_mem, },
  { simp only [lift_of, set_like.mem_coe], exact h i (set.mem_range_self x), },
  { simp only [map_mul, set_like.mem_coe], exact s.mul_mem hx hy, },
end

lemma range_eq_supr {N} [group N] (f : Π i, G i →* N) :
  (lift f).range = ⨆ i, (f i).range :=
begin
  apply le_antisymm (lift_range_le _ f (λ i, le_supr _ i)),
  apply supr_le _,
  rintros i _ ⟨x, rfl⟩,
  exact ⟨of x, by simp only [lift_of]⟩
end

end group

namespace word

/-- The empty reduced word. -/
def empty : word M := { to_list := [], ne_one := λ _, false.elim, chain_ne := list.chain'_nil }

instance : inhabited (word M) := ⟨empty⟩

/-- A reduced word determines an element of the free product, given by multiplication. -/
def prod (w : word M) : free_product M :=
list.prod (w.to_list.map $ λ l, of l.snd)

@[simp] lemma prod_empty : prod (empty : word M) = 1 := rfl

/-- `fst_idx w` is `some i` if the first letter of `w` is `⟨i, m⟩` with `m : M i`. If `w` is empty
then it's `none`. -/
def fst_idx (w : word M) : option ι := w.to_list.head'.map sigma.fst

lemma fst_idx_ne_iff {w : word M} {i} :
  fst_idx w ≠ some i ↔ ∀ l ∈ w.to_list.head', i ≠ sigma.fst l :=
not_iff_not.mp $ by simp [fst_idx]

variable (M)

/-- Given an index `i : ι`, `pair M i` is the type of pairs `(head, tail)` where `head : M i` and
`tail : word M`, subject to the constraint that first letter of `tail` can't be `⟨i, m⟩`.
By prepending `head` to `tail`, one obtains a new word. We'll show that any word can be uniquely
obtained in this way. -/
@[ext] structure pair (i : ι) :=
(head : M i)
(tail : word M)
(fst_idx_ne : fst_idx tail ≠ some i)

instance (i : ι) : inhabited (pair M i) := ⟨⟨1, empty, by tauto⟩⟩

variable {M}

variables [∀ i, decidable_eq (M i)]

/-- Given a pair `(head, tail)`, we can form a word by prepending `head` to `tail`, except if `head`
is `1 : M i` then we have to just return `word` since we need the result to be reduced. -/
def rcons {i} (p : pair M i) : word M :=
if h : p.head = 1 then p.tail
else { to_list  := ⟨i, p.head⟩ :: p.tail.to_list,
       ne_one   := by { rintros l (rfl | hl), exact h, exact p.tail.ne_one l hl },
       chain_ne := p.tail.chain_ne.cons' (fst_idx_ne_iff.mp p.fst_idx_ne) }

/-- Given a word of the form `⟨l :: ls, h1, h2⟩`, we can form a word of the form `⟨ls, _, _⟩`,
dropping the first letter. -/
private def mk_aux {l} (ls : list (Σ i, M i)) (h1 : ∀ l' ∈ l :: ls, sigma.snd l' ≠ 1)
  (h2 : (l :: ls).chain' _) : word M :=
⟨ls, λ l' hl, h1 _ (list.mem_cons_of_mem _ hl), h2.tail⟩

lemma cons_eq_rcons {i} {m : M i} {ls h1 h2} :
  word.mk (⟨i, m⟩ :: ls) h1 h2 = rcons ⟨m, mk_aux ls h1 h2, fst_idx_ne_iff.mpr h2.rel_head'⟩ :=
by { rw [rcons, dif_neg], refl, exact h1 ⟨i, m⟩ (ls.mem_cons_self _) }

@[simp] lemma prod_rcons {i} (p : pair M i) :
  prod (rcons p) = of p.head * prod p.tail :=
if hm : p.head = 1 then by rw [rcons, dif_pos hm, hm, monoid_hom.map_one, one_mul]
else by rw [rcons, dif_neg hm, prod, list.map_cons, list.prod_cons, prod]

lemma rcons_inj {i} : function.injective (rcons : pair M i → word M) :=
begin
  rintros ⟨m, w, h⟩ ⟨m', w', h'⟩ he,
  by_cases hm : m = 1;
  by_cases hm' : m' = 1,
  { simp only [rcons, dif_pos hm, dif_pos hm'] at he, cc, },
  { exfalso, simp only [rcons, dif_pos hm, dif_neg hm'] at he, rw he at h, exact h rfl },
  { exfalso, simp only [rcons, dif_pos hm', dif_neg hm] at he, rw ←he at h', exact h' rfl, },
  { have : m = m' ∧ w.to_list = w'.to_list,
    { simpa only [rcons, dif_neg hm, dif_neg hm', true_and, eq_self_iff_true, subtype.mk_eq_mk,
      heq_iff_eq, ←subtype.ext_iff_val] using he },
    rcases this with ⟨rfl, h⟩,
    congr, exact word.ext _ _ h, }
end

variable [decidable_eq ι]

/-- Given `i : ι`, any reduced word can be decomposed into a pair `p` such that `w = rcons p`. -/
-- This definition is computable but not very nice to look at. Thankfully we don't have to inspect
-- it, since `rcons` is known to be injective.
private def equiv_pair_aux (i) : Π w : word M, { p : pair M i // rcons p = w }
| w@⟨[], _, _⟩             := ⟨⟨1, w, by rintro ⟨⟩⟩, dif_pos rfl⟩
| w@⟨⟨j, m⟩ :: ls, h1, h2⟩ := if ij : i = j then
  { val := { head := ij.symm.rec m,
             tail := mk_aux ls h1 h2,
             fst_idx_ne := by cases ij; exact fst_idx_ne_iff.mpr h2.rel_head' },
    property := by cases ij; exact cons_eq_rcons.symm }
else ⟨⟨1, w, (option.some_injective _).ne (ne.symm ij)⟩, dif_pos rfl⟩

/-- The equivalence between words and pairs. Given a word, it decomposes it as a pair by removing
the first letter if it comes from `M i`. Given a pair, it prepends the head to the tail. -/
def equiv_pair (i) : word M ≃ pair M i :=
{ to_fun := λ w, (equiv_pair_aux i w).val,
  inv_fun := rcons,
  left_inv := λ w, (equiv_pair_aux i w).property,
  right_inv := λ p, rcons_inj (equiv_pair_aux i _).property }

lemma equiv_pair_symm (i) (p : pair M i) : (equiv_pair i).symm p = rcons p := rfl

lemma equiv_pair_eq_of_fst_idx_ne {i} {w : word M} (h : fst_idx w ≠ some i) :
  equiv_pair i w = ⟨1, w, h⟩ :=
(equiv_pair i).apply_eq_iff_eq_symm_apply.mpr $ eq.symm (dif_pos rfl)

instance summand_action (i) : mul_action (M i) (word M) :=
{ smul     := λ m w, rcons { head := m * (equiv_pair i w).head, ..equiv_pair i w },
  one_smul := λ w, by { simp_rw [one_mul], apply (equiv_pair i).symm_apply_eq.mpr, ext; refl },
  mul_smul := λ m m' w, by simp only [mul_assoc, ←equiv_pair_symm, equiv.apply_symm_apply], }

instance : mul_action (free_product M) (word M) :=
mul_action.of_End_hom (lift (λ i, mul_action.to_End_hom))

lemma of_smul_def (i) (w : word M) (m : M i) :
  of m • w = rcons { head := m * (equiv_pair i w).head, ..equiv_pair i w } := rfl

lemma cons_eq_smul {i} {m : M i} {ls h1 h2} :
  word.mk (⟨i, m⟩ :: ls) h1 h2 = of m • mk_aux ls h1 h2 :=
by rw [cons_eq_rcons, of_smul_def, equiv_pair_eq_of_fst_idx_ne _]; simp only [mul_one]

lemma smul_induction {C : word M → Prop}
  (h_empty : C empty)
  (h_smul : ∀ i (m : M i) w, C w → C (of m • w))
  (w : word M) : C w :=
begin
  cases w with ls h1 h2,
  induction ls with l ls ih,
  { exact h_empty },
  cases l with i m,
  rw cons_eq_smul,
  exact h_smul _ _ _ (ih _ _),
end

@[simp] lemma prod_smul (m) : ∀ w : word M, prod (m • w) = m * prod w :=
begin
  apply m.induction_on,
  { intro, rw [one_smul, one_mul] },
  { intros, rw [of_smul_def, prod_rcons, of.map_mul, mul_assoc, ←prod_rcons,
      ←equiv_pair_symm, equiv.symm_apply_apply] },
  { intros x y hx hy w, rw [mul_smul, hx, hy, mul_assoc] },
end

/-- Each element of the free product corresponds to a unique reduced word. -/
def equiv : free_product M ≃ word M :=
{ to_fun := λ m, m • empty,
  inv_fun := λ w, prod w,
  left_inv := λ m, by dsimp only; rw [prod_smul, prod_empty, mul_one],
  right_inv := begin
    apply smul_induction,
    { dsimp only, rw [prod_empty, one_smul], },
    { dsimp only, intros i m w ih, rw [prod_smul, mul_smul, ih], },
  end }

instance : decidable_eq (word M) := function.injective.decidable_eq word.ext
instance : decidable_eq (free_product M) := word.equiv.decidable_eq

end word

variable (M)

/-- A `neword M i j` is a representation of a non-empty reduced words where the first letter comes
from `M i` and the last letter comes from `M j`. It can be constructed from singletons and via
concatentation, and thus provides a useful induction principle. -/
@[nolint has_inhabited_instance]
inductive neword : ι → ι → Type (max u_1 u_2)
| singleton : ∀ {i} (x : M i) (hne1 : x ≠ 1), neword i i
| append : ∀ {i j k l} (w₁ : neword i j) (hne : j ≠ k) (w₂ : neword k l), neword i l
variable {M}

namespace neword

open word

/-- The list represented by a given `neword` -/
@[simp]
def to_list : Π {i j} (w : neword M i j), list (Σ i, M i)
| i _ (singleton x hne1) := [⟨i, x⟩]
| _ _ (append w₁ hne w₂) := w₁.to_list ++ w₂.to_list

/--  The first letter of a `neword` -/
@[simp]
def head : Π {i j} (w : neword M i j), M i
| i _ (singleton x hne1) := x
| _ _ (append w₁ hne w₂) := w₁.head

/--  The last letter of a `neword` -/
@[simp]
def last : Π {i j} (w : neword M i j), M j
| i _ (singleton x hne1) := x
| _ _ (append w₁ hne w₂) := w₂.last

@[simp]
lemma to_list_head' {i j} (w : neword M i j) :
  w.to_list.head' = option.some ⟨i, w.head⟩ :=
begin
  rw ← option.mem_def,
  induction w,
  { rw option.mem_def, reflexivity, },
  { exact list.head'_append w_ih_w₁, },
end

@[simp]
lemma to_list_last' {i j} (w : neword M i j) :
  w.to_list.last' = option.some ⟨j, w.last⟩ :=
begin
  rw ← option.mem_def,
  induction w,
  { rw option.mem_def, reflexivity, },
  { exact list.last'_append w_ih_w₂, },
end

/-- The `word M` represented by a `neword M i j` -/
def to_word {i j} (w : neword M i j) : word M :=
{ to_list := w.to_list,
  ne_one :=
  begin
    induction w,
    { rintros ⟨k,x⟩ ⟨rfl, rfl⟩,
      exact w_hne1,
      exfalso, apply H, },
    { intros l h,
      simp only [to_list, list.mem_append] at h,
      cases h,
      { exact w_ih_w₁ _ h, },
      { exact w_ih_w₂ _ h, }, },
  end,
  chain_ne := begin
    induction w,
    { exact list.chain'_singleton _, },
    { apply list.chain'.append w_ih_w₁ w_ih_w₂,
      intros x hx y hy,
      rw [w_w₁.to_list_last', option.mem_some_iff] at hx,
      rw [w_w₂.to_list_head', option.mem_some_iff] at hy,
      subst hx, subst hy,
      exact w_hne, },
  end, }

/-- Every nonempty `word M` can be constructed as a `neword M i j` -/
lemma of_word (w : word M) (h : w ≠ empty) :
  ∃ i j (w' : neword M i j), w'.to_word = w :=
begin
  suffices : ∃ i j (w' : neword M i j), w'.to_word.to_list = w.to_list,
  { obtain ⟨i, j, w, h⟩ := this, refine ⟨i, j, w, _⟩, ext, rw h, },
  cases w with l hnot1 hchain,
  induction l with x l hi,
  { contradiction, },
  { rw list.forall_mem_cons at hnot1,
    cases l with y l,
    { refine ⟨x.1, x.1, singleton x.2 hnot1.1, _ ⟩,
      simp [to_word], },
    { rw list.chain'_cons at hchain,
      specialize hi hnot1.2 hchain.2 (by rintros ⟨rfl⟩),
      obtain ⟨i, j, w', hw' : w'.to_list = y :: l⟩ := hi,
      obtain rfl : y = ⟨i, w'.head⟩, by simpa [hw'] using w'.to_list_head',
      refine ⟨x.1, j, append (singleton x.2 hnot1.1) hchain.1 w', _⟩,
      { simpa [to_word] using hw', } } }
end

/-- A non-empty reduced word determines an element of the free product, given by multiplication. -/
def prod {i j} (w : neword M i j) := w.to_word.prod

@[simp]
lemma singleton_head {i} (x : M i) (hne_one : x ≠ 1) :
  (singleton x hne_one).head = x := rfl

@[simp]
lemma singleton_last {i} (x : M i) (hne_one : x ≠ 1) :
  (singleton x hne_one).last = x := rfl

@[simp] lemma prod_singleton {i} (x : M i) (hne_one : x ≠ 1) :
  (singleton x hne_one).prod = of x :=
by simp [to_word, prod, word.prod]

@[simp]
lemma append_head {i j k l} {w₁ : neword M i j} {hne : j ≠ k} {w₂ : neword M k l} :
  (append w₁ hne w₂).head = w₁.head := rfl

@[simp]
lemma append_last {i j k l} {w₁ : neword M i j} {hne : j ≠ k} {w₂ : neword M k l} :
  (append w₁ hne w₂).last = w₂.last := rfl

@[simp]
lemma append_prod {i j k l} {w₁ : neword M i j} {hne : j ≠ k} {w₂ : neword M k l} :
  (append w₁ hne w₂).prod = w₁.prod * w₂.prod :=
by simp [to_word, prod, word.prod]

/-- One can replace the first letter in a non-empty reduced word by an element of the same
group -/
def replace_head : Π {i j : ι} (x : M i) (hnotone : x ≠ 1) (w : neword M i j), neword M i j
| _ _ x h (singleton _ _) := singleton x h
| _ _ x h (append w₁ hne w₂) := append (replace_head x h w₁) hne w₂

@[simp]
lemma replace_head_head {i j : ι} (x : M i) (hnotone : x ≠ 1) (w : neword M i j) :
  (replace_head x hnotone w).head = x :=
by { induction w, refl, exact w_ih_w₁ _ _, }

/-- One can multiply an element from the left to a non-empty reduced word if it does not cancel
with the first element in the word. -/
def mul_head {i j : ι} (w : neword M i j) (x : M i) (hnotone : x * w.head ≠ 1) :
  neword M i j := replace_head (x * w.head) hnotone w

@[simp]
lemma mul_head_head {i j : ι} (w : neword M i j) (x : M i) (hnotone : x * w.head ≠ 1) :
   (mul_head w x hnotone).head = x * w.head :=
by { induction w, refl, exact w_ih_w₁ _ _, }

@[simp]
lemma mul_head_prod {i j : ι} (w : neword M i j) (x : M i) (hnotone : x * w.head ≠ 1) :
  (mul_head w x hnotone).prod = of x * w.prod :=
begin
  unfold mul_head,
  induction w,
  { simp [mul_head, replace_head], },
  { specialize w_ih_w₁ _ hnotone, clear w_ih_w₂,
    simp [replace_head, ← mul_assoc] at *,
    congr' 1, }
end

section group

variables {G : ι → Type*} [Π i, group (G i)]

/-- The inverse of a non-empty reduced word -/
def inv : Π {i j} (w : neword G i j), neword G j i
| _ _ (singleton x h) := singleton x⁻¹ (mt inv_eq_one.mp h)
| _ _ (append w₁ h w₂) := append w₂.inv h.symm w₁.inv

@[simp]
lemma inv_prod {i j} (w : neword G i j) : w.inv.prod = w.prod⁻¹ :=
by induction w; simp [inv, *]

@[simp]
lemma inv_head {i j} (w : neword G i j) : w.inv.head = w.last⁻¹ :=
by induction w; simp [inv, *]

@[simp]
lemma inv_last {i j} (w : neword G i j) : w.inv.last = w.head⁻¹ :=
by induction w; simp [inv, *]

end group

end neword

section ping_pong_lemma

open_locale pointwise
open_locale cardinal

variables [hnontriv : nontrivial ι]
variables {G : Type*} [group G]
variables {H : ι → Type*} [∀ i, group (H i)]
variables (f : Π i, H i →* G)

-- We need many groups or one group with many elements
variables (hcard : 3 ≤ # ι ∨ ∃ i, 3 ≤ # (H i))

-- A group action on α, and the ping-pong sets
variables {α : Type*} [mul_action G α]
variables (X : ι → set α)
variables (hXnonempty : ∀ i, (X i).nonempty)
variables (hXdisj : pairwise (λ i j, disjoint (X i) (X j)))
variables (hpp : pairwise (λ i j, ∀ h : H i, h ≠ 1 → f i h • X j ⊆ X i))

include hpp

lemma lift_word_ping_pong {i j k} (w : neword H i j) (hk : j ≠ k) :
  lift f w.prod • X k ⊆ X i :=
begin
  rename [i → i', j → j', k → m, hk → hm],
  induction w with i x hne_one i j k l w₁ hne w₂  hIw₁ hIw₂ generalizing m; clear i' j',
  { simpa using hpp _ _ hm _ hne_one, },
  { calc lift f (neword.append w₁ hne w₂).prod • X m
        = lift f w₁.prod • lift f w₂.prod • X m : by simp [mul_action.mul_smul]
    ... ⊆ lift f w₁.prod • X k : set_smul_subset_set_smul_iff.mpr (hIw₂ hm)
    ... ⊆ X i : hIw₁ hne },
end

include X hXnonempty hXdisj

lemma lift_word_prod_nontrivial_of_other_i {i j k} (w : neword H i j)
  (hhead : k ≠ i) (hlast : k ≠ j) : lift f w.prod ≠ 1 :=
begin
  intro heq1,
  have : X k ⊆ X i,
    by simpa [heq1] using lift_word_ping_pong f X hpp w hlast.symm,
  obtain ⟨x, hx⟩ := hXnonempty k,
  exact hXdisj k i hhead ⟨hx, this hx⟩,
end

include hnontriv

lemma lift_word_prod_nontrivial_of_head_eq_last {i} (w : neword H i i) :
  lift f w.prod ≠ 1 :=
begin
  obtain ⟨k, hk⟩ := exists_ne i,
  exact lift_word_prod_nontrivial_of_other_i f X hXnonempty hXdisj hpp w hk hk,
end

lemma lift_word_prod_nontrivial_of_head_card {i j} (w : neword H i j)
  (hcard : 3 ≤ # (H i)) (hheadtail : i ≠ j) : lift f w.prod ≠ 1 :=
begin
  obtain ⟨h, hn1, hnh⟩ := cardinal.three_le hcard 1 (w.head⁻¹),
  have hnot1 : h * w.head ≠ 1, by { rw ← div_inv_eq_mul, exact div_ne_one_of_ne hnh },
  let w' : neword H i i := neword.append
    (neword.mul_head w h hnot1) hheadtail.symm
    (neword.singleton h⁻¹ (inv_ne_one.mpr hn1)),
  have hw' : lift f w'.prod ≠ 1 :=
    lift_word_prod_nontrivial_of_head_eq_last f X hXnonempty hXdisj hpp w',
  intros heq1, apply hw', simp [w', heq1]
end

include hcard
lemma lift_word_prod_nontrivial_of_not_empty {i j} (w : neword H i j) :
  lift f w.prod ≠ 1 :=
begin
  classical,
  cases hcard,
  { obtain ⟨i, h1, h2⟩ := cardinal.three_le hcard i j,
    exact lift_word_prod_nontrivial_of_other_i f X hXnonempty hXdisj hpp w h1 h2, },
  { cases hcard with k hcard,
    by_cases hh : i = k; by_cases hl : j = k,
    { subst hh, subst hl,
      exact lift_word_prod_nontrivial_of_head_eq_last f X hXnonempty hXdisj hpp w, },
    { subst hh,
      change j ≠ i at hl,
      exact lift_word_prod_nontrivial_of_head_card f X hXnonempty hXdisj hpp w hcard hl.symm, },
    { subst hl,
      change i ≠ j at hh,
      have : lift f w.inv.prod ≠ 1 :=
        lift_word_prod_nontrivial_of_head_card f X hXnonempty hXdisj hpp w.inv hcard hh.symm,
      intros heq, apply this, simpa using heq, },
    { change i ≠ k at hh,
      change j ≠ k at hl,
      obtain ⟨h, hn1, -⟩ := cardinal.three_le hcard 1 1,
      let w' : neword H k k := neword.append
        (neword.append (neword.singleton h hn1) hh.symm w)
        hl (neword.singleton h⁻¹ (inv_ne_one.mpr hn1)) ,
      have hw' : lift f w'.prod ≠ 1 :=
        lift_word_prod_nontrivial_of_head_eq_last f X hXnonempty hXdisj hpp w',
      intros heq1, apply hw', simp [w', heq1], }, }
end

lemma empty_of_word_prod_eq_one {w : word H} (h : lift f w.prod = 1) :
  w = word.empty :=
begin
  by_contradiction hnotempty,
  obtain ⟨i, j, w, rfl⟩ := neword.of_word _ hnotempty,
  exact lift_word_prod_nontrivial_of_not_empty f hcard X hXnonempty hXdisj hpp w h,
end

/--
The Ping-Pong-Lemma.

Given a group action of `G` on `X` so that the `H i` acts in a specific way on disjoint subsets
`X i` we can prove that `lift f` is injective, and thus the image of `lift f` is isomorphic to the
direct product of the `H i`.

Often the Ping-Pong-Lemma is stated with regard to subgroups `H i` that generate the whole group;
we generalize to arbitrary group homomorphisms `f i : H i →* G` and do not require the group to be
generated by the images.

Usually the Ping-Pong-Lemma requires that one group `H i` has at least three elements. This
condition is only needed if `# ι = 2`, and we accept `3 ≤ # ι` as an alternative.
-/
theorem lift_injective_of_ping_pong:
  function.injective (lift f) :=
begin
  classical,
  apply (monoid_hom.injective_iff (lift f)).mpr,
  rw free_product.word.equiv.forall_congr_left',
  { intros w Heq,
    dsimp [word.equiv] at *,
    { rw empty_of_word_prod_eq_one f hcard X hXnonempty hXdisj hpp Heq,
      reflexivity, }, },
  apply_instance,
  apply_instance,
end

end ping_pong_lemma

/-- The free product of free groups is itself a free group -/
@[simps]
instance {ι : Type*} (G : ι → Type*) [∀ i, group (G i)] [hG : ∀ i, is_free_group (G i)] :
  is_free_group (free_product G) :=
{ generators := Σ i, is_free_group.generators (G i),
  of := λ x, free_product.of (is_free_group.of x.2),
  unique_lift' :=
  begin
    introsI X _ f,
    refine ⟨free_product.lift (λ i, is_free_group.lift (λ x, f ⟨i, x⟩)), _ ⟩,
    split,
    { simp, },
    { intros g hfg, ext i x, simpa using hfg ⟨i, x⟩, }
  end, }

end free_product