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
  have h1 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)),
  from by auto [int.fract_eq_iff, int.coe_nat_ne_zero, hα_irrat, int.coe_nat_inj, subtype.ext, int.coe_nat_inj],

  have h2 : closure ((λ m : ℤ, int.fract (α * ↑m)) '' univ) ⊆ Icc (0 : ℝ) (1 : ℝ),
  from by auto [closure_subset_iff, int.fract_nonneg, int.fract_lt_one],

  have h3 : ∀ (m : ℤ), (int.fract (α * ↑m)) ∈ Icc (0 : ℝ) (1 : ℝ),
  from by auto [int.fract_nonneg, int.fract_lt_one],

  have h4 : ∀ (m : ℤ), (int.fract (α * ↑m)) ∈ closure ((λ m : ℤ, int.fract (α * ↑m)) '' univ),
  from by auto [closure_iff, h3, h2],

  have h5 : ∀ (m : ℤ), (int.fract (α * ↑m)) ∈ set.Icc 0 1,
  from by auto [h4, h2],

  have h6 : Icc (0 : ℝ) (1 : ℝ) ⊆ closure ((λ m : ℤ, int.fract (α * ↑m)) '' univ),
  from by auto [closure_iff, h5],

  show Icc 0 1 = closure ((λ m : ℤ, int.fract (α * ↑m)) '' univ),
  from by auto [closure_subset_iff, h6]

end

--OUTPUT 2
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  let S : set ℝ := {x : ℝ | ∃ m : ℤ, x = int.fract (α * ↑m)},
  have h1 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from begin
    assume i j h1 h2,
    have h3 : (α = (int.fract (α * ↑i) - int.fract (α * ↑j))/(i-j)),
    from by auto [int.fract_add, int.fract_mul, int.fract_eq_of_eq, h2],
    have h4 : (α ∈ ℚ), from by auto [h3],
    exact absurd h4 hα_irrat,
  end,
  have h2 : S.nonempty, from by auto [h1, exists_int],
  have h3 : ∃ x : ℝ, x ∈ S, from by auto using [exists_int],
  have h4 : S ⊆ set.Icc 0 1, from by auto [int.fract_lt_one, int.fract_nonneg],
  have h5 : ∀ x : ℝ, x ∈ S → x ∈ closure S, from by auto [mem_closure_iff_nhds],
  have h6 : ∀ x : ℝ, x ∈ S → x ∈ closure S, from by auto [mem_closure_iff_nhds],
  have h7 : ∀ (x : ℝ) (hx : x ∈ S), closure S ⊆ closure (set.Icc 0 1), from by auto [closure_mono],
  have h8 : closure S ⊆ closure (set.Icc 0 1), from by auto [h7],
  have h9 : closure (set.Icc 0 1) ⊆ closure S, from by auto [closure_mono],
  have h10 : closure S = closure (set.Icc 0 1), from by auto [set.eq_of_subset_of_subset_of_empty h8 h9],
  have h11 : ∀ (x : ℝ) (hx : x ∈ S), closure S ⊆ closure (set.Icc 0 1), from by auto [closure_mono],
  have h12 : closure S ⊆ closure (set.Icc 0 1), from by auto [h11],
  have h13 : closure (set.Icc 0 1) ⊆ closure S, from by auto [closure_mono],
  have h14 : closure S = closure (set.Icc 0 1), from by auto [set.eq_of_subset_of_subset_of_empty h12 h13],
  have h15 : closure S = closure (set.Icc 0 1), from by auto [h14],
  show closure S = set.Icc 0 1, from by auto [h15],
end

--OUTPUT 3
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  have h1 : ∀ n m : ℤ, (n ≠ m) → (int.fract (α * ↑n) ≠ int.fract (α * ↑m)),
  begin
    assume (n m : ℤ) (h1 : n ≠ m),
    assume h2 : (int.fract (α * ↑n)) = (int.fract (α * ↑m)),
    have h3 : (α * ↑n) = (α * ↑m), from by auto [int.fract_eq_iff] using [h1, h2],
    have h4 : α = (↑m * α * ↑n⁻¹) ∈ ℚ, from by auto [mul_comm, mul_assoc, mul_comm, ←mul_assoc, mul_inv_cancel] using [h1, h3, int.coe_nat_ne_zero],
    show false, from by auto [hα_irrat] using [h4],
  end,

  let seq_limit : (ℕ → ℝ) → ℤ → ℝ → Prop :=
  λ (u : ℕ → ℝ) (l : ℤ) (l' : ℝ), ∀ ε > 0, ∃ N, ∀ n > N, |u n - l'| < ε,

  have h2 : ∀ (l : ℤ), seq_limit (λ (n : ℕ), int.fract (α * ↑n)) l 0,
  begin
    assume (l : ℤ),
    assume (ε),
    assume (h3 : ε > 0),
    use (l + 1),
    assume (n),
    assume (h4 : n > l + 1),
    have h5 : (int.fract (α * ↑(n - 1))) = (int.fract (α * ↑l)), from by auto [int.fract_eq_iff] using [h1],
    have h6 : (int.fract (α * ↑n)) = (int.fract (α * ↑(n - 1))), from by auto [mul_sub_left_distrib, int.fract_add],
    have h7 : (int.fract (α * ↑n)) = (int.fract (α * ↑l)), from by auto [h5, h6],
    have h8 : |(int.fract (α * ↑n))| < ε, from by auto [int.fract_int_lt, h4, h7],
    show |(int.fract (α * ↑n)) - 0| < ε, from by auto [h8],
  end,

  have h3 : ∀ (l : ℤ), seq_limit (λ (n : ℕ), int.fract (α * ↑n)) l 0, from by auto [h2] using [h2],

  have h4 : ∀ (l : ℤ), seq_limit (λ (n : ℕ), int.fract (α * ↑n)) l 0, from by auto [h3] using [h3],

  have h5 : ∃ (l : ℤ), seq_limit (λ (n : ℕ), int.fract (α * ↑n)) l 0, from by auto [exists.intro] using [h2],

  have h6 : ∃ (l : ℤ), seq_limit (λ (n : ℕ), int.fract (α * ↑n)) l 0, from by auto [exists.intro] using [h2],

  have h7 : ∃ (l : ℤ), seq_limit (λ (n : ℕ), int.fract (α * ↑n)) l 0, from by auto [exists.intro] using [h2],

  have h8 : ∃ (l : ℤ), seq_limit (λ (n : ℕ), int.fract (α * ↑n)) l 0, from by auto [exists.intro] using [h2],

  have h9 : ∃ (l : ℤ), seq_limit (λ (n : ℕ), int.fract (α * ↑n)) l 0, from by auto [exists.intro] using [h2],

  have h10 : ∃ (l : ℤ), seq_limit (λ (n : ℕ), int.fract (α * ↑n)) l 0, from by auto [exists.intro] using [h2],

  have h11 : ∃ (l : ℤ), seq_limit (λ (n : ℕ), int.fract (α * ↑n)) l 0, from by auto [exists.intro] using [h2],

  have h12 : ∃ (l : ℤ), seq_limit (λ (n : ℕ), int.fract (α * ↑n)) l 0, from by auto [exists.intro] using [h2],

  have h13 : ∃ (l : ℤ), seq_limit (λ (n : ℕ), int.fract (α * ↑n)) l 0, from by auto [exists.intro] using [h2],

  have h14 : ∃ (l : ℤ), seq_limit (λ (n : ℕ), int.fract (α * ↑n)) l 0, from by auto [exists.intro] using [h2],

  have h15 : ∃ (l : ℤ), seq_limit (λ (n : ℕ), int.fract (α * ↑n)) l 0, from by auto [exists.intro] using [h2],

  have h16 : ∃ (l : ℤ), seq_limit (λ (n : ℕ), int.fract (α * ↑n)) l 0, from by auto [exists.intro] using [h2],

  have h17 : ∃ (l : ℤ), seq_limit (λ (n : ℕ), int.fract (α * ↑n)) l 0, from by auto [exists.intro] using [h2],

  have h18 : ∃ (l : ℤ), seq_limit (λ (n : ℕ), int.fract (α * ↑n)) l 0, from by auto [exists.intro] using [h2],

  have h19 : ∃ (l : ℤ), seq_limit (λ (n : ℕ), int.fract (α * ↑n)) l 0, from by auto [exists.intro] using [h2],

  have h20 : ∃ (l : ℤ), seq_limit (λ (n : ℕ), int.fract (α * ↑n)) l 0, from by auto [exists.intro] using [h2],

  have h21 : ∃ (l : ℤ), seq_limit (λ (n : ℕ), int.fract (α * ↑n)) l 0, from by auto [exists.intro] using [h2],

  have h22 : ∃ (l : ℤ), seq_limit (λ (n : ℕ), int.fract (α * ↑n)) l 0, from by auto [exists.intro] using [h2],

  have h23 : ∃ (l : ℤ), seq_limit (λ (n : ℕ), int.fract (α * ↑n)) l 0, from by auto [exists.intro] using [h2],

  have h24 : ∃ (l : ℤ), seq_limit (λ (n : ℕ), int.fract (α * ↑n)) l 0, from by auto [exists.intro] using [h2],

  have h25 : ∃ (l : ℤ), seq_limit (λ (n : ℕ), int.fract (α * ↑n)) l 0, from by auto [exists.intro] using [h2],

  have h26 : ∃ (l : ℤ), seq_limit (λ (n : ℕ), int.fract (α * ↑n)) l 0, from by auto [exists.intro] using [h2],

  have h27 : ∃ (l : ℤ), seq_limit (λ (n : ℕ), int.fract (α * ↑n)) l 0, from by auto
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 :=
begin
  let S := (λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ),
  let S_nonempty : ¬ S = ∅ := set.ne_empty_iff_exists_mem.2 ⟨0, ⟨0, by simp⟩⟩,
  let S_clos_S : closure S = S := set.closure_eq_of_is_closed (show is_closed S, from set.is_closed_Icc_iff.2 ⟨S_nonempty, S_nonempty⟩),
  have h1 : ∀ (i : ℤ) (j : ℤ), i ≠ j → ⟨int.fract (α * ↑i), 0, 1⟩ ≠ ⟨int.fract (α * ↑j), 0, 1⟩,
  begin
    assume i j h,
    have h1 : int.fract (α * ↑i) = int.fract (α * ↑j), from by simp [h],
    have h2 : (int.fract (α * ↑i) : ℝ) = (int.fract (α * ↑j) : ℝ), from by simp [h1],
    have h3 : (α * ↑i - int.fract (α * ↑i) : ℝ) = (α * ↑j - int.fract (α * ↑j) : ℝ), from by simp [h2, int.fract_eq_of_lt],
    have h4 : (α : ℝ) = ((int.fract (α * ↑i) - int.fract (α * ↑j)) : ℝ) / ((i - j) : ℝ), from by simp [h3],
    have h5 : (α : ℝ) * ((i - j) : ℝ) = (int.fract (α * ↑i) - int.fract (α * ↑j)) : ℝ, from by simp [h4],
    have h6 : (α : ℝ) * ((i - j) : ℝ) = (α * ↑i - int.fract (α * ↑i) : ℝ) - (α * ↑j - int.fract (α * ↑j) : ℝ), from by simp [h5, mul_sub],
    have h7 : (α : ℝ) * ((i - j) : ℝ) = α * (↑i - ↑j), from by simp [h6],
    have h8 : (α : ℝ) * ((i - j) : ℝ) = α * ((i - j) : ℝ), from by simp [h7],
    have h9 : (α : ℝ) * ((i - j) : ℝ) = 0, from by simp [h8],
    have h10 : (α : ℝ) ≠ 0, from by simp [hα_irrat],
    have h11 : (i - j) = 0, from (eq_zero_or_eq_zero_of_mul_eq_zero h10 h9).elim (λ h, absurd h h),
    show false, from by simp [h11, h],
  end,
  have h2 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i) : ℝ) ≠ (int.fract (α * ↑j) : ℝ), from by auto [h1],
  have h3 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i) : ℝ) ∉ {(int.fract (α * ↑j) : ℝ)}, from by auto [h2],
  have S_inj : function.injective (λ (m : ℤ), int.fract (α * ↑m)) := set.injective_iff_ne_iff_image_ne_empty.2 h3,
  have h4 : (S : set ℝ) = range (λ (m : ℤ), int.fract (α * ↑m)), from by auto [S_inj, S],
  have S_dense : closure S = set.Icc 0 1 := set.closure_range (λ m hm, by simp [hm, int.fract_nonneg, int.fract_lt_one]),
  show closure S = set.Icc 0 1, from by simp [S_dense, S_clos_S, h4],
end

--OUTPUT 5
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  have h1 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from
  begin
    assume i j h1,
    assume h2 : int.fract (α * ↑i) = int.fract (α * ↑j),
    have h3 : α = (int.nat_abs α * ↑i + int.fract (α * ↑i)) / ↑i, from by auto [int.fract_add_nat_abs, mul_comm],
    have h4 : α = (int.nat_abs α * ↑j + int.fract (α * ↑j)) / ↑j, from by auto [int.fract_add_nat_abs, mul_comm, h2],
    have h5 : α = (int.nat_abs α * ↑i - int.nat_abs α * ↑j) / (↑i - ↑j), from by auto [h3, h4, int.fract_add_nat_abs, mul_comm, mul_add, mul_neg_eq_neg_mul_symm, add_mul, nat_abs_mul_self, nat_abs_of_nonneg, le_of_lt, int.coe_nat_lt, int.coe_nat_le_coe_nat_iff, nat.cast_lt, nat.cast_le, int.cast_le, int.cast_lt],
    have h6 : (int.nat_abs α * ↑i - int.nat_abs α * ↑j) / (↑i - ↑j) ∈ ℚ, from by auto [h5, rationals.of_int],
    have h7 : (int.nat_abs α * ↑i - int.nat_abs α * ↑j) = 0, from by auto [int.cast_inj, int.nat_abs_eq_nat_abs],
    have h8 : ↑i = ↑j, from by auto [nat.mul_right_inj, int.coe_nat_eq_coe_nat_iff, h7, int.coe_nat_zero, nat.cast_inj],
    have h9 : i = j, from by auto [h8],
    show false, from by auto [h1, h9],
  end,
  have h2 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ∈ (λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ), from by auto [h1],
  have h3 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ∉ (λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ), from by auto [h1],
  have h4 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ∈ closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)), from by auto [set.mem_closure_iff],
  have h5 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ∉ closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)), from by auto [set.not_mem_closure_iff],
  have h6 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ∈ (closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ))), from by auto [h4],
  have h7 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ∉ (closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ))), from by auto [h5],
  have h8 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by auto [h1],
  have h9 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ∈ (closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ))), from by auto [h6],
  have h10 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ∉ (closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ))), from by auto [h7],
  have h11 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ∈ (closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ))), from by auto [h9],
  have h12 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ∉ (closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ))), from by auto [h10],
  have h13 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ∈ (closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ))), from by auto [h11],
  have h14 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ∉ (closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ))), from by auto [h12],
  have h15 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ∈ (closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ))), from by auto [h13],
  have h16 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ∉ (closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ))), from by auto [h14],
  have h17 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ∈ (closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ))), from by auto [h15],
  have h18 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ∉ (closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ))), from by auto [h16],
  have h19 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ∈ (closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ))), from by auto [h17],
  have h20 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ∉ (closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ))), from by auto [h18],
  have h21 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ∈ (closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ))), from by auto [h19],
  have h22 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ∉ (closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ
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 :=
begin
  have h1 : ∀ i j ∈ ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff] using [hα_irrat, classical],

  have h2 : ∀ i ∈ ℤ, int.fract (α * ↑i) ∈ set.Icc 0 1,
  from by auto [int.fract_range],

  have h3 : ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) ⊆ set.Icc 0 1,
  from by auto [mem_image, h2],

  have h4 : ∀ i j ∈ ℤ, i ≠ j → λ (x : ℝ), abs (int.fract (α * ↑i) - int.fract (α * ↑j)) ≠ x,
  from by auto [abs_of_pos (int.fract_pos), h1],

  have h5 : ∀ i ∈ ℤ, λ (x : ℝ), abs (int.fract (α * ↑i) - int.fract (α * ↑i)) ≠ x,
  from by auto [abs_of_nonneg (int.fract_nonneg), h1],

  have h6 : ∀ i ∈ ℤ, int.fract (α * ↑i) ≠ 0,
  from by auto [int.fract_pos, zero_lt_one],

  have h7 : ∀ i ∈ ℤ, int.fract (α * ↑i) ≠ 1,
  from by auto [int.fract_lt_one, one_lt_two],

  have h8 : ∀ i ∈ ℤ, λ (x : ℝ), abs (int.fract (α * ↑i)) ≠ x,
  from by auto [abs_of_nonneg (int.fract_nonneg), h6, h7],

  have h9 : ∀ i ∈ ℤ, λ (x : ℝ), abs (int.fract (α * ↑i)) ≠ x,
  from by auto [abs_of_nonneg (int.fract_nonneg), h6, h7],

  have h10 : ∀ i ∈ ℤ, λ (x : ℝ), abs (int.fract (α * ↑i) - 1) ≠ x,
  from by auto [abs_of_nonneg (int.fract_nonneg), h6, h7],

  have h11 : ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) ⊆ ((λ (x : ℝ), abs (x)) '' set.Icc 0 1),
  from by auto [mem_image, mem_Icc, h6, h7, h8],

  have h12 : ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) ⊆ ((λ (x : ℝ), abs (x - 1)) '' set.Icc 0 1),
  from by auto [mem_image, mem_Icc, h6, h7, h10],

  have h13 : ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) ⊆ ((λ (x : ℝ), abs (x - x)) '' set.Icc 0 1),
  from by auto [mem_image, mem_Icc, h6, h7, h9],

  have h14 : ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) ⊆ ((λ (x : ℝ), abs (x - y)) '' set.Icc 0 1) ∪ ((λ (x : ℝ), abs (x - z)) '' set.Icc 0 1),
  from by auto [mem_image, mem_Icc, h6, h7, h4, h5],

  have h15 : ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) ⊆ ((λ (x : ℝ), abs (x - y)) '' set.Icc 0 1),
  from by auto [mem_image, mem_Icc, h6, h7, h4, h5],

  have h16 : ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) ⊆ ((λ (x : ℝ), abs (x - z)) '' set.Icc 0 1),
  from by auto [mem_image, mem_Icc, h6, h7, h4, h5],

  have h17 : ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) ⊆ closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)),
  from by auto [mem_image, mem_Icc, h6, h7, h4, h5],

  have h18 : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) ⊆ ((λ (x : ℝ), abs (x - y)) '' set.Icc 0 1) ∪ ((λ (x : ℝ), abs (x - z)) '' set.Icc 0 1),
  from by auto [mem_image, mem_Icc, h6, h7, h4, h5],

  have h19 : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) ⊆ ((λ (x : ℝ), abs (x - y)) '' set.Icc 0 1),
  from by auto [mem_image, mem_Icc, h6, h7, h4, h5],

  have h20 : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) ⊆ ((λ (x : ℝ), abs (x - z)) '' set.Icc 0 1),
  from by auto [mem_image, mem_Icc, h6, h7, h4, h5],

  have h21 : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) ⊆ ((λ (x : ℝ), abs (x)) '' set.Icc 0 1),
  from by auto [mem_image, mem_Icc, h6, h7, h8],

  have h22 : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) ⊆ ((λ (x : ℝ), abs (x - 1)) '' set.Icc 0 1),
  from by auto [mem_image, mem_Icc, h6, h7, h10],

  have h23 : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) ⊆ ((λ (x : ℝ), abs (x - x)) '' set.Icc 0 1),
  from by auto [mem_image, mem_Icc, h6, h7, h9],

  have h24 : ((λ (x : ℝ), abs (x - y)) '' set.Icc 0 1) ⊆ ((λ (x : ℝ), abs (x - z)) '' set.Icc 0 1) ∪ ((λ (x : ℝ), abs (x - z)) '' set.Icc 0 1),
  from by auto [mem_image, mem_Icc, h6, h7, h4, h5],

  have h25 : ((λ (x : ℝ), abs (x - y)) '' set.Icc 0 1) ⊆ ((λ (x : ℝ), abs (x - z)) '' set.Icc 0 1),
  from by auto [mem_image, mem_
end --Needs more than 2000 tokens!

--OUTPUT 7
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  have h1 : (λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ) ∈ 𝒫 (set.univ : set ℤ), from by auto [int.fract_between_zero_one],

  have h2 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from begin
    assume (i j : ℤ) (h2 : i ≠ j),
    have h3 : (α * ↑i) - (↑i * α) < 1 ∧ (α * ↑i) - (↑i * α) ≥ 0,
    from by auto [int.fract_lt_one, int.fract_nonneg],
    have h4 : (α * ↑j) - (↑j * α) < 1 ∧ (α * ↑j) - (↑j * α) ≥ 0,
    from by auto [int.fract_lt_one, int.fract_nonneg],
    have h5 : ((α * ↑i) - (↑i * α)) = ((α * ↑j) - (↑j * α)) ↔ (α * ↑i - α * ↑j) = (↑i - ↑j) * α ↔ (α * (↑i - ↑j)) = (↑i - ↑j) * α ↔ α = (↑i - ↑j) / (↑i - ↑j),
    from by auto [sub_eq_iff_eq_add, mul_sub, mul_sub, mul_sub, mul_sub, mul_sub, mul_sub, mul_sub, mul_sub, mul_sub, sub_mul],
    have h6 : i - j ≠ 0, from by auto [sub_ne_zero],
    have h7 : α = (↑i - ↑j) / (↑i - ↑j), from by auto [h5, h3, h4],
    have h8 : α ∈ (rat.fract (↑i - ↑j) (↑i - ↑j)) :: set.univ, from by auto [rat.mk_eq_div, rat.mk_eq_div, rat.mk_eq_div, rat.mk_eq_div, h7],
    have h9 : α ∈ set.univ, from by auto [h8, set.mem_univ],
    show int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by auto [h2, h9, hα_irrat, irrational_iff_not_in_fracts],
  end,

  have h3 : ∀ i j : ℤ, i ≠ j → (λ (m : ℤ), int.fract (α * ↑m)) i ≠ (λ (m : ℤ), int.fract (α * ↑m)) j,
  from by auto [h2],

  have h4 : ∀ i j : ℤ, i ≠ j → ¬(int.fract (α * ↑i) = int.fract (α * ↑j)), from by auto [h3],
  have h5 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i) = int.fract (α * ↑j)) → false, from by auto [h4],
  have h6 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by auto [h5] using [classical],
  have h7 : ∀ i j : ℤ, i ≠ j → (λ (m : ℤ), int.fract (α * ↑m)) i ≠ (λ (m : ℤ), int.fract (α * ↑m)) j, from by auto [h6],
  have h8 : ∀ i j : ℤ, i ≠ j → ¬(int.fract (α * ↑i) = int.fract (α * ↑j)), from by auto [h7],
  have h9 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i) = int.fract (α * ↑j)) → false, from by auto [h8],
  have h10 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by auto [h9] using [classical],
  have h11 : ∀ i j : ℤ, i ≠ j → (λ (m : ℤ), int.fract (α * ↑m)) i ≠ (λ (m : ℤ), int.fract (α * ↑m)) j, from by auto [h10],
  have h12 : ∀ i j : ℤ, i ≠ j → ¬(int.fract (α * ↑i) = int.fract (α * ↑j)), from by auto [h11],
  have h13 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i) = int.fract (α * ↑j)) → false, from by auto [h12],
  have h14 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by auto [h13] using [classical],
  have h15 : ∀ i j : ℤ, i ≠ j → (λ (m : ℤ), int.fract (α * ↑m)) i ≠ (λ (m : ℤ), int.fract (α * ↑m)) j, from by auto [h14],
  have h16 : ∀ i j : ℤ, i ≠ j → ¬(int.fract (α * ↑i) = int.fract (α * ↑j)), from by auto [h15],
  have h17 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i) = int.fract (α * ↑j)) → false, from by auto [h16],
  have h18 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by auto [h17] using [classical],
  have h19 : ∀ i j : ℤ, i ≠ j → (λ (m : ℤ), int.fract (α * ↑m)) i ≠ (λ (m : ℤ), int.fract (α * ↑m)) j, from by auto [h18],
  have h20 : ∀ i j : ℤ, i ≠ j → ¬(int.fract (α * ↑i) = int.fract (α * ↑j)), from by auto [h19],
  have h21 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i) = int.fract (α * ↑j)) → false, from by auto [h20],
  have h22 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by auto [h21] using [classical],
  have h23 : ∀ i j : ℤ, i ≠ j → (λ (m : ℤ), int.fract (α * ↑m)) i ≠ (λ (m : ℤ), int.fract (α * ↑m)) j, from by auto [h22],
  have h24 : ∀ i j : ℤ, i ≠ j → ¬(int.fract (α * ↑i) = int.fract (α * ↑j)), from by auto [h23],
  have h25 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i) = int.fract (α * ↑j)) → false, from by auto [h24],
  have h26 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by auto [h25] using [classical],
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 :=
begin
  have h1 : ∀ i j : ℤ, (i ≠ j) → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from
  begin
    assume i j,
    assume h2 : (i ≠ j),
    assume h3 : (int.fract (α * ↑i) = int.fract (α * ↑j)),
    have h4 : ↑i * α - ↑(int.floor (↑i * α)) = int.fract (α * ↑i), from by auto [int.fract_def],
    have h5 : ↑j * α - ↑(int.floor (↑j * α)) = int.fract (α * ↑j), from by auto [int.fract_def],
    have h6 : ↑i * α - ↑(int.floor (↑i * α)) = ↑j * α - ↑(int.floor (↑j * α)), from by auto [h3, h4, h5],
    have h7 : ↑i * α - ↑(int.floor (↑i * α)) = (↑j - ↑i) * α, from by auto [sub_eq_iff_eq_add, nat.cast_sub, ← int.coe_nat_eq_coe_nat_iff, int.coe_nat_sub, int.coe_nat_add],
    have h8 : (↑j - ↑i) * α = ↑(int.floor (↑j * α)) - ↑(int.floor (↑i * α)), from by auto [h6, h7],
    have h9 : (↑j - ↑i) * α = ↑(int.floor (↑j * α)) - ↑(int.floor (↑i * α)), from by auto [h7, h6],
    have h10 : int.floor (↑j * α) - int.floor (↑i * α) = 0, from by auto [int.coe_nat_sub, int.coe_nat_eq_coe_nat_iff],
    have h11 : ↑(int.floor (↑j * α)) - ↑(int.floor (↑i * α)) = 0, from by auto [nat.cast_sub, ← int.coe_nat_eq_coe_nat_iff, int.coe_nat_sub, int.coe_nat_eq_coe_nat_iff, h10],
    have h12 : (↑j - ↑i) * α = 0, from by auto [h11, h9],
    have h13 : (↑j - ↑i) = 0, from by auto [int.coe_nat_sub, int.coe_nat_eq_coe_nat_iff, int.coe_nat_zero, int.coe_nat_mul, int.coe_nat_eq_coe_nat_iff, h12, int.coe_nat_zero],
    have h14 : (j - i) = 0, from by auto [nat.sub_eq_zero_iff_eq, h13],
    have h15 : (j = i), from by auto [nat.sub_eq_zero_iff_eq, h14],
    have h16 : (j = i), from by auto [h15, h2],
    show false, from by auto [h16],
  end,
  have h2 : ∀ i j : ℤ, (int.fract (α * ↑i) = int.fract (α * ↑j)) → (i = j), from
  begin
    assume i j,
    assume h3 : (int.fract (α * ↑i) = int.fract (α * ↑j)),
    have h4 : (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h1],
    have h5 : ¬(i ≠ j), from by auto [h4, h3],
    have h6 : i = j, from by auto [h5],
    show (i = j), from by auto [h6],
  end,
  have h3 : ∀ i j : ℤ, (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h1],
  have h4 : ∀ i j : ℤ, (int.fract (α * ↑i) = int.fract (α * ↑j)) → (i = j), from by auto [h2],
  have h5 : ∀ x : ℤ, (int.fract (α * ↑x) ∈ set.Icc 0 1), from by auto [int.fract_range],
  have h6 : (λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ) ⊆ set.Icc 0 1, from by auto [h5],
  have h7 : (λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ) ⊆ (closure (λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ)), from by auto [set.subset.refl],
  have h8 : (λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ) ⊆ (closure (λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ)), from by auto [set.subset.trans, h6, h7],
  have h9 : (closure (λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ)) ⊆ (closure (λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ)), from by auto [set.subset.refl],
  have h10 : (λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ) ⊆ (closure (λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ)) → (closure (λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ)) ⊆ (closure (λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ)) → closure ((λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ)) = closure (λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ), from by auto [set.eq_of_subset_of_subset],
  have h11 : closure ((λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ)) = closure (λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ), from by auto [h10, h8, h9],
  have h12 : closure ((λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ)) = closure (λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ) → closure ((λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ)) = closure (λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ), from by auto [set.eq_of_subset_of_subset],
  have h13 : closure ((λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ)) = closure (λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ), from by auto [h12, h11],
  have h14 : closure ((λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ)) = closure (λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ) → closure ((λ (m : ℤ), int.
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  irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
FEW SHOT PROMPTS TO CODEX(END)-/


import measure_theory.decomposition.radon_nikodym
import measure_theory.measure.with_density_vector_measure

noncomputable theory
open_locale classical measure_theory nnreal ennreal

lemma ennreal.of_real_le_norm (r : ℝ) : ennreal.of_real r ≤ ∥r∥₊ :=
begin
  by_cases hr : r ≤ 0,
  { rw [ennreal.of_real_eq_zero.2 hr],
    simp only [zero_le', ennreal.coe_nonneg] },
  { rw [real.nnnorm_of_nonneg (le_of_not_le hr), ennreal.of_real, ennreal.coe_le_coe,
        ← nnreal.coe_le_coe, real.coe_to_nnreal r (le_of_not_le hr), subtype.coe_mk] }
end

variables {α β : Type*} {m : measurable_space α}

namespace measure_theory

include m

open signed_measure

-- namespace measure -- In mathlib as measure.with_densityᵥ

-- open topological_space

-- section with_density_signed_measure

-- /- Show s ↦ ∫ x in s, f x ∂μ form a signed measure. -/

-- variables {μ ν : measure α} {f g : α → ℝ}

-- lemma is_finite_measure_of_real_of_integrable (hf : has_finite_integral f μ) :
--   is_finite_measure (μ.with_density (λ x, ennreal.of_real (f x))) :=
-- is_finite_measure_with_density
--   (lt_of_le_of_lt (lintegral_mono (λ x, ennreal.of_real_le_norm (f x))) hf)

-- /-- Given a measure `μ` and a integrable function `f`, `μ.with_density_signed_measure f` is
-- the signed measure which maps the set `s` to `∫ₛ f⁺ ∂μ - ∫ₛ f⁻ ∂μ`. -/
-- def with_density_signed_measure {m : measurable_space α}
--   (μ : measure α) (f : α → ℝ) : signed_measure α :=
-- if hf : has_finite_integral f μ then
--   @to_signed_measure α m (μ.with_density (λ x, ennreal.of_real (f x)))
--   (is_finite_measure_of_real_of_integrable hf)
--   -
--   @to_signed_measure α m (μ.with_density (λ x, ennreal.of_real (-f x)))
--   (is_finite_measure_of_real_of_integrable (has_finite_integral_neg_iff.2 hf))
-- else 0

-- lemma with_density_signed_measure_apply (hf : integrable f μ)
--   {i : set α} (hi : measurable_set i) :
--   μ.with_density_signed_measure f i = ∫ x in i, f x ∂μ :=
-- begin
--   rw integral_eq_lintegral_pos_part_sub_lintegral_neg_part,
--   { rw [with_density_signed_measure, dif_pos hf.2],
--     simp [if_pos hi, with_density_apply _ hi] },
--   { rw ← integrable_on_univ,
--     exact hf.integrable_on.restrict measurable_set.univ },
-- end

-- @[simp]
-- lemma with_density_signed_measure_zero :
--   μ.with_density_signed_measure 0 = 0 :=
-- begin
--   ext1 i hi,
--   erw [with_density_signed_measure_apply (integrable_zero α ℝ μ) hi],
--   simp,
-- end

-- @[simp]
-- lemma with_density_signed_measure_neg (hf : integrable f μ) :
--   μ.with_density_signed_measure (-f) = -μ.with_density_signed_measure f :=
-- begin
--   ext1 i hi,
--   rw [vector_measure.neg_apply, with_density_signed_measure_apply hf hi,
--       ← integral_neg, with_density_signed_measure_apply hf.neg hi],
--   refl
-- end

-- @[simp]
-- lemma with_density_signed_measure_add (hf : integrable f μ) (hg : integrable g μ) :
--   μ.with_density_signed_measure (f + g) =
--   μ.with_density_signed_measure f + μ.with_density_signed_measure g :=
-- begin
--   ext1 i hi,
--   rw [with_density_signed_measure_apply (hf.add hg) hi, vector_measure.add_apply,
--       with_density_signed_measure_apply hf hi, with_density_signed_measure_apply hg hi],
--   simp_rw [pi.add_apply],
--   rw integral_add; rw ← integrable_on_univ,
--   { exact hf.integrable_on.restrict measurable_set.univ },
--   { exact hg.integrable_on.restrict measurable_set.univ }
-- end

-- @[simp]
-- lemma with_density_signed_measure_sub (hf : integrable f μ) (hg : integrable g μ) :
--   μ.with_density_signed_measure (f - g) =
--   μ.with_density_signed_measure f - μ.with_density_signed_measure g :=
-- by rw [sub_eq_add_neg, sub_eq_add_neg, with_density_signed_measure_add hf hg.neg,
--        with_density_signed_measure_neg hg]

-- @[simp]
-- lemma with_density_signed_measure_smul (r : ℝ) (hf : integrable f μ) :
--   μ.with_density_signed_measure (r • f) = r • μ.with_density_signed_measure f :=
-- begin
--   ext1 i hi,
--   rw [with_density_signed_measure_apply (hf.smul r) hi, vector_measure.smul_apply,
--       with_density_signed_measure_apply hf hi, ← integral_smul],
--   refl
-- end

-- lemma with_density_signed_measure_absolutely_continuous
--   (μ : measure α) (f : α → ℝ) :
--   μ.with_density_signed_measure f ≪ μ.to_ennreal_vector_measure :=
-- begin
--   by_cases hf : has_finite_integral f μ,
--   { refine vector_measure.absolutely_continuous.mk (λ i hi₁ hi₂, _),
--     rw to_ennreal_vector_measure_apply_measurable hi₁ at hi₂,
--     rw [with_density_signed_measure, dif_pos hf, vector_measure.sub_apply,
--         to_signed_measure_apply_measurable hi₁, to_signed_measure_apply_measurable hi₁,
--         with_density_apply _ hi₁, with_density_apply _ hi₁,
--         lintegral_in_measure_zero _ _ hi₂, lintegral_in_measure_zero _ _ hi₂,
--         ennreal.zero_to_real, sub_zero] },
--   { rw [with_density_signed_measure, dif_neg hf],
--     exact vector_measure.absolutely_continuous.zero _ }
-- end

-- end with_density_signed_measure

-- section

-- variables {μ : measure α} {f g : α → ℝ}

-- /-- Having the same density implies the underlying functions are equal almost everywhere. -/
-- lemma ae_eq_of_with_density_signed_measure_eq (hf : integrable f μ) (hg : integrable g μ)
--   (hfg : μ.with_density_signed_measure f = μ.with_density_signed_measure g) :
--   f =ᵐ[μ] g :=
-- begin
--   refine integrable.ae_eq_of_forall_set_integral_eq f g hf hg (λ i hi _, _),
--   rw [← with_density_signed_measure_apply hf hi, hfg, with_density_signed_measure_apply hg hi]
-- end

-- end

-- end measure

namespace signed_measure

open measure vector_measure

def radon_nikodym_deriv (s : signed_measure α) (μ : measure α) : α → ℝ := λ x,
(s.to_jordan_decomposition.pos_part.radon_nikodym_deriv μ x).to_real -
(s.to_jordan_decomposition.neg_part.radon_nikodym_deriv μ x).to_real

@[measurability]
lemma measurable_radon_nikodym_deriv (s : signed_measure α) (μ : measure α) :
  measurable (radon_nikodym_deriv s μ) :=
begin
  rw [radon_nikodym_deriv],
  measurability,
end

lemma has_finite_integral_to_real_of_lintegral_ne_top
  {μ : measure α} {f : α → ℝ≥0∞} (hf : ∫⁻ x, f x ∂μ ≠ ∞) :
  has_finite_integral (λ x, (f x).to_real) μ :=
begin
  have : ∀ x, (∥(f x).to_real∥₊ : ℝ≥0∞) =
    @coe ℝ≥0 ℝ≥0∞ _ (⟨(f x).to_real, ennreal.to_real_nonneg⟩ : ℝ≥0),
  { intro x, rw real.nnnorm_of_nonneg },
  simp_rw [has_finite_integral, this],
  refine lt_of_le_of_lt (lintegral_mono (λ x, _)) (lt_top_iff_ne_top.2 hf),
  by_cases hfx : f x = ∞,
  { simp [hfx] },
  { lift f x to ℝ≥0 using hfx with fx,
    simp [← h] }
end

@[simp]
lemma lintegral_univ {μ : measure α} (f : α → ℝ≥0∞) :
  ∫⁻ x in set.univ, f x ∂μ = ∫⁻ x, f x ∂μ :=
by rw measure.restrict_univ

-- move to `measure` namespace
lemma lintegral_radon_nikodym_deriv_lt_top
  (μ ν : measure α) [is_finite_measure μ] :
  ∫⁻ x, μ.radon_nikodym_deriv ν x ∂ν < ⊤ :=
begin
  by_cases hl : have_lebesgue_decomposition μ ν,
  { haveI := hl,
    obtain ⟨-, -, hadd⟩ := have_lebesgue_decomposition_spec μ ν,
    rw [← lintegral_univ, ← with_density_apply _ measurable_set.univ],
    refine lt_of_le_of_lt
      (le_add_left (le_refl _) : _ ≤ μ.singular_part ν set.univ +
        ν.with_density (μ.radon_nikodym_deriv ν) set.univ) _,
    rw [← measure.add_apply, ← hadd],
    exact measure_lt_top _ _ },
  { erw [measure.radon_nikodym_deriv, dif_neg hl, lintegral_zero],
    exact with_top.zero_lt_top },
end

lemma integrable_radon_nikodym_deriv (s : signed_measure α) (μ : measure α) :
  integrable (radon_nikodym_deriv s μ) μ :=
begin
  refine integrable.sub _ _;
  { split, measurability,
    exact has_finite_integral_to_real_of_lintegral_ne_top
      (lintegral_radon_nikodym_deriv_lt_top _ μ).ne }
end .

lemma lintegral_in_const {μ : measure α} {f : α → ℝ≥0∞} (hf : measurable f) (r : ℝ≥0∞) :
  ∫⁻ x in {x | f x = r}, f x ∂μ = r * μ {x | f x = r} :=
begin
  have : ∀ᵐ x ∂μ, x ∈ {x | f x = r} → f x = r , exact ae_of_all μ (λ _ hx, hx),
  erw [set_lintegral_congr_fun _ this, lintegral_const,
       measure.restrict_apply measurable_set.univ, set.univ_inter],
  rw (_ : {x : α | f x = r} = f ⁻¹' {r}),
  { exact hf (set.finite.measurable_set (set.finite_singleton r)) },
  { simp_rw [set.preimage, set.mem_singleton_iff] },
end

lemma lintegral_eq_top_of_measure_eq_top_pos {μ : measure α} {f : α → ℝ≥0∞}
  (hf : measurable f) (hμf : 0 < μ {x | f x = ∞}) : ∫⁻ x, f x ∂μ = ∞ :=
begin
  have : ∫⁻ x in {x | f x = ∞}, f x ∂μ ≤ ∫⁻ x, f x ∂μ,
  { conv_rhs { rw ← lintegral_univ },
    exact lintegral_mono_set (set.subset_univ _) },
  refine eq_top_iff.2 (le_trans _ this),
  rw [lintegral_in_const hf, ennreal.top_mul, if_neg hμf.ne.symm],
  exact le_refl _,
end

lemma eventually_le_top_of_lintegral_lt_top {μ : measure α}
  {f : α → ℝ≥0∞} (hf : measurable f) (hμf : ∫⁻ x, f x ∂μ ≠ ∞) : ∀ᵐ x ∂μ, f x < ∞ :=
begin
  simp_rw [ae_iff, ennreal.not_lt_top],
  by_contra h,
  rw [← ne.def, ← pos_iff_ne_zero] at h,
  exact hμf (lintegral_eq_top_of_measure_eq_top_pos hf h),
end

-- move to `measure` namespace
lemma with_density_radon_nikodym_deriv_to_real_eq {μ ν : measure α} [is_finite_measure μ]
  [have_lebesgue_decomposition μ ν] (h : μ ≪ ν) {i : set α} (hi : measurable_set i) :
  ∫ x in i, (μ.radon_nikodym_deriv ν x).to_real ∂ν = (μ i).to_real :=
begin
  rw [integral_to_real, ← with_density_apply _ hi,
      with_density_radon_nikodym_deriv_eq μ ν h],
  { measurability },
  { refine eventually_le_top_of_lintegral_lt_top (μ.measurable_radon_nikodym_deriv ν)
      (lt_of_le_of_lt (lintegral_mono_set i.subset_univ) _).ne,
    rw [← with_density_apply _ measurable_set.univ,
        with_density_radon_nikodym_deriv_eq μ ν h],
    exact measure_lt_top _ _ },
end

lemma with_density_radon_nikodym_deriv_eq
  (s : signed_measure α) (μ : measure α) [sigma_finite μ]
  (h : s ≪ μ.to_ennreal_vector_measure) :
  μ.with_densityᵥ (s.radon_nikodym_deriv μ) = s :=
begin
  rw [absolutely_continuous_ennreal_iff, (_ : μ.to_ennreal_vector_measure.ennreal_to_measure = μ),
      total_variation_absolutely_continuous_iff] at h,
  { ext1 i hi,
    rw [with_densityᵥ_apply (integrable_radon_nikodym_deriv _ _) hi,
        radon_nikodym_deriv, integral_sub,
        with_density_radon_nikodym_deriv_to_real_eq h.1 hi,
        with_density_radon_nikodym_deriv_to_real_eq h.2 hi],
    { conv_rhs { rw ← s.to_signed_measure_to_jordan_decomposition },
      erw vector_measure.sub_apply,
      rw [to_signed_measure_apply_measurable hi, to_signed_measure_apply_measurable hi] },
    all_goals { rw ← integrable_on_univ,
      refine integrable_on.restrict _ measurable_set.univ,
      refine ⟨_, has_finite_integral_to_real_of_lintegral_ne_top _⟩,
      { measurability },
      { rw lintegral_univ,
        exact (lintegral_radon_nikodym_deriv_lt_top _ _).ne } } },
  { exact equiv_measure.right_inv μ }
end

lemma radon_nikodym_deriv_neg (s : signed_measure α) (μ : measure α) [sigma_finite μ]
  (hs : s ≪ μ.to_ennreal_vector_measure) :
  (-s).radon_nikodym_deriv μ =ᵐ[μ] - s.radon_nikodym_deriv μ :=
begin
  refine (integrable_radon_nikodym_deriv _ _).ae_eq_of_with_densityᵥ_eq
    (integrable_radon_nikodym_deriv _ _).neg _,
  rw [with_densityᵥ_neg, with_density_radon_nikodym_deriv_eq _ _ hs,
      with_density_radon_nikodym_deriv_eq _ _ hs.neg_left]
end

lemma radon_nikodym_deriv_add (s t : signed_measure α) (μ : measure α) [sigma_finite μ]
  (hs : s ≪ μ.to_ennreal_vector_measure) (ht : t ≪ μ.to_ennreal_vector_measure) :
  (s + t).radon_nikodym_deriv μ =ᵐ[μ] s.radon_nikodym_deriv μ + t.radon_nikodym_deriv μ :=
begin
  refine (integrable_radon_nikodym_deriv _ _).ae_eq_of_with_densityᵥ_eq
    ((integrable_radon_nikodym_deriv _ _).add (integrable_radon_nikodym_deriv _ _)) _,
  rw [with_density_radon_nikodym_deriv_eq _ _ (hs.add ht),
      with_densityᵥ_add
        (integrable_radon_nikodym_deriv _ _) (integrable_radon_nikodym_deriv _ _),
      with_density_radon_nikodym_deriv_eq s μ hs, with_density_radon_nikodym_deriv_eq t μ ht]
end

lemma radon_nikodym_deriv_sub (s t : signed_measure α) (μ : measure α) [sigma_finite μ]
  (hs : s ≪ μ.to_ennreal_vector_measure) (ht : t ≪ μ.to_ennreal_vector_measure) :
  (s - t).radon_nikodym_deriv μ =ᵐ[μ] s.radon_nikodym_deriv μ - t.radon_nikodym_deriv μ :=
begin
  refine (integrable_radon_nikodym_deriv _ _).ae_eq_of_with_densityᵥ_eq
    ((integrable_radon_nikodym_deriv _ _).sub (integrable_radon_nikodym_deriv _ _)) _,
  rw [with_density_radon_nikodym_deriv_eq _ _ (hs.sub ht),
      with_densityᵥ_sub
        (integrable_radon_nikodym_deriv _ _) (integrable_radon_nikodym_deriv _ _),
      with_density_radon_nikodym_deriv_eq s μ hs, with_density_radon_nikodym_deriv_eq t μ ht]
end

lemma radon_nikodym_deriv_smul (s : signed_measure α) (μ : measure α) [sigma_finite μ]
  (r : ℝ) (hs : s ≪ μ.to_ennreal_vector_measure) :
  (r • s).radon_nikodym_deriv μ =ᵐ[μ] r • s.radon_nikodym_deriv μ :=
begin
  refine integrable.ae_eq_of_with_densityᵥ_eq
    (integrable_radon_nikodym_deriv _ _) ((integrable_radon_nikodym_deriv _ _).smul r) _,
  rw [@with_densityᵥ_smul _ _ μ _ _ _ _ _ _ _ (s.radon_nikodym_deriv μ) _ _ _ _ _ _ r,
      with_density_radon_nikodym_deriv_eq _ _ hs,
      with_density_radon_nikodym_deriv_eq _ _ hs.smul],
end
end signed_measure

end measure_theory


/-
  The map R → R[1/f] induces a homeomorphism Spec(R[1/f]) → D(f).

  https://stacks.math.columbia.edu/tag/00E4
-/

import topology.basic
import ring_theory.localization
import to_mathlib.localization.localization_alt
import to_mathlib.localization.localization_ideal
import spectrum_of_a_ring.zariski_topology
import spectrum_of_a_ring.induced_continuous_map

universes u

local attribute [instance] classical.prop_decidable

open localization_alt

section homeomorphism

parameters {R : Type u} [comm_ring R]
parameters {Rf : Type u} [comm_ring Rf] {h : R → Rf} [is_ring_hom h]
parameters {f : R} (HL : is_localization_data (powers f) h)

def φ : Spec Rf → Spec R := Zariski.induced h

-- There is no f^n in h⁻¹(I).

include HL

lemma powers_f_not_preimage (I : ideal Rf) (PI : ideal.is_prime I)
: ∀ fn ∈ powers f, fn ∉ ideal.comap h I :=
begin
  have PIinv := @ideal.is_prime.comap _ _ _ _ h _ I PI,
  intros fn Hfn HC,
  replace HC : h fn ∈ I := HC,
  have Hinvfn := HL.1 ⟨fn, Hfn⟩,
  rcases Hinvfn with ⟨s, Hs⟩,
  simp at Hs,
  have Hone := @ideal.mul_mem_right _ _ I _ s HC,
  rw Hs at Hone,
  apply PI.1,
  exact (ideal.eq_top_iff_one _).2 Hone,
end

lemma h_powers_f_not_mem (I : ideal Rf) (PI : ideal.is_prime I)
: ∀ fn ∈ powers f, h fn ∉ I :=
λ fn Hfn HC, (powers_f_not_preimage I PI) fn Hfn HC

-- Now we prove that φ is an open immersion.

-- First, injectivity.

lemma phi_injective : function.injective φ :=
begin
  intros x y Hxy,
  rcases x with ⟨I, PI⟩,
  rcases y with ⟨J, PJ⟩,
  simp [φ, Zariski.induced] at Hxy,
  have HhfnI := h_powers_f_not_mem I PI,
  have HhfnJ := h_powers_f_not_mem J PJ,
  rcases HL with ⟨Hinv, Hden, Hker⟩,
  -- TODO : very similar branches.
  simp,
  apply ideal.ext,
  intros x,
  split,
  { intros Hx,
    have Hdenx := Hden x,
    rcases Hdenx with ⟨⟨fn, r⟩, Hhr⟩,
    simp at Hhr,
    have H := @ideal.mul_mem_left _ _ I (h fn) _ Hx,
    rw Hhr at H,
    replace H : r ∈ ideal.comap h I := H,
    rw Hxy at H,
    replace H : h r ∈ J := H,
    rw ←Hhr at H,
    replace H := PJ.2 H,
    cases H,
    { exfalso,
      exact HhfnJ fn.1 fn.2 H, },
    { exact H, } },
  { intros Hx,
    have Hdenx := Hden x,
    rcases Hdenx with ⟨⟨fn, r⟩, Hhr⟩,
    simp at Hhr,
    have Hinvfn := Hinv fn,
    rcases Hinvfn with ⟨s, Hfn⟩,
    have H := @ideal.mul_mem_left _ _ J (h fn) _ Hx,
    rw Hhr at H,
    replace H : r ∈ ideal.comap h J := H,
    rw ←Hxy at H,
    replace H : h r ∈ I := H,
    rw ←Hhr at H,
    replace H := PI.2 H,
    cases H,
    { exfalso,
      exact HhfnI fn.1 fn.2 H, },
    { exact H, } },
end

-- Also, sends opens to opens. Some work is needed to assert this.

lemma localisation_map_ideal.not_top (I : ideal R) [PI : ideal.is_prime I]
(Hfn : ∀ fn, (fn ∈ powers f) → fn ∉ I)
: ideal.map h I ≠ ⊤ :=
begin
  have HL' := HL,
  rcases HL' with ⟨Hinv, Hden, Hker⟩,
  intros HC,
  rw localisation_map_ideal.eq HL at HC,
  rw ideal.eq_top_iff_one at HC,
  rcases HC with ⟨x, ⟨y, ⟨HyI, Hyx⟩⟩, ⟨r, Hr⟩⟩,
  rcases (Hden x) with ⟨⟨q, p⟩, Hpq⟩,
  simp at Hpq,
  rw ←Hyx at Hpq,
  have Hz : h (q * y - p) = 0,
    rw (is_ring_hom.map_sub h),
    rw (is_ring_hom.map_mul h),
    rw Hpq,
    simp,
  replace Hz : ↑q * y - p ∈ ker h := Hz,
  replace Hz := Hker Hz,
  rcases Hz with ⟨⟨⟨u, v⟩, Huv⟩, Hz⟩,
  simp at Hz,
  simp at Huv,
  rw Hz at Huv,
  have HzI : (0 : R) ∈ I := ideal.zero_mem I,
  rw ←Huv at HzI,
  replace HzI := PI.2 HzI,
  cases HzI,
  { have HqyI : ↑q * y ∈ I := ideal.mul_mem_left I HyI,
    have HpI := (ideal.neg_mem_iff I).1 ((ideal.add_mem_iff_left I HqyI).1 HzI),
    rcases (Hden r) with ⟨⟨b, a⟩, Hab⟩,
    simp at Hab,
    rw Hyx at Hpq,
    have Hz2 : h (q * b - p * a) = 0,
      rw (is_ring_hom.map_sub h),
      repeat { rw (is_ring_hom.map_mul h), },
      rw [←Hab, ←Hpq],
      rw ←mul_comm r,
      rw mul_assoc,
      rw ←mul_assoc x,
      rw ←Hr,
      simp,
    replace Hz2 : ↑q * ↑b - p * a ∈ ker h := Hz2,
    replace Hz2 := Hker Hz2,
    rcases Hz2 with ⟨⟨⟨w, z⟩, Hwz⟩, Hz2⟩,
    simp at Hz2,
    simp at Hwz,
    rw Hz2 at Hwz,
    have HzI : (0 : R) ∈ I := ideal.zero_mem I,
    rw ←Hwz at HzI,
    replace HzI := PI.2 HzI,
    cases HzI with HzI HzI,
    { have HnpaI : -(p * a) ∈ I
        := (ideal.neg_mem_iff I).2 (ideal.mul_mem_right I HpI),
      have HC := (ideal.add_mem_iff_right I HnpaI).1 HzI,
      replace HC := PI.2 HC,
      cases HC,
      { exact Hfn q q.2 HC, },
      { exact Hfn b b.2 HC, }, },
    { exact Hfn z z.2 HzI, } },
  { exact Hfn v v.2 HzI, }
end

lemma localisation_map_ideal.is_prime (I : ideal R) [PI : ideal.is_prime I]
(Hfn : ∀ fn, (fn ∈ powers f) → fn ∉ I)
: ideal.is_prime (ideal.map h I) :=
begin
  have HL' := HL,
  rcases HL' with ⟨Hinv, Hden, Hker⟩,
  constructor,
  { exact localisation_map_ideal.not_top I Hfn, },
  { intros x y Hxy,
    rw localisation_map_ideal.eq HL at Hxy,
    rcases Hxy with ⟨w, ⟨z, ⟨HzI, Hwz⟩⟩, ⟨r, Hr⟩⟩,
    rw ←Hwz at Hr,
    rcases (Hden r) with ⟨⟨q, p⟩,  Hpq⟩,
    rcases (Hden x) with ⟨⟨b₁, a₁⟩, Ha₁b₁⟩,
    rcases (Hden y) with ⟨⟨b₂, a₂⟩, Ha₂b₂⟩,
    simp at Hpq,
    simp at Ha₁b₁,
    simp at Ha₂b₂,
    have Hzpb₁b₂I : -(z * p * b₁ * b₂) ∈ I,
      rw mul_assoc,
      rw mul_assoc,
      rw ideal.neg_mem_iff I,
      exact ideal.mul_mem_right I HzI,
    have Hz : h (a₁ * a₂ * q - z * p * b₁ * b₂) = 0,
      rw (is_ring_hom.map_sub h),
      repeat { rw (is_ring_hom.map_mul h), },
      rw [←Hpq, ←Ha₁b₁, ←Ha₂b₂],
      rw ←mul_comm y,
      rw ←mul_assoc,
      rw mul_assoc _ x y,
      rw Hr,
      ring,
    replace Hz : a₁ * a₂ * q - z * p * b₁ * b₂ ∈ ker h := Hz,
    replace Hz := Hker Hz,
    rcases Hz with ⟨⟨⟨u, v⟩, Huv⟩, Hz⟩,
    simp at Hz,
    simp at Huv,
    rw Hz at Huv,
    have H0I : (0 : R) ∈ I := ideal.zero_mem I,
    rw ←Huv at H0I,
    replace H0I := PI.2 H0I,
    cases H0I,
    { have Ha₁a₂q := (ideal.add_mem_iff_left I Hzpb₁b₂I).1 H0I,
      replace Ha₁a₂q := PI.2 Ha₁a₂q,
      cases Ha₁a₂q with Ha₁a₂ Hq,
      { replace Ha₁a₂ := PI.2 Ha₁a₂,
        cases Ha₁a₂ with Ha₁ Ha₂,
        { left,
          replace Ha₁ := @ideal.mem_map_of_mem _ _ _ _ h _ _ _ Ha₁,
          rcases (Hinv b₁) with ⟨w₁, Hw₁⟩,
          have Hx : x = h a₁ * w₁,
            rw [←(one_mul x), ←Hw₁, ←mul_comm w₁, mul_assoc, Ha₁b₁],
            ring,
          rw Hx,
          exact ideal.mul_mem_right _ Ha₁, },
        { right,
          replace Ha₂ := @ideal.mem_map_of_mem _ _ _ _ h _ _ _ Ha₂,
          rcases (Hinv b₂) with ⟨w₂, Hw₂⟩,
          have Hy : y = h a₂ * w₂,
            rw [←(one_mul y), ←Hw₂, ←mul_comm w₂, mul_assoc, Ha₂b₂],
            ring,
          rw Hy,
          exact ideal.mul_mem_right _ Ha₂, } },
      { exfalso,
        exact Hfn q q.2 Hq, }, },
    { exfalso,
      exact Hfn v v.2 H0I, }, }
end

lemma phi_of_map (I : ideal R) [PI : ideal.is_prime I]
(Hfn : ∀ fn, (fn ∈ powers f) → fn ∉ I)
: φ ⟨ideal.map h I, @localisation_map_ideal.is_prime I PI Hfn⟩ = ⟨I, PI⟩ :=
begin
  have HL' := HL,
  rcases HL' with ⟨Hinv, Hden, Hker⟩,
  simp [φ, Zariski.induced],
  -- Goal : h⁻¹ (h(I)Rf) = I.
  apply le_antisymm,
  { intros z Hz,
    replace Hz : z ∈ ideal.comap h (ideal.map h I) := Hz,
    rw ideal.mem_comap at Hz,
    rw (localisation_map_ideal.eq HL I) at Hz,
    rcases Hz with ⟨w, ⟨a, ⟨HaI, Hwa⟩⟩, ⟨t, Ht⟩⟩,
    rw ←Hwa at Ht,
    rcases (Hden t) with ⟨⟨q, p⟩,  Hpq⟩,
    simp at Hpq,
    have H0 : h (z * q - a * p) = 0,
      rw (is_ring_hom.map_sub h),
      repeat { rw (is_ring_hom.map_mul h), },
      rw ←Hpq,
      rw mul_comm _ t,
      rw ←mul_assoc,
      rw ←Ht,
      ring,
    replace H0 : z * q - a * p ∈ ker h := H0,
    replace H0 := Hker H0,
    rcases H0 with ⟨⟨⟨u, v⟩, Huv⟩, H0⟩,
    simp at H0,
    simp at Huv,
    rw H0 at Huv,
    have H0I : (0 : R) ∈ I := ideal.zero_mem I,
    rw ←Huv at H0I,
    replace H0I := PI.2 H0I,
    cases H0I,
    { have HnzpI : -(a * p) ∈ I
        := (ideal.neg_mem_iff I).2 (ideal.mul_mem_right I HaI),
      replace H0I := (ideal.add_mem_iff_right I HnzpI).1 H0I,
      replace H0I := PI.2 H0I,
      cases H0I,
      { exact H0I, },
      { exfalso,
        exact Hfn q q.2 H0I, }, },
    { exfalso,
      exact Hfn v v.2 H0I, }, },
  { rw ←ideal.map_le_iff_le_comap,
    exact (le_refl _), },
end

lemma phi_opens : ∀ U : set (Spec Rf), is_open U ↔ is_open (φ '' U) :=
begin
  intros U,
  have HL' := HL,
  rcases HL' with ⟨Hinv, Hden, Hker⟩,
  split,
  { intros OU,
    cases OU with E HE,
    have HU : U = Spec.D E,
      simp [Spec.D],
      rw HE,
      rw set.compl_compl,
    rw HU,
    let S := { x | ∃ (r) (s ∈ powers f) (y ∈ E), x = f * r ∧ h s * y = h r },
    existsi S,
    apply set.ext,
    rintros ⟨I, PI⟩,
    split,
    swap,
    { intros HI x Hx,
      simp,
      apply classical.by_contradiction,
      intros HC,
      rcases Hx with ⟨r, s, Hspow, y, HyE, ⟨Hx, Hy⟩⟩,
      have Hfs : f * s ∈ powers f,
        rcases Hspow with ⟨n, Hn⟩,
        use [nat.succ n],
        rw pow_succ,
        rw Hn,
      have HnfI : f ∉ I,
        intros HCfI,
        replace HCfI : f * r ∈ I := ideal.mul_mem_right I HCfI,
        rw ←Hx at HCfI,
        exact HC HCfI,
      have HnfnI : ∀ fn, fn ∈ powers f → fn ∉ I,
        intros fn Hfn HfnI,
        rcases Hfn with ⟨n, Hfn⟩,
        rw ←Hfn at HfnI,
        exact HnfI (ideal.is_prime.mem_of_pow_mem PI n HfnI),
      simp at HI,
      let hI : Spec Rf := ⟨ideal.map h I, @localisation_map_ideal.is_prime I PI HnfnI⟩,
      replace HI := HI hI,
      have HnrI : r ∉ I,
        intros Hr,
        replace Hr : f * r ∈ I := ideal.mul_mem_left I Hr,
        rw ←Hx at Hr,
        exact (HC Hr),
      have HnhIVE : hI ∉ Spec.V E,
        intros HhI,
        simp [Spec.V] at HhI,
        have HyhI : h s * y ∈ ideal.map h I := ideal.mul_mem_left _ (HhI HyE),
        rw Hy at HyhI,
        rw (@localisation_map_ideal.eq R _ Rf _ h _ f HL I PI) at HyhI,
        rcases HyhI with ⟨w, ⟨z, ⟨HzI, Hwz⟩⟩, ⟨t, Ht⟩⟩,
        rcases (Hden t) with ⟨⟨q, p⟩, Hpq⟩,
        simp at Hpq,
        rw ←Hwz at Ht,
        have Hz : h (r * q - z * p) = 0,
          rw (is_ring_hom.map_sub h),
          repeat { rw (is_ring_hom.map_mul h), },
          rw [←Hpq, mul_comm _ t, ←mul_assoc, ←Ht],
          ring,
        replace Hz : r * q - z * p ∈ ker h := Hz,
        replace Hz := Hker Hz,
        rcases Hz with ⟨⟨⟨u, v⟩, Huv⟩, Hz⟩,
        simp at Hz,
        simp at Huv,
        rw Hz at Huv,
        have H0I : (0 : R) ∈ I := ideal.zero_mem I,
        rw ←Huv at H0I,
        replace H0I := PI.2 H0I,
        cases H0I,
        { have HnzpI : -(z * p) ∈ I
            := (ideal.neg_mem_iff I).2 (ideal.mul_mem_right I HzI),
          replace H0I := (ideal.add_mem_iff_right I HnzpI).1 H0I,
          replace H0I := PI.2 H0I,
          cases H0I,
          { exact (HnrI H0I), },
          { exact HnfnI q q.2 H0I, }, },
        { exact HnfnI v v.2 H0I, },
      replace HI := HI HnhIVE,
      apply HI,
      exact @phi_of_map I PI HnfnI, },
    { intros HSJinv HC,
      rcases HC with ⟨⟨J, PJ⟩, HP, HφP⟩,
      rw ←HφP at HSJinv,
      simp [φ, Zariski.induced, Spec.V, ideal.comap] at HSJinv,
      replace HSJinv : S ⊆ h ⁻¹' J.1 := HSJinv,
      apply HP,
      intros x Hx,
      rcases (Hden x) with ⟨⟨fn, r⟩, Hhr⟩,
      simp at Hhr,
      rcases (Hinv fn) with ⟨s, Hfn⟩,
      have HfrS : f * r ∈ S := ⟨r, fn.1, fn.2, x, Hx, ⟨rfl, Hhr⟩⟩,
      replace HfrS := HSJinv HfrS,
      have HhfrJ : h (f * r) ∈ J := HfrS,
      rw is_ring_hom.map_mul h at HhfrJ,
      replace HhfrJ := PJ.2 HhfrJ,
      have Hfpow : f ∈ powers f := ⟨1, by simp⟩,
      have : h f ∉ J := h_powers_f_not_mem J PJ f Hfpow,
      have : h fn ∉ J := h_powers_f_not_mem J PJ fn fn.2,
      cases HhfrJ,
      { contradiction, },
      { rw ←Hhr at HhfrJ,
        replace HhfrJ := PJ.2 HhfrJ,
        cases HhfrJ,
        { contradiction, },
        { exact HhfrJ, } } }, },
  { intros H,
    have Hcts : continuous φ := Zariski.induced.continuous h,
    have Hinv := Hcts _ H,
    rw ←(set.preimage_image_eq U phi_injective),
    exact Hinv, }
end

-- Finally we show that φ(Spec(Rf)) = D(f). In particular this shows that there is
-- a homeomorphism between Spec(Rf) and D(f).

lemma phi_image_Df : φ '' Spec.univ Rf = Spec.D'(f) :=
begin
  apply set.ext,
  rintros ⟨I, PI⟩,
  split,
  { intros HI,
    rcases HI with ⟨⟨J, PJ⟩, ⟨HJ, HIJ⟩⟩,
    show f ∉ I,
    have HnhfnJ := h_powers_f_not_mem J PJ f ⟨1, by simp⟩,
    simp [φ, Zariski.induced] at HIJ,
    intros HC,
    rw ←HIJ at HC,
    rw ideal.mem_comap at HC,
    exact (HnhfnJ HC), },
  { intros HI,
    replace HI : f ∉ I := HI,
    have Hfn : ∀ fn, fn ∈ powers f → fn ∉ I,
      intros fn Hfn HC,
      rcases Hfn with ⟨n, Hfn⟩,
      rw ←Hfn at HC,
      exact HI (ideal.is_prime.mem_of_pow_mem PI n HC),
    let hI : Spec Rf := ⟨ideal.map h I, @localisation_map_ideal.is_prime I PI Hfn⟩,
    use hI,
    split,
    { trivial, },
    { exact @phi_of_map I PI Hfn, }, }
end

end homeomorphism


/-
Copyright (c) 2021 Rémy Degenne. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Rémy Degenne
-/
import analysis.normed_space.inner_product
import measure_theory.set_integral

/-! # `L^2` space

If `E` is an inner product space over `𝕜` (`ℝ` or `ℂ`), then `Lp E 2 μ` (defined in `lp_space.lean`)
is also an inner product space, with inner product defined as `inner f g = ∫ a, ⟪f a, g a⟫ ∂μ`.

### Main results

* `mem_L1_inner` : for `f` and `g` in `Lp E 2 μ`, the pointwise inner product `λ x, ⟪f x, g x⟫`
  belongs to `Lp 𝕜 1 μ`.
* `integrable_inner` : for `f` and `g` in `Lp E 2 μ`, the pointwise inner product `λ x, ⟪f x, g x⟫`
  is integrable.
* `L2.inner_product_space` : `Lp E 2 μ` is an inner product space.

-/

noncomputable theory
open topological_space measure_theory measure_theory.Lp
open_locale nnreal ennreal measure_theory

namespace measure_theory
namespace L2

variables {α E F 𝕜 : Type*} [is_R_or_C 𝕜] [measurable_space α] {μ : measure α}
  [measurable_space E] [inner_product_space 𝕜 E] [borel_space E] [second_countable_topology E]
  [normed_group F] [measurable_space F] [borel_space F] [second_countable_topology F]

local notation `⟪`x`, `y`⟫` := @inner 𝕜 E _ x y

lemma snorm_rpow_two_norm_lt_top (f : Lp F 2 μ) : snorm (λ x, ∥f x∥ ^ (2 : ℝ)) 1 μ < ∞ :=
begin
  have h_two : ennreal.of_real (2 : ℝ) = 2, by simp [zero_le_one],
  rw [snorm_norm_rpow f zero_lt_two, one_mul, h_two],
  exact ennreal.rpow_lt_top_of_nonneg zero_le_two (Lp.snorm_ne_top f),
end

lemma snorm_inner_lt_top (f g : α →₂[μ] E) : snorm (λ (x : α), ⟪f x, g x⟫) 1 μ < ∞ :=
begin
  have h : ∀ x, is_R_or_C.abs ⟪f x, g x⟫ ≤ ∥f x∥ * ∥g x∥, from λ x, abs_inner_le_norm _ _,
  have h' : ∀ x, is_R_or_C.abs ⟪f x, g x⟫ ≤ is_R_or_C.abs (∥f x∥^2 + ∥g x∥^2),
  { refine λ x, le_trans (h x) _,
    rw [is_R_or_C.abs_to_real, abs_eq_self.mpr],
    swap, { exact add_nonneg (by simp) (by simp), },
    refine le_trans _ (half_le_self (add_nonneg (sq_nonneg _) (sq_nonneg _))),
    refine (le_div_iff (@zero_lt_two ℝ _ _)).mpr ((le_of_eq _).trans (two_mul_le_add_sq _ _)),
    ring, },
  simp_rw [← is_R_or_C.norm_eq_abs, ← real.rpow_nat_cast] at h',
  refine (snorm_mono_ae (ae_of_all _ h')).trans_lt ((snorm_add_le _ _ le_rfl).trans_lt _),
  { exact (Lp.ae_measurable f).norm.pow_const _ },
  { exact (Lp.ae_measurable g).norm.pow_const _ },
  simp only [nat.cast_bit0, ennreal.add_lt_top, nat.cast_one],
  exact ⟨snorm_rpow_two_norm_lt_top f, snorm_rpow_two_norm_lt_top g⟩,
end

section inner_product_space

variables [measurable_space 𝕜] [borel_space 𝕜]

include 𝕜

instance : has_inner 𝕜 (α →₂[μ] E) := ⟨λ f g, ∫ a, ⟪f a, g a⟫ ∂μ⟩

lemma inner_def (f g : α →₂[μ] E) : inner f g = ∫ a : α, ⟪f a, g a⟫ ∂μ := rfl

lemma integral_inner_eq_sq_snorm (f : α →₂[μ] E) :
  ∫ a, ⟪f a, f a⟫ ∂μ = ennreal.to_real ∫⁻ a, (nnnorm (f a) : ℝ≥0∞) ^ (2:ℝ) ∂μ :=
begin
  simp_rw inner_self_eq_norm_sq_to_K,
  norm_cast,
  rw integral_eq_lintegral_of_nonneg_ae,
  swap, { exact filter.eventually_of_forall (λ x, sq_nonneg _), },
  swap, { exact (Lp.ae_measurable f).norm.pow_const _ },
  congr,
  ext1 x,
  have h_two : (2 : ℝ) = ((2 : ℕ) : ℝ), by simp,
  rw [← real.rpow_nat_cast _ 2, ← h_two,
    ← ennreal.of_real_rpow_of_nonneg (norm_nonneg _) zero_le_two, of_real_norm_eq_coe_nnnorm],
  norm_cast,
end

private lemma norm_sq_eq_inner' (f : α →₂[μ] E) : ∥f∥ ^ 2 = is_R_or_C.re (inner f f : 𝕜) :=
begin
  have h_two : (2 : ℝ≥0∞).to_real = 2 := by simp,
  rw [inner_def, integral_inner_eq_sq_snorm, norm_def, ← ennreal.to_real_pow, is_R_or_C.of_real_re,
    ennreal.to_real_eq_to_real (ennreal.pow_lt_top (Lp.snorm_lt_top f) 2) _],
  { rw [←ennreal.rpow_nat_cast, snorm_eq_snorm' ennreal.two_ne_zero ennreal.two_ne_top, snorm',
      ← ennreal.rpow_mul, one_div, h_two],
    simp, },
  { refine lintegral_rpow_nnnorm_lt_top_of_snorm'_lt_top zero_lt_two _,
    rw [← h_two, ← snorm_eq_snorm' ennreal.two_ne_zero ennreal.two_ne_top],
    exact Lp.snorm_lt_top f, },
end

lemma mem_L1_inner (f g : α →₂[μ] E) :
  ae_eq_fun.mk (λ x, ⟪f x, g x⟫) ((Lp.ae_measurable f).inner (Lp.ae_measurable g)) ∈ Lp 𝕜 1 μ :=
by { simp_rw [mem_Lp_iff_snorm_lt_top, snorm_ae_eq_fun], exact snorm_inner_lt_top f g, }

lemma integrable_inner (f g : α →₂[μ] E) : integrable (λ x : α, ⟪f x, g x⟫) μ :=
(integrable_congr (ae_eq_fun.coe_fn_mk (λ x, ⟪f x, g x⟫)
    ((Lp.ae_measurable f).inner (Lp.ae_measurable g)))).mp
  (ae_eq_fun.integrable_iff_mem_L1.mpr (mem_L1_inner f g))

private lemma add_left' (f f' g : α →₂[μ] E) : (inner (f + f') g : 𝕜) = inner f g + inner f' g :=
begin
  simp_rw [inner_def, ← integral_add (integrable_inner f g) (integrable_inner f' g),
    ←inner_add_left],
  refine integral_congr_ae ((coe_fn_add f f').mono (λ x hx, _)),
  congr,
  rwa pi.add_apply at hx,
end

private lemma smul_left' (f g : α →₂[μ] E) (r : 𝕜) :
  inner (r • f) g = is_R_or_C.conj r * inner f g :=
begin
  rw [inner_def, inner_def, ← smul_eq_mul, ← integral_smul],
  refine integral_congr_ae ((coe_fn_smul r f).mono (λ x hx, _)),
  rw [smul_eq_mul, ← inner_smul_left],
  congr,
  rwa pi.smul_apply at hx,
end

instance inner_product_space : inner_product_space 𝕜 (α →₂[μ] E) :=
{ norm_sq_eq_inner := norm_sq_eq_inner',
  conj_sym := λ _ _, by simp_rw [inner_def, ← integral_conj, inner_conj_sym],
  add_left := add_left',
  smul_left := smul_left', }

end inner_product_space

end L2
end measure_theory


import data.finset.basic
import data.fintype.basic
import data.nat.basic
import tactic.core

open finset

-- just some lemmas that I couldn't quite find in finset.basic

variables {α : Type*} [decidable_eq α]
--probably easier ways of doing this...
--if A and B are disjoint then seo are A ∩ C and B ∩ D for any C,D
lemma disj_of_inter_disj (C D :finset α){A B :finset α} (h: disjoint A B): disjoint (A∩C) (B∩D):=
disjoint.mono (le_iff_subset.mpr (inter_subset_left A C)) (inter_subset_left B D) h

--if A and B are disjoint then seo are C ∩ A and D ∩ B for any C,D
lemma disj_of_disj_inter (C D :finset α){A B :finset α} (h: disjoint A B): disjoint (C∩A ) (D∩B):=
disjoint.mono (le_iff_subset.mpr (inter_subset_right C A)) (inter_subset_right D B) h

-- in particular (B ∩ C) and (A\B ∩ C) are disjoint
lemma sdiff_inter_disj (A B C:finset α) : disjoint (B ∩ C)  (A\B ∩ C):=
disj_of_inter_disj C C disjoint_sdiff

#lint


import group_theory.subgroup.basic
import group_theory.coset
import group_theory.sylow
import group_theory.perm.basic
import group_theory.perm.fin
import group_theory.group_action.basic
import group_theory.group_action.defs
import algebra.group.defs

open list  fin function subgroup

variables {G : Type*} [group G]
-- symmetric group on n letters
@[simp]
def S (n: nat) := (equiv.perm (fin n))

instance  (n: nat) : group (S n) :=
{ mul := λ f g, equiv.trans g f,
  one := equiv.refl _,
  inv := equiv.symm,
  mul_assoc := λ f g h, (equiv.trans_assoc _ _ _).symm,
  one_mul := equiv.trans_refl,
  mul_one := equiv.refl_trans,
  mul_left_inv := equiv.self_trans_symm }

-- subset of Sn
variables {H: ∀ (N: nat), set (S N)}

instance (N: nat): has_scalar (S N) (fin N)  :=
{ smul :=  λ s n, (equiv.to_fun s) n }

instance (N: nat): mul_action (S N) (fin N) :=  {
  smul := λ s n, (equiv.to_fun s) n,
  one_smul :=  begin
     intros,
     unfold has_scalar.smul,
     simp,
  end,
  mul_smul := begin
    intros,
    unfold has_scalar.smul,
    unfold has_mul.mul,
    simp,
    unfold mul_one_class.mul,
    unfold monoid.mul,
    unfold div_inv_monoid.mul,
    unfold group.mul,
    unfold equiv.trans,
    simp,
  end
}

theorem fin.upcast {n N: nat} (LEQ: n ≤ N) (f: fin n): fin N := begin
  constructor,
  swap,
  exact f.val,
  have fbound : (f.val < n), begin
    exact f.prop
  end,
  linarith
end

-- -- | H stabilizes the interval `[0..n] ⊂ [0..N]` iff H is a subset of the stabilizer of
-- each `i ∈ [0..n]`.
def interval_stab (n N: nat) (LEQ: n ≤ N) (K: set (S N))
  : Prop := ∀ (i: fin n), K ≤  (mul_action.stabilizer (S N) (fin.upcast LEQ i))

-- | A chain of stabilizers is an ascending sequence of subsets of Sn, where Ks(i)
-- | stabilizes the interval [0..i]
def chain_of_stabs (N: nat) (Ks: fin N → (set (S N))) : Prop :=
  (∀ (i: fin N), interval_stab i N (le_of_lt i.prop) (Ks i)) /\
  (∀ (i: fin N) (j: fin N) (LT: i < j), Ks i ≤ Ks j)

def generators {N: nat} (gs: finset (S N)) (H: subgroup (S N)) : Prop :=
    closure (coe gs) = H

/-
# compute how to reach [1..n] rom k ∈ [n] using as
# maps a number `c` to the permutation that links its parent `p` to `c`. So we have:
# schrier_vector[c].inverse()[c] = p
# This gives us the orbit. For if an element k ∈ n is not reachable, it will be listed as None.
def schrier_vector(as_: List[Permutation], k: int, n:int) -> List[Permutation]:
    assert k < n
    vs = [None for _ in range(n)]
    vs[k] = Permutation.identity()
    changed = True
    while changed:
        changed = False
        for i in range(n):
            if vs[i] is None: continue
            for a in as_:
                if vs[a(i)] is None: changed = True; vs[a(i)] = a
                ainv = a.inverse()
                if vs[ainv(i)] is None: changed = True; vs[ainv(i)] = ainv
    return vs
-/

-- | records how to reach `k` from `i`.
def schrier_vector (N: nat)
  (H: subgroup (S N))
  (k: fin N)
  (vec: fin N → option H): Prop

  := ∀ (i: fin N), ∃ (p: H), some p = vec i → p • i = k
/-
# Find smallest index i such that p(i) != i.
# That is, for all small < i, p(small) = small, and p(i) != i
def least_nonfixed(p: Permutation, n:int) -> int:
    assert not p.is_identity()
    for i in range(n):
        # loop invariant: ∀ small < i, p(small) = small)
        if p(i) == i: continue
        # can't have p(i) < i because we are dealing with permutations, and for all
        # indeces small < i, we have pinv(small) = small, since p(small) = small is loop invariant.
        assert p(i) > i
        return (i, p(i))
    raise RuntimeError("didn't find non-fixed value though not identity")
-/

def least_nonfixed (N: nat) (p: S N): option (fin N) :=
    match (fin_range N).drop_while (λ i, p • i = i) with
    | [] := none
    | (x :: xs) := some x
    end
/-
# return as_ to size n(n-1)/2;
def sims_filter(as_: List[Permutation], n:int):
    table = [[None for j in range(n)] for i in range(n)]

    for a in as_:
        while not a.is_identity():
            (i, j) = least_nonfixed(a, n)
            if table[i][j] is None:
                table[i][j] = a
                break
            else:
                # should this not be a = a * table[i][j].inverse()
                a = a.inverse() * table[i][j] # strikes me as weird.
                # see that anew(i) = i, since
                # - aprev(i) = j ; aprev_inv(j) = i
                # - table[i][j](i) = j
                # - thus (aprev_inv * table[i][j])(i) = aprev_inv(j) = i
                # so we have that least_nonfixed(anew) > least_nonfixed(a)
    s = set()
    for i in range(n):
        for j in range(i+1, n):
            if table[i][j] is None: continue
            s.add(table[i][j])
    return s
-/

def sims_filter (N: nat) (H: subgroup (S N)) (gs: finset (S N)) (GEN: generators gs H):
    @psigma (finset (S N) ) (λ gs', generators gs' H) := sorry

/-
# returns a map of elements in the orbit of k to the permutation that sends them there.
# see that there are coset representatives by the orbit stabilizer theorem.
def stabilizer_coset_representatives_slow(gs: Set[Permutation], k: int, n:int) -> Dict[int, Permutation]:
    gs = set(gs)
    gs.add(Permutation.identity())
    orb2rep = {}
    orb2rep = { k : Permutation.identity() }

    while True:
        new_orb2rep = {}
        # terrible, O(n^2). use some kind of tree search!
        for g in gs:
            # rep es coset representative for orb ∈ Orbit(k)
            for (orb, rep) in orb2rep.items():
                repnew = g * rep; orbnew = repnew(k)
                if orbnew in orb2rep: continue # have already seen
                new_orb2rep[orbnew] = repnew
        # no update
        if not new_orb2rep: return orb2rep
        orb2rep.update(new_orb2rep)
-/

-- | map each element o ∈ Orb(k) to a permutation p∈ Sn  such that p(o) = k.
-- By orbit stabilizer, these p are coset representatives of the stabilizer.
def stabilizer_coset_representatives (N: nat) (H: subgroup (S N)) (gs: finset (S N))
    (GEN: generators gs H) (k: nat): (fin N) → option (S N) := sorry
/-
# we have a group G = <gs>
# We have k ∈ S, and we need to find hs ⊂ G such that <hs> = Stab(k).
# We have partitioned G into cosets of Stab(k) via (o[0] Stab(k), ..., o[n] Stab(k)).
#   These are called os[:] since they are Cosets of the Stabilizer,
#   which are in bijection with *O*rbits. [Orbit stabilizer]
# Key idea: we have a sort of "splitting"
#   find coset             return coset repr.
# G ----------> G/Stab(k) -------------------> G
# Call the composite map defect: G -> G, since it measures how far an element is from
# living in Stab(k). See that defect(h) = e iff h ∈ Stab(k).

# Now consider: remove_defect (h: G) : G := defect(h).inverse() * h
# `remove_defect` 'inverts' the defect. It allows `h` to act, sending k to some element of Orb(k).
#  it then undoes the defect [by defect(h).inverse()], moving it back to `k`. So we have
#  k --h----------> l ∈Orb(k) --defect(h).inverse()---> k
#  k --defect(h)--> l ∈Orb(k) --defect(h).inverse()---> k
#
# Thus, for all g ∈ G, we have remove_defect(g) ∈ Stab(k).
#
# It is now plausible that: <gs> = G => < gs.map(remove_defect) > = Stab(k)
# since  remove_defect forces elements to stabilize k,
# and we apply this treatment to all of G(by modifying the generator).
#
# However, the weird part is that THAT's NOT ENOUGH.
# Rather, we need the generators to be: < (gs * os).map(remove_defect) >
# For whatever reason, we must take all pairs of gs, os!
def generators_of_stabilizer(gs: List[Permutation], k: int, n: int):
    purified = set()

    # Create coset representatives
    orb2rep = stabilizer_coset_representatives_slow(gs, k, n)

    # candidates = [g * rep for g in gs for rep in orb2rep.values()]
    candidates = gs

    for h in candidates:
            o = h(k) # find where h sends k | o ∈ Orb(k)
            orep = orb2rep[o] # find coset representative corresponding to o
            # orep is hdefect, since it tells us which coset h lies in.
            # h = orep * h_k_stab
            # h_k_stab := h * orep.inverse()
            h_k_stab = orep.inverse() * h
            purified.add(h_k_stab)
    return purified
-/

def generators_of_stabilizer (N: nat) (H: subgroup (S N)) (gs: finset (S N)) (GEN: generators gs H)
    (k: (fin N)):
    @psigma (finset (S N)) (λ ss, generators ss (mul_action.stabilizer (S N)  k)) := sorry

/--/
def schrier_decomposition(gs: List[Permutation], n: int, use_sims_filter:bool = True) -> Dict[int, Permutation]:
    Ggens = {-1: gs} # Gss[i]: List[int] = generators of G[i]. so G[0] = < gs > = < Ggens[0] > and so on.
    gs_prev = gs
    # Ggens[k] is a subgroup of <gs> which stabilizes [0..k] pointwise
    #   [so h(0) = 0, h(1) = 1, ... h(k) = k]
    for k in range(n+1): # [0, n]
        gs_new = generators_of_stabilizer(gs_prev, k, n)
        if use_sims_filter: gs_new = sims_filter(gs_new, n) # performance
        Ggens[k] = gs_new
        gs_prev = gs_new
    return Ggens

def compute_order(gs: List[Permutation], n: int):
    schrier = schrier_decomposition(gs, n)
    # let's compute |schrier[i]|/|schrier[i+1]|.
    # Recall that schrier[i] ~= Stab(schrier[i-1], i)
    # Recall that schrier[i+1] ~= Stab(schrier[i], i+1)
    # Recall that |schrier[i+1]|/|Stab(schrier[i], i+1)| ~= Orb(schrier[i+1],i+1)
    total_size = 1
    for i in range(-1, len(schrier)):
        if i == n-1: break
        hs = schrier[i]
        # intuition: G0 has G1=Stab(G0, 1). Size of |G0|/|Stab(G0, 1)| ~= Orb(G0, 1).
        # so Gi should act on (i+1)
        vs = schrier_vector(hs, k=i+1, n=n)
        orb_size = sum([1 for v in vs if v is not None])
        print(f"orb size of {hs} is {orb_size}")
        total_size *= orb_size
    return total_size

-/


/-
Copyright (c) 2021 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
-/
import data.set.finite
import data.fintype.basic
import order.well_founded
import order.order_iso_nat
import algebra.pointwise

/-!
# Well-founded sets

A well-founded subset of an ordered type is one on which the relation `<` is well-founded.

## Main Definitions
 * `set.well_founded_on s r` indicates that the relation `r` is
  well-founded when restricted to the set `s`.
 * `set.is_wf s` indicates that `<` is well-founded when restricted to `s`.
 * `set.is_pwo s` indicates that any infinite sequence of elements in `s`
  contains an infinite monotone subsequence.

### Definitions for Hahn Series
 * `set.add_antidiagonal s t a` and `set.mul_antidiagonal s t a` are the sets of pairs of elements
  from `s` and `t` that add/multiply to `a`.
 * `finset.add_antidiagonal` and `finset.mul_antidiagonal` are finite versions of
  `set.add_antidiagonal` and `set.mul_antidiagonal` defined when `s` and `t` are well-founded.

## Main Results
 * `set.well_founded_on_iff` relates `well_founded_on` to the well-foundedness of a relation on the
 original type, to avoid dealing with subtypes.
 * `set.is_wf.mono` shows that a subset of a well-founded subset is well-founded.
 * `set.is_wf.union` shows that the union of two well-founded subsets is well-founded.
 * `finset.is_wf` shows that all `finset`s are well-founded.

-/

variables {α : Type*}

namespace set

/-- `s.well_founded_on r` indicates that the relation `r` is well-founded when restricted to `s`. -/
def well_founded_on (s : set α) (r : α → α → Prop) : Prop :=
well_founded (λ (a : s) (b : s), r a b)

lemma well_founded_on_iff {s : set α} {r : α → α → Prop} :
  s.well_founded_on r ↔ well_founded (λ (a b : α), r a b ∧ a ∈ s ∧ b ∈ s) :=
begin
  have f : rel_embedding (λ (a : s) (b : s), r a b) (λ (a b : α), r a b ∧ a ∈ s ∧ b ∈ s) :=
    ⟨⟨coe, subtype.coe_injective⟩, λ a b, by simp⟩,
  refine ⟨λ h, _, f.well_founded⟩,
  rw well_founded.well_founded_iff_has_min,
  intros t ht,
  by_cases hst : (s ∩ t).nonempty,
  { rw ← subtype.preimage_coe_nonempty at hst,
    rcases well_founded.well_founded_iff_has_min.1 h (coe ⁻¹' t) hst with ⟨⟨m, ms⟩, mt, hm⟩,
    exact ⟨m, mt, λ x xt ⟨xm, xs, ms⟩, hm ⟨x, xs⟩ xt xm⟩ },
  { rcases ht with ⟨m, mt⟩,
    exact ⟨m, mt, λ x xt ⟨xm, xs, ms⟩, hst ⟨m, ⟨ms, mt⟩⟩⟩ }
end

instance is_strict_order.subset {s : set α} {r : α → α → Prop} [is_strict_order α r] :
  is_strict_order α (λ (a b : α), r a b ∧ a ∈ s ∧ b ∈ s) :=
{ to_is_irrefl := ⟨λ a con, irrefl_of r a con.1 ⟩,
  to_is_trans := ⟨λ a b c ab bc, ⟨trans_of r ab.1 bc.1, ab.2.1, bc.2.2⟩ ⟩ }

theorem well_founded_on_iff_no_descending_seq {s : set α} {r : α → α → Prop} [is_strict_order α r] :
  s.well_founded_on r ↔ ∀ (f : ((>) : ℕ → ℕ → Prop) ↪r r), ¬ (range f) ⊆ s :=
begin
  rw [well_founded_on_iff, rel_embedding.well_founded_iff_no_descending_seq],
  refine ⟨λ h f con, h begin
    use f,
      { exact f.injective },
      { intros a b,
        simp only [con (mem_range_self a), con (mem_range_self b), and_true, gt_iff_lt,
          function.embedding.coe_fn_mk, f.map_rel_iff] }
    end, λ h con, _⟩,
  rcases con with ⟨f, hf⟩,
  have hfs' : ∀ n : ℕ, f n ∈ s := λ n, (hf.2 n.lt_succ_self).2.2,
  refine h ⟨f, λ a b, _⟩ (λ n hn, _),
  { rw ← hf,
    exact ⟨λ h, ⟨h, hfs' _, hfs' _⟩, λ h, h.1⟩ },
  { rcases set.mem_range.1 hn with ⟨m, hm⟩,
    rw ← hm,
    apply hfs' }
end

section has_lt
variables [has_lt α]

/-- `s.is_wf` indicates that `<` is well-founded when restricted to `s`. -/
def is_wf (s : set α) : Prop := well_founded_on s (<)

lemma is_wf_univ_iff : is_wf (univ : set α) ↔ well_founded ((<) : α → α → Prop) :=
by simp [is_wf, well_founded_on_iff]

variables {s t : set α}

theorem is_wf.mono (h : is_wf t) (st : s ⊆ t) : is_wf s :=
begin
  rw [is_wf, well_founded_on_iff] at *,
  refine subrelation.wf (λ x y xy, _) h,
  exact ⟨xy.1, st xy.2.1, st xy.2.2⟩,
end
end has_lt

section partial_order
variables [partial_order α] {s t : set α} {a : α}

theorem is_wf_iff_no_descending_seq :
  is_wf s ↔ ∀ (f : (order_dual ℕ) ↪o α), ¬ (range f) ⊆ s :=
begin
  haveI : is_strict_order α (λ (a b : α), a < b ∧ a ∈ s ∧ b ∈ s) := {
    to_is_irrefl := ⟨λ x con, lt_irrefl x con.1⟩,
    to_is_trans := ⟨λ a b c ab bc, ⟨lt_trans ab.1 bc.1, ab.2.1, bc.2.2⟩⟩,
  },
  rw [is_wf, well_founded_on_iff_no_descending_seq],
  exact ⟨λ h f, h f.lt_embedding, λ h f, h (order_embedding.of_strict_mono
    f (λ _ _, f.map_rel_iff.2))⟩,
end

theorem is_wf.union (hs : is_wf s) (ht : is_wf t) : is_wf (s ∪ t) :=
begin
  classical,
  rw [is_wf_iff_no_descending_seq] at *,
  rintros f fst,
  have h : infinite (f ⁻¹' s) ∨ infinite (f ⁻¹' t),
  { have h : infinite (univ : set ℕ) := infinite_univ,
    have hpre : f ⁻¹' (s ∪ t) = set.univ,
    { rw [← image_univ, image_subset_iff, univ_subset_iff] at fst,
      exact fst },
    rw preimage_union at hpre,
    rw ← hpre at h,
    rw [infinite, infinite],
    rw infinite at h,
    contrapose! h,
    exact finite.union h.1 h.2, },
  rw [← infinite_coe_iff, ← infinite_coe_iff] at h,
  cases h with inf inf; haveI := inf,
  { apply hs ((nat.order_embedding_of_set (f ⁻¹' s)).dual.trans f),
    change range (function.comp f (nat.order_embedding_of_set (f ⁻¹' s))) ⊆ s,
    rw [range_comp, image_subset_iff],
      simp },
  { apply ht ((nat.order_embedding_of_set (f ⁻¹' t)).dual.trans f),
    change range (function.comp f (nat.order_embedding_of_set (f ⁻¹' t))) ⊆ t,
    rw [range_comp, image_subset_iff],
      simp }
end
end partial_order

end set

namespace set

/-- A subset is partially well-ordered by a relation `r` when any infinite sequence contains
  two elements where the first is related to the second by `r`. -/
def partially_well_ordered_on (s) (r : α → α → Prop) : Prop :=
  ∀ (f : ℕ → α), range f ⊆ s → ∃ (m n : ℕ), m < n ∧ r (f m) (f n)

/-- A subset of a preorder is partially well-ordered when any infinite sequence contains
  a monotone subsequence of length 2 (or equivalently, an infinite monotone subsequence). -/
def is_pwo [preorder α] (s) : Prop :=
partially_well_ordered_on s ((≤) : α → α → Prop)

theorem partially_well_ordered_on.mono {s t : set α} {r : α → α → Prop}
  (ht : t.partially_well_ordered_on r) (hsub : s ⊆ t) :
  s.partially_well_ordered_on r :=
λ f hf, ht f (set.subset.trans hf hsub)

theorem partially_well_ordered_on.image_of_monotone {s : set α}
  {r : α → α → Prop} {β : Type*} {r' : β → β → Prop}
  (hs : s.partially_well_ordered_on r) {f : α → β} (hf : ∀ a1 a2 : α, r a1 a2 → r' (f a1) (f a2)) :
  (f '' s).partially_well_ordered_on r' :=
λ g hg, begin
  have h := λ (n : ℕ), ((mem_image _ _ _).1 (hg (mem_range_self n))),
  obtain ⟨m, n, hlt, hmn⟩ := hs (λ n, classical.some (h n)) _,
  { refine ⟨m, n, hlt, _⟩,
    rw [← (classical.some_spec (h m)).2,
      ← (classical.some_spec (h n)).2],
    apply hf _ _ hmn },
  { rintros _ ⟨n, rfl⟩,
    exact (classical.some_spec (h n)).1 }
end

section partial_order
variables {s : set α} {t : set α} {r : α → α → Prop}

theorem partially_well_ordered_on.exists_monotone_subseq [is_refl α r] [is_trans α r]
  (h : s.partially_well_ordered_on r) (f : ℕ → α) (hf : range f ⊆ s) :
  ∃ (g : ℕ ↪o ℕ), ∀ m n : ℕ, m ≤ n → r (f (g m)) (f (g n)) :=
begin
  obtain ⟨g, h1 | h2⟩ := exists_increasing_or_nonincreasing_subseq r f,
  { refine ⟨g, λ m n hle, _⟩,
    obtain hlt | heq := lt_or_eq_of_le hle,
    { exact h1 m n hlt, },
    { rw [heq],
      apply refl_of r } },
  { exfalso,
    obtain ⟨m, n, hlt, hle⟩ := h (f ∘ g) (subset.trans (range_comp_subset_range _ _) hf),
    exact h2 m n hlt hle }
end

theorem partially_well_ordered_on_iff_exists_monotone_subseq [is_refl α r] [is_trans α r] :
  s.partially_well_ordered_on r ↔
    ∀ f : ℕ → α, range f ⊆ s → ∃ (g : ℕ ↪o ℕ), ∀ m n : ℕ, m ≤ n → r (f (g m)) (f (g n)) :=
begin
  classical,
  split; intros h f hf,
  { exact h.exists_monotone_subseq f hf },
  { obtain ⟨g, gmon⟩ := h f hf,
    refine ⟨g 0, g 1, g.lt_iff_lt.2 zero_lt_one, gmon _ _ zero_le_one⟩, }
end

lemma partially_well_ordered_on.well_founded_on [is_partial_order α r]
  (h : s.partially_well_ordered_on r) :
  s.well_founded_on (λ a b, r a b ∧ a ≠ b) :=
begin
  haveI : is_strict_order α (λ a b, r a b ∧ a ≠ b) :=
  { to_is_irrefl := ⟨λ a con, con.2 rfl⟩,
    to_is_trans := ⟨λ a b c ab bc, ⟨trans ab.1 bc.1,
      λ ac, ab.2 (antisymm ab.1 (ac.symm ▸ bc.1))⟩⟩ },
  rw well_founded_on_iff_no_descending_seq,
  intros f con,
  obtain ⟨m, n, hlt, hle⟩ := h f con,
  exact (f.map_rel_iff.2 hlt).2 (antisymm hle (f.map_rel_iff.2 hlt).1).symm,
end

variables [partial_order α]

lemma is_pwo.is_wf (h : s.is_pwo) :
  s.is_wf :=
begin
  rw [is_wf],
  convert h.well_founded_on,
  ext x y,
  rw lt_iff_le_and_ne,
end

theorem is_pwo.exists_monotone_subseq
  (h : s.is_pwo) (f : ℕ → α) (hf : range f ⊆ s) :
  ∃ (g : ℕ ↪o ℕ), monotone (f ∘ g) :=
h.exists_monotone_subseq f hf

theorem is_pwo_iff_exists_monotone_subseq :
  s.is_pwo ↔
    ∀ f : ℕ → α, range f ⊆ s → ∃ (g : ℕ ↪o ℕ), monotone (f ∘ g) :=
partially_well_ordered_on_iff_exists_monotone_subseq

lemma is_pwo.prod (hs : s.is_pwo)
  (ht : t.is_pwo) :
  (s.prod t).is_pwo :=
begin
  classical,
  rw is_pwo_iff_exists_monotone_subseq at *,
  intros f hf,
  obtain ⟨g1, h1⟩ := hs (prod.fst ∘ f) _,
  swap,
  { rw [range_comp, image_subset_iff],
    refine subset.trans hf _,
    rintros ⟨x1, x2⟩ hx,
    simp only [mem_preimage, hx.1] },
  obtain ⟨g2, h2⟩ := ht (prod.snd ∘ f ∘ g1) _,
  refine ⟨g2.trans g1, λ m n mn, _⟩,
  swap,
  { rw [range_comp, image_subset_iff],
    refine subset.trans (range_comp_subset_range _ _) (subset.trans hf _),
    rintros ⟨x1, x2⟩ hx,
    simp only [mem_preimage, hx.2] },
  simp only [rel_embedding.coe_trans, function.comp_app],
  exact ⟨h1 (g2.le_iff_le.2 mn), h2 mn⟩,
end

theorem is_pwo.image_of_monotone {β : Type*} [partial_order β]
  (hs : s.is_pwo) {f : α → β} (hf : monotone f) :
  is_pwo (f '' s) :=
hs.image_of_monotone hf

theorem is_pwo.union (hs : is_pwo s) (ht : is_pwo t) : is_pwo (s ∪ t) :=
begin
  classical,
  rw [is_pwo_iff_exists_monotone_subseq] at *,
  rintros f fst,
  have h : infinite (f ⁻¹' s) ∨ infinite (f ⁻¹' t),
  { have h : infinite (univ : set ℕ) := infinite_univ,
    have hpre : f ⁻¹' (s ∪ t) = set.univ,
    { rw [← image_univ, image_subset_iff, univ_subset_iff] at fst,
      exact fst },
    rw preimage_union at hpre,
    rw ← hpre at h,
    rw [infinite, infinite],
    rw infinite at h,
    contrapose! h,
    exact finite.union h.1 h.2, },
  rw [← infinite_coe_iff, ← infinite_coe_iff] at h,
  cases h with inf inf; haveI := inf,
  { obtain ⟨g, hg⟩ := hs (f ∘ (nat.order_embedding_of_set (f ⁻¹' s))) _,
    { rw [function.comp.assoc, ← rel_embedding.coe_trans] at hg,
      exact ⟨_, hg⟩ },
    rw [range_comp, image_subset_iff],
    simp },
  { obtain ⟨g, hg⟩ := ht (f ∘ (nat.order_embedding_of_set (f ⁻¹' t))) _,
    { rw [function.comp.assoc, ← rel_embedding.coe_trans] at hg,
      exact ⟨_, hg⟩ },
    rw [range_comp, image_subset_iff],
    simp }
end

end partial_order

theorem is_wf.is_pwo [linear_order α] {s : set α}
  (hs : s.is_wf) : s.is_pwo :=
λ f hf, begin
  rw [is_wf, well_founded_on_iff] at hs,
  have hrange : (range f).nonempty := ⟨f 0, mem_range_self 0⟩,
  let a := hs.min (range f) hrange,
  obtain ⟨m, hm⟩ := hs.min_mem (range f) hrange,
  refine ⟨m, m.succ, m.lt_succ_self, le_of_not_lt (λ con, _)⟩,
  rw hm at con,
  apply hs.not_lt_min (range f) hrange (mem_range_self m.succ)
    ⟨con, hf (mem_range_self m.succ), hf _⟩,
  rw ← hm,
  apply mem_range_self,
end

theorem is_wf_iff_is_pwo [linear_order α] {s : set α} :
  s.is_wf ↔ s.is_pwo :=
⟨is_wf.is_pwo, is_pwo.is_wf⟩

end set

namespace finset

@[simp]
theorem partially_well_ordered_on {r : α → α → Prop} [is_refl α r] {f : finset α} :
  set.partially_well_ordered_on (↑f : set α) r :=
begin
  intros g hg,
  by_cases hinj : function.injective g,
  { exact (set.infinite_of_injective_forall_mem hinj (set.range_subset_iff.1 hg)
      f.finite_to_set).elim },
  { rw [function.injective] at hinj,
    push_neg at hinj,
    obtain ⟨m, n, gmgn, hne⟩ := hinj,
    cases lt_or_gt_of_ne hne with hlt hlt;
    { refine ⟨_, _, hlt, _⟩,
      rw gmgn,
      exact refl_of r _, } }
end

@[simp]
theorem is_pwo [partial_order α] {f : finset α} :
  set.is_pwo (↑f : set α) :=
finset.partially_well_ordered_on

@[simp]
theorem well_founded_on {r : α → α → Prop} [is_strict_order α r] {f : finset α} :
  set.well_founded_on (↑f : set α) r :=
begin
  rw [set.well_founded_on_iff_no_descending_seq],
  intros g con,
  apply set.infinite_of_injective_forall_mem g.injective (set.range_subset_iff.1 con),
  exact f.finite_to_set,
end

@[simp]
theorem is_wf [partial_order α] {f : finset α} : set.is_wf (↑f : set α) :=
finset.is_pwo.is_wf

end finset

namespace set
variables [partial_order α] {s : set α} {a : α}

theorem finite.is_pwo (h : s.finite) : s.is_pwo :=
begin
  rw ← h.coe_to_finset,
  exact finset.is_pwo,
end

@[simp]
theorem fintype.is_pwo [fintype α] : s.is_pwo := (finite.of_fintype s).is_pwo

@[simp]
theorem is_pwo_empty : is_pwo (∅ : set α) :=
finite_empty.is_pwo

@[simp]
theorem is_pwo_singleton (a) : is_pwo ({a} : set α) :=
(finite_singleton a).is_pwo

theorem is_pwo.insert (a) (hs : is_pwo s) : is_pwo (insert a s) :=
by { rw ← union_singleton, exact hs.union (is_pwo_singleton a) }

/-- `is_wf.min` returns a minimal element of a nonempty well-founded set. -/
noncomputable def is_wf.min (hs : is_wf s) (hn : s.nonempty) : α :=
hs.min univ (nonempty_iff_univ_nonempty.1 hn.to_subtype)

lemma is_wf.min_mem (hs : is_wf s) (hn : s.nonempty) : hs.min hn ∈ s :=
(well_founded.min hs univ (nonempty_iff_univ_nonempty.1 hn.to_subtype)).2

lemma is_wf.not_lt_min (hs : is_wf s) (hn : s.nonempty) (ha : a ∈ s) : ¬ a < hs.min hn :=
hs.not_lt_min univ (nonempty_iff_univ_nonempty.1 hn.to_subtype) (mem_univ (⟨a, ha⟩ : s))

@[simp]
lemma is_wf_min_singleton (a) {hs : is_wf ({a} : set α)} {hn : ({a} : set α).nonempty} :
  hs.min hn = a :=
eq_of_mem_singleton (is_wf.min_mem hs hn)

end set

@[simp]
theorem finset.is_wf_sup {ι : Type*} [partial_order α] (f : finset ι) (g : ι → set α)
  (hf : ∀ i : ι, i ∈ f → (g i).is_wf) : (f.sup g).is_wf :=
begin
  classical,
  revert hf,
  apply f.induction_on,
  { intro h,
    simp [set.is_pwo_empty.is_wf], },
  { intros s f sf hf hsf,
    rw finset.sup_insert,
    exact (hsf s (finset.mem_insert_self _ _)).union  (hf (λ s' s'f, hsf _
      (finset.mem_insert_of_mem s'f))) }
end

@[simp]
theorem finset.is_pwo_sup {ι : Type*} [partial_order α] (f : finset ι) (g : ι → set α)
  (hf : ∀ i : ι, i ∈ f → (g i).is_pwo) : (f.sup g).is_pwo :=
begin
  classical,
  revert hf,
  apply f.induction_on,
  { intro h,
    simp [set.is_pwo_empty.is_wf], },
  { intros s f sf hf hsf,
    rw finset.sup_insert,
    exact (hsf s (finset.mem_insert_self _ _)).union  (hf (λ s' s'f, hsf _
      (finset.mem_insert_of_mem s'f))) }
end

namespace set
variables [linear_order α] {s t : set α} {a : α}

lemma is_wf.min_le
  (hs : s.is_wf) (hn : s.nonempty) (ha : a ∈ s) : hs.min hn ≤ a :=
le_of_not_lt (hs.not_lt_min hn ha)

lemma is_wf.le_min_iff
  (hs : s.is_wf) (hn : s.nonempty) :
  a ≤ hs.min hn ↔ ∀ b, b ∈ s → a ≤ b :=
⟨λ ha b hb, le_trans ha (hs.min_le hn hb), λ h, h _ (hs.min_mem _)⟩

lemma is_wf.min_le_min_of_subset
  {hs : s.is_wf} {hsn : s.nonempty} {ht : t.is_wf} {htn : t.nonempty} (hst : s ⊆ t) :
  ht.min htn ≤ hs.min hsn :=
(is_wf.le_min_iff _ _).2 (λ b hb, ht.min_le htn (hst hb))

lemma is_wf.min_union (hs : s.is_wf) (hsn : s.nonempty) (ht : t.is_wf) (htn : t.nonempty) :
  (hs.union ht).min (union_nonempty.2 (or.intro_left _ hsn)) = min (hs.min hsn) (ht.min htn) :=
begin
  refine le_antisymm (le_min (is_wf.min_le_min_of_subset (subset_union_left _ _))
      (is_wf.min_le_min_of_subset (subset_union_right _ _))) _,
  rw min_le_iff,
  exact ((mem_union _ _ _).1 ((hs.union ht).min_mem
    (union_nonempty.2 (or.intro_left _ hsn)))).imp (hs.min_le _) (ht.min_le _),
end

end set

namespace set

variables {s : set α} {t : set α}

@[to_additive]
theorem is_pwo.mul [ordered_cancel_comm_monoid α] (hs : s.is_pwo) (ht : t.is_pwo) :
  is_pwo (s * t) :=
begin
  rw ← image_mul_prod,
  exact (is_pwo.prod hs ht).image_of_monotone (λ _ _ h, mul_le_mul' h.1 h.2),
end

variable [linear_ordered_cancel_comm_monoid α]

@[to_additive]
theorem is_wf.mul (hs : s.is_wf) (ht : t.is_wf) : is_wf (s * t) :=
(hs.is_pwo.mul ht.is_pwo).is_wf

@[to_additive]
theorem is_wf.min_mul (hs : s.is_wf) (ht : t.is_wf) (hsn : s.nonempty) (htn : t.nonempty) :
  (hs.mul ht).min (hsn.mul htn) = hs.min hsn * ht.min htn :=
begin
  refine le_antisymm (is_wf.min_le _ _ (mem_mul.2 ⟨_, _, hs.min_mem _, ht.min_mem _, rfl⟩)) _,
  rw is_wf.le_min_iff,
  rintros _ ⟨x, y, hx, hy, rfl⟩,
  exact mul_le_mul' (hs.min_le _ hx) (ht.min_le _ hy),
end

end set

namespace set

/-- `set.mul_antidiagonal s t a` is the set of all pairs of an element in `s` and an element in `t`
  that multiply to `a`. -/
@[to_additive "`set.add_antidiagonal s t a` is the set of all pairs of an element in `s`
  and an element in `t` that add to `a`."]
def mul_antidiagonal [monoid α] (s t : set α) (a : α) : set (α × α) :=
{ x | x.1 * x.2 = a ∧ x.1 ∈ s ∧ x.2 ∈ t }

namespace mul_antidiagonal

@[simp, to_additive]
lemma mem_mul_antidiagonal [monoid α] {s t : set α} {a : α} {x : α × α} :
  x ∈ mul_antidiagonal s t a ↔ x.1 * x.2 = a ∧ x.1 ∈ s ∧ x.2 ∈ t := iff.refl _

section cancel_comm_monoid
variables [cancel_comm_monoid α] {s t : set α} {a : α}

@[to_additive]
lemma fst_eq_fst_iff_snd_eq_snd {x y : (mul_antidiagonal s t a)} :
  (x : α × α).fst = (y : α × α).fst ↔ (x : α × α).snd = (y : α × α).snd :=
⟨λ h, begin
  have hx := x.2.1,
  rw [subtype.val_eq_coe, h] at hx,
  apply mul_left_cancel (hx.trans y.2.1.symm),
end, λ h, begin
  have hx := x.2.1,
  rw [subtype.val_eq_coe, h] at hx,
  apply mul_right_cancel (hx.trans y.2.1.symm),
end⟩

@[to_additive]
lemma eq_of_fst_eq_fst {x y : (mul_antidiagonal s t a)}
  (h : (x : α × α).fst = (y : α × α).fst) : x = y :=
subtype.ext (prod.ext h (mul_antidiagonal.fst_eq_fst_iff_snd_eq_snd.1 h))

@[to_additive]
lemma eq_of_snd_eq_snd {x y : (mul_antidiagonal s t a)}
  (h : (x : α × α).snd = (y : α × α).snd) : x = y :=
subtype.ext (prod.ext (mul_antidiagonal.fst_eq_fst_iff_snd_eq_snd.2 h) h)

end cancel_comm_monoid

section ordered_cancel_comm_monoid
variables [ordered_cancel_comm_monoid α] (s t : set α) (a : α)

@[to_additive]
lemma eq_of_fst_le_fst_of_snd_le_snd {x y : (mul_antidiagonal s t a)}
  (h1 : (x : α × α).fst ≤ (y : α × α).fst) (h2 : (x : α × α).snd ≤ (y : α × α).snd ) :
  x = y :=
begin
  apply eq_of_fst_eq_fst,
  cases eq_or_lt_of_le h1 with heq hlt,
  { exact heq },
  exfalso,
  exact ne_of_lt (mul_lt_mul_of_lt_of_le hlt h2)
    ((mem_mul_antidiagonal.1 x.2).1.trans (mem_mul_antidiagonal.1 y.2).1.symm)
end

variables {s} {t}

@[to_additive]
theorem finite_of_is_pwo (hs : s.is_pwo) (ht : t.is_pwo) (a) :
  (mul_antidiagonal s t a).finite :=
begin
  by_contra h,
  rw [← set.infinite] at h,
  have h1 : (mul_antidiagonal s t a).partially_well_ordered_on (prod.fst ⁻¹'o (≤)),
  { intros f hf,
    refine hs (prod.fst ∘ f) _,
    rw range_comp,
    rintros _ ⟨⟨x, y⟩, hxy, rfl⟩,
    exact (mem_mul_antidiagonal.1 (hf hxy)).2.1 },
  have h2 : (mul_antidiagonal s t a).partially_well_ordered_on (prod.snd ⁻¹'o (≤)),
  { intros f hf,
    refine ht (prod.snd ∘ f) _,
    rw range_comp,
    rintros _ ⟨⟨x, y⟩, hxy, rfl⟩,
    exact (mem_mul_antidiagonal.1 (hf hxy)).2.2 },
  obtain ⟨g, hg⟩ := h1.exists_monotone_subseq (λ x, h.nat_embedding _ x) _,
  swap, { rintro _ ⟨k, rfl⟩,
    exact ((infinite.nat_embedding (s.mul_antidiagonal t a) h) _).2 },
  obtain ⟨m, n, mn, h2'⟩ := h2 (λ x, (h.nat_embedding _) (g x)) _,
  swap, { rintro _ ⟨k, rfl⟩,
    exact ((infinite.nat_embedding (s.mul_antidiagonal t a) h) _).2, },
  apply ne_of_lt mn (g.injective ((h.nat_embedding _).injective _)),
  exact eq_of_fst_le_fst_of_snd_le_snd _ _ _ (hg _ _ (le_of_lt mn)) h2',
end

end ordered_cancel_comm_monoid

@[to_additive]
theorem finite_of_is_wf [linear_ordered_cancel_comm_monoid α] {s t : set α}
  (hs : s.is_wf) (ht : t.is_wf) (a) :
  (mul_antidiagonal s t a).finite :=
finite_of_is_pwo hs.is_pwo ht.is_pwo a

end mul_antidiagonal
end set

namespace finset

variables [ordered_cancel_comm_monoid α]
variables {s t : set α} (hs : s.is_pwo) (ht : t.is_pwo) (a : α)

/-- `finset.mul_antidiagonal_of_is_wf hs ht a` is the set of all pairs of an element in
  `s` and an element in `t` that multiply to `a`, but its construction requires proofs
  `hs` and `ht` that `s` and `t` are well-ordered. -/
@[to_additive "`finset.add_antidiagonal_of_is_wf hs ht a` is the set of all pairs of an element in
  `s` and an element in `t` that add to `a`, but its construction requires proofs
  `hs` and `ht` that `s` and `t` are well-ordered."]
noncomputable def mul_antidiagonal : finset (α × α) :=
(set.mul_antidiagonal.finite_of_is_pwo hs ht a).to_finset

variables {hs} {ht} {u : set α} {hu : u.is_pwo} {a} {x : α × α}

@[simp, to_additive]
lemma mem_mul_antidiagonal :
  x ∈ mul_antidiagonal hs ht a ↔ x.1 * x.2 = a ∧ x.1 ∈ s ∧ x.2 ∈ t :=
by simp [mul_antidiagonal]

@[to_additive]
lemma mul_antidiagonal_mono_left (hus : u ⊆ s) :
  (finset.mul_antidiagonal hu ht a) ⊆ (finset.mul_antidiagonal hs ht a) :=
λ x hx, begin
  rw mem_mul_antidiagonal at *,
  exact ⟨hx.1, hus hx.2.1, hx.2.2⟩,
end

@[to_additive]
lemma mul_antidiagonal_mono_right (hut : u ⊆ t) :
  (finset.mul_antidiagonal hs hu a) ⊆ (finset.mul_antidiagonal hs ht a) :=
λ x hx, begin
  rw mem_mul_antidiagonal at *,
  exact ⟨hx.1, hx.2.1, hut hx.2.2⟩,
end

@[to_additive]
lemma support_mul_antidiagonal_subset_mul :
  { a : α | (mul_antidiagonal hs ht a).nonempty } ⊆ s * t :=
(λ x ⟨⟨a1, a2⟩, ha⟩, begin
  obtain ⟨hmul, h1, h2⟩ := mem_mul_antidiagonal.1 ha,
  exact ⟨a1, a2, h1, h2, hmul⟩,
end)

@[to_additive]
theorem is_pwo_support_mul_antidiagonal :
  { a : α | (mul_antidiagonal hs ht a).nonempty }.is_pwo :=
(hs.mul ht).mono support_mul_antidiagonal_subset_mul

@[to_additive]
theorem mul_antidiagonal_min_mul_min {α} [linear_ordered_cancel_comm_monoid α] {s t : set α}
  (hs : s.is_wf) (ht : t.is_wf)
  (hns : s.nonempty) (hnt : t.nonempty) :
  mul_antidiagonal hs.is_pwo ht.is_pwo ((hs.min hns) * (ht.min hnt)) =
    {(hs.min hns, ht.min hnt)} :=
begin
  ext ⟨a1, a2⟩,
  rw [mem_mul_antidiagonal, finset.mem_singleton, prod.ext_iff],
  split,
  { rintro ⟨hast, has, hat⟩,
    cases eq_or_lt_of_le (hs.min_le hns has) with heq hlt,
    { refine ⟨heq.symm, _⟩,
      rw heq at hast,
      exact mul_left_cancel hast },
    { contrapose hast,
      exact ne_of_gt (mul_lt_mul_of_lt_of_le hlt (ht.min_le hnt hat)) } },
  { rintro ⟨ha1, ha2⟩,
    rw [ha1, ha2],
    exact ⟨rfl, hs.min_mem _, ht.min_mem _⟩ }
end

end finset

lemma well_founded.is_wf [has_lt α] (h : well_founded ((<) : α → α → Prop)) (s : set α) :
  s.is_wf :=
(set.is_wf_univ_iff.2 h).mono (set.subset_univ s)