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 → ∃ m : ℤ, m ≠ 0 ∧ (int.fract (α * ↑i)) = int.fract (α * ↑j), from
  begin
    assume (i j : ℤ) (hij : i ≠ j),
    cases int.eq_or_lt_of_ne hij with h1 h2,
    {
      cases (hα_irrat i j h1) with h3 h4,
      have h5 : ¬(i * α = j * α), from by auto [h3],
      have h6 : (int.fract (i * α)) ≠ (int.fract (j * α)), from
      begin
        assume h7 : (int.fract (i * α)) = (int.fract (j * α)),
        have h8 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h7],
        have h9 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h8, sub_eq_zero],
        have h10 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h9],
        have h11 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h10],
        have h12 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h11],
        have h13 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h12],
        have h14 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h13],
        have h15 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h14],
        have h16 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h15],
        have h17 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h16],
        have h18 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h17],
        have h19 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h18],
        have h20 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h19],
        have h21 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h20],
        have h22 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h21],
        have h23 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h22],
        have h24 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h23],
        have h25 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h24],
        have h26 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h25],
        have h27 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h26],
        have h28 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h27],
        have h29 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h28],
        have h30 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h29],
        have h31 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h30],
        have h32 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h31],
        have h33 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h32],
        have h34 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h33],
        have h35 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h34],
        have h36 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h35],
        have h37 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h36],
        have h38 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h37],
        have h39 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h38],
        have h40 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h39],
        have h41 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h40],
        have h42 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h41],
        have h43 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h42],
        have h44 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h43],
        have h45 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h44],
        have h46 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h45],
        have h47 : (i * α) - (int.floor (i * α)) = (j * α) - (int.floor (j * α)), from by auto [h46],
        have h48 : (i * α) - (int.floor (i * α)) = (
end --Needs more than 2000 tokens!

--OUTPUT 2
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin

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 : ℤ, n ≠ 0 → int.fract (α * n) ≠ 0, from
  begin
    assume (n : ℤ) (hn_ne_0 : n ≠ 0),
    have h1 : (α * n) ≠ (0 : ℝ), from mul_ne_zero hn_ne_0 hα_irrat,
    show int.fract (α * n) ≠ 0, from by auto [int.fract, ne_iff_not_congr],
  end,

  have h2 : ∀ n : ℤ, int.fract (α * n) ≠ int.fract (α * ↑(n + 1)), from
  begin
    assume (n : ℤ),
    have h1 : (α * ↑n) ≠ (α * ↑(n + 1)), from by auto [int.coe_nat_add, mul_ne_zero, hα_irrat],
    show int.fract (α * n) ≠ int.fract (α * ↑(n + 1)), from by auto [int.fract, ne_iff_not_congr, h1],
  end,

  have h3 : ∀ n : ℤ, int.fract (α * ↑n) ∈ set.Icc 0 1, from
  begin
    assume (n : ℤ),
    have h1 : (0 : ℝ) ≤ int.fract (α * n), from by auto [int.fract, le_add_right],
    have h2 : int.fract (α * n) ≤ (1 : ℝ), from by auto [int.fract, add_le_to_le_sub],
    show int.fract (α * ↑n) ∈ set.Icc 0 1, from by auto [set.mem_Icc],
  end,

  have h4 : (λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ) ⊆ set.Icc 0 1, from
  begin
    assume (m : ℤ) (h_m_mem : m ∈ (@set.univ ℤ)),
    show int.fract (α * ↑m) ∈ set.Icc 0 1, from by auto [h3],
  end,

  have h5 : set.Icc 0 1 ⊆ closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)), from
  begin
    assume (x : ℝ) (h_x_mem : x ∈ set.Icc 0 1),
    have h1 : 0 ≤ x, from by auto [set.mem_Icc],
    have h2 : x ≤ 1, from by auto [set.mem_Icc],
    have h3 : int.fract x ∈ set.Icc 0 1, from by auto [int.fract, set.mem_Icc],
    show x ∈ closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)), from by auto [set.mem_closure_iff] using [exists_nat_gt, h1, h2, h3],
  end,

  show closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1, from by auto [h4, h5, set.subset.antisymm],
end

--OUTPUT 4
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 : ℝ) * α, from by auto [hα_irrat, irrational.irrational_iff_int_mul_ne],
  have h2 : ∀ (i j : ℤ), int.fract ((i : ℝ) * α) ≠ int.fract ((j : ℝ) * α), from by auto [h1, int.fract_eq, eq_iff_iff_eq_int_mul_irrat],
  have h3 : ∀ (i j : ℤ), (i : ℝ) * α ≠ (j : ℝ) * α, from by auto [hα_irrat, irrational.irrational_iff_int_mul_ne],
  have h4 : ∀ (i j : ℤ), int.fract ((i : ℝ) * α) ≠ int.fract ((j : ℝ) * α), from by auto [h1, int.fract_eq, eq_iff_iff_eq_int_mul_irrat],

  have h5 : ∀ (i j : ℤ), i ≠ j → int.fract (i * α) ≠ int.fract (j * α), from by auto [h4],
  have h6 : ∀ (i j : ℤ), i ≠ j → int.fract (i * α) ≠ int.fract (j * α), from by auto [h4],

  have h7 : ∃! e : ℤ, ∀ a : ℤ, int.fract (a * α) = int.fract (e * α), from by auto [exists_unique_int.intro, h5, h6, int.fract_eq],
  have h8 : ∃! e : ℤ, ∀ a : ℤ, int.fract (a * α) = int.fract (e * α), from by auto [exists_unique_int.intro, h5, h6, int.fract_eq],

  have h9 : (λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ) = {int.fract (α * ↑(classical.some h8.exists))}, from by auto [set.image_univ, h7, classical.some_spec, exists_unique.exists],
  have h10 : (λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ) = {int.fract (α * ↑(classical.some h8.exists))}, from by auto [set.image_univ, h7, classical.some_spec, exists_unique.exists],

  have h11 : int.fract (α * ↑(classical.some h8.exists)) ∈ set.Icc 0 1, from by auto [int.fract_mem_Icc, int.fract_eq, eq_iff_iff_eq_int_mul_irrat],
  have h12 : int.fract (α * ↑(classical.some h8.exists)) ∈ set.Icc 0 1, from by auto [int.fract_mem_Icc, int.fract_eq, eq_iff_iff_eq_int_mul_irrat],

  have h13 : (λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ) ⊆ set.Icc 0 1, from by auto [h11],
  have h14 : (λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ) ⊆ set.Icc 0 1, from by auto [h12],

  have h15 : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = {int.fract (α * ↑(classical.some h8.exists))}, from by auto [h9, closure_singleton],
  have h16 : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = {int.fract (α * ↑(classical.some h8.exists))}, from by auto [h10, closure_singleton],

  show closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1, from by auto [h15, h13, set.subset_def, h16, h14, set.subset_def] using [set.ext, set.mem_Icc],
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 by auto [int.fract_eq_iff_of_irrational hα_irrat.ne_zero],
  have h2 : ∃ l : ℝ, l ∈ closure ((λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ)), from by auto [exists_limit_point],
  have h3 : ∀ m : ℤ, int.fract (α * ↑m) ∈ closure ((λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ)), from by auto [closure_subset_iff],
  have h4 : ∀ m : ℤ, int.fract (α * ↑m) ∈ set.Icc 0 1, from by auto [int.fract_lt_one],
  have h5 : ∀ y ∈ set.Icc 0 1, ∃ m : ℤ, int.fract (α * ↑m) = y, from by auto [int.fract_eq_iff_of_irrational hα_irrat.ne_zero],
  have h6 : closure ((λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ)) ⊆ set.Icc 0 1, from by auto [closure_subset_iff],
  have h7 : set.Icc 0 1 ⊆ closure ((λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ)), from by auto [closure_subset_iff],
  show closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1, from by auto [closure_eq_iff_eq_of_is_closed, set.is_closed_Icc] using [int.fract_lt_one],
end

--OUTPUT 6
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  have h1 : ∀ n : ℤ, ∀ i : ℤ, n ≠ i → (int.fract (α * ↑n)) ≠ (int.fract (α * ↑i)), from by auto using [irrational.int_fract_ne, hα_irrat],
  have h2 : ∀ i : ℤ, (int.fract (α * ↑i)) ∈ set.Icc 0 1, from by auto,
  have h3 : ∀ i : ℤ, (int.fract (α * ↑i)) ∈ closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)), from by auto [set.closure_eq, set.mem_closure_iff_nhds, set.mem_image_of_mem, set.mem_univ, set.mem_nhds_right, set.mem_Icc_self, set.mem_Icc_self, set.mem_Icc_self],
  have h4 : ∀ i : ℤ, ∀ j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h1],
  have h5 : ∀ i : ℤ, (int.fract (α * ↑i)) ∈ set.Icc 0 1, from by auto [h2],
  have h6 : set.Icc 0 1 ⊆ closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)), from by auto [set.subset.trans, h5, h3],

  have h7 : ∀ i : ℤ, ∀ j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h4],
  have h8 : ∀ i : ℤ, (int.fract (α * ↑i)) ∈ set.Icc 0 1, from by auto [h2],
  have h9 : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) ⊆ set.Icc 0 1, from by auto [set.subset.trans, h8, h3],

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

--OUTPUT 7
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 [hα_irrat, int.fract_eq_iff_eq_of_rat],
  have h2 : (λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ) ≠ ∅, from by auto [set.univ_ne_empty, exists.intro 0],
  have h3 : ∀ i : ℤ, ∃ j : ℤ, j ≠ i ∧ int.fract (α * ↑j) = int.fract (α * ↑i), from by auto [exists.intro (i+1)],
  have h4 : ∀ m : ℤ, int.fract (α * ↑m) ∈ (λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ), from by auto [exists.intro m],

  have h5 : (λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ) ⊆ set.Icc 0 1, from by auto [int.fract_range, int.fract_pos],
  have h6 : (λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ) ⊆ closure (λ (m : ℤ), int.fract (α * ↑m) '' (@set.univ ℤ)), from by auto [set.subset_closure],
  have h7 : closure (λ (m : ℤ), int.fract (α * ↑m) '' (@set.univ ℤ)) ⊆ closure (set.Icc 0 1), from by auto [set.closure_mono],
  have h8 : closure (set.Icc 0 1) ⊆ set.Icc 0 1, from by auto,

  have h9 : closure ((λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ)) ⊆ set.Icc 0 1, from by auto [set.subset.trans, set.subset.trans],

  have h10 : ∀ y : ℝ, y ∈ set.Icc 0 1 → y ∈ closure ((λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ)), from by auto [set.mem_closure_iff, set.mem_Icc.mp, exists.intro 1],
  have h11 : set.Icc 0 1 ⊆ closure ((λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ)), from by auto [set.subset_closure],

  have h12 : closure ((λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ)) ⊆ set.Icc 0 1, from by auto [set.subset_closure, set.subset.trans, set.subset.trans],

  show closure ((λ (m : ℤ), int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1, from by auto [set.subset.antisymm],
end

--OUTPUT 8
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  have h1 : ∀ a b : ℤ, ¬(int.fract (α * ↑a) = int.fract (α * ↑b)), from by auto [int.fract_eq_iff, hα_irrat],
  have h2 : ∀ a b : ℤ, ¬(a = b), from by auto [h1],
  have h3 : ∃! e : ℤ, int.fract (α * ↑e) = 0, from by auto using [use 0],
  have h4 : ∃! e : ℤ, int.fract (α * ↑e) = 1, from by auto using [use 1],
  have h5 : ∀ n : ℤ, 0 ≤ int.fract (α * ↑n) ∧ int.fract (α * ↑n) ≤ 1, from by auto using [int.fract_nonneg_iff, int.fract_lt_one],
  have h6 : ∀ n : ℤ, int.fract (α * ↑n) = 0 ∨ int.fract (α * ↑n) = 1, from by auto [h5],
  have h7 : ∀ n : ℤ, int.fract (α * ↑n) = 0 ∨ 0 < int.fract (α * ↑n) ∧ int.fract (α * ↑n) < 1, from by auto [h5],
  have h8 : ∀ n : ℤ, int.fract (α * ↑n) = 0 ∨ 1 < int.fract (α * ↑n) ∧ int.fract (α * ↑n) < 1, from by auto [h5, int.fract_lt_one],
  have h9 : ∀ n : ℤ, int.fract (α * ↑n) = 1 ∨ 0 ≤ int.fract (α * ↑n) ∧ int.fract (α * ↑n) < 1, from by auto [h5, int.fract_lt_one],
  have h10 : ∀ n : ℤ, int.fract (α * ↑n) = 1 ∨ 0 < int.fract (α * ↑n) ∧ int.fract (α * ↑n) ≤ 1, from by auto [h5],
  have h11 : ∀ n : ℤ, int.fract (α * ↑n) = 1 ∨ 1 < int.fract (α * ↑n) ∧ int.fract (α * ↑n) ≤ 1, from by auto [h5, int.fract_lt_one],
  have h12 : ∀ n : ℤ, int.fract (α * ↑n) = 1 ∨ int.fract (α * ↑n) < 0 ∨ int.fract (α * ↑n) > 1, from by auto [h5, int.fract_lt_one],
  have h13 : ∀ n : ℤ, int.fract (α * ↑n) = 0 ∨ int.fract (α * ↑n) > 0 ∧ int.fract (α * ↑n) < 1, from by auto [h5, int.fract_lt_one],
  have h14 : ∀ n : ℤ, int.fract (α * ↑n) = 0 ∨ int.fract (α * ↑n) > 1 ∧ int.fract (α * ↑n) < 1, from by auto [h5, int.fract_lt_one],
  have h15 : ∀ n : ℤ, int.fract (α * ↑n) = 0 ∨ int.fract (α * ↑n) < 0 ∨ int.fract (α * ↑n) > 0, from by auto [h5, int.fract_lt_one],
  have h16 : ∀ n : ℤ, int.fract (α * ↑n) = 0 ∨ int.fract (α * ↑n) < 0 ∨ 0 < int.fract (α * ↑n), from by auto [h5, int.fract_lt_one],
  have h17 : ∀ n : ℤ, int.fract (α * ↑n) = 0 ∨ int.fract (α * ↑n) < 0 ∨ 1 < int.fract (α * ↑n), from by auto [h5, int.fract_lt_one],
  have h18 : ∀ n : ℤ, int.fract (α * ↑n) = 0 ∨ int.fract (α * ↑n) < 0 ∨ int.fract (α * ↑n) > 1, from by auto [h5, int.fract_lt_one],
  have h19 : ∀ n : ℤ, int.fract (α * ↑n) = 1 ∨ int.fract (α * ↑n) < 0 ∨ 0 < int.fract (α * ↑n), from by auto [h5, int.fract_lt_one],
  have h20 : ∀ n : ℤ, int.fract (α * ↑n) = 1 ∨ int.fract (α * ↑n) < 0 ∨ 1 < int.fract (α * ↑n), from by auto [h5, int.fract_lt_one],
  have h21 : ∀ n : ℤ, int.fract (α * ↑n) = 1 ∨ int.fract (α * ↑n) < 0 ∨ int.fract (α * ↑n) > 1, from by auto [h5, int.fract_lt_one],
  have h22 : ∀ n : ℤ, int.fract (α * ↑n) = 1 ∨ 0 < int.fract (α * ↑n) ∧ int.fract (α * ↑n) < 1, from by auto [h5, int.fract_lt_one],
  have h23 : ∀ n : ℤ, int.fract (α * ↑n) = 1 ∨ 1 < int.fract (α * ↑n) ∧ int.fract (α * ↑n) < 1, from by auto [h5, int.fract_lt_one],
  have h24 : ∀ n : ℤ, int.fract (α * ↑n) = 1 ∨ int.fract (α * ↑n) < 0 ∨ 0 < int.fract (α * ↑n), from by auto [h5, int.fract_lt_one],
  have h25 : ∀ n : ℤ, int.fract (α * ↑n) = 1 ∨ int.fract (α * ↑n) < 0 ∨ 1 < int.fract (α * ↑n), from by auto [h5, int.fract_lt_one],
  have h26 : ∀ n : ℤ, int.fract (α * ↑n) = 1 ∨ int.fract (α * ↑n) < 0 ∨ int.fract (α * ↑n) > 1, from by auto [h5, int.fract_lt_one],
  have h27 : ∀ n : ℤ, int.fract (α * ↑n) = 1 ∨ 0 ≤ int.fract (α * ↑n) ∧ int.fract (α * ↑n) < 1, from by auto [h5, int.fract_lt_one],
  have h28 : ∀ n : ℤ, int.fract (α * ↑n) = 1 ∨ 1 < int.fract (α * ↑n) ∧ int.fract (α * ↑n) ≤ 1, from by auto [h5, int.fract_lt_one],
  have h29 : ∀ n : ℤ, int.fract (α * ↑n) = 1 ∨ int.fract (α * ↑n) < 0 ∨ 0 ≤ int.fract (α * ↑n), from by auto [h5, int.fract_lt_one],
  have h30 : ∀ n : ℤ, int.fract (α * ↑n) = 1 ∨ int.fract (α * ↑n) < 0 ∨ 1 < int.fract (α * ↑n), from by auto [h5, int.fract_lt_one],
  have h31 : ∀ n : ℤ, int.fract (α * ↑n) = 1 ∨ int.fract (α * ↑n) < 0 ∨ int.fract (α
end --Needs more than 2000 tokens!

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

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

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

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

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

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

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  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`
Density of irrational orbit
The fractional parts of the integer multiples of an irrational number form a dense subset of the unit interval
`proof`
Let $\alpha$ be an irrational number. Then for distinct $i, j \in \mathbb{Z}$, we must have $\{i \alpha\} \neq\{j \alpha\}$. If this were not true, then
$$
i \alpha-\lfloor i \alpha\rfloor=\{i \alpha\}=\{j \alpha\}=j \alpha-\lfloor j \alpha\rfloor,
$$
which yields the false statement $\alpha=\frac{\lfloor i \alpha\rfloor-\lfloor j \alpha\rfloor}{i-j} \in \mathbb{Q}$. Hence,
$$
S:=\{\{i \alpha\} \mid i \in \mathbb{Z}\}
$$
is an infinite subset of $\left[0,1\right]$.

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

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

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


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Jeremy Avigad, Mario Carneiro
-/
import Mathlib.Tactic.Alias
import Mathlib.Tactic.IrreducibleDef
import Mathlib.Mathport.Rename
import Mathlib.Init.Logic

/-! ### alignments from lean 3 `init.classical` -/

namespace Classical

#align classical.inhabited_of_nonempty Classical.inhabited_of_nonempty
#align classical.inhabited_of_exists Classical.inhabited_of_exists

attribute [local instance] propDecidable
attribute [local instance] decidableInhabited

alias axiomOfChoice ← axiom_of_choice -- TODO: fix in core
alias propComplete ← prop_complete -- TODO: fix in core

@[elab_as_elim] theorem cases_true_false (p : Prop → Prop)
    (h1 : p True) (h2 : p False) (a : Prop) : p a :=
  Or.elim (prop_complete a) (fun ht : a = True ↦ ht.symm ▸ h1) fun hf : a = False ↦ hf.symm ▸ h2

theorem cases_on (a : Prop) {p : Prop → Prop} (h1 : p True) (h2 : p False) : p a :=
  @cases_true_false p h1 h2 a

theorem cases {p : Prop → Prop} (h1 : p True) (h2 : p False) (a) : p a := cases_on a h1 h2
#align classical.cases Classical.cases

alias byCases ← by_cases
alias byContradiction ← by_contradiction

theorem eq_false_or_eq_true (a : Prop) : a = False ∨ a = True := (prop_complete a).symm

end Classical


import field_theory.polynomial_galois_group

open polynomial
open_locale polynomial big_operators

namespace mul_action

@[to_additive]
instance (α : Type*) {β : Type*} [monoid α] [fintype α] [mul_action α β] [decidable_eq β] (b : β) :
  fintype (orbit α b) := set.fintype_range _

@[to_additive]
instance (α : Type*) {β : Type*} [group α] [fintype α] [mul_action α β] [decidable_eq β]
  (x : mul_action.orbit_rel.quotient α β) :
  fintype x.orbit :=
quotient.rec_on_subsingleton' x (λ a, set.fintype_range _)

end mul_action

namespace minpoly

lemma eq_of_alg_hom_eq {K S T : Type*} [field K] [ring S] [ring T]
  [algebra K S] [algebra K T]
  (f : S →ₐ[K] T) (hf : function.injective f)
  {x : S} {y : T} (hx : is_integral K x) (h : y = f x) :
  minpoly K x = minpoly K y :=
minpoly.unique _ _ (minpoly.monic hx)
  (by rw [h, aeval_alg_hom_apply, minpoly.aeval, alg_hom.map_zero])
  (λ q q_monic root_q, minpoly.min _ _ q_monic
    (by rwa [h, aeval_alg_hom_apply, map_eq_zero_iff _ hf] at root_q))

end minpoly

section heq
universes u₁ u₂ u₃

namespace fun_like

variables {F F' : Sort u₁} {α α' : Sort u₂} {β : α → Sort u₃} {β' : α' → Sort u₃}
  [i : fun_like F α β] [i' : fun_like F' α' β']

lemma ext_heq {f : F} {f' : F'}
  (h₁ : F = F') (h₂ : α = α') (h₃ : β == β') (h₄ : i == i')
  (h : ∀ x x', x == x' → f x == f' x') :
  f == f' :=
by { unfreezingI { cases h₁, cases h₂, cases h₃, cases h₄, },
  exact heq_of_eq (fun_like.ext f f' (λ x, eq_of_heq (h x x heq.rfl))), }

lemma congr_heq {f : F} {f' : F'} {x : α} {x' : α'}
  (h₁ : f == f') (h₂ : x == x') (h₃ : β == β') (h₄ : i == i') :
  f x == f' x' :=
by { unfreezingI { cases h₁, cases h₂, cases h₃, cases h₄, }, refl, }

end fun_like

universe u

lemma cast_heq' {α β α' : Sort u} (h : α = β) {a : α} {a' : α'} (h' : a == a') : cast h a == a' :=
by { cases h, cases h', refl, }

end heq

namespace alg_equiv
variables {R : Type*} [comm_semiring R] {A₁ A₂ : Type*}
variables [semiring A₁] [semiring A₂]
variables [algebra R A₁] [algebra R A₂]
variables (e : A₁ ≃ₐ[R] A₂)

lemma symm_apply_eq {x y} : e.symm x = y ↔ x = e y :=
e.to_equiv.symm_apply_eq

end alg_equiv

namespace intermediate_field

variables (F : Type*) [field F] {E : Type*} [field E] [algebra F E] {α : E}

lemma adjoin_root_equiv_adjoin_symm_apply_gen (h : is_integral F α) :
  (adjoin_root_equiv_adjoin F h).symm (adjoin_simple.gen F α) =
    adjoin_root.root (minpoly F α) :=
by rw [alg_equiv.symm_apply_eq, adjoin_root_equiv_adjoin_apply_root]

end intermediate_field

namespace polynomial

variables {T : Type*} [comm_ring T]

noncomputable abbreviation aroots (p : T[X]) (S) [comm_ring S] [is_domain S] [algebra T S] : multiset S :=
(p.map (algebra_map T S)).roots

lemma aroots_def (p : T[X]) (S) [comm_ring S] [is_domain S] [algebra T S] :
  p.aroots S = (p.map (algebra_map T S)).roots := rfl

lemma aroots_map (p : T[X]) (S) (A) [comm_ring S] [is_domain S] [algebra T S]
  [comm_ring A] [is_domain A] [algebra S A] [algebra T A] [is_scalar_tower T S A] :
(p.map (algebra_map T S)).aroots A = p.aroots A :=
by rw [aroots_def, map_map, ← is_scalar_tower.algebra_map_eq T S A]

end polynomial

section gal_conj_classes
variables (F : Type*) [field F] (E : Type*) [field E] [algebra F E]

def is_gal_conj.setoid := mul_action.orbit_rel (E ≃ₐ[F] E) E
def gal_conj_classes := mul_action.orbit_rel.quotient (E ≃ₐ[F] E) E

local attribute [instance] is_gal_conj.setoid

variable {E}

def is_gal_conj (x y : E) : Prop := (is_gal_conj.setoid F E).r x y

-- need to fix the precedence
notation (name := is_gal_conj) x ` ≈g[`:50 F `] ` y := is_gal_conj F x y

instance [decidable_eq E] [fintype (E ≃ₐ[F] E)] (x y : E) : decidable (x ≈g[F] y) :=
  fintype.decidable_exists_fintype

instance [decidable_eq E] [fintype (E ≃ₐ[F] E)] : decidable_eq (gal_conj_classes F E) :=
@quotient.decidable_eq _ (is_gal_conj.setoid F E) (is_gal_conj.decidable F)

namespace is_gal_conj

instance : is_equiv E (is_gal_conj F) := quotient.has_equiv.equiv.is_equiv

@[refl] lemma refl (x : E) : x ≈g[F] x := refl x
@[symm] lemma symm {x y : E} : (x ≈g[F] y) → (y ≈g[F] x) := symm
@[trans] lemma trans {x y z : E} : (x ≈g[F] y) → (y ≈g[F] z) → (x ≈g[F] z) := trans

end is_gal_conj

namespace gal_conj_classes

def mk (x : E) : gal_conj_classes F E := ⟦x⟧

instance : has_zero (gal_conj_classes F E) := ⟨mk F 0⟩

lemma zero_def : (0 : gal_conj_classes F E) = mk F 0 := rfl

variable {F}

noncomputable def out (c : gal_conj_classes F E) : E := c.out

@[simp] theorem eq {x y : E} : mk F x = mk F y ↔ x ≈g[F] y := quotient.eq
@[simp] theorem out_eq (q : gal_conj_classes F E) : mk F q.out = q := q.out_eq
theorem mk_out (x : E) : (mk F x).out ≈ x := quotient.mk_out x
lemma mk_eq_iff_out {x : E} {c : gal_conj_classes F E} :
  mk F x = c ↔ x ≈g[F] c.out := quotient.mk_eq_iff_out
lemma eq_mk_iff_out {c : gal_conj_classes F E} {x : E} :
  c = mk F x ↔ c.out ≈g[F] x := quotient.eq_mk_iff_out
@[simp] lemma out_equiv_out {c₁ c₂ : gal_conj_classes F E} :
  (c₁.out ≈g[F] c₂.out) ↔ c₁ = c₂ := @quotient.out_equiv_out _ _ c₁ c₂

lemma equiv_zero_iff (x : E) : (x ≈g[F] 0) ↔ x = 0 :=
begin
  refine ⟨λ h, _, λ h, by rw [h]⟩,
  cases h with a ha,
  simp_rw [← ha, alg_equiv.smul_def, map_zero],
end

lemma out_eq_zero_iff (c : gal_conj_classes F E) : c.out = 0 ↔ c = 0 :=
by rw [zero_def, eq_mk_iff_out, equiv_zero_iff]

lemma zero_out : (0 : gal_conj_classes F E).out = 0 :=
(out_eq_zero_iff 0).mpr rfl

lemma mk_eq_zero_iff (x : E) : mk F x = 0 ↔ x = 0 :=
by rw [mk_eq_iff_out, zero_out, equiv_zero_iff]

lemma mk_zero : mk F (0 : E) = 0 :=
(mk_eq_zero_iff 0).mpr rfl

def orbit (c : gal_conj_classes F E) : set E := c.orbit

instance [decidable_eq E] [fintype (E ≃ₐ[F] E)] (c : gal_conj_classes F E) :
  fintype c.orbit :=
quotient.rec_on_subsingleton' c (λ a, set.fintype_range _)

lemma mem_orbit {x : E} {c : gal_conj_classes F E} :
  x ∈ c.orbit ↔ mk F x = c := mul_action.orbit_rel.quotient.mem_orbit

lemma orbit_zero : (0 : gal_conj_classes F E).orbit = {0} :=
by { ext, rw [mem_orbit, mk_eq_zero_iff], refl, }

instance : has_neg (gal_conj_classes F E) :=
  ⟨quotient.lift (λ (x : E), mk F (-x)) begin
    rintros _ y ⟨f, rfl⟩, rw [eq],
    use f, change f (-y) = -f y, rw [alg_equiv.map_neg],
end⟩

lemma mk_neg (x : E) : mk F (-x) = -mk F x := rfl

instance : has_involutive_neg (gal_conj_classes F E) :=
{ neg_neg := λ x, by rw [← out_eq x, ← mk_neg, ← mk_neg, neg_neg],
  ..(infer_instance : has_neg (gal_conj_classes F E)), }

lemma exist_mem_orbit_add_eq_zero (x y : gal_conj_classes F E) :
  (∃ (a b : E), (a ∈ x.orbit ∧ b ∈ y.orbit) ∧ a + b = 0) ↔ x = -y :=
begin
  simp_rw [mem_orbit],
  split,
  { rintros ⟨a, b, ⟨rfl, rfl⟩, h⟩,
    rw [← mk_neg, eq, add_eq_zero_iff_eq_neg.mp h], },
  { rintro rfl,
    refine ⟨-y.out, y.out, _⟩,
    simp_rw [mk_neg, out_eq, neg_add_self, eq_self_iff_true, true_and], },
end

variable [is_separable F E]

noncomputable def minpoly : gal_conj_classes F E → F[X] :=
quotient.lift (minpoly F) (λ (a b : E) ⟨f, h⟩, minpoly.eq_of_alg_hom_eq
  f.symm.to_alg_hom f.symm.injective
  (is_separable.is_integral F a) (h ▸ (f.symm_apply_apply b).symm))

lemma minpoly_mk (x : E) : minpoly (mk F x) = _root_.minpoly F x := rfl

lemma minpoly_out (c : gal_conj_classes F E) : _root_.minpoly F c.out = minpoly c :=
by rw [← c.out_eq, minpoly_mk, c.out_eq]

lemma minpoly.monic (c : gal_conj_classes F E) : (minpoly c).monic :=
by { rw [← c.out_eq, minpoly_mk], exact minpoly.monic (is_separable.is_integral F _), }

lemma minpoly.ne_zero (c : gal_conj_classes F E) : minpoly c ≠ 0 :=
by { rw [← c.out_eq, minpoly_mk], exact minpoly.ne_zero (is_separable.is_integral F _), }

lemma minpoly.irreducible (c : gal_conj_classes F E) : irreducible (minpoly c) :=
by { rw [← c.out_eq, minpoly_mk], exact minpoly.irreducible (is_separable.is_integral F _), }

lemma minpoly.splits [n : normal F E] (c : gal_conj_classes F E) :
  splits (algebra_map F E) (minpoly c) :=
by { rw [← c.out_eq, minpoly_mk], exact n.splits c.out, }

lemma minpoly.separable (c : gal_conj_classes F E) : separable (minpoly c) :=
by { rw [← c.out_eq, minpoly_mk], exact is_separable.separable F c.out, }

lemma minpoly.inj [normal F E] {c d : gal_conj_classes F E} (h : minpoly c = minpoly d) : c = d :=
begin
  let fc := intermediate_field.adjoin_root_equiv_adjoin F (is_separable.is_integral F c.out),
  let fd := intermediate_field.adjoin_root_equiv_adjoin F (is_separable.is_integral F d.out),
  let congr_f : adjoin_root (_root_.minpoly F c.out) ≃ₐ[F] adjoin_root (_root_.minpoly F d.out),
  { rw [minpoly_out, minpoly_out, h], },
  have congr_f_apply : ∀ x, congr_f x == x,
  { intro x, change congr_f x == (alg_equiv.refl : _ ≃ₐ[F] _) x,
    dsimp only [congr_f],
    refine fun_like.congr_heq _ heq.rfl _ _,
    { simp_rw [eq_mpr_eq_cast, cast_cast],
      refine cast_heq' _ (fun_like.ext_heq _ _ _ _ _),
      any_goals { rw [minpoly_out, h], },
      rintros x₁ x₂ rfl, refl, },
    all_goals { rw [minpoly_out, minpoly_out, h], }, },
  let f' := fc.symm.trans (congr_f.trans fd),
  let f := f'.lift_normal E,
  rw [← out_equiv_out],
  refine ⟨f.symm, _⟩,
  dsimp only [f, alg_equiv.smul_def],
  simp_rw [alg_equiv.symm_apply_eq, ← intermediate_field.adjoin_simple.algebra_map_gen F c.out,
    ← intermediate_field.adjoin_simple.algebra_map_gen F d.out, alg_equiv.lift_normal_commutes],
  apply congr_arg,
  simp_rw [f', alg_equiv.trans_apply, ← fd.symm_apply_eq, fc, fd,
    intermediate_field.adjoin_root_equiv_adjoin_symm_apply_gen],
  refine eq_of_heq (heq.trans _ (congr_f_apply _).symm),
  rw [minpoly_out, minpoly_out, h],
end

lemma minpoly.injective [normal F E] : function.injective (@minpoly F _ E _ _ _) :=
λ x y, minpoly.inj

lemma minpoly.nodup_aroots (c : gal_conj_classes F E) :
  ((minpoly c).aroots E).nodup :=
nodup_roots (minpoly.separable c).map

lemma aeval_minpoly_iff [normal F E] (x : E) (c : gal_conj_classes F E) :
  aeval x (minpoly c) = 0 ↔ mk F x = c :=
begin
  symmetry, split, { rintros rfl, exact minpoly.aeval _ _, },
  intros h,
  apply minpoly.inj,
  rw [minpoly_mk, ← minpoly.eq_of_irreducible (minpoly.irreducible c) h],
  rw [(minpoly.monic c).leading_coeff, inv_one, map_one, mul_one],
end

lemma root_set_minpoly_eq_orbit [normal F E] (c : gal_conj_classes F E) :
  (minpoly c).root_set E = c.orbit :=
begin
  ext x, rw [mem_orbit],
  simp_rw [mem_root_set, aeval_minpoly_iff x c],
  simp [minpoly.ne_zero c],
end

lemma aroots_minpoly_eq_orbit_val [decidable_eq E] [fintype (E ≃ₐ[F] E)] [normal F E]
  (c : gal_conj_classes F E) : (minpoly c).aroots E = c.orbit.to_finset.1 :=
begin
  simp_rw [← root_set_minpoly_eq_orbit, root_set_def, finset.to_finset_coe,
    multiset.to_finset_val], symmetry, rw [multiset.dedup_eq_self],
  exact nodup_roots ((separable_map _).mpr (minpoly.separable c)),
end

lemma orbit_eq_mk_aroots_minpoly [decidable_eq E] [fintype (E ≃ₐ[F] E)] [normal F E]
  (c : gal_conj_classes F E) :
  c.orbit.to_finset = ⟨(minpoly c).aroots E, minpoly.nodup_aroots c⟩ :=
by simpa only [aroots_minpoly_eq_orbit_val]

lemma minpoly.map_eq_prod [decidable_eq E] [fintype (E ≃ₐ[F] E)] [normal F E]
  (c : gal_conj_classes F E) :
  (minpoly c).map (algebra_map F E) = ∏ x in c.orbit.to_finset, (X - C x) :=
begin
  simp_rw [← root_set_minpoly_eq_orbit, finset.prod_eq_multiset_prod, root_set_def,
    finset.to_finset_coe, multiset.to_finset_val],
  rw [multiset.dedup_eq_self.mpr (nodup_roots _),
    prod_multiset_X_sub_C_of_monic_of_roots_card_eq (monic.map _ _)],
  { rw [splits_iff_card_roots.mp], rw [splits_id_iff_splits], exact minpoly.splits c, },
  { exact minpoly.monic c, },
  { exact (minpoly.separable c).map, },
end
/-
def class_of_roots_irreducible
  {q : F[X]} (q_splits : q.splits (algebra_map F E))
  (hq : _root_.irreducible q) : gal_conj_classes F E :=
⟦root_of_splits (algebra_map F E) q_splits (degree_pos_of_irreducible hq).ne'⟧

lemma minpoly_class_of_roots_irreducible_of_monic
  {q : F[X]} (q_splits : splits (algebra_map F E) q)
  (hq : _root_.irreducible q) (q_monic : q.monic) :
  (class_of_roots_irreducible q_splits hq).minpoly = q :=
begin
  dsimp only [class_of_roots_irreducible], rw [minpoly_mk],
  exact (minpoly.eq_of_irreducible_of_monic hq (map_root_of_splits _ _ _) q_monic).symm,
end

lemma minpoly_class_of_roots_irreducible
  {q : F[X]} (q_splits : splits (algebra_map F E) q)
  (hq : _root_.irreducible q) :
  (class_of_roots_irreducible q_splits hq).minpoly = q * C q.leading_coeff⁻¹ :=
begin
  dsimp only [class_of_roots_irreducible], rw [minpoly_mk],
  exact (minpoly.eq_of_irreducible hq (map_root_of_splits _ _ _)).symm,
end

lemma class_of_roots_irreducible_minpoly (c : gal_conj_classes F E)
  (h₁ : c.minpoly.splits (algebra_map F E)) (h₂ : irreducible c.minpoly) :
  class_of_roots_irreducible h₁ h₂ = c :=
begin
  dsimp only [class_of_roots_irreducible], apply minpoly.inj, rw [minpoly_mk],
  exact minpoly_class_of_roots_irreducible_of_monic _ _ (minpoly.monic c),
end

lemma root_set_C_mul (q : F[X]) {a : F} (a0 : a ≠ 0) :
  q.root_set E = (C a * q).root_set E :=
by { simp_rw [root_set, map_mul, map_C,
  roots_C_mul _ (((algebra_map F E).map_ne_zero).mpr a0)], }

lemma root_set_mul_C (q : F[X]) {a : F} (a0 : a ≠ 0) :
  q.root_set E = (q * C a).root_set E :=
by { rw [mul_comm], exact root_set_C_mul q a0, }

lemma root_set_eq_orbit {q : F[X]} (q_splits : splits (algebra_map F E) q)
  (hq : _root_.irreducible q) :
  q.root_set E = (class_of_roots_irreducible q_splits hq).orbit :=
begin
  rw [← root_set_minpoly_eq_orbit, minpoly_class_of_roots_irreducible, root_set_mul_C],
  exact inv_ne_zero (leading_coeff_ne_zero.mpr hq.ne_zero),
end

lemma aroots_eq_orbit {q : F[X]} (q_splits : splits (algebra_map F E) q)
  (hq : _root_.irreducible q) :
  q.aroots E =
    (class_of_roots_irreducible q_splits hq).orbit.to_finset.1 :=
begin
  simp_rw [← root_set_eq_orbit q_splits hq, root_set_def, to_finset_coe,
    multiset.to_finset_val], symmetry, rw [multiset.dedup_eq_self],
  exact nodup_roots ((separable_map _).mpr hq.separable),
end

def classes_of_roots {q : F[X]} (q_splits : q.splits (algebra_map F E)) :
  multiset (gal_conj_classes F E) :=
(unique_factorization_monoid.normalized_factors q).pmap
  (λ (q : F[X]) (hq : q.splits (algebra_map F E) ∧ irreducible q),
    class_of_roots_irreducible hq.1 hq.2)
  (λ d hd,
  begin
    refine ⟨_, unique_factorization_monoid.irreducible_of_normalized_factor _ hd⟩,
    have d_dvd_q := unique_factorization_monoid.dvd_of_mem_normalized_factors hd,
    refine splits_of_splits_of_dvd _ _ q_splits d_dvd_q,
    rintros rfl, simpa [unique_factorization_monoid.normalized_factors_zero] using hd,
  end)

section

open list multiset

variables {α : Type*} {β : Type*} {γ : Type*}

variables (a : α) (s t : multiset α) (f g : α → multiset β)

namespace multiset

theorem pmap_congr' {p q : α → Prop} {f : Π a, p a → β} {g : Π a, q a → β}
  (s : multiset α) {H₁ H₂} :
  (∀ (a ∈ s) h₁ h₂, f a h₁ = g a h₂) → pmap f s H₁ = pmap g s H₂ := sorry

lemma count_dedup (m : multiset α) (a : α) :
  m.dedup.count a = if a ∈ m then 1 else 0 :=
by { rcases m, simp [count_dedup], }

@[simp]
lemma dedup_bind_dedup (m : multiset α) (f : α → multiset γ) :
  (m.dedup.bind f).dedup = (m.bind f).dedup :=
by { ext x, simp_rw [count_dedup, multiset.mem_bind, multiset.mem_dedup], }

@[simp]
lemma dedup_dedup (m : multiset α) :
  m.dedup.dedup = m.dedup :=
by { ext x, simp_rw [count_dedup, multiset.mem_dedup], }

@[simp]
lemma to_finset_dedup (m : multiset α) :
  m.dedup.to_finset = m.to_finset :=
by simp_rw [multiset.to_finset, dedup_dedup]

@[simp]
lemma to_finset_bind_dedup (m : multiset α) (f : α → multiset γ) :
  (m.dedup.bind f).to_finset = (m.bind f).to_finset :=
by simp_rw [multiset.to_finset, dedup_bind_dedup]

end multiset

end

lemma classes_of_roots_zero :
  classes_of_roots (splits_zero (algebra_map F E)) = 0 :=
by simp_rw [classes_of_roots, unique_factorization_monoid.normalized_factors_zero,
  multiset.pmap_zero]

section
/-
`monic_normalize` caused following instance defeq problem:
`(λ (a b : F), classical.prop_decidable (a = b)) = (λ (a b : F), rat.decidable_eq a b)`
`classical.prop_decidable` is in `monic_normalize`
-/
lemma monic_normalize' {K : Type*} [field K] [decidable_eq K] {p : K[X]}
  (hp0 : p ≠ 0) : monic (normalize p) :=
begin
  rw [ne.def, ← leading_coeff_eq_zero, ← ne.def, ← is_unit_iff_ne_zero] at hp0,
  rw [monic, leading_coeff_normalize, normalize_eq_one],
  apply hp0,
end

variables {α : Type*}
local infix ` ~ᵤ ` : 50 := associated
variables [cancel_comm_monoid_with_zero α] [decidable_eq α] [normalization_monoid α]
variables [unique_factorization_monoid α]

open unique_factorization_monoid
namespace unique_factorization_monoid

lemma associated_iff_normalized_factors_eq_normalized_factors {x y : α} (hx : x ≠ 0) (hy : y ≠ 0) :
  x ~ᵤ y ↔ normalized_factors x = normalized_factors y :=
begin
  split,
  { intro h,
    apply le_antisymm; rw [← dvd_iff_normalized_factors_le_normalized_factors],
    all_goals { simp [*, h.dvd, h.symm.dvd], }, },
  { intro h,
    apply associated_of_dvd_dvd; rw [dvd_iff_normalized_factors_le_normalized_factors],
    all_goals { simp [*, h.le, h.ge], }, },
end

end unique_factorization_monoid

end

lemma prod_classes_of_roots_map_minpoly_of_monic
  {q : F[X]} (q_splits : splits (algebra_map F E) q) (q0 : q ≠ 0)
  (q_monic : q.monic) :
  ((classes_of_roots q_splits).map (λ c, minpoly c)).prod = q :=
begin
  simp_rw [classes_of_roots, multiset.map_pmap],
  suffices :
    (multiset.pmap (λ (q : F[X]) (h : q.splits (algebra_map F E) ∧ irreducible q),
      q) (unique_factorization_monoid.normalized_factors q) _).prod = q,
  { refine eq.trans _ this, swap, congr' 1,
    rw [(λ _ _ _ _ _, iff.rfl : ∀ {α β} {f g : α → β} (a : α), f a = g a ↔ f a = g a)], -- hack
    -- I wonder if there is a better method
    refine multiset.pmap_congr' _ (λ d hd _ _, minpoly_class_of_roots_irreducible_of_monic _ _ _),
    swap, rw [← unique_factorization_monoid.normalize_normalized_factor _ hd],
    have : d ≠ 0 := (unique_factorization_monoid.irreducible_of_normalized_factor _ hd).ne_zero,
    exact monic_normalize' this, },
  rw [multiset.pmap_eq_map, multiset.map_id'],
  refine eq_of_monic_of_associated _ q_monic
    (unique_factorization_monoid.normalized_factors_prod q0),
  refine monic_multiset_prod_of_monic _ _ (λ d hd, monic_normalize' _),
  exact (unique_factorization_monoid.irreducible_of_factor _ hd).ne_zero,
end

lemma prod_classes_of_roots_map_minpoly
  {q : F[X]} (q_splits : splits (algebra_map F E) q) (q0 : q ≠ 0) :
  ((classes_of_roots q_splits).map (λ c, minpoly c)).prod = q * C q.leading_coeff⁻¹ :=
begin
  rw [← @prod_classes_of_roots_map_minpoly_of_monic p (q * C q.leading_coeff⁻¹)], rotate 1,
  { exact splits_mul _ q_splits (splits_C _ _), },
  { refine mul_ne_zero q0 _, rwa [ne.def, C_eq_zero, inv_eq_zero, leading_coeff_eq_zero], },
  { exact monic_mul_leading_coeff_inv q0, },
  congr' 2, dsimp only [classes_of_roots],
  have l0 := inv_ne_zero (leading_coeff_ne_zero.mpr q0),
  have ql0 := mul_ne_zero q0 (C_eq_zero.not.mpr l0),
  have : associated q (q * C q.leading_coeff⁻¹),
  { refine associated_mul_unit_right _ _ _,
    rwa [is_unit_C, is_unit_iff_ne_zero], },
  simp_rw [(unique_factorization_monoid.associated_iff_normalized_factors_eq_normalized_factors
    q0 ql0).mp this],
end

lemma leading_coeff_mul_prod_classes_of_roots_map_minpoly
  {q : F[X]} (q_splits : splits (algebra_map F E) q) :
  C q.leading_coeff * ((classes_of_roots q_splits).map (λ c, minpoly c)).prod = q :=
begin
  rcases eq_or_ne q 0 with rfl | q0, { rw [leading_coeff_zero, C_0, zero_mul], },
  rw [prod_classes_of_roots_map_minpoly q_splits q0, mul_left_comm, ← C_mul, mul_inv_cancel,
    C_1, mul_one],
  exact leading_coeff_ne_zero.mpr q0,
end

lemma aroots_eq_classes_of_roots_bind_orbit
  {q : F[X]} (q_splits : splits (algebra_map F E) q) :
  q.aroots E =
    (classes_of_roots q_splits).bind (λ c, c.orbit.to_finset.1) :=
begin
  rcases eq_or_ne q 0 with rfl | q0,
  { rw [classes_of_roots_zero, multiset.zero_bind, map_zero, roots_zero], },
  conv_lhs { rw [← leading_coeff_mul_prod_classes_of_roots_map_minpoly q_splits], },
  rw [map_mul, map_multiset_prod, map_C, roots_C_mul, roots_multiset_prod,
    multiset.bind_map, multiset.bind_map],
  simp_rw [roots_minpoly_eq_orbit_val],
  { intros h, simp_rw [multiset.mem_map] at h,
    obtain ⟨_, ⟨⟨y, _, rfl⟩, h⟩⟩ := h,
    rw [map_eq_zero] at h,
    exact minpoly.ne_zero y h, },
  { rwa [ring_hom.map_ne_zero, leading_coeff_ne_zero], },
end

lemma root_set_eq_classes_of_roots_bUnion_orbit
  {q : F[X]} (q_splits : splits (algebra_map F E) q) :
  q.root_set E =
    ⋃ c ∈ ((classes_of_roots q_splits).to_finset : set (gal_conj_classes F E)), (c : _).orbit :=
begin
  refine eq.trans _ (eq.trans
    (congr_arg (λ (m : multiset E), (m.to_finset : set E))
    (roots_eq_classes_of_roots_bind_orbit q_splits)) _),
  { exact root_set_def _ _, },
  convert_to _ = ⋃ (c : gal_conj_classes F E) (H : c ∈ ↑((classes_of_roots q_splits).to_finset)),
    (c.orbit.to_finset : set E),
  { simp_rw [set.coe_to_finset], },
  rw [← coe_bUnion, finset.bUnion, finset.coe_inj, multiset.to_finset_val],
  convert (multiset.to_finset_bind_dedup _ _).symm,
end
-/

end gal_conj_classes

end gal_conj_classes


/-
Copyright (c) 2020 Heather Macbeth. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Heather Macbeth, Frédéric Dupuis
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.analysis.normed_space.hahn_banach
import Mathlib.analysis.normed_space.inner_product
import Mathlib.PostPort

universes u_1 u_2 u v

namespace Mathlib

/-!
# The topological dual of a normed space

In this file we define the topological dual of a normed space, and the bounded linear map from
a normed space into its double dual.

We also prove that, for base field `𝕜` with `[is_R_or_C 𝕜]`, this map is an isometry.

We then consider inner product spaces, with base field over `ℝ` (the corresponding results for `ℂ`
will require the definition of conjugate-linear maps). We define `to_dual_map`, a continuous linear
map from `E` to its dual, which maps an element `x` of the space to `λ y, ⟪x, y⟫`. We check
(`to_dual_map_isometry`) that this map is an isometry onto its image, and particular is injective.
We also define `to_dual'` as the function taking taking a vector to its dual for a base field `𝕜`
with `[is_R_or_C 𝕜]`; this is a function and not a linear map.

Finally, under the hypothesis of completeness (i.e., for Hilbert spaces), we prove the Fréchet-Riesz
representation (`to_dual_map_eq_top`), which states the surjectivity: every element of the dual
of a Hilbert space `E` has the form `λ u, ⟪x, u⟫` for some `x : E`.  This permits the map
`to_dual_map` to be upgraded to an (isometric) continuous linear equivalence, `to_dual`, between a
Hilbert space and its dual.

## References

* [M. Einsiedler and T. Ward, *Functional Analysis, Spectral Theory, and Applications*]
  [EinsiedlerWard2017]

## Tags

dual, Fréchet-Riesz
-/

namespace normed_space

/-- The topological dual of a normed space `E`. -/
def dual (𝕜 : Type u_1) [nondiscrete_normed_field 𝕜] (E : Type u_2) [normed_group E]
    [normed_space 𝕜 E] :=
  continuous_linear_map 𝕜 E 𝕜

protected instance dual.inhabited (𝕜 : Type u_1) [nondiscrete_normed_field 𝕜] (E : Type u_2)
    [normed_group E] [normed_space 𝕜 E] : Inhabited (dual 𝕜 E) :=
  { default := 0 }

/-- The inclusion of a normed space in its double (topological) dual. -/
def inclusion_in_double_dual' (𝕜 : Type u_1) [nondiscrete_normed_field 𝕜] (E : Type u_2)
    [normed_group E] [normed_space 𝕜 E] (x : E) : dual 𝕜 (dual 𝕜 E) :=
  linear_map.mk_continuous (linear_map.mk (fun (f : dual 𝕜 E) => coe_fn f x) sorry sorry) (norm x)
    sorry

@[simp] theorem dual_def (𝕜 : Type u_1) [nondiscrete_normed_field 𝕜] (E : Type u_2) [normed_group E]
    [normed_space 𝕜 E] (x : E) (f : dual 𝕜 E) :
    coe_fn (inclusion_in_double_dual' 𝕜 E x) f = coe_fn f x :=
  rfl

theorem double_dual_bound (𝕜 : Type u_1) [nondiscrete_normed_field 𝕜] (E : Type u_2)
    [normed_group E] [normed_space 𝕜 E] (x : E) : norm (inclusion_in_double_dual' 𝕜 E x) ≤ norm x :=
  sorry

/-- The inclusion of a normed space in its double (topological) dual, considered
   as a bounded linear map. -/
def inclusion_in_double_dual (𝕜 : Type u_1) [nondiscrete_normed_field 𝕜] (E : Type u_2)
    [normed_group E] [normed_space 𝕜 E] : continuous_linear_map 𝕜 E (dual 𝕜 (dual 𝕜 E)) :=
  linear_map.mk_continuous
    (linear_map.mk (fun (x : E) => inclusion_in_double_dual' 𝕜 E x) sorry sorry) 1 sorry

/-- If one controls the norm of every `f x`, then one controls the norm of `x`.
    Compare `continuous_linear_map.op_norm_le_bound`. -/
theorem norm_le_dual_bound {𝕜 : Type v} [is_R_or_C 𝕜] {E : Type u} [normed_group E]
    [normed_space 𝕜 E] (x : E) {M : ℝ} (hMp : 0 ≤ M)
    (hM : ∀ (f : dual 𝕜 E), norm (coe_fn f x) ≤ M * norm f) : norm x ≤ M :=
  sorry

/-- The inclusion of a normed space in its double dual is an isometry onto its image.-/
theorem inclusion_in_double_dual_isometry {𝕜 : Type v} [is_R_or_C 𝕜] {E : Type u} [normed_group E]
    [normed_space 𝕜 E] (x : E) : norm (coe_fn (inclusion_in_double_dual 𝕜 E) x) = norm x :=
  sorry

end normed_space

namespace inner_product_space

/--
Given some `x` in an inner product space, we can define its dual as the continuous linear map
`λ y, ⟪x, y⟫`. Consider using `to_dual` or `to_dual_map` instead in the real case.
-/
def to_dual' (𝕜 : Type u_1) {E : Type u_2} [is_R_or_C 𝕜] [inner_product_space 𝕜 E] :
    E →+ normed_space.dual 𝕜 E :=
  add_monoid_hom.mk
    (fun (x : E) =>
      linear_map.mk_continuous (linear_map.mk (fun (y : E) => inner x y) sorry sorry) (norm x)
        sorry)
    sorry sorry

@[simp] theorem to_dual'_apply (𝕜 : Type u_1) {E : Type u_2} [is_R_or_C 𝕜] [inner_product_space 𝕜 E]
    {x : E} {y : E} : coe_fn (coe_fn (to_dual' 𝕜) x) y = inner x y :=
  rfl

/-- In an inner product space, the norm of the dual of a vector `x` is `∥x∥` -/
@[simp] theorem norm_to_dual'_apply (𝕜 : Type u_1) {E : Type u_2} [is_R_or_C 𝕜]
    [inner_product_space 𝕜 E] (x : E) : norm (coe_fn (to_dual' 𝕜) x) = norm x :=
  sorry

theorem to_dual'_isometry (𝕜 : Type u_1) (E : Type u_2) [is_R_or_C 𝕜] [inner_product_space 𝕜 E] :
    isometry ⇑(to_dual' 𝕜) :=
  add_monoid_hom.isometry_of_norm (to_dual' 𝕜) (norm_to_dual'_apply 𝕜)

/--
Fréchet-Riesz representation: any `ℓ` in the dual of a Hilbert space `E` is of the form
`λ u, ⟪y, u⟫` for some `y : E`, i.e. `to_dual'` is surjective.
-/
theorem to_dual'_surjective (𝕜 : Type u_1) (E : Type u_2) [is_R_or_C 𝕜] [inner_product_space 𝕜 E]
    [complete_space E] : function.surjective ⇑(to_dual' 𝕜) :=
  sorry

/-- In a real inner product space `F`, the function that takes a vector `x` in `F` to its dual
`λ y, ⟪x, y⟫` is a continuous linear map. If the space is complete (i.e. is a Hilbert space),
consider using `to_dual` instead. -/
-- TODO extend to `is_R_or_C` (requires a definition of conjugate linear maps)

def to_dual_map {F : Type u_1} [inner_product_space ℝ F] :
    continuous_linear_map ℝ F (normed_space.dual ℝ F) :=
  linear_map.mk_continuous (linear_map.mk ⇑(to_dual' ℝ) sorry sorry) 1 sorry

@[simp] theorem to_dual_map_apply {F : Type u_1} [inner_product_space ℝ F] {x : F} {y : F} :
    coe_fn (coe_fn to_dual_map x) y = inner x y :=
  rfl

/-- In an inner product space, the norm of the dual of a vector `x` is `∥x∥` -/
@[simp] theorem norm_to_dual_map_apply {F : Type u_1} [inner_product_space ℝ F] (x : F) :
    norm (coe_fn to_dual_map x) = norm x :=
  norm_to_dual'_apply ℝ x

theorem to_dual_map_isometry {F : Type u_1} [inner_product_space ℝ F] : isometry ⇑to_dual_map :=
  add_monoid_hom.isometry_of_norm (to_dual' ℝ) norm_to_dual_map_apply

theorem to_dual_map_injective {F : Type u_1} [inner_product_space ℝ F] :
    function.injective ⇑to_dual_map :=
  isometry.injective to_dual_map_isometry

@[simp] theorem ker_to_dual_map {F : Type u_1} [inner_product_space ℝ F] :
    continuous_linear_map.ker to_dual_map = ⊥ :=
  iff.mpr linear_map.ker_eq_bot to_dual_map_injective

@[simp] theorem to_dual_map_eq_iff_eq {F : Type u_1} [inner_product_space ℝ F] {x : F} {y : F} :
    coe_fn to_dual_map x = coe_fn to_dual_map y ↔ x = y :=
  function.injective.eq_iff (iff.mp linear_map.ker_eq_bot ker_to_dual_map)

/--
Fréchet-Riesz representation: any `ℓ` in the dual of a real Hilbert space `F` is of the form
`λ u, ⟪y, u⟫` for some `y` in `F`.  See `inner_product_space.to_dual` for the continuous linear
equivalence thus induced.
-/
-- TODO extend to `is_R_or_C` (requires a definition of conjugate linear maps)

theorem range_to_dual_map {F : Type u_1} [inner_product_space ℝ F] [complete_space F] :
    continuous_linear_map.range to_dual_map = ⊤ :=
  iff.mpr linear_map.range_eq_top (to_dual'_surjective ℝ F)

/--
Fréchet-Riesz representation: If `F` is a Hilbert space, the function that takes a vector in `F` to
its dual is a continuous linear equivalence.  -/
def to_dual {F : Type u_1} [inner_product_space ℝ F] [complete_space F] :
    continuous_linear_equiv ℝ F (normed_space.dual ℝ F) :=
  continuous_linear_equiv.of_isometry (continuous_linear_map.to_linear_map to_dual_map)
    to_dual_map_isometry range_to_dual_map

/--
Fréchet-Riesz representation: If `F` is a Hilbert space, the function that takes a vector in `F` to
its dual is an isometry.  -/
def isometric.to_dual {F : Type u_1} [inner_product_space ℝ F] [complete_space F] :
    F ≃ᵢ normed_space.dual ℝ F :=
  isometric.mk (linear_equiv.to_equiv (continuous_linear_equiv.to_linear_equiv to_dual))
    (to_dual'_isometry ℝ F)

@[simp] theorem to_dual_apply {F : Type u_1} [inner_product_space ℝ F] [complete_space F] {x : F}
    {y : F} : coe_fn (coe_fn to_dual x) y = inner x y :=
  rfl

@[simp] theorem to_dual_eq_iff_eq {F : Type u_1} [inner_product_space ℝ F] [complete_space F]
    {x : F} {y : F} : coe_fn to_dual x = coe_fn to_dual y ↔ x = y :=
  function.injective.eq_iff (continuous_linear_equiv.injective to_dual)

theorem to_dual_eq_iff_eq' {F : Type u_1} [inner_product_space ℝ F] [complete_space F] {x : F}
    {x' : F} : (∀ (y : F), inner x y = inner x' y) ↔ x = x' :=
  sorry

@[simp] theorem norm_to_dual_apply {F : Type u_1} [inner_product_space ℝ F] [complete_space F]
    (x : F) : norm (coe_fn to_dual x) = norm x :=
  norm_to_dual_map_apply x

/-- In a Hilbert space, the norm of a vector in the dual space is the norm of its corresponding
primal vector. -/
theorem norm_to_dual_symm_apply {F : Type u_1} [inner_product_space ℝ F] [complete_space F]
    (ℓ : normed_space.dual ℝ F) : norm (coe_fn (continuous_linear_equiv.symm to_dual) ℓ) = norm ℓ :=
  sorry

end Mathlib


import tag006T -- sheaves of types
import tag006N -- presheaves of rings

-- this should really be done for abstract categories; we "cheat" here because
-- equalizers in the category of commutative rings are the same as equalizers
-- in the underlying category of sets: see tag0073 (lemma 6.9.2)

def is_sheaf_of_rings {α : Type*} [T : topological_space α]
  (PR : presheaf_of_rings α) : Prop :=
is_sheaf_of_types PR.to_presheaf_of_types


import data.finset

import lib.core.rel3
import config

variables {α : Type*} [linear_order α] (C : config α)

structure config.label (S : finset α) :=
(slope : α → α → Prop)
(decidable_slope : decidable_rel slope)
-- The direction looks odd, but it is written in perspective of
-- _where_ the edge ab is placed
(extend_left : ∀ {a b : α}, a ∈ S → b ∈ S → a < b → ¬slope a b →
  ∀ {c : α}, c ∈ S → b < c → C.cup3 a b c)
(extend_right : ∀ {a b : α}, a ∈ S → b ∈ S → a < b → slope a b →
  ∀ {c : α}, c ∈ S → c < a → C.cup3 c a b)

attribute [instance] config.label.decidable_slope

def cap4_free_slope {S : finset α} (h : ¬C.has_ncap 4 S) (a b : α) : Prop :=
  ∀ c : S, ↑c < a → C.cup3 c a b

instance decidable_cap4_free_slope {S : finset α} (h : ¬C.has_ncap 4 S) :
  decidable_rel (cap4_free_slope C h) :=
λ a b, by rw cap4_free_slope; simp; apply_instance

variable {C}

def cap4_free_label {S : finset α} (h : ¬C.has_ncap 4 S) : C.label S :=
begin
  use cap4_free_slope C h,
  apply_instance,
  { intros a b ha hb hab hn c hc hbc,
    by_contra h', apply hn, intros d hd,
    by_contra h'', apply h, use [[d, a, b, c]], simp [config.ncap], tauto },
  { intros a b ha hb hab hy c hc hca,
    exact hy ⟨c, hc⟩ hca },
end

variables {C} {S : finset α} {label : C.label S}

protected theorem config.cup.extend_left
  {l : list α} (l_cup : C.cup l)
  {a b : α} (s_ab : ¬label.slope a b)
  (ha : a ∈ S) (hab : a < b) (l_in_S : l.in S)
  (b_head_l : b ∈ l.head') : C.cup (a :: l) :=
begin
  cases l with b l,
  { simp at b_head_l, tauto },
  simp at b_head_l, subst b_head_l,
  cases l with c l,
  { simp, exact hab },
  simp at l_in_S, simp,
  refine ⟨_, _, _⟩; try {tauto},
  simp [config.cup] at l_cup,
  apply label.extend_left; tauto,
end

protected theorem config.cup.extend_right
  {l : list α} (l_cup : C.cup l)
  {a b : α} (s_ab : label.slope a b)
  (hab : a < b) (hb : b ∈ S) (l_in_S : l.in S)
  (a_last_l : a ∈ l.last') : C.cup (l ++ [b]) :=
begin
  by_cases hl : 2 ≤ l.length,
  { rcases list.take_last2 hl with ⟨c, a, l', eq_l⟩,
    rw eq_l at a_last_l, simp at a_last_l, subst a_last_l,
    rw eq_l, simp, rw ←eq_l,
    refine ⟨_, _, _⟩; try {tauto},
    simp [config.cup] at l_cup,
    rw eq_l at l_in_S, simp at l_in_S,
    rw eq_l at l_cup, simp at l_cup,
    apply label.extend_right; tauto },
  cases l with p l, simp,
  cases l with q l, simp at *, subst a_last_l; tauto,
  exfalso, apply hl, exact le_add_self,
end

protected theorem config.ncup.extend_left
  {n : ℕ} {l : list α} (l_ncup : C.ncup n l)
  {a b : α} (s_ab : ¬label.slope a b)
  (ha : a ∈ S) (hab : a < b) (l_in_S : l.in S)
  (b_head_l : b ∈ l.head') : C.ncup (n+1) (a :: l) :=
begin
  cases l_ncup with l_cup l_len, split,
  apply l_cup.extend_left s_ab; try {assumption},
  simp, assumption,
end

protected theorem config.ncup.extend_right
  {n : ℕ} {l : list α} (l_ncup : C.ncup n l)
  {a b : α} (s_ab : label.slope a b)
  (hab : a < b) (hb : b ∈ S) (l_in_S : l.in S)
  (a_last_l : a ∈ l.last') : C.ncup (n+1) (l ++ [b]) :=
begin
  cases l_ncup with l_cup l_len, split,
  apply l_cup.extend_right s_ab; try {assumption},
  simp, assumption,
end

variable (label)

open order_dual

protected def config.label.mirror :
  C.mirror.label S.mirror :=
⟨ λ a b, ¬(mirror2 label.slope a b),
  λ a b, @not.decidable _ (label.decidable_slope.mirror2 a b),
  begin
    intros a b a_in_S b_in_S hab hslope c c_in_S hbc,
    simp [mirror2] at hslope,
    simp [config.mirror, mirror3],
    simp [finset.mirror] at a_in_S b_in_S c_in_S,
    rcases a_in_S with ⟨oa, ⟨oa_in_S, oa_eq⟩⟩,
    rcases b_in_S with ⟨ob, ⟨ob_in_S, ob_eq⟩⟩,
    rcases c_in_S with ⟨oc, ⟨oc_in_S, oc_eq⟩⟩,
    rw ←oa_eq at hab,
    rw ←ob_eq at hab hbc,
    rw ←oc_eq at hbc,
    simp at hab hbc,
    rw [←oa_eq, ←ob_eq, ←oc_eq], simp,
    rw [←oa_eq, ←ob_eq] at hslope, simp at hslope,
    apply label.extend_right; tauto,
  end,
  begin
    intros a b a_in_S b_in_S hab hslope c c_in_S hca,
    simp [mirror2] at hslope,
    simp [config.mirror, mirror3],
    simp [finset.mirror] at a_in_S b_in_S c_in_S,
    rcases a_in_S with ⟨oa, ⟨oa_in_S, oa_eq⟩⟩,
    rcases b_in_S with ⟨ob, ⟨ob_in_S, ob_eq⟩⟩,
    rcases c_in_S with ⟨oc, ⟨oc_in_S, oc_eq⟩⟩,
    rw ←oa_eq at hab hca,
    rw ←ob_eq at hab,
    rw ←oc_eq at hca,
    simp at hab hca,
    rw [←oa_eq, ←ob_eq, ←oc_eq], simp,
    rw [←oa_eq, ←ob_eq] at hslope, simp at hslope,
    apply label.extend_left; tauto,
  end⟩

variable {label}

def mirror_slope {a b : α} :
  ¬label.mirror.slope (to_dual b) (to_dual a) ↔ label.slope a b :=
begin
  rw config.label.mirror, simp,
  rw mirror2, simp,
end


/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import category_theory.limits.shapes.products
import category_theory.limits.shapes.equalizers
import category_theory.limits.cone_category
import category_theory.adjunction

/-!

# Multi-(co)equalizers

A *multiequalizer* is an equalizer of two morphisms between two products.
Since both products and equalizers are limits, such an object is again a limit.
This file provides the diagram whose limit is indeed such an object.
In fact, it is well-known that any limit can be obtained as a multiequalizer.
The dual construction (multicoequalizers) is also provided.

## Projects

Prove that a multiequalizer can be identified with
an equalizer between products (and analogously for multicoequalizers).

Prove that the limit of any diagram is a multiequalizer (and similarly for colimits).

-/

namespace category_theory.limits

open category_theory

universes v u

/-- The type underlying the multiequalizer diagram. -/
@[nolint unused_arguments]
inductive walking_multicospan {L R : Type v} (fst snd : R → L) : Type v
| left : L → walking_multicospan
| right : R → walking_multicospan

/-- The type underlying the multiecoqualizer diagram. -/
@[nolint unused_arguments]
inductive walking_multispan {L R : Type v} (fst snd : L → R) : Type v
| left : L → walking_multispan
| right : R → walking_multispan

namespace walking_multicospan

variables {L R : Type v} {fst snd : R → L}

instance [inhabited L] : inhabited (walking_multicospan fst snd) :=
⟨left (default _)⟩

/-- Morphisms for `walking_multicospan`. -/
inductive hom : Π (a b : walking_multicospan fst snd), Type v
| id (A)  : hom A A
| fst (b) : hom (left (fst b)) (right b)
| snd (b) : hom (left (snd b)) (right b)

instance {a : walking_multicospan fst snd} : inhabited (hom a a) :=
⟨hom.id _⟩

/-- Composition of morphisms for `walking_multicospan`. -/
def hom.comp : Π {A B C : walking_multicospan fst snd} (f : hom A B) (g : hom B C),
  hom A C
| _ _ _ (hom.id X) f := f
| _ _ _ (hom.fst b) (hom.id X) := hom.fst b
| _ _ _ (hom.snd b) (hom.id X) := hom.snd b

instance : small_category (walking_multicospan fst snd) :=
{ hom := hom,
  id := hom.id,
  comp := λ X Y Z, hom.comp,
  id_comp' := by { rintro (_|_) (_|_) (_|_|_), tidy },
  comp_id' := by { rintro (_|_) (_|_) (_|_|_), tidy },
  assoc' := by { rintro (_|_) (_|_) (_|_) (_|_) (_|_|_) (_|_|_) (_|_|_), tidy } }

end walking_multicospan

namespace walking_multispan

variables {L R : Type v} {fst snd : L → R}

instance [inhabited L] : inhabited (walking_multispan fst snd) :=
⟨left (default _)⟩

/-- Morphisms for `walking_multispan`. -/
inductive hom : Π (a b : walking_multispan fst snd), Type v
| id (A)  : hom A A
| fst (a) : hom (left a) (right (fst a))
| snd (a) : hom (left a) (right (snd a))

instance {a : walking_multispan fst snd} : inhabited (hom a a) :=
⟨hom.id _⟩

/-- Composition of morphisms for `walking_multispan`. -/
def hom.comp : Π {A B C : walking_multispan fst snd} (f : hom A B) (g : hom B C),
  hom A C
| _ _ _ (hom.id X) f := f
| _ _ _ (hom.fst a) (hom.id X) := hom.fst a
| _ _ _ (hom.snd a) (hom.id X) := hom.snd a

instance : small_category (walking_multispan fst snd) :=
{ hom := hom,
  id := hom.id,
  comp := λ X Y Z, hom.comp,
  id_comp' := by { rintro (_|_) (_|_) (_|_|_), tidy },
  comp_id' := by { rintro (_|_) (_|_) (_|_|_), tidy },
  assoc' := by { rintro (_|_) (_|_) (_|_) (_|_) (_|_|_) (_|_|_) (_|_|_), tidy } }

end walking_multispan

/-- This is a structure encapsulating the data necessary to define a `multicospan`. -/
@[nolint has_inhabited_instance]
structure multicospan_index (C : Type u) [category.{v} C] :=
(L R : Type v)
(fst_to snd_to : R → L)
(left : L → C)
(right : R → C)
(fst : Π b, left (fst_to b) ⟶ right b)
(snd : Π b, left (snd_to b) ⟶ right b)

/-- This is a structure encapsulating the data necessary to define a `multispan`. -/
@[nolint has_inhabited_instance]
structure multispan_index (C : Type u) [category.{v} C] :=
(L R : Type v)
(fst_from snd_from : L → R)
(left : L → C)
(right : R → C)
(fst : Π a, left a ⟶ right (fst_from a))
(snd : Π a, left a ⟶ right (snd_from a))

namespace multicospan_index

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

/-- The multicospan associated to `I : multicospan_index`. -/
def multicospan : walking_multicospan I.fst_to I.snd_to ⥤ C :=
{ obj := λ x,
  match x with
  | walking_multicospan.left a := I.left a
  | walking_multicospan.right b := I.right b
  end,
  map := λ x y f,
  match x, y, f with
  | _, _, walking_multicospan.hom.id x := 𝟙 _
  | _, _, walking_multicospan.hom.fst b := I.fst _
  | _, _, walking_multicospan.hom.snd b := I.snd _
  end,
  map_id' := by { rintros (_|_), tidy },
  map_comp' := by { rintros (_|_) (_|_) (_|_) (_|_|_) (_|_|_), tidy } }

@[simp] lemma multicospan_obj_left (a) :
  I.multicospan.obj (walking_multicospan.left a) = I.left a := rfl

@[simp] lemma multicospan_obj_right (b) :
  I.multicospan.obj (walking_multicospan.right b) = I.right b := rfl

@[simp] lemma multicospan_map_fst (b) :
  I.multicospan.map (walking_multicospan.hom.fst b) = I.fst b := rfl

@[simp] lemma multicospan_map_snd (b) :
  I.multicospan.map (walking_multicospan.hom.snd b) = I.snd b := rfl

variables [has_product I.left] [has_product I.right]

/-- The induced map `∏ I.left ⟶ ∏ I.right` via `I.fst`. -/
noncomputable
def fst_pi_map : ∏ I.left ⟶ ∏ I.right := pi.lift (λ b, pi.π I.left (I.fst_to b) ≫ I.fst b)

/-- The induced map `∏ I.left ⟶ ∏ I.right` via `I.snd`. -/
noncomputable
def snd_pi_map : ∏ I.left ⟶ ∏ I.right := pi.lift (λ b, pi.π I.left (I.snd_to b) ≫ I.snd b)

@[simp, reassoc]
lemma fst_pi_map_π (b) : I.fst_pi_map ≫ pi.π I.right b = pi.π I.left _ ≫ I.fst b :=
by simp [fst_pi_map]

@[simp, reassoc]
lemma snd_pi_map_π (b) : I.snd_pi_map ≫ pi.π I.right b = pi.π I.left _ ≫ I.snd b :=
by simp [snd_pi_map]

/--
Taking the multiequalizer over the multicospan index is equivalent to taking the equalizer over
the two morphsims `∏ I.left ⇉ ∏ I.right`. This is the diagram of the latter.
-/
@[simps] protected noncomputable
def parallel_pair_diagram := parallel_pair I.fst_pi_map I.snd_pi_map

end multicospan_index

namespace multispan_index

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

/-- The multispan associated to `I : multispan_index`. -/
def multispan : walking_multispan I.fst_from I.snd_from ⥤ C :=
{ obj := λ x,
  match x with
  | walking_multispan.left a := I.left a
  | walking_multispan.right b := I.right b
  end,
  map := λ x y f,
  match x, y, f with
  | _, _, walking_multispan.hom.id x := 𝟙 _
  | _, _, walking_multispan.hom.fst b := I.fst _
  | _, _, walking_multispan.hom.snd b := I.snd _
  end,
  map_id' := by { rintros (_|_), tidy },
  map_comp' := by { rintros (_|_) (_|_) (_|_) (_|_|_) (_|_|_), tidy } }

@[simp] lemma multispan_obj_left (a) :
  I.multispan.obj (walking_multispan.left a) = I.left a := rfl

@[simp] lemma multispan_obj_right (b) :
  I.multispan.obj (walking_multispan.right b) = I.right b := rfl

@[simp] lemma multispan_map_fst (a) :
  I.multispan.map (walking_multispan.hom.fst a) = I.fst a := rfl

@[simp] lemma multispan_map_snd (a) :
  I.multispan.map (walking_multispan.hom.snd a) = I.snd a := rfl

variables [has_coproduct I.left] [has_coproduct I.right]

/-- The induced map `∐ I.left ⟶ ∐ I.right` via `I.fst`. -/
noncomputable
def fst_sigma_map : ∐ I.left ⟶ ∐ I.right := sigma.desc (λ b, I.fst b ≫ sigma.ι _ (I.fst_from b))

/-- The induced map `∐ I.left ⟶ ∐ I.right` via `I.snd`. -/
noncomputable
def snd_sigma_map : ∐ I.left ⟶ ∐ I.right := sigma.desc (λ b, I.snd b ≫ sigma.ι _ (I.snd_from b))

@[simp, reassoc]
lemma ι_fst_sigma_map (b) : sigma.ι I.left b ≫ I.fst_sigma_map = I.fst b ≫ sigma.ι I.right _ :=
by simp [fst_sigma_map]

@[simp, reassoc]
lemma ι_snd_sigma_map (b) : sigma.ι I.left b ≫ I.snd_sigma_map = I.snd b ≫ sigma.ι I.right _ :=
by simp [snd_sigma_map]

/--
Taking the multicoequalizer over the multispan index is equivalent to taking the coequalizer over
the two morphsims `∐ I.left ⇉ ∐ I.right`. This is the diagram of the latter.
-/
protected noncomputable
abbreviation parallel_pair_diagram := parallel_pair I.fst_sigma_map I.snd_sigma_map

end multispan_index

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

/-- A multifork is a cone over a multicospan. -/
@[nolint has_inhabited_instance]
abbreviation multifork (I : multicospan_index C) := cone I.multicospan

/-- A multicofork is a cocone over a multispan. -/
@[nolint has_inhabited_instance]
abbreviation multicofork (I : multispan_index C) := cocone I.multispan

namespace multifork

variables {I : multicospan_index C} (K : multifork I)

/-- The maps from the cone point of a multifork to the objects on the left. -/
def ι (a : I.L) : K.X ⟶ I.left a :=
K.π.app (walking_multicospan.left _)

@[simp] lemma ι_eq_app_left (a) : K.ι a = K.π.app (walking_multicospan.left _) := rfl

@[simp] lemma app_left_fst (b) :
  K.π.app (walking_multicospan.left (I.fst_to b)) ≫ I.fst b =
    K.π.app (walking_multicospan.right b) :=
by { rw ← K.w (walking_multicospan.hom.fst b), refl }

@[simp] lemma app_left_snd (b) :
  K.π.app (walking_multicospan.left (I.snd_to b)) ≫ I.snd b =
    K.π.app (walking_multicospan.right b) :=
by { rw ← K.w (walking_multicospan.hom.snd b), refl }

/-- Construct a multifork using a collection `ι` of morphisms. -/
@[simps]
def of_ι (I : multicospan_index C) (P : C) (ι : Π a, P ⟶ I.left a)
  (w : ∀ b, ι (I.fst_to b) ≫ I.fst b = ι (I.snd_to b) ≫ I.snd b) :
  multifork I :=
{ X := P,
  π :=
  { app := λ x,
    match x with
    | walking_multicospan.left a := ι _
    | walking_multicospan.right b := ι (I.fst_to b) ≫ I.fst b
    end,
    naturality' := begin
      rintros (_|_) (_|_) (_|_|_),
      any_goals { symmetry, dsimp, rw category.id_comp, apply category.comp_id },
      { dsimp, rw category.id_comp, refl },
      { dsimp, rw category.id_comp, apply w }
    end } }

@[reassoc]
lemma condition (b) :
  K.ι (I.fst_to b) ≫ I.fst b = K.ι (I.snd_to b) ≫ I.snd b := by simp

/-- This definition provides a convenient way to show that a multifork is a limit. -/
@[simps]
def is_limit.mk
  (lift : Π (E : multifork I), E.X ⟶ K.X)
  (fac : ∀ (E : multifork I) (i : I.L), lift E ≫ K.ι i = E.ι i)
  (uniq : ∀ (E : multifork I) (m : E.X ⟶ K.X),
    (∀ i : I.L, m ≫ K.ι i = E.ι i) → m = lift E) : is_limit K :=
{ lift := lift,
  fac' := begin
    rintros E (a|b),
    { apply fac },
    { rw [← E.w (walking_multicospan.hom.fst b), ← K.w (walking_multicospan.hom.fst b),
        ← category.assoc],
      congr' 1,
      apply fac }
  end,
  uniq' := begin
    rintros E m hm,
    apply uniq,
    intros i,
    apply hm,
  end }

variables [has_product I.left] [has_product I.right]

@[simp, reassoc]
lemma pi_condition :
  pi.lift K.ι ≫ I.fst_pi_map = pi.lift K.ι ≫ I.snd_pi_map := by { ext, simp }

/-- Given a multifork, we may obtain a fork over `∏ I.left ⇉ ∏ I.right`. -/
@[simps X] noncomputable
def to_pi_fork (K : multifork I) : fork I.fst_pi_map I.snd_pi_map :=
{ X := K.X,
  π :=
  { app := λ x,
    match x with
    | walking_parallel_pair.zero := pi.lift K.ι
    | walking_parallel_pair.one := pi.lift K.ι ≫ I.fst_pi_map
    end,
    naturality' :=
    begin
      rintros (_|_) (_|_) (_|_|_),
      any_goals { symmetry, dsimp, rw category.id_comp, apply category.comp_id },
      all_goals { change 𝟙 _ ≫ _ ≫ _ = pi.lift _ ≫ _, simp }
    end } }

@[simp] lemma to_pi_fork_π_app_zero :
  K.to_pi_fork.π.app walking_parallel_pair.zero = pi.lift K.ι := rfl

@[simp] lemma to_pi_fork_π_app_one :
  K.to_pi_fork.π.app walking_parallel_pair.one = pi.lift K.ι ≫ I.fst_pi_map := rfl

variable (I)

/-- Given a fork over `∏ I.left ⇉ ∏ I.right`, we may obtain a multifork. -/
@[simps X] noncomputable
def of_pi_fork (c : fork I.fst_pi_map I.snd_pi_map) : multifork I :=
{ X := c.X,
  π :=
  { app := λ x,
    match x with
    | walking_multicospan.left a := c.ι ≫ pi.π _ _
    | walking_multicospan.right b := c.ι ≫ I.fst_pi_map ≫ pi.π _ _
    end,
    naturality' :=
    begin
      rintros (_|_) (_|_) (_|_|_),
      any_goals { symmetry, dsimp, rw category.id_comp, apply category.comp_id },
      { change 𝟙 _ ≫ _ ≫ _ = (_ ≫ _) ≫ _, simp },
      { change 𝟙 _ ≫ _ ≫ _ = (_ ≫ _) ≫ _, rw c.condition_assoc, simp }
    end } }

@[simp] lemma of_pi_fork_π_app_left (c : fork I.fst_pi_map I.snd_pi_map) (a) :
  (of_pi_fork I c).π.app (walking_multicospan.left a) = c.ι ≫ pi.π _ _ := rfl

@[simp] lemma of_pi_fork_π_app_right (c : fork I.fst_pi_map I.snd_pi_map) (a) :
  (of_pi_fork I c).π.app (walking_multicospan.right a) = c.ι ≫ I.fst_pi_map ≫ pi.π _ _ := rfl

end multifork

namespace multicospan_index

variables (I : multicospan_index C) [has_product I.left] [has_product I.right]

local attribute [tidy] tactic.case_bash

/-- `multifork.to_pi_fork` is functorial. -/
@[simps] noncomputable
def to_pi_fork_functor : multifork I ⥤ fork I.fst_pi_map I.snd_pi_map :=
{ obj := multifork.to_pi_fork, map := λ K₁ K₂ f, { hom := f.hom } }

/-- `multifork.of_pi_fork` is functorial. -/
@[simps] noncomputable
def of_pi_fork_functor : fork I.fst_pi_map I.snd_pi_map ⥤ multifork I :=
{ obj := multifork.of_pi_fork I, map := λ K₁ K₂ f, { hom := f.hom, w' := by rintros (_|_); simp } }

/--
The category of multiforks is equivalent to the category of forks over `∏ I.left ⇉ ∏ I.right`.
It then follows from `category_theory.is_limit_of_preserves_cone_terminal` (or `reflects`) that it
preserves and reflects limit cones.
-/
@[simps] noncomputable
def multifork_equiv_pi_fork : multifork I ≌ fork I.fst_pi_map I.snd_pi_map :=
{ functor := to_pi_fork_functor I,
  inverse := of_pi_fork_functor I,
  unit_iso := nat_iso.of_components (λ K, cones.ext (iso.refl _) (by rintros (_|_); dsimp; simp))
    (λ K₁ K₂ f, by { ext, simp }),
  counit_iso := nat_iso.of_components (λ K, fork.ext (iso.refl _) (by { ext, dsimp, simp }))
    (λ K₁ K₂ f, by { ext, simp }) }

end multicospan_index

namespace multicofork

variables {I : multispan_index C} (K : multicofork I)

/-- The maps to the cocone point of a multicofork from the objects on the right. -/
def π (b : I.R) : I.right b ⟶ K.X :=
K.ι.app (walking_multispan.right _)

@[simp] lemma π_eq_app_right (b) : K.π b = K.ι.app (walking_multispan.right _) := rfl

@[simp] lemma fst_app_right (a) :
  I.fst a ≫ K.ι.app (walking_multispan.right (I.fst_from a)) =
    K.ι.app (walking_multispan.left a) :=
by { rw ← K.w (walking_multispan.hom.fst a), refl }

@[simp] lemma snd_app_right (a) :
  I.snd a ≫ K.ι.app (walking_multispan.right (I.snd_from a)) =
    K.ι.app (walking_multispan.left a) :=
by { rw ← K.w (walking_multispan.hom.snd a), refl }

/-- Construct a multicofork using a collection `π` of morphisms. -/
@[simps]
def of_π (I : multispan_index C) (P : C) (π : Π b, I.right b ⟶ P)
  (w : ∀ a, I.fst a ≫ π (I.fst_from a) = I.snd a ≫ π (I.snd_from a)) :
  multicofork I :=
{ X := P,
  ι :=
  { app := λ x,
    match x with
    | walking_multispan.left a := I.fst a ≫ π _
    | walking_multispan.right b := π _
    end,
    naturality' := begin
      rintros (_|_) (_|_) (_|_|_),
      any_goals { dsimp, rw category.comp_id, apply category.id_comp },
      { dsimp, rw category.comp_id, refl },
      { dsimp, rw category.comp_id, apply (w _).symm }
    end } }

@[reassoc]
lemma condition (a) :
  I.fst a ≫ K.π (I.fst_from a) = I.snd a ≫ K.π (I.snd_from a) := by simp

/-- This definition provides a convenient way to show that a multicofork is a colimit. -/
@[simps]
def is_colimit.mk
  (desc : Π (E : multicofork I), K.X ⟶ E.X)
  (fac : ∀ (E : multicofork I) (i : I.R), K.π i ≫ desc E = E.π i)
  (uniq : ∀ (E : multicofork I) (m : K.X ⟶ E.X),
    (∀ i : I.R, K.π i ≫ m = E.π i) → m = desc E) : is_colimit K :=
{ desc := desc,
  fac' := begin
    rintros S (a|b),
    { rw [← K.w (walking_multispan.hom.fst a), ← S.w (walking_multispan.hom.fst a),
        category.assoc],
      congr' 1,
      apply fac },
    { apply fac },
  end,
  uniq' := begin
    intros S m hm,
    apply uniq,
    intros i,
    apply hm
  end }

variables [has_coproduct I.left] [has_coproduct I.right]

@[simp, reassoc]
lemma sigma_condition :
  I.fst_sigma_map ≫ sigma.desc K.π = I.snd_sigma_map ≫ sigma.desc K.π := by { ext, simp }

/-- Given a multicofork, we may obtain a cofork over `∐ I.left ⇉ ∐ I.right`. -/
@[simps X] noncomputable
def to_sigma_cofork (K : multicofork I) : cofork I.fst_sigma_map I.snd_sigma_map :=
{ X := K.X,
  ι :=
  { app := λ x,
    match x with
    | walking_parallel_pair.zero := I.fst_sigma_map ≫ sigma.desc K.π
    | walking_parallel_pair.one := sigma.desc K.π
    end,
    naturality' :=
    begin
      rintros (_|_) (_|_) (_|_|_),
      any_goals { dsimp, rw category.comp_id, apply category.id_comp },
      all_goals { change _ ≫ sigma.desc _ = (_ ≫ _) ≫ 𝟙 _, simp }
    end } }

@[simp] lemma to_sigma_cofork_ι_app_zero :
  K.to_sigma_cofork.ι.app walking_parallel_pair.zero = I.fst_sigma_map ≫ sigma.desc K.π := rfl

@[simp] lemma to_sigma_cofork_ι_app_one :
  K.to_sigma_cofork.ι.app walking_parallel_pair.one = sigma.desc K.π := rfl

variable (I)

/-- Given a cofork over `∐ I.left ⇉ ∐ I.right`, we may obtain a multicofork. -/
@[simps X] noncomputable
def of_sigma_cofork (c : cofork I.fst_sigma_map I.snd_sigma_map) : multicofork I :=
{ X := c.X,
  ι :=
  { app := λ x,
    match x with
    | walking_multispan.left a := (sigma.ι I.left a : _) ≫ I.fst_sigma_map ≫ c.π
    | walking_multispan.right b := (sigma.ι I.right b : _) ≫ c.π
    end,
    naturality' :=
    begin
      rintros (_|_) (_|_) (_|_|_),
      any_goals { dsimp, rw category.comp_id, apply category.id_comp },
      { change _ ≫ _ ≫ _ = (_ ≫ _) ≫ _,
        dsimp, simp [←cofork.left_app_one, -cofork.left_app_one] },
      { change _ ≫ _ ≫ _ = (_ ≫ _) ≫ 𝟙 _,
        rw c.condition,
        dsimp, simp [←cofork.right_app_one, -cofork.right_app_one] }
    end } }

@[simp] lemma of_sigma_cofork_ι_app_left (c : cofork I.fst_sigma_map I.snd_sigma_map) (a) :
  (of_sigma_cofork I c).ι.app (walking_multispan.left a) =
    (sigma.ι I.left a : _) ≫ I.fst_sigma_map ≫ c.π := rfl

@[simp] lemma of_sigma_cofork_ι_app_right (c : cofork I.fst_sigma_map I.snd_sigma_map) (b) :
  (of_sigma_cofork I c).ι.app (walking_multispan.right b) = (sigma.ι I.right b : _) ≫ c.π := rfl

end multicofork

namespace multispan_index

variables (I : multispan_index C) [has_coproduct I.left] [has_coproduct I.right]

local attribute [tidy] tactic.case_bash

/-- `multicofork.to_sigma_cofork` is functorial. -/
@[simps] noncomputable
def to_sigma_cofork_functor : multicofork I ⥤ cofork I.fst_sigma_map I.snd_sigma_map :=
{ obj := multicofork.to_sigma_cofork, map := λ K₁ K₂ f, { hom := f.hom } }

/-- `multicofork.of_sigma_cofork` is functorial. -/
@[simps] noncomputable
def of_sigma_cofork_functor : cofork I.fst_sigma_map I.snd_sigma_map ⥤ multicofork I :=
{ obj := multicofork.of_sigma_cofork I,
  map := λ K₁ K₂ f, { hom := f.hom, w' := by rintros (_|_); simp } }

/--
The category of multicoforks is equivalent to the category of coforks over `∐ I.left ⇉ ∐ I.right`.
It then follows from `category_theory.is_colimit_of_preserves_cocone_initial` (or `reflects`) that
it preserves and reflects colimit cocones.
-/
@[simps] noncomputable
def multicofork_equiv_sigma_cofork : multicofork I ≌ cofork I.fst_sigma_map I.snd_sigma_map :=
{ functor := to_sigma_cofork_functor I,
  inverse := of_sigma_cofork_functor I,
  unit_iso := nat_iso.of_components (λ K, cocones.ext (iso.refl _) (by rintros (_|_); dsimp; simp))
    (λ K₁ K₂ f, by { ext, simp }),
  counit_iso := nat_iso.of_components (λ K, cofork.ext (iso.refl _) (by { ext, dsimp, simp }))
    (λ K₁ K₂ f, by { ext, dsimp, simp, }) }

end multispan_index

/-- For `I : multicospan_index C`, we say that it has a multiequalizer if the associated
  multicospan has a limit. -/
abbreviation has_multiequalizer (I : multicospan_index C) :=
  has_limit I.multicospan

noncomputable theory

/-- The multiequalizer of `I : multicospan_index C`. -/
abbreviation multiequalizer (I : multicospan_index C) [has_multiequalizer I] : C :=
  limit I.multicospan

/-- For `I : multispan_index C`, we say that it has a multicoequalizer if
  the associated multicospan has a limit. -/
abbreviation has_multicoequalizer (I : multispan_index C) :=
  has_colimit I.multispan

/-- The multiecoqualizer of `I : multispan_index C`. -/
abbreviation multicoequalizer (I : multispan_index C) [has_multicoequalizer I] : C :=
  colimit I.multispan

namespace multiequalizer

variables (I : multicospan_index C) [has_multiequalizer I]

/-- The canonical map from the multiequalizer to the objects on the left. -/
abbreviation ι (a : I.L) : multiequalizer I ⟶ I.left a :=
limit.π _ (walking_multicospan.left a)

/-- The multifork associated to the multiequalizer. -/
abbreviation multifork : multifork I :=
limit.cone _

@[simp]
lemma multifork_ι (a) :
  (multiequalizer.multifork I).ι a = multiequalizer.ι I a := rfl

@[simp]
lemma multifork_π_app_left (a) :
  (multiequalizer.multifork I).π.app (walking_multicospan.left a) =
  multiequalizer.ι I a := rfl

@[reassoc]
lemma condition (b) :
  multiequalizer.ι I (I.fst_to b) ≫ I.fst b =
  multiequalizer.ι I (I.snd_to b) ≫ I.snd b :=
multifork.condition _ _

/-- Construct a morphism to the multiequalizer from its universal property. -/
abbreviation lift (W : C) (k : Π a, W ⟶ I.left a)
  (h : ∀ b, k (I.fst_to b) ≫ I.fst b = k (I.snd_to b) ≫ I.snd b) :
  W ⟶ multiequalizer I :=
limit.lift _ (multifork.of_ι I _ k h)

@[simp, reassoc]
lemma lift_ι (W : C) (k : Π a, W ⟶ I.left a)
  (h : ∀ b, k (I.fst_to b) ≫ I.fst b = k (I.snd_to b) ≫ I.snd b) (a) :
  multiequalizer.lift I _ k h ≫ multiequalizer.ι I a = k _ :=
limit.lift_π _ _

@[ext]
lemma hom_ext {W : C} (i j : W ⟶ multiequalizer I)
  (h : ∀ a, i ≫ multiequalizer.ι I a =
  j ≫ multiequalizer.ι I a) :
  i = j :=
limit.hom_ext
begin
  rintro (a|b),
  { apply h },
  simp_rw [← limit.w I.multicospan (walking_multicospan.hom.fst b),
    ← category.assoc, h],
end

variables [has_product I.left] [has_product I.right] [has_equalizer I.fst_pi_map I.snd_pi_map]

/-- The multiequalizer is isomorphic to the equalizer of `∏ I.left ⇉ ∏ I.right`. -/
def iso_equalizer : multiequalizer I ≅ equalizer I.fst_pi_map I.snd_pi_map :=
limit.iso_limit_cone ⟨_, is_limit.of_preserves_cone_terminal
  I.multifork_equiv_pi_fork.inverse (limit.is_limit _)⟩

/-- The canonical injection `multiequalizer I ⟶ ∏ I.left`. -/
def ι_pi : multiequalizer I ⟶ ∏ I.left :=
  (iso_equalizer I).hom ≫ equalizer.ι I.fst_pi_map I.snd_pi_map

@[simp, reassoc]
lemma ι_pi_π (a) : ι_pi I ≫ pi.π I.left a = ι I a :=
by { rw [ι_pi, category.assoc, ← iso.eq_inv_comp, iso_equalizer], simpa }

instance : mono (ι_pi I) := @@mono_comp _ _ _ _ equalizer.ι_mono

end multiequalizer

namespace multicoequalizer

variables (I : multispan_index C) [has_multicoequalizer I]

/-- The canonical map from the multiequalizer to the objects on the left. -/
abbreviation π (b : I.R) : I.right b ⟶ multicoequalizer I :=
colimit.ι I.multispan (walking_multispan.right _)

/-- The multicofork associated to the multicoequalizer. -/
abbreviation multicofork : multicofork I :=
colimit.cocone _

@[simp]
lemma multicofork_π (b) :
  (multicoequalizer.multicofork I).π b = multicoequalizer.π I b := rfl

@[simp]
lemma multicofork_ι_app_right (b) :
  (multicoequalizer.multicofork I).ι.app (walking_multispan.right b) =
  multicoequalizer.π I b := rfl

@[reassoc]
lemma condition (a) :
  I.fst a ≫ multicoequalizer.π I (I.fst_from a) =
  I.snd a ≫ multicoequalizer.π I (I.snd_from a) :=
multicofork.condition _ _

/-- Construct a morphism from the multicoequalizer from its universal property. -/
abbreviation desc (W : C) (k : Π b, I.right b ⟶ W)
  (h : ∀ a, I.fst a ≫  k (I.fst_from a) = I.snd a ≫ k (I.snd_from a)) :
  multicoequalizer I ⟶ W :=
colimit.desc _ (multicofork.of_π I _ k h)

@[simp, reassoc]
lemma π_desc (W : C) (k : Π b, I.right b ⟶ W)
  (h : ∀ a, I.fst a ≫  k (I.fst_from a) = I.snd a ≫ k (I.snd_from a)) (b) :
  multicoequalizer.π I b ≫ multicoequalizer.desc I _ k h = k _ :=
colimit.ι_desc _ _

@[ext]
lemma hom_ext {W : C} (i j : multicoequalizer I ⟶ W)
  (h : ∀ b, multicoequalizer.π I b ≫ i = multicoequalizer.π I b ≫ j) :
  i = j :=
colimit.hom_ext
begin
  rintro (a|b),
  { simp_rw [← colimit.w I.multispan (walking_multispan.hom.fst a),
    category.assoc, h] },
  { apply h },
end

variables [has_coproduct I.left] [has_coproduct I.right]
variables [has_coequalizer I.fst_sigma_map I.snd_sigma_map]

/-- The multicoequalizer is isomorphic to the coequalizer of `∐ I.left ⇉ ∐ I.right`. -/
def iso_coequalizer : multicoequalizer I ≅ coequalizer I.fst_sigma_map I.snd_sigma_map :=
colimit.iso_colimit_cocone ⟨_, is_colimit.of_preserves_cocone_initial
  I.multicofork_equiv_sigma_cofork.inverse (colimit.is_colimit _)⟩

/-- The canonical projection `∐ I.right ⟶ multicoequalizer I`. -/
def sigma_π : ∐ I.right ⟶ multicoequalizer I :=
  coequalizer.π I.fst_sigma_map I.snd_sigma_map ≫ (iso_coequalizer I).inv

@[simp, reassoc]
lemma ι_sigma_π (b) : sigma.ι I.right b ≫ sigma_π I = π I b :=
by { rw [sigma_π, ← category.assoc, iso.comp_inv_eq, iso_coequalizer], simpa }

instance : epi (sigma_π I) := @@epi_comp _ _ coequalizer.π_epi _ _

end multicoequalizer

end category_theory.limits


/-
Copyright (c) 2019 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon

The writer monad transformer for passing immutable state.

! This file was ported from Lean 3 source module control.monad.writer
! leanprover-community/mathlib commit 9407b03373c8cd201df99d6bc5514fc2db44054f
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Group.Defs
import Mathbin.Logic.Equiv.Defs

universe u v w u₀ u₁ v₀ v₁

structure WriterT (ω : Type u) (m : Type u → Type v) (α : Type u) : Type max u v where
  run : m (α × ω)
#align writer_t WriterTₓ

#print Writer /-
@[reducible]
def Writer (ω : Type u) :=
  WriterT ω id
#align writer Writer
-/

attribute [pp_using_anonymous_constructor] WriterT

namespace WriterT

section

variable {ω : Type u}

variable {m : Type u → Type v}

variable [Monad m]

variable {α β : Type u}

open Function

@[ext]
protected theorem ext (x x' : WriterT ω m α) (h : x.run = x'.run) : x = x' := by
  cases x <;> cases x' <;> congr <;> apply h
#align writer_t.ext WriterTₓ.ext

@[inline]
protected def tell (w : ω) : WriterT ω m PUnit :=
  ⟨pure (PUnit.unit, w)⟩
#align writer_t.tell WriterTₓ.tell

@[inline]
protected def listen : WriterT ω m α → WriterT ω m (α × ω)
  | ⟨cmd⟩ => ⟨(fun x : α × ω => ((x.1, x.2), x.2)) <$> cmd⟩
#align writer_t.listen WriterTₓ.listen

@[inline]
protected def pass : WriterT ω m (α × (ω → ω)) → WriterT ω m α
  | ⟨cmd⟩ => ⟨uncurry (uncurry fun x (f : ω → ω) w => (x, f w)) <$> cmd⟩
#align writer_t.pass WriterTₓ.pass

@[inline]
protected def pure [One ω] (a : α) : WriterT ω m α :=
  ⟨pure (a, 1)⟩
#align writer_t.pure WriterTₓ.pure

@[inline]
protected def bind [Mul ω] (x : WriterT ω m α) (f : α → WriterT ω m β) : WriterT ω m β :=
  ⟨do
    let x ← x.run
    let x' ← (f x.1).run
    pure (x'.1, x.2 * x'.2)⟩
#align writer_t.bind WriterTₓ.bind

instance [One ω] [Mul ω] : Monad (WriterT ω m)
    where
  pure α := WriterT.pure
  bind α β := WriterT.bind

instance [Monoid ω] [LawfulMonad m] : LawfulMonad (WriterT ω m)
    where
  id_map := by
    intros
    cases x
    simp [(· <$> ·), WriterT.bind, WriterT.pure]
  pure_bind := by
    intros
    simp [Pure.pure, WriterT.pure, (· >>= ·), WriterT.bind]
    ext <;> rfl
  bind_assoc := by
    intros
    simp [(· >>= ·), WriterT.bind, mul_assoc, functor_norm]

@[inline]
protected def lift [One ω] (a : m α) : WriterT ω m α :=
  ⟨flip Prod.mk 1 <$> a⟩
#align writer_t.lift WriterTₓ.lift

instance (m) [Monad m] [One ω] : HasMonadLift m (WriterT ω m) :=
  ⟨fun α => WriterT.lift⟩

@[inline]
protected def monadMap {m m'} [Monad m] [Monad m'] {α} (f : ∀ {α}, m α → m' α) :
    WriterT ω m α → WriterT ω m' α := fun x => ⟨f x.run⟩
#align writer_t.monad_map WriterTₓ.monadMap

instance (m m') [Monad m] [Monad m'] : MonadFunctor m m' (WriterT ω m) (WriterT ω m') :=
  ⟨@WriterT.monadMap ω m m' _ _⟩

@[inline]
protected def adapt {ω' : Type u} {α : Type u} (f : ω → ω') : WriterT ω m α → WriterT ω' m α :=
  fun x => ⟨Prod.map id f <$> x.run⟩
#align writer_t.adapt WriterTₓ.adapt

instance (ε) [One ω] [Monad m] [MonadExcept ε m] : MonadExcept ε (WriterT ω m)
    where
  throw α := WriterT.lift ∘ throw
  catch α x c := ⟨catch x.run fun e => (c e).run⟩

end

end WriterT

#print MonadWriter /-
/-- An implementation of [MonadReader](
https://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Reader-Class.html#t:MonadReader).
It does not contain `local` because this function cannot be lifted using `monad_lift`.
Instead, the `monad_reader_adapter` class provides the more general `adapt_reader` function.

Note: This class can be seen as a simplification of the more "principled" definition
```
class monad_reader (ρ : out_param (Type u)) (n : Type u → Type u) :=
(lift {α : Type u} : (∀ {m : Type u → Type u} [monad m], reader_t ρ m α) → n α)
```
-/
class MonadWriter (ω : outParam (Type u)) (m : Type u → Type v) where
  tell (w : ω) : m PUnit
  listen {α} : m α → m (α × ω)
  pass {α : Type u} : m (α × (ω → ω)) → m α
#align monad_writer MonadWriter
-/

export MonadWriter ()

instance {ω : Type u} {m : Type u → Type v} [Monad m] : MonadWriter ω (WriterT ω m)
    where
  tell := WriterT.tell
  listen α := WriterT.listen
  pass α := WriterT.pass

instance {ω ρ : Type u} {m : Type u → Type v} [Monad m] [MonadWriter ω m] :
    MonadWriter ω (ReaderT ρ m)
    where
  tell x := monadLift (tell x : m PUnit)
  listen := fun α ⟨cmd⟩ => ⟨fun r => listen (cmd r)⟩
  pass := fun α ⟨cmd⟩ => ⟨fun r => pass (cmd r)⟩

def swapRight {α β γ} : (α × β) × γ → (α × γ) × β
  | ⟨⟨x, y⟩, z⟩ => ((x, z), y)
#align swap_right swapRight

instance {ω σ : Type u} {m : Type u → Type v} [Monad m] [MonadWriter ω m] :
    MonadWriter ω (StateT σ m)
    where
  tell x := monadLift (tell x : m PUnit)
  listen := fun α ⟨cmd⟩ => ⟨fun r => swapRight <$> listen (cmd r)⟩
  pass := fun α ⟨cmd⟩ => ⟨fun r => pass (swapRight <$> cmd r)⟩

open Function

def ExceptT.passAux {ε α ω} : Except ε (α × (ω → ω)) → Except ε α × (ω → ω)
  | Except.error a => (Except.error a, id)
  | Except.ok (x, y) => (Except.ok x, y)
#align except_t.pass_aux ExceptTₓ.passAux

instance {ω ε : Type u} {m : Type u → Type v} [Monad m] [MonadWriter ω m] :
    MonadWriter ω (ExceptT ε m)
    where
  tell x := monadLift (tell x : m PUnit)
  listen := fun α ⟨cmd⟩ => ⟨(uncurry fun x y => flip Prod.mk y <$> x) <$> listen cmd⟩
  pass := fun α ⟨cmd⟩ => ⟨pass (ExceptT.passAux <$> cmd)⟩

def OptionT.passAux {α ω} : Option (α × (ω → ω)) → Option α × (ω → ω)
  | none => (none, id)
  | some (x, y) => (some x, y)
#align option_t.pass_aux OptionTₓ.passAux

instance {ω : Type u} {m : Type u → Type v} [Monad m] [MonadWriter ω m] : MonadWriter ω (OptionT m)
    where
  tell x := monadLift (tell x : m PUnit)
  listen := fun α ⟨cmd⟩ => ⟨(uncurry fun x y => flip Prod.mk y <$> x) <$> listen cmd⟩
  pass := fun α ⟨cmd⟩ => ⟨pass (OptionT.passAux <$> cmd)⟩

/-- Adapt a monad stack, changing the type of its top-most environment.

This class is comparable to
[Control.Lens.Magnify](https://hackage.haskell.org/package/lens-4.15.4/docs/Control-Lens-Zoom.html#t:Magnify),
but does not use lenses (why would it), and is derived automatically for any transformer
implementing `monad_functor`.

Note: This class can be seen as a simplification of the more "principled" definition
```
class monad_reader_functor (ρ ρ' : out_param (Type u)) (n n' : Type u → Type u) :=
(map {α : Type u} :
  (∀ {m : Type u → Type u} [monad m], reader_t ρ m α → reader_t ρ' m α) → n α → n' α)
```
-/
class MonadWriterAdapter (ω ω' : outParam (Type u)) (m m' : Type u → Type v) where
  adaptWriter {α : Type u} : (ω → ω') → m α → m' α
#align monad_writer_adapter MonadWriterAdapter

export MonadWriterAdapter (adaptWriter)

section

variable {ω ω' : Type u} {m m' : Type u → Type v}

/-- Transitivity.

This instance generates the type-class problem with a metavariable argument (which is why this
is marked as `[nolint dangerous_instance]`).
Currently that is not a problem, as there are almost no instances of `monad_functor` or
`monad_writer_adapter`.

see Note [lower instance priority] -/
@[nolint dangerous_instance]
instance (priority := 100) monadWriterAdapterTrans {n n' : Type u → Type v}
    [MonadWriterAdapter ω ω' m m'] [MonadFunctor m m' n n'] : MonadWriterAdapter ω ω' n n' :=
  ⟨fun α f => monadMap fun α => (adaptWriter f : m α → m' α)⟩
#align monad_writer_adapter_trans monadWriterAdapterTrans

instance [Monad m] : MonadWriterAdapter ω ω' (WriterT ω m) (WriterT ω' m) :=
  ⟨fun α => WriterT.adapt⟩

end

instance (ω : Type u) (m out) [MonadRun out m] : MonadRun (fun α => out (α × ω)) (WriterT ω m) :=
  ⟨fun α x => run <| x.run⟩

/-- reduce the equivalence between two writer monads to the equivalence between
their underlying monad -/
def WriterT.equiv {m₁ : Type u₀ → Type v₀} {m₂ : Type u₁ → Type v₁} {α₁ ω₁ : Type u₀}
    {α₂ ω₂ : Type u₁} (F : m₁ (α₁ × ω₁) ≃ m₂ (α₂ × ω₂)) : WriterT ω₁ m₁ α₁ ≃ WriterT ω₂ m₂ α₂
    where
  toFun := fun ⟨f⟩ => ⟨F f⟩
  invFun := fun ⟨f⟩ => ⟨F.symm f⟩
  left_inv := fun ⟨f⟩ => congr_arg WriterT.mk <| F.left_inv _
  right_inv := fun ⟨f⟩ => congr_arg WriterT.mk <| F.right_inv _
#align writer_t.equiv WriterTₓ.equiv


import tactic.transport
import order.bounded_order
import algebra.lie.basic

-- We verify that `transport` can move a `semiring` across an equivalence.
-- Note that we've never even mentioned the idea of addition or multiplication to `transport`.
def semiring.map {α : Type} [semiring α] {β : Type} (e : α ≃ β) : semiring β :=
begin
  transport using e,
  -- TODO
  { simp *, refl }, -- nat_cast_zero
  { intros, simp *, show _ = e _, simp, refl, }, -- nat_cast_succ
end

-- Indeed, it can equally well move a `semilattice_sup`.
def sup.map {α : Type} [semilattice_sup α] {β : Type} (e : α ≃ β) : semilattice_sup β :=
by transport using e

-- Verify definitional equality of the new structure data.
example {α : Type} [semilattice_sup α] {β : Type} (e : α ≃ β) (x y : β) :
begin
  haveI := sup.map e,
  exact (x ≤ y) = (e.symm x ≤ e.symm y),
end :=
rfl

-- Below we verify in more detail that the transported structure for `semiring`
-- is definitionally what you would hope for.

inductive mynat : Type
| zero : mynat
| succ : mynat → mynat

def mynat_equiv : ℕ ≃ mynat :=
{ to_fun := λ n, nat.rec_on n mynat.zero (λ n, mynat.succ),
  inv_fun := λ n, mynat.rec_on n nat.zero (λ n, nat.succ),
  left_inv := λ n, begin induction n, refl, exact congr_arg nat.succ n_ih, end,
  right_inv := λ n, begin induction n, refl, exact congr_arg mynat.succ n_ih, end }

@[simp] lemma mynat_equiv_apply_zero : mynat_equiv 0 = mynat.zero := rfl
@[simp] lemma mynat_equiv_apply_succ (n : ℕ) :
  mynat_equiv (n + 1) = mynat.succ (mynat_equiv n) := rfl
@[simp] lemma mynat_equiv_symm_apply_zero : mynat_equiv.symm mynat.zero = 0:= rfl
@[simp] lemma mynat_equiv_symm_apply_succ (n : mynat) :
  mynat_equiv.symm (mynat.succ n) = (mynat_equiv.symm n) + 1 := rfl

instance semiring_mynat : semiring mynat :=
semiring.map mynat_equiv

lemma mynat_add_def (a b : mynat) : a + b = mynat_equiv (mynat_equiv.symm a + mynat_equiv.symm b) :=
rfl

-- Verify that we can do computations with the transported structure.
example :
  (mynat.succ (mynat.succ mynat.zero)) + (mynat.succ mynat.zero) =
    (mynat.succ (mynat.succ (mynat.succ mynat.zero))) :=
rfl

lemma mynat_zero_def : (0 : mynat) = mynat_equiv 0 :=
rfl

lemma mynat_one_def : (1 : mynat) = mynat_equiv 1 :=
rfl

lemma mynat_mul_def (a b : mynat) : a * b = mynat_equiv (mynat_equiv.symm a * mynat_equiv.symm b) :=
rfl

example : (3 : mynat) + (7 : mynat) = (10 : mynat) :=
rfl

example : (2 : mynat) * (2 : mynat) = (4 : mynat) :=
rfl

example : (3 : mynat) + (7 : mynat) * (2 : mynat) = (17 : mynat) :=
rfl

example : (2 : ℕ) • (3 : mynat) = (6 : mynat) :=
rfl

example : (3 : mynat) ^ 2 = (9 : mynat) :=
rfl


import Hw9
import Sets.Basic
import Lean.Elab.Print
import Lean.Elab.Command

open Set

variable (α β : Type)
variable (X Y Z : Set α)
variable (W : Set β)

theorem desiredType1 : ∅ ∈ 𝒫  X := sorry

theorem desiredType2 (U : β → Set α) : ∀ b, U b ⊆ BigUnion U := sorry

theorem desiredType3 (h : X ⊆ Y) : (X ×ˢ W) ⊆ (Y ×ˢ W) := sorry

theorem desiredType4 (h : Y ∩ Z = ∅) : Yᶜ ∪ Zᶜ = Univ := sorry

theorem desiredType5 : (X \ Y) ∪ (Y \ X) = (X ∪ Y) \ (X ∩ Y) := sorry

open Lean
open Lean.Meta
open Lean.Elab.Command

def n : String := "3"

def problem : String := "problem"++n

def desired : String := "desiredType"++n

def collectAxiomsOf (constName : Name) : MetaM (List String) := do
  let env ← getEnv
  let (_, s) := ((CollectAxioms.collect constName).run env).run {}
  let a := s.axioms.toList.map toString
  return a

#eval isDefEq (Expr.const desired []) (Expr.const problem [])
#eval collectAxiomsOf problem