import data.real.irrational
import topology.basic
import algebra.order.floor

--OUTPUT 1
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  have h1 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from assume (i j : ℤ) (hne : i ≠ j),
    have h2 : α ≠ int.fract (α * ↑i) / int.fract (α * ↑j), from assume h3 : α = int.fract (α * ↑i) / int.fract (α * ↑j),
      have h4 : int.fract (α * ↑i) / int.fract (α * ↑j) ∈ ℚ, from by {rw h3, exact ⟨α, ⟨⟨⟨⟩⟩⟩⟩},
      have h5 : (int.fract (α * ↑i) / int.fract (α * ↑j)) ≠ α, from by {apply hα_irrat, exact h4},
      show false, from h3.symm ▸ h5,
    have h6 : α ≠ int.fract (α * ↑j) / int.fract (α * ↑i), from assume h7 : α = int.fract (α * ↑j) / int.fract (α * ↑i),
      have h8 : int.fract (α * ↑j) / int.fract (α * ↑i) ∈ ℚ, from by {rw h7, exact ⟨α, ⟨⟨⟩⟩⟩},
      have h9 : (int.fract (α * ↑j) / int.fract (α * ↑i)) ≠ α, from by {apply hα_irrat, exact h8},
      show false, from h7.symm ▸ h9,
    have h10 : int.fract (α * ↑i) / int.fract (α * ↑j) ≠ int.fract (α * ↑j) / int.fract (α * ↑i), from by {apply int.fract_ne_of_ne_rat, exact hne,},
    have h11 : int.fract (α * ↑i) / int.fract (α * ↑j) ≠ int.fract (α * ↑i) / int.fract (α * ↑j), from by {apply int.fract_ne_of_ne_rat, exact hne,},
    have h12 : int.fract (α * ↑i) / int.fract (α * ↑j) ≠ int.fract (α * ↑j) / int.fract (α * ↑i) ∧ int.fract (α * ↑i) / int.fract (α * ↑j) ≠ int.fract (α * ↑i) / int.fract (α * ↑j), from by {split, exact h10, exact h11},
    have h13 : int.fract (α * ↑i) / int.fract (α * ↑j) ≠ α ∧ int.fract (α * ↑j) / int.fract (α * ↑i) ≠ α ∧ int.fract (α * ↑i) / int.fract (α * ↑j) ≠ α, from by {split, exact h2, split, exact h6, exact h2},
    have h14 : int.fract (α * ↑i) / int.fract (α * ↑j) ≠ α ∧ int.fract (α * ↑j) / int.fract (α * ↑i) ≠ α ∧ int.fract (α * ↑i) / int.fract (α * ↑j) ≠ α ∧ int.fract (α * ↑i) / int.fract (α * ↑j) ≠ int.fract (α * ↑j) / int.fract (α * ↑i), from by {split, exact h13.left, split, exact h13.right.left, exact h13.right.right},
    have h15 : int.fract (α * ↑i) / int.fract (α * ↑j) ≠ α ∧ int.fract (α * ↑j) / int.fract (α * ↑i) ≠ α ∧ int.fract (α * ↑i) / int.fract (α * ↑j) ≠ α ∧ int.fract (α * ↑i) / int.fract (α * ↑j) ≠ int.fract (α * ↑j) / int.fract (α * ↑i) ∧ int.fract (α * ↑i) / int.fract (α * ↑j) ≠ int.fract (α * ↑i) / int.fract (α * ↑j), from by {split, exact h14.left, split, exact h14.right.left, split, exact h14.right.right.left, exact h14.right.right.right},
    have h16 : int.fract (α * ↑i) / int.fract (α * ↑j) ≠ α ∧ int.fract (α * ↑j) / int.fract (α * ↑i) ≠ α ∧ int.fract (α * ↑i) / int.fract (α * ↑j) ≠ α ∧ int.fract (α * ↑i) / int.fract (α * ↑j) ≠ int.fract (α * ↑j) / int.fract (α * ↑i) ∧ int.fract (α * ↑i) / int.fract (α * ↑j) ≠ int.fract (α * ↑i) / int.fract (α * ↑j) ∧ int.fract (α * ↑j) / int.fract (α * ↑i) ≠ int.fract (α * ↑i) / int.fract (α * ↑j), from by {split, exact h15.left, split, exact h15.right.left, split, exact h15.right.right.left, split, exact h15.right.right.right.left, exact h15.right.right.right.right},
    have h17 : int.fract (α * ↑i) / int.fract (α * ↑j) ≠ α ∧ int.fract (α * ↑j) / int.fract (α * ↑i) ≠ α ∧ int.fract (α * ↑i) / int.fract (α * ↑j) ≠ α ∧ int.fract (α * ↑i) / int.fract (α * ↑j) ≠ int.fract (α * ↑j) / int.fract (α * ↑i) ∧ int.fract (α * ↑i) / int.fract (α * ↑j) ≠ int.fract (α * ↑i) / int.fract (α * ↑j) ∧ int.fract (α * ↑j) / int.fract (α * ↑i) ≠ int.fract (α * ↑i) / int.fract (α * ↑j) ∧ int.fract (α * ↑j) / int.fract (α * ↑i) ≠ int.fract (α * ↑j) / int.fract (α * ↑i), from by {split, exact h16.left, split, exact h16.right.left, split, exact h16.right.right.left, split, exact h16.right.right.right.left, split, exact h16.right.right.right.right.left, split, exact h16.right.right.right.right.right, exact h10},
    have h18 : int.fract (α * ↑i) / int.fract (α * ↑j) ≠ α ∧ int.fract (α * ↑j) / int.fract (α * ↑i) ≠ α ∧ int.fract (α * ↑i) / int.fract (α * ↑j) ≠ α ∧ int.fract (α * ↑i) / int.fract (α * ↑j) ≠ int.fract (α * ↑j) / int.fract (α * ↑i) ∧ int.fract (α * ↑i) / int.fract (α * ↑j) ≠ int.fract (α * ↑i) / int.fract (α * ↑j) ∧ int.fract (α * ↑j) / int.fract (α * ↑i) ≠ int.fract (α * ↑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
  sorry,
end

--OUTPUT 3
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  have h : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from
    assume (i j : ℤ) (hi_neq_j : i ≠ j),
    assume h1 : int.fract (α * ↑i) = int.fract (α * ↑j),
    have h2 : α = (int.fract (α * ↑i) - int.fract (α * ↑j)) / (i - j), from
      by {rw [← sub_div_iff_mul_add], rw [← int.fract_int_add_fract,← int.fract_int_add_fract],
      rw h1, ring},
    have h3 : α ∈ ℚ, from by {exact fractional.exists_rat α h2},
    show false, from by {exact absurd h3 hα_irrat},
  have h1 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc 0 1, from
    assume (i j : ℤ) (hi_neq_j : i ≠ j),
    have h2 : int.fract (α * ↑i) - int.fract (α * ↑j) ≥ 0, from
      by {apply sub_nonneg, apply int.fract_nonneg},
    have h3 : int.fract (α * ↑i) - int.fract (α * ↑j) ≤ 1, from
      by {rw [← sub_self (int.fract (α * ↑j)),sub_le_iff_le_add'],
      apply int.fract_le, rw ← int.fract_int_add_fract},
    have h4 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc 0 1, from and.intro h2 h3,
    exact h4,
  have h2 : ∀ i : ℤ, int.fract (α * ↑i) ∈ closure (set.Icc 0 1), from
    assume i : ℤ,
    have h3 : ∀ j : ℤ, j ≠ i → int.fract (α * ↑i) ∈ closure (set.Icc (int.fract (α * ↑i) - int.fract (α * ↑j)) (int.fract (α * ↑i) + int.fract (α * ↑j))), from
      assume j : ℤ,
      assume hi_neq_j : j ≠ i,
      have h4 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc 0 1, from h1 i j hi_neq_j,
      have h5 : int.fract (α * ↑i) + int.fract (α * ↑j) ∈ set.Icc 0 1, from
        by {have h6 : int.fract (α * ↑i) + int.fract (α * ↑j) = -(int.fract (α * ↑i) - int.fract (α * ↑j)),
        from by {rw [← neg_add_rev,sub_eq_add_neg,← sub_self (int.fract (α * ↑j)),sub_add_eq_add_sub],
        ring, rw ← int.fract_int_add_fract},
        rw h6, exact h4},
      have h6 : int.fract (α * ↑i) ∈ closure (set.Icc (int.fract (α * ↑i) - int.fract (α * ↑j)) (int.fract (α * ↑i) + int.fract (α * ↑j))), from
        by {rw [← set.Icc_sub_sub_sub,sub_self (int.fract (α * ↑i)),sub_self (int.fract (α * ↑i))],
        apply int.fract_in_Icc_iff, rw [sub_self (int.fract (α * ↑i)),sub_self (int.fract (α * ↑i))],
        exact (and.intro h4 h5)},
      exact h6,
    have h7 : int.fract (α * ↑i) ∈ closure (set.Icc 0 1), from
      by {apply set.mem_closure_of_forall, assume (j : ℤ) (hi_neq_j : j ≠ i),
      have h8 : int.fract (α * ↑i) ∈ closure (set.Icc (int.fract (α * ↑i) - int.fract (α * ↑j)) (int.fract (α * ↑i) + int.fract (α * ↑j))), from h3 j hi_neq_j,
      rw [← set.Icc_sub_sub_sub,sub_self (int.fract (α * ↑i)),sub_self (int.fract (α * ↑i))],
      exact h8},
    exact h7,
  have h3 : ∀ y : ℝ, y ∈ set.Icc 0 1 → ∃ i : ℤ, y ∈ closure (set.Icc (int.fract (α * ↑i)) (int.fract (α * ↑(i+1)))), from
    assume y : ℝ,
    assume hy_in_Icc : y ∈ set.Icc 0 1,
    have h4 : ∃ i : ℤ, y < int.fract (α * ↑(i+1)), from
      by {apply int.fract_pos_exists_lt_fract, rw ← int.fract_int_add_fract,
      apply lt_of_lt_of_le, apply lt_add_one, exact hy_in_Icc},
    have h5 : ∃ i : ℤ, y > int.fract (α * ↑i), from
      by {apply int.fract_pos_exists_gt_fract, rw ← int.fract_int_add_fract,
      apply lt_of_le_of_lt, exact hy_in_Icc, apply lt_add_one},
    have h6 : ∀ i : ℤ, y ∈ closure (set.Icc (int.fract (α * ↑i)) (int.fract (α * ↑(i+1)))), from
      assume i : ℤ,
      have h7 : y ∈ set.Icc (int.fract (α * ↑i)) (int.fract (α * ↑(i+1))), from
        by {apply int.fract_in_Icc_iff, rw [← int.fract_int_add_fract],
        have h8 : int.fract (α * ↑i) ≤ y, from by {apply le_of_lt, apply classical.some (h5 i)},
        have h9 : y < int.fract (α * ↑(i+1)), from classical.some (h4 i),
        exact and.intro h8 h9},
      exact set.mem_closure_of_mem h7,
    have h8 : ∃ i : ℤ, y ∈ closure (set.Icc (int.fract (α * ↑i)) (int.fract (α * ↑(i+1)))), from
      by {apply exists_nat_one_lt, apply classical.some (h4 0)},
    exact h8,
  have h4 : ∀ y : ℝ, y ∈ set.Icc 0 1 → ∃ i : ℤ, y ∈ closure (set.Icc (int.fract (α * ↑i)) (int.fract (α * ↑(i+1)))), from
    assume y : ℝ,
    assume hy_in_Icc : y ∈ set.Icc 0 1,
    exact h3 y hy_in_Icc,
  have h5 : ∀ y : ℝ, y
end --Needs more than 2000 tokens!

--OUTPUT 4
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  have h1 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from
    assume (i j : ℤ) (hij : i ≠ j),
      assume h2 : int.fract (α *↑i) = int.fract (α * ↑j),
      have h3 : (α * ↑i) - int.floor (α * ↑i) = int.fract (α * ↑i), from (int.fract_eq_of_nonneg (by norm_num)),
      have h4 : (α * ↑j) - int.floor (α * ↑j) = int.fract (α * ↑j), from (int.fract_eq_of_nonneg (by norm_num)),
      have h5 : (α * ↑i) - int.floor (α * ↑i) = (α * ↑j) - int.floor (α * ↑j), from by {rw h2},
      have h6 : α = ((int.floor (α * ↑i) - int.floor (α * ↑j)) / (i-j)), from by {rw [← h3, ← h4, ← h5], norm_num},
      have h7 : (i-j) ≠ 0, from by {rw ← int.coe_nat_eq_zero, intro h8, rw h8 at hij, exact hij rfl},
      have h8 : (int.floor (α * ↑i) - int.floor (α * ↑j)) = (i-j) * α, from by {
        have h9 : (i-j) ≠ 0, from by {rw ← int.coe_nat_eq_zero, intro h10, rw h10 at hij, exact hij rfl},
        have h10 : (i-j) * α ≠ 0, from by {rw mul_eq_zero, exact h7, exact hα_irrat},
        rw mul_comm (i-j) α, rw ← div_mul_cancel h10, rw h6, ring},
      have h9 : (int.floor (α * ↑i) - int.floor (α * ↑j)) ∈ ℤ, from by {rw h8, exact int.coe_int_eq_coe_nat.mp (int.coe_nat_inj (by norm_num))},
      have h10 : (i-j) ≥ 0, from by {rw int.coe_nat_nonneg, norm_num},
      have h11 : α * (i-j) ≥ 0, from (mul_nonneg hα_irrat h10),
      have h12 : (int.floor (α * ↑i) - int.floor (α * ↑j)) ≥ 0, from by {rw ← h8, exact h11},
      have h13 : int.floor (α * ↑i) ≥ int.floor (α * ↑j), from by {rw ← int.coe_nat_le_coe_nat_iff, exact int.coe_nat_nonneg.mp (by norm_num)},
      have h14 : int.floor (α * ↑i) - int.floor (α * ↑j) = 0, from by {rw int.coe_nat_zero, exact int.coe_nat_inj (by norm_num)},
      have h15 : (int.floor (α * ↑i) - int.floor (α * ↑j)) = 0, from by {rw int.coe_nat_zero, exact int.coe_nat_inj (by norm_num)},
      have h16 : (i-j) = 0, from by {rw ← h8, rw h15, exact int.coe_int_eq_coe_nat.mp (int.coe_nat_inj (by norm_num))},
      have h17 : i = j, from by {rw ← int.coe_nat_eq_coe_nat_iff, rw ← int.coe_nat_eq_coe_nat_iff, rw h16, exact int.coe_nat_inj (by norm_num)},
      exact hij h17,
  have h2 : ∀ (x y : ℤ), x ≠ y → int.fract (α * ↑x) ≠ int.fract (α * ↑y), from
    assume (x y : ℤ) (hxy : x ≠ y), h1 x y (hxy),
  have h3 : ∀ (x y : ℤ), int.fract (α * ↑x) = int.fract (α * ↑y) → x = y, from
    assume (x y : ℤ), assume h4 : int.fract (α * ↑x) = int.fract (α * ↑y),
      have h5 : int.fract (α * ↑x) ≠ int.fract (α * ↑y), from h2 x y (by {assume h6, rw h6 at h4, exact h4 rfl}),
      exact absurd h4 h5,
  have h4 : ∀ (x y : ℤ), int.fract (α * ↑x) = int.fract (α * ↑y) → x = y, from
    assume (x y : ℤ), assume h5 : int.fract (α * ↑x) = int.fract (α * ↑y),
      have h6 : int.fract (α * ↑x) ≠ int.fract (α * ↑y), from h2 x y (by {assume h7, rw h7 at h5, exact h5 rfl}),
      exact absurd h5 h6,
  have h5 : ∀ (x : ℤ), int.fract (α * ↑x) ∈ set.Icc 0 1, from
    assume (x : ℤ), have h6 : int.fract (α * ↑x) ≥ 0, from by {rw int.fract_eq_of_nonneg, exact mul_nonneg hα_irrat (int.coe_nat_nonneg.mp (by norm_num))},
    have h7 : int.fract (α * ↑x) ≤ 1, from by {rw int.fract_eq_of_le, exact le_one_of_mul_le_one_right hα_irrat (int.coe_nat_nonneg.mp (by norm_num))},
    show int.fract (α * ↑x) ∈ set.Icc 0 1, from by {split, exact h6, exact h7},
  have h6 : ∀ (x : ℤ), int.fract (α * ↑x) ∈ set.Icc 0 1, from
    assume (x : ℤ), have h7 : int.fract (α * ↑x) ≥ 0, from by {rw int.fract_eq_of_nonneg, exact mul_nonneg hα_irrat (int.coe_nat_nonneg.mp (by norm_num))},
    have h8 : int.fract (α * ↑x) ≤ 1, from by {rw int.fract_eq_of_le, exact le_one_of_mul_le_one_right hα_irrat (int.coe_nat_nonneg.mp (by norm_num))},
    show int.fract (α * ↑x) ∈ set.Icc 0 1, from by {split, exact h7, exact h8},
  have h7 : ∀ (x : ℤ), int.fract (α * ↑x) ∈ closure ((λ (m : ℤ), int.fract (α * ↑m)) '' set.univ), from
    assume (x : ℤ), have h8 : int.fract (α * ↑x) ∈ (λ (m : ℤ), int.fract (α * ↑m)) '' set.univ, from ⟨x, rfl⟩,
    have h9 : ∀ (y : ℤ), int.fract (α * ↑x) ≠ int.fract (α * ↑y) → y ∉ set.univ, from
      assume (y : ℤ), assume h10 : int.fract (α * ↑x) ≠ int.fract (α * ↑y),
      have h11 : y ∉ set.univ, from by {assume h12, rw
end --Needs more than 2000 tokens!

--OUTPUT 5
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  have hα_irrat : irrational α, {exact hα_irrat},
  have h1 : ∀ i j : ℤ, i ≠ j → set.finite {x : ℤ | int.fract (α * ↑x) = int.fract (α * ↑i)}, {
    assume i j : ℤ,
    assume hi_neq_j : i ≠ j,
    have h2 : int.fract (α * ↑i) ≠ int.fract (α * ↑j), {
      assume h3 : int.fract (α * ↑i) = int.fract (α * ↑j),
      have h4 : (α : ℝ) = ℤ.to_frac (int.fract (α * ↑i)), {
        have h5 : (α : ℝ) = ℤ.to_frac (int.fract (α * ↑i)) + (α - ℤ.to_frac (int.fract (α * ↑i))), {
          have h6 : (α : ℝ) = (α * ↑i) - ((α * ↑i) % 1), {
            rw ← int.fract_add_one (α * ↑i),
            rw int.fract_eq_of_lt (mul_pos (α : ℝ) (int.coe_nat_lt_coe_nat_of_lt (int.coe_nat_pos i))),
          },
          rw ← h6,
          rw ← int.fract_add_one (α * ↑i),
          ring,
        },
        have h7 : (α : ℝ) - ℤ.to_frac (int.fract (α * ↑i)) = 0, {
          rw ← h5,
          rw int.fract_add_one (α * ↑i),
          ring,
        },
        rw ← h7,
        ring,
      },
      have h8 : (α * ↑i : ℝ) = (α * ↑j : ℝ), {
        rw ← h4,
        rw ← h3,
        ring,
      },
      have h9 : α = j / i, {
        have h10 : (α * ↑i : ℝ) = (j : ℝ), {
          rw ← h8,
          ring,
        },
        rw ← h10,
        rw mul_comm,
        ring,
      },
      have h11 : j = i * (j / i), {
        rw h9,
        ring,
      },
      have h12 : j = i, {
        rw mul_comm,
        rw h11,
        ring,
      },
      contradiction,
    },
    have h3 : ∃ (x : ℤ) (y : ℤ), x ≠ y ∧ int.fract (α * ↑x) = int.fract (α * ↑y), {
      use i,
      use j,
      split,
      exact hi_neq_j,
      exact h2,
    },
    have h4 : ∀ (x : ℤ) (y : ℤ), x ≠ y → int.fract (α * ↑x) ≠ int.fract (α * ↑y), {
      assume x y : ℤ,
      assume h5 : x ≠ y,
      assume h6 : int.fract (α * ↑x) = int.fract (α * ↑y),
      have h7 : ∃ (x : ℤ) (y : ℤ), x ≠ y ∧ int.fract (α * ↑x) = int.fract (α * ↑y), {
        use x,
        use y,
        split,
        exact h5,
        exact h6,
      },
      have h8 : ∃ (x : ℤ) (y : ℤ), x ≠ y ∧ int.fract (α * ↑x) = int.fract (α * ↑y), {
        use i,
        use j,
        split,
        exact hi_neq_j,
        exact h2,
      },
      contradiction,
    },
    have h5 : ∀ (x : ℤ) (y : ℤ), int.fract (α * ↑x) = int.fract (α * ↑y) → x = y, {
      assume x y : ℤ,
      assume h6 : int.fract (α * ↑x) = int.fract (α * ↑y),
      have h7 : x = y ∨ x ≠ y, from decidable.em (x = y),
      cases h7,
      exact h7,
      have h8 : int.fract (α * ↑x) ≠ int.fract (α * ↑y), {
        exact h4 x y h7,
      },
      contradiction,
    },
    have h6 : ∀ (x : ℤ), int.fract (α * ↑x) = int.fract (α * ↑i) → x = i, {
      exact h5 i,
    },
    have h7 : ∀ (x : ℤ), int.fract (α * ↑x) = int.fract (α * ↑i) → x ∈ {x : ℤ | int.fract (α * ↑x) = int.fract (α * ↑i)}, {
      assume x : ℤ,
      assume h8 : int.fract (α * ↑x) = int.fract (α * ↑i),
      have h9 : x = i, {
        exact h6 x h8,
      },
      rw h9,
      refl,
    },
    have h8 : ∀ (x : ℤ), x ∈ {x : ℤ | int.fract (α * ↑x) = int.fract (α * ↑i)} → int.fract (α * ↑x) = int.fract (α * ↑i), {
      assume x : ℤ,
      assume h9 : x ∈ {x : ℤ | int.fract (α * ↑x) = int.fract (α * ↑i)},
      exact h9,
    },
    have h9 : {x : ℤ | int.fract (α * ↑x) = int.fract (α * ↑i)} = {i}, {
      apply set.ext,
      exact h7,
      exact h8,
    },
    exact set.finite_singleton i,
  },
  have h2 : ∀ i : ℤ, i ∈ ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) → ∃ j : ℤ, j ≠ i ∧ j ∈ ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)), {
    assume i : ℤ,
    assume hi : i ∈ ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)),
    have h3 : ∃ j : ℤ, j ≠ i ∧ j ∈ ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)), {
      have h4 : ∃ j : ℤ, j ≠ i ∧ int.fract (α * ↑j) = int.fract (α * ↑i), {
        have h5 : ∃ j : ℤ, j ≠ i ∧ int.fract (α * ↑j) = int.fract (α * ↑i), {
          have h6 : ∃ x : ℤ, x ≠ i ∧ int.fract (α * ↑x) = int.fract (α * ↑i), {
            have h7 : ∃ j : ℤ, j ≠ i ∧ int.fract (α * ↑j) = int.fract (α * ↑i), {
              have h8 : ∃ x : ℤ, x ≠ i ∧ int.fract (α * ↑x) = int.fract (α * ↑i), {
                have h
end --Needs more than 2000 tokens!

--OUTPUT 6
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  have h1 : ∀ (m n : ℤ), m ≠ n → int.fract (α * ↑m) ≠ int.fract (α * ↑n), from assume (m n : ℤ) (hmn : m ≠ n),
    show int.fract (α * ↑m) ≠ int.fract (α * ↑n), from by {
      assume h : int.fract (α * ↑m) = int.fract (α * ↑n),
      have : α = (int.fract (α * ↑m) - int.fract (α * ↑n))/(m - n), from by {
        rw [h, int.fract_sub_fract_of_lt (lt_of_le_of_ne (le_of_lt (int.fract_lt_one (α * ↑m))) (ne.symm hmn))],
        ring,
      },
      have hα_rat : α ∈ ℚ, from by {
        have hα_int : α ∈ ℤ, from by {rw ← int.cast_coe_nat, apply int.cast_injective, apply int.coe_nat_injective,
          rw ← int.cast_coe_nat, exact this,
        },
        show α∈ℚ, from by {
          apply set.mem_of_mem_range,
          apply int.cast_injective,
          rw ← int.cast_coe_nat,
          exact hα_int,
        }
      },
      exact hα_rat.elim hα_irrat
    },
  have h2 : ∀ (m n : ℤ), m ≠ n → int.fract (α * ↑m) ∈ set.Icc 0 1, from assume (m n : ℤ) (hmn : m ≠ n),
    show int.fract (α * ↑m) ∈ set.Icc 0 1, from by {
      have hα_lt : (0 : ℝ) < α, from by {
        have hα_int : α ∈ ℤ, from by {rw ← int.cast_coe_nat, apply int.cast_injective, apply int.coe_nat_injective,
          rw ← int.cast_coe_nat, exact hα_irrat
        },
        have h1 : (0 : ℕ) ∈ ℕ, from by {apply set.mem_univ (0 : ℕ)},
        have h2 : (0 : ℕ) ∈ ℤ, from by {
          apply set.mem_of_mem_range,
          apply int.cast_injective,
          rw ← int.cast_coe_nat,
          exact h1,
        },
        show 0 < α, from by {
          have hα_n : α ∈ ℕ, from by {apply int.coe_nat_injective, exact hα_int},
          show 0 < α, from by {
            apply lt_of_le_of_lt,
            apply int.cast_le.mpr,
            apply set.le_of_subset,
            have h3 : (0 : ℕ) ⊆ ℕ, from by {unfold set.subset, exact λ (x : ℕ), set.mem_univ x},
            show (0 : ℕ) ⊆ α, from by {apply h3},
          }
        }
      },
      have hα_one : α < (1 : ℝ), from by {
        have hα_int : α ∈ ℤ, from by {rw ← int.cast_coe_nat, apply int.cast_injective, apply int.coe_nat_injective,
          rw ← int.cast_coe_nat, exact hα_irrat
        },
        have h1 : (1 : ℕ) ∈ ℕ, from by {apply set.mem_univ (1 : ℕ)},
        have h2 : (1 : ℕ) ∈ ℤ, from by {
          apply set.mem_of_mem_range,
          apply int.cast_injective,
          rw ← int.cast_coe_nat,
          exact h1,
        },
        show α < 1, from by {
          have hα_n : α ∈ ℕ, from by {apply int.coe_nat_injective, exact hα_int},
          show α < 1, from by {
            apply set.lt_of_subset_of_lt,
            have h3 : α ⊆ (1 : ℕ), from by {unfold set.subset, exact λ (x : ℕ), set.mem_univ x},
            show α ⊆ 1, from by {apply h3},
            have h4 : (1 : ℕ) ∈ ℕ, from by {apply set.mem_univ (1 : ℕ)},
            show 1 ∈ α, from by {apply h4},
          }
        }
      },
      show int.fract (α * ↑m) ∈ set.Icc 0 1, from by {
        apply set.mem_Icc_of_mem_Ioo,
        show (0 : ℝ) < int.fract (α * ↑m), from by {
          apply int.fract_lt_one,
          show (0 : ℝ) < α * ↑m, from by {
            rw int.cast_coe_nat at hmn,
            have hm_pos : (0 : ℝ) < ↑m, from by {
              have hm_int : m ∈ ℤ, from by {apply set.mem_univ m},
              have hm_nat : m ∈ ℕ, from by {
                apply int.coe_nat_injective,
                apply int.cast_injective,
                exact hm_int,
              },
              show 0 < ↑m, from by {
                apply lt_of_le_of_lt,
                apply int.cast_le.mpr,
                apply set.le_of_subset,
                have h1 : (0 : ℕ) ⊆ ℕ, from by {unfold set.subset, exact λ (x : ℕ), set.mem_univ x},
                show (0 : ℕ) ⊆ m, from by {apply h1},
              }
            },
            show 0 < α * ↑m, from by {
              apply mul_pos hα_lt hm_pos,
            }
          }
        },
        show int.fract (α * ↑m) < (1 : ℝ), from by {
          have hα_one : α < (1 : ℝ), from by {
            have hα_int : α ∈ ℤ, from by {rw ← int.cast_coe_nat, apply int.cast_injective, apply int.coe_nat_injective,
              rw ← int.cast_coe_nat, exact hα_irrat
            },
            have h1 : (1 : ℕ) ∈ ℕ, from by {apply set.mem_univ (1 : ℕ)},
            have h2 : (1 : ℕ) ∈ ℤ, from by {
              apply set.mem_of_mem_range,
              apply int.cast_injective,
              rw ← int.cast_coe_nat,
              exact h1,
            },
            show α < 1, from by {
              have hα_n : α ∈ ℕ, from by {apply int.coe_nat_injective, exact hα_int},
              show α < 1, from by {
                apply set.lt_of_subset_of_lt,
                have h3 : α ⊆ (1 : ℕ), from by {unfold set.subset, exact λ (x : ℕ), set.mem_univ x},
                show α ⊆ 1, from by {apply h3},
                have h4 : (1 : ℕ) ∈ ℕ, from by {apply set.mem_univ (1 :
end --Needs more than 2000 tokens!

--OUTPUT 7
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  let S : set ℝ := (λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ),
  have h_S_nonempty : (∃ (r : ℝ), r ∈ S), from by {
    use (int.fract α), simp,
    have h_irrat_pos : (α > 0), from by { rw ← int.fract_eq_iff_irrat hα_irrat, norm_num, },
    have h_pos : (0 < int.fract α), from by { apply lt_of_le_of_lt, norm_num, exact h_irrat_pos, },
    have h_pos' : (0 < int.fract (α * 1)), from by { exact int.fract_mul h_pos, },
    simp [int.fract_mul, h_pos']
  },
  have h_S_infinite : (∀ (r : ℝ), r ∈ S → ∃ (s : ℝ), (s ∈ S ∧ s ≠ r)), from by {
    assume r : ℝ,
    assume h_r_mem : r ∈ S,
    have h_r_mem' : r ∈ (λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ), from by { exact h_r_mem, },
    have h_r_mem'' : (∃ (m : ℤ), (int.fract (α * ↑m) = r ∧ m ∈ @set.univ ℤ)), from by { exact h_r_mem', },
    have h_r_mem''' : (∃ (m : ℤ), (int.fract (α * ↑m) = r)), from by { exact h_r_mem'', },
    have h_r_mem'''' : (∃ (m : ℤ), (int.fract (α * ↑m) = r ∧ m ≠ 0)), from by { apply exists_ne, exact h_r_mem''' },
    have h_r_mem''''' : (∃ (m : ℤ), (int.fract (α * ↑m) = r ∧ 0 < m)), from by { apply exists_pos, exact h_r_mem'''' },
    have h_r_mem'''''' : (∃ (m : ℤ), (int.fract (α * ↑m) = r ∧ 0 < m ∧ m ≠ r)), from by { apply exists_ne, exact h_r_mem''''' },
    have h_r_mem''''''' : (∃ (m : ℤ), (int.fract (α * ↑m) = r ∧ 0 < m ∧ m ≠ r ∧ m ∈ @set.univ ℤ)), from by { apply exists_mem_univ, exact h_r_mem'''''' },
    have h_r_mem'''''''' : (∃ (m : ℤ), (int.fract (α * ↑m) = r ∧ 0 < m ∧ m ≠ r ∧ m ∈ @set.univ ℤ ∧ r ∈ S)), from by { split, exact h_r_mem'''', exact h_r_mem, },
    have h_r_mem''''''''' : (∃ (m : ℤ), (int.fract (α * ↑m) = r ∧ 0 < m ∧ m ∈ @set.univ ℤ ∧ r ∈ S)), from by { exact h_r_mem'''''''' },
    have h_r_mem'''''''''' : (∃ (m : ℤ), (int.fract (α * ↑m) = r ∧ 0 < m ∧ m ∈ @set.univ ℤ ∧ r ∈ S ∧ m ≠ r)), from by { exact h_r_mem''''''''' },
    have h_r_mem''''''''''' : (∃ (m : ℤ), (int.fract (α * ↑m) = r ∧ 0 < m ∧ m ∈ @set.univ ℤ ∧ m ≠ r)), from by { exact h_r_mem'''''''''' },
    have h_r_mem'''''''''''' : (∃ (m : ℤ), (int.fract (α * ↑m) = r ∧ 0 < m ∧ m ∈ @set.univ ℤ ∧ m ≠ r ∧ r ∈ S)), from by { exact h_r_mem''''''''''' },
    have h_r_mem''''''''''''' : (∃ (m : ℤ), (int.fract (α * ↑m) = r ∧ 0 < m ∧ m ∈ @set.univ ℤ)), from by { exact h_r_mem'''''''''''' },
    have h_r_mem'''''''''''''' : (∃ (m : ℤ), (int.fract (α * ↑m) = r ∧ 0 < m ∧ m ∈ @set.univ ℤ ∧ m ≠ r)), from by { exact h_r_mem''''''''''''' },
    have h_r_mem''''''''''''''' : (∃ (m : ℤ), (int.fract (α * ↑m) = r ∧ 0 < m ∧ m ∈ @set.univ ℤ ∧ m ≠ r ∧ m ∈ S)), from by { split, exact h_r_mem'''''''''''''', rw mem_image, exact h_r_mem'''''''''''''' },
    have h_r_mem'''''''''''''''' : (∃ (m : ℤ), (int.fract (α * ↑m) = r ∧ 0 < m ∧ m ∈ S ∧ m ≠ r)), from by { exact h_r_mem''''''''''''''' },
    have h_r_mem''''''''''''''''' : (∃ (m : ℤ), (int.fract (α * ↑m) = r ∧ 0 < m ∧ m ∈ S ∧ m ≠ r ∧ m ∈ @set.univ ℤ)), from by { exact h_r_mem'''''''''''''''' },
    have h_r_mem'''''''''''''''''' : (∃ (m : ℤ), (int.fract (α * ↑m) = r ∧ 0 < m ∧ m ∈ S)), from by { exact h_r_mem''''''''''''''''' },
    have h_r_mem''''''''''''''''''' : (∃ (m : ℤ), (int.fract (α * ↑m) = r ∧ 0 < m ∧ m ∈ S ∧ m ≠ r)), from by { exact h_r_mem'''''''''''''''''' },
    have h_r_mem'''''''''''''''''''' : (∃ (m : ℤ), (int.fract (α * ↑m) = r ∧ 0 < m ∧ m ∈ S ∧ m ≠ r ∧ m ∈ @set.univ ℤ)), from by { exact h_r_mem''''''''''''''''''' },
    have h_r_mem''''''''''''''''''''' : (∃ (m : ℤ), (int.fract (α * ↑m) = r ∧ 0 < m ∧ m ∈ S ∧ m ∈ @set.univ ℤ)), from by { exact h_r_mem'''''''''''''''''''' },
    have h_r_mem'''''''''''''''''''''' : (∃ (m : ℤ), (int.fract (α * ↑m) = r ∧ 0 < m ∧ m ∈ S ∧ m ∈ @set.univ ℤ ∧ m ≠ r)), from by { exact h_r_mem''''''''''''''''''''' },
    have h_r_mem''''''''''''''''''''''' : (∃ (m : ℤ), (int.fract (α * ↑m) = r ∧ 0 < m ∧ m ∈ S ∧ m ≠ r)), from by { exact h_r_mem'''''''''''''''''''''' },
    exact h_r_mem''''''''''''''''''''''',
  },
  have h_S_dense : (∀ (r : ℝ), r ∈ set.Icc 0 1 →
end --Needs more than 2000 tokens!

--OUTPUT 8
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  have h1 : ∀ m n ∈ ℤ, (α * m) ≠ (α * n), from assume (m n : ℤ) (hm : m ∈ ℤ) (hn : n ∈ ℤ) (h : (α * m) = (α * n)),
  begin
    have h2 : (α * m) - m = (α * n) - n, from by rw [h],
    have h3 : α = (m - n)⁻¹ * ((m - n) * (α)), from by rw [int.fract_add_int, int.fract_add_int] at h2,
    have h4 : α ∈ ℚ, from by {rw [h3], apply int.cast_ne_zero, rw [int.mul_sub, int.mul_zero], exact mul_ne_zero (int.cast_ne_zero (m - n)) hα_irrat},
    exact absurd h4 (irrational_iff_not_rat.1 hα_irrat),
  end,

  have h2 : ∀ m n ∈ ℤ, (α * m) - m ≠ (α * n) - n, from assume (m n : ℤ) (hm : m ∈ ℤ) (hn : n ∈ ℤ) (h : (α * m) - m = (α * n) - n),
  begin
    have h3 : (α * m) = (α * n), from by rw [h, add_sub_cancel],
    exact h1 m n hm hn h3,
  end,

  have h3 : ∀ m n ∈ ℤ, (m ≠ n) → (α * ↑m) - m ≠ (α * ↑n) - n, from assume (m n : ℤ) (hm : m ∈ ℤ) (hn : n ∈ ℤ) (hmn : m ≠ n) (h : (α * ↑m) - m = (α * ↑n) - n),
  begin
    have h2 : (α * ↑m) = (α * ↑n), from by rw [h, add_sub_cancel],
    exact h1 m n hm hn h2,
  end,

  have h4 : ∀ m n ∈ ℤ, (m ≠ n) → (int.fract (α * ↑m)) ≠ (int.fract (α * ↑n)), from assume (m n : ℤ) (hm : m ∈ ℤ) (hn : n ∈ ℤ) (hmn : m ≠ n) (h : int.fract (α * ↑m) = int.fract (α * ↑n)),
  begin
    have h2 : (α * ↑m) - m = (α * ↑n) - n, from by rw [h],
    exact h3 m n hm hn hmn h2,
  end,

  have h5 : ∀ m n ∈ ℤ, (m ≠ n) → (int.fract (α * ↑m)) ≠ (int.fract (α * ↑n)), from assume (m n : ℤ) (hm : m ∈ ℤ) (hn : n ∈ ℤ) (hmn : m ≠ n) (h : int.fract (α * ↑m) = int.fract (α * ↑n)),
  begin
    have h2 : (α * ↑m) - m = (α * ↑n) - n, from by rw [h],
    exact h3 m n hm hn hmn h2,
  end,

  have h6 : ∀ m n ∈ ℤ, (m ≠ n) → (int.fract (α * ↑m)) ≠ (int.fract (α * ↑n)), from assume (m n : ℤ) (hm : m ∈ ℤ) (hn : n ∈ ℤ) (hmn : m ≠ n) (h : int.fract (α * ↑m) = int.fract (α * ↑n)),
  begin
    have h2 : (α * ↑m) - m = (α * ↑n) - n, from by rw [h],
    exact h3 m n hm hn hmn h2,
  end,

  have h7 : ∀ m n ∈ ℤ, (m ≠ n) → (int.fract (α * ↑m)) ≠ (int.fract (α * ↑n)), from assume (m n : ℤ) (hm : m ∈ ℤ) (hn : n ∈ ℤ) (hmn : m ≠ n) (h : int.fract (α * ↑m) = int.fract (α * ↑n)),
  begin
    have h2 : (α * ↑m) - m = (α * ↑n) - n, from by rw [h],
    exact h3 m n hm hn hmn h2,
  end,

  have h8 : ∀ m n ∈ ℤ, (m ≠ n) → (int.fract (α * ↑m)) ≠ (int.fract (α * ↑n)), from assume (m n : ℤ) (hm : m ∈ ℤ) (hn : n ∈ ℤ) (hmn : m ≠ n) (h : int.fract (α * ↑m) = int.fract (α * ↑n)),
  begin
    have h2 : (α * ↑m) - m = (α * ↑n) - n, from by rw [h],
    exact h3 m n hm hn hmn h2,
  end,

  have h9 : ∀ m n ∈ ℤ, (m ≠ n) → (int.fract (α * ↑m)) ≠ (int.fract (α * ↑n)), from assume (m n : ℤ) (hm : m ∈ ℤ) (hn : n ∈ ℤ) (hmn : m ≠ n) (h : int.fract (α * ↑m) = int.fract (α * ↑n)),
  begin
    have h2 : (α * ↑m) - m = (α * ↑n) - n, from by rw [h],
    exact h3 m n hm hn hmn h2,
  end,

  have h10 : ∀ m n ∈ ℤ, (m ≠ n) → (int.fract (α * ↑m)) ≠ (int.fract (α * ↑n)), from assume (m n : ℤ) (hm : m ∈ ℤ) (hn : n ∈ ℤ) (hmn : m ≠ n) (h : int.fract (α * ↑m) = int.fract (α * ↑n)),
  begin
    have h2 : (α * ↑m) - m = (α * ↑n) - n, from by rw [h],
    exact h3 m n hm hn hmn h2,
  end,

  have h11 : ∀ m n ∈ ℤ, (m ≠ n) → (int.fract (α * ↑m)) ≠ (int.fract (α * ↑n)), from assume (m n : ℤ) (hm : m ∈ ℤ) (hn : n ∈ ℤ) (hmn : m ≠ n) (h : int.fract (α * ↑m) = int.fract (α * ↑n)),
  begin
    have h2 : (α * ↑m) - m = (α * ↑n) - n, from by rw [h],
    exact h3 m n hm hn hmn h2,
  end,

  have h12 : ∀ m n ∈ ℤ, (m ≠ n) → (int.fract (α * ↑m)) ≠ (int.fract (α * ↑n)), from assume (m n : ℤ) (hm : m ∈ ℤ) (hn : n ∈ ℤ) (hmn : m ≠ n) (h : int.fract (α * ↑m) = int.fract (α * ↑n)),
  begin
    have h2 : (α * ↑m) - m = (α * ↑n) - n, from by
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 {split,apply set.subset_of_mem_powerset,exact hA,apply set.subset_of_mem_powerset,exact hB},
  have h2 : (A ∩ B) ⊆ A, from by apply set.inter_subset_left,
  have h3 : (A ∩ B) ⊆ S, from by {apply set.subset.trans h2 h1.left},
  show (A ∩ B) ∈  𝒫 S, from by {apply set.mem_powerset h3},
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  calc (x + y)^2 = (x+y)*(x+y) : by rw sq
  ... = x*(x+y) + y*(x+y) : by rw add_mul
  ... = x*x + x*y + y*x + y*y : by {rw [mul_comm x (x+y),mul_comm y (x+y)], rw [add_mul,add_mul], ring}
  ... = x^2 + 2*x*y + y^2 : by {repeat {rw ← sq}, rw mul_comm y x, ring}
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from by {
    assume a b : G, use a⁻¹ * b, obviously, },
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from by {
    assume a b : G, use b * a⁻¹, obviously, },

  have h3 : ∀ a : G, ∃! x : G, a * x = a, from
    assume a : G, h1 a a,
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from
    assume a : G, h2 a a,

  have h5 : ∀ a : G, classical.some (h3 a).exists = (1 : G), from assume a :G,
    exists_unique.unique (h3 a) (classical.some_spec (exists_unique.exists (h3 a)))
    (mul_one a),
  have h6 : ∀ a : G, classical.some (h4 a).exists = (1 : G), from assume a : G,
    exists_unique.unique (h4 a) (classical.some_spec (exists_unique.exists (h4 a))) (one_mul a),

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by {
    use (1 : G),
    have h7 : ∀ e : G, (∀ a : G, e * a = a ∧ a * e = a) → e = 1, from by {
      assume (e : G) (hident : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a).exists, from assume (a : G),
        exists_unique.unique (h3 a) (hident a).right
        (classical.some_spec (exists_unique.exists (h3 a))),
      have h9 : ∀ a : G, e = classical.some (h4 a).exists, from assume (a : G),
        exists_unique.unique (h4 a) (hident a).left
        (classical.some_spec (exists_unique.exists (h4 a))),
      show e = (1 : G), from eq.trans (h9 e) (h6 _),
    },
    exact ⟨by obviously, h7⟩,
  }
end

/--`theorem`
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) 2022 Eric Wieser. All rights reserved.
Released under MIT license as described in the file LICENSE.
Authors: Eric Wieser
-/
import linear_algebra.clifford_algebra.fold
import linear_algebra.bilinear_form
import linear_algebra.tensor_product
import linear_algebra.prod
import linear_algebra.clifford_algebra.grading

/-!
# Recursive computation rules

## Main definitions

* `clifford_algebra.foldr'`: a computation rule for building linear maps out of the clifford
  algebra.

-/

universes u1 u2 u3

variables {R : Type u1} [comm_ring R]
variables {M : Type u2} [add_comm_group M] [module R M]
variables {N : Type u3} [add_comm_group N] [module R N]
variables (Q : quadratic_form R M)

namespace clifford_algebra

-- lemma foldr'_mul_ι (f : M →ₗ[R] clifford_algebra Q × N →ₗ[R] N)
--   (hf : ∀ m x fx, f m (ι Q m * x, f m (x, fx)) = Q m • fx) (n m) (x) :
--   foldr' Q f hf n (x * ι Q m) = foldr' Q f hf (f m (1, n)) x :=
-- begin
--   dsimp [foldr'],
--   rw [foldr_mul, foldr_ι, foldr'_aux_apply_apply],
--   dsimp only,
--   rw mul_one,
--   refine congr_arg (f m) (prod.mk.eta.symm.trans _),
--   congr' 1,
--   apply clifford_algebra.foldr_induction _ (λ r, _) (λ x y hx hy, _) (λ m x hx, _) x,
--   { simp_rw [foldr_algebra_map, prod.smul_mk, algebra.algebra_map_eq_smul_one] },
--   { rw [map_add, prod.fst_add, hx, hy] },
--   { rw [foldr_mul, foldr_ι, foldr'_aux_apply_apply, hx], },
-- end
-- lemma foldr'_add
--   (f g : M →ₗ[R] clifford_algebra Q × N →ₗ[R] N)
--   (hfg : ∀ m x fgx, (f + g) m (ι Q m * x, (f + g) m (x, fgx)) = Q m • fgx)
--   (hf : ∀ m x fx, f m (ι Q m * x, f m (x, fx)) = Q m • fx)
--   (hg : ∀ m x gx, g m (ι Q m * x, g m (x, gx)) = Q m • gx) :
--   foldr' Q (f + g) hfg 0 = foldr' Q f hf 0 + foldr' Q g hg 0 :=
-- begin
--   ext x,
--   rw linear_map.add_apply,
--   apply clifford_algebra.foldr_induction _ (λ r, _) (λ x y hx hy, _) (λ m x hx, _) x,
--   { simp_rw [foldr'_algebra_map, smul_zero, zero_add] },
--   { rw [map_add, map_add, map_add, add_add_add_comm, hx, hy] },
--   { simp_rw [foldr'_ι_mul],
--     rw [hx],
--     rw hx,},
-- end

-- lemma foldr'_smul (c : R)
--   (f : M →ₗ[R] clifford_algebra Q × N →ₗ[R] N)
--   (hfg : ∀ m x fcx, (c • f) m (ι Q m * x, (c • f) m (x, fcx)) = Q m • fcx)
--   (hf : ∀ m x fx, f m (ι Q m * x, f m (x, fx)) = Q m • fx) :
--   foldr' Q (c • f) hfg 0 = c • foldr' Q f hf 0 :=
-- begin
--   ext x,
--   rw linear_map.smul_apply,
--   apply clifford_algebra.foldr_induction _ (λ r, _) (λ x y hx hy, _) (λ m x hx, _) x,
--   { simp_rw [foldr'_algebra_map, smul_zero] },
--   { rw [map_add, map_add,smul_add, hx, hy] },
--   { simp_rw [foldr'_ι_mul, line],
--     rw [hx],
--     rw hx,},
-- end

end clifford_algebra


import data.matrix tactic.ring

open tactic declaration expr binder_info
#print binder_fin

local infix ` ⬝ `:70 := matrix.mul
local postfix `ᵀ` : 1500 := matrix.transpose
#print matrix.mul
--set_option trace.class_instances true
set_option eqn_compiler.max_steps 100000
set_option trace.app_builder true
meta def mk_new_theorem : expr → tactic (expr)
| (pi n b dom cod) := do cod ← mk_new_theorem cod, return (pi n b dom cod)
| `(@matrix.mul %%l %%m %%n %%fl %%fm %%fn ℚ _ _ %%A %%B = %%C) :=
    do k ← mk_fresh_name,
       k' ← mk_local' k implicit `(ℕ),
       fintype_k ← mk_app `fin.fintype [k'],
       D ← mk_fresh_name,
       D_type ← mk_mapp `matrix [n, `(fin %%k'), fn, fintype_k, `(ℚ)],
       B' ← mk_local_def `B B,
       D' ← mk_local' D default D_type,
       B_mul_D ← mk_mapp `matrix.mul [some m, some n, some k', fm, fn,
        fintype_k, `(rat), `(rat.has_mul), `(rat.add_comm_monoid), B', D'],
       trace "x",
       return`(ℕ)
    --    A_mul_B_mul_D ← mk_app `matrix.mul [A, B_mul_D],
    --    C_mul_D ← mk_app `matrix.mul [C, (var (v + 1))],
    --    eeq ← mk_app `eq [A_mul_B_mul_D, C_mul_D],
    -- return (pi k implicit `(nat) (pi D implicit `(matrix (fin %%m) (fin %%(var v)) ℚ) eeq))
    -- let e : expr := `(%%A ⬝ (%%B ⬝ D) = %%C ⬝ D) in
    -- return `(∀ {k : ℕ} (D : matrix (fin %%n) (fin k) ℚ), %%A ⬝ (%%B ⬝ D) = %%C ⬝ D)
| _ := do trace "y", failure

run_cmd do t ← mk_local_pis `(∀ A B : matrix (fin 1) (fin 1) ℚ, A ⬝ B = 1),
  trace (t.1.map to_raw_fmt)

meta def codomain (e : expr) : expr :=
if e.is_pi then codomain e.binding_body else e

#print tactic.interactive.ring
meta def m_assoc_simp_attr : user_attribute :=
{ name := `m_assoc_simp,
  descr := "given a proof A ⬝ B = C, generate the lemma A ⬝ (B ⬝ D) = C ⬝ D, and mark it with a simp attribute",
  after_set := some $ λ n _ _,
    do env ← get_env,
    dec ← get_decl n,
    match dec with
    | thm n _ t _ := let target := codomain t in
      match target with
      | `(@matrix.mul (fin %%l) (fin %%m) (fin %%n) %%_x %%__x %%___x ℚ _ _ %%A %%B = %%C) :=
        sorry
      | _ := trace "declaration has wrong type", fail
    | _ := trace "declaratin is not a theorem", fail
    end }

#reduce  user_attribute_cache_cfg unit


/-
Copyright (c) 2020 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.monad.bundled
import Mathlib.category_theory.monoidal.End
import Mathlib.category_theory.monoidal.Mon_
import Mathlib.category_theory.category.Cat
import Mathlib.PostPort

universes u v

namespace Mathlib

/-!

# The equivalence between `Monad C` and `Mon_ (C ⥤ C)`.

A monad "is just" a monoid in the category of endofunctors.

# Definitions/Theorems

1. `to_Mon` associates a monoid object in `C ⥤ C` to any monad on `C`.
2. `Monad_to_Mon` is the functorial version of `to_Mon`.
3. `of_Mon` associates a monad on `C` to any monoid object in `C ⥤ C`.
4. `Monad_Mon_equiv` is the equivalence between `Monad C` and `Mon_ (C ⥤ C)`.

-/

namespace category_theory

namespace Monad

/-- To every `Monad C` we associated a monoid object in `C ⥤ C`.-/
@[simp] theorem to_Mon_mul {C : Type u} [category C] : ∀ (ᾰ : Monad C), Mon_.mul (to_Mon ᾰ) = μ_ :=
  fun (ᾰ : Monad C) => Eq.refl (Mon_.mul (to_Mon ᾰ))

/-- Passing from `Monad C` to `Mon_ (C ⥤ C)` is functorial. -/
@[simp] theorem Monad_to_Mon_obj (C : Type u) [category C] : ∀ (ᾰ : Monad C), functor.obj (Monad_to_Mon C) ᾰ = to_Mon ᾰ :=
  fun (ᾰ : Monad C) => Eq.refl (functor.obj (Monad_to_Mon C) ᾰ)

/-- To every monoid object in `C ⥤ C` we associate a `Monad C`. -/
def of_Mon {C : Type u} [category C] : Mon_ (C ⥤ C) → Monad C :=
  fun (M : Mon_ (C ⥤ C)) => mk (Mon_.X M)

/-- Passing from `Mon_ (C ⥤ C)` to `Monad C` is functorial. -/
def Mon_to_Monad (C : Type u) [category C] : Mon_ (C ⥤ C) ⥤ Monad C :=
  functor.mk of_Mon
    fun (_x _x_1 : Mon_ (C ⥤ C)) (f : _x ⟶ _x_1) => monad_hom.mk (nat_trans.mk (nat_trans.app (Mon_.hom.hom f)))

namespace Monad_Mon_equiv

/-- Isomorphism of functors used in `Monad_Mon_equiv` -/
@[simp] theorem counit_iso_hom_app_hom {C : Type u} [category C] (_x : Mon_ (C ⥤ C)) : Mon_.hom.hom (nat_trans.app (iso.hom counit_iso) _x) = 𝟙 :=
  Eq.refl (Mon_.hom.hom (nat_trans.app (iso.hom counit_iso) _x))

/-- Auxilliary definition for `Monad_Mon_equiv` -/
def unit_iso_hom {C : Type u} [category C] : 𝟭 ⟶ Monad_to_Mon C ⋙ Mon_to_Monad C :=
  nat_trans.mk fun (_x : Monad C) => monad_hom.mk (nat_trans.mk fun (_x_1 : C) => 𝟙)

/-- Auxilliary definition for `Monad_Mon_equiv` -/
@[simp] theorem unit_iso_inv_app_to_nat_trans_app {C : Type u} [category C] (_x : Monad C) : ∀ (_x_1 : C), nat_trans.app (monad_hom.to_nat_trans (nat_trans.app unit_iso_inv _x)) _x_1 = 𝟙 :=
  fun (_x_1 : C) => Eq.refl (nat_trans.app (monad_hom.to_nat_trans (nat_trans.app unit_iso_inv _x)) _x_1)

/-- Isomorphism of functors used in `Monad_Mon_equiv` -/
def unit_iso {C : Type u} [category C] : 𝟭 ≅ Monad_to_Mon C ⋙ Mon_to_Monad C :=
  iso.mk unit_iso_hom unit_iso_inv

end Monad_Mon_equiv

/-- Oh, monads are just monoids in the category of endofunctors (equivalence of categories). -/
def Monad_Mon_equiv (C : Type u) [category C] : Monad C ≌ Mon_ (C ⥤ C) :=
  equivalence.mk' (Monad_to_Mon C) (Mon_to_Monad C) sorry sorry


/-
Copyright (c) 2017 Simon Hudon All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.pfunctor.univariate.basic
import Mathlib.PostPort

universes u l w u_1

namespace Mathlib

/-!
# M-types

M types are potentially infinite tree-like structures. They are defined
as the greatest fixpoint of a polynomial functor.
-/

namespace pfunctor

namespace approx

/-- `cofix_a F n` is an `n` level approximation of a M-type -/
inductive cofix_a (F : pfunctor) : ℕ → Type u
where
| continue : cofix_a F 0
| intro : {n : ℕ} → (a : A F) → (B F a → cofix_a F n) → cofix_a F (Nat.succ n)

/-- default inhabitant of `cofix_a` -/
protected def cofix_a.default (F : pfunctor) [Inhabited (A F)] (n : ℕ) : cofix_a F n :=
  sorry

protected instance cofix_a.inhabited (F : pfunctor) [Inhabited (A F)] {n : ℕ} : Inhabited (cofix_a F n) :=
  { default := cofix_a.default F n }

theorem cofix_a_eq_zero (F : pfunctor) (x : cofix_a F 0) (y : cofix_a F 0) : x = y := sorry

/--
The label of the root of the tree for a non-trivial
approximation of the cofix of a pfunctor.
-/
def head' {F : pfunctor} {n : ℕ} : cofix_a F (Nat.succ n) → A F :=
  sorry

/-- for a non-trivial approximation, return all the subtrees of the root -/
def children' {F : pfunctor} {n : ℕ} (x : cofix_a F (Nat.succ n)) : B F (head' x) → cofix_a F n :=
  sorry

theorem approx_eta {F : pfunctor} {n : ℕ} (x : cofix_a F (n + 1)) : x = cofix_a.intro (head' x) (children' x) := sorry

/-- Relation between two approximations of the cofix of a pfunctor that state they both contain the same
data until one of them is truncated -/
inductive agree {F : pfunctor} : {n : ℕ} → cofix_a F n → cofix_a F (n + 1) → Prop
where
| continue : ∀ (x : cofix_a F 0) (y : cofix_a F 1), agree x y
| intro : ∀ {n : ℕ} {a : A F} (x : B F a → cofix_a F n) (x' : B F a → cofix_a F (n + 1)),
  (∀ (i : B F a), agree (x i) (x' i)) → agree (cofix_a.intro a x) (cofix_a.intro a x')

/--
Given an infinite series of approximations `approx`,
`all_agree approx` states that they are all consistent with each other.
-/
def all_agree {F : pfunctor} (x : (n : ℕ) → cofix_a F n) :=
  ∀ (n : ℕ), agree (x n) (x (Nat.succ n))

@[simp] theorem agree_trival {F : pfunctor} {x : cofix_a F 0} {y : cofix_a F 1} : agree x y :=
  agree.continue x y

theorem agree_children {F : pfunctor} {n : ℕ} (x : cofix_a F (Nat.succ n)) (y : cofix_a F (Nat.succ n + 1)) {i : B F (head' x)} {j : B F (head' y)} (h₀ : i == j) (h₁ : agree x y) : agree (children' x i) (children' y j) := sorry

/-- `truncate a` turns `a` into a more limited approximation -/
def truncate {F : pfunctor} {n : ℕ} : cofix_a F (n + 1) → cofix_a F n :=
  sorry

theorem truncate_eq_of_agree {F : pfunctor} {n : ℕ} (x : cofix_a F n) (y : cofix_a F (Nat.succ n)) (h : agree x y) : truncate y = x := sorry

/-- `s_corec f i n` creates an approximation of height `n`
of the final coalgebra of `f` -/
def s_corec {F : pfunctor} {X : Type w} (f : X → obj F X) (i : X) (n : ℕ) : cofix_a F n :=
  sorry

theorem P_corec {F : pfunctor} {X : Type w} (f : X → obj F X) (i : X) (n : ℕ) : agree (s_corec f i n) (s_corec f i (Nat.succ n)) := sorry

/-- `path F` provides indices to access internal nodes in `corec F` -/
def path (F : pfunctor) :=
  List (Idx F)

protected instance path.inhabited {F : pfunctor} : Inhabited (path F) :=
  { default := [] }

protected instance cofix_a.subsingleton {F : pfunctor} : subsingleton (cofix_a F 0) :=
  subsingleton.intro
    fun (a b : cofix_a F 0) =>
      cofix_a.cases_on a
        (fun (a_1 : 0 = 0) (H_2 : a == cofix_a.continue) =>
          Eq._oldrec
            (cofix_a.cases_on b
              (fun (a : 0 = 0) (H_2 : b == cofix_a.continue) =>
                Eq._oldrec (Eq.refl cofix_a.continue) (Eq.symm (eq_of_heq H_2)))
              (fun {b_n : ℕ} (b_a : A F) (b_ᾰ : B F b_a → cofix_a F b_n) (a : 0 = Nat.succ b_n) => nat.no_confusion a)
              (Eq.refl 0) (HEq.refl b))
            (Eq.symm (eq_of_heq H_2)))
        (fun {a_n : ℕ} (a_a : A F) (a_ᾰ : B F a_a → cofix_a F a_n) (a_1 : 0 = Nat.succ a_n) => nat.no_confusion a_1)
        (Eq.refl 0) (HEq.refl a)

theorem head_succ' {F : pfunctor} (n : ℕ) (m : ℕ) (x : (n : ℕ) → cofix_a F n) (Hconsistent : all_agree x) : head' (x (Nat.succ n)) = head' (x (Nat.succ m)) := sorry

end approx

/-- Internal definition for `M`. It is needed to avoid name clashes
between `M.mk` and `M.cases_on` and the declarations generated for
the structure -/
structure M_intl (F : pfunctor)
where
  approx : (n : ℕ) → approx.cofix_a F n
  consistent : approx.all_agree approx

/-- For polynomial functor `F`, `M F` is its final coalgebra -/
def M (F : pfunctor) :=
  M_intl F

theorem M.default_consistent (F : pfunctor) [Inhabited (A F)] (n : ℕ) : approx.agree Inhabited.default Inhabited.default := sorry

protected instance M.inhabited (F : pfunctor) [Inhabited (A F)] : Inhabited (M F) :=
  { default := M_intl.mk (fun (n : ℕ) => Inhabited.default) (M.default_consistent F) }

protected instance M_intl.inhabited (F : pfunctor) [Inhabited (A F)] : Inhabited (M_intl F) :=
  (fun (this : Inhabited (M F)) => this) (M.inhabited F)

namespace M

theorem ext' (F : pfunctor) (x : M F) (y : M F) (H : ∀ (i : ℕ), M_intl.approx x i = M_intl.approx y i) : x = y := sorry

/-- Corecursor for the M-type defined by `F`. -/
protected def corec {F : pfunctor} {X : Type u_1} (f : X → obj F X) (i : X) : M F :=
  M_intl.mk (approx.s_corec f i) (approx.P_corec f i)

/-- given a tree generated by `F`, `head` gives us the first piece of data
it contains -/
def head {F : pfunctor} (x : M F) : A F :=
  approx.head' (M_intl.approx x 1)

/-- return all the subtrees of the root of a tree `x : M F` -/
def children {F : pfunctor} (x : M F) (i : B F (head x)) : M F :=
  M_intl.mk (fun (n : ℕ) => approx.children' (M_intl.approx x (Nat.succ n)) (cast sorry i)) sorry

/-- select a subtree using a `i : F.Idx` or return an arbitrary tree if
`i` designates no subtree of `x` -/
def ichildren {F : pfunctor} [Inhabited (M F)] [DecidableEq (A F)] (i : Idx F) (x : M F) : M F :=
  dite (sigma.fst i = head x) (fun (H' : sigma.fst i = head x) => children x (cast sorry (sigma.snd i)))
    fun (H' : ¬sigma.fst i = head x) => Inhabited.default

theorem head_succ {F : pfunctor} (n : ℕ) (m : ℕ) (x : M F) : approx.head' (M_intl.approx x (Nat.succ n)) = approx.head' (M_intl.approx x (Nat.succ m)) :=
  approx.head_succ' n m (M_intl.approx x) (M_intl.consistent x)

theorem head_eq_head' {F : pfunctor} (x : M F) (n : ℕ) : head x = approx.head' (M_intl.approx x (n + 1)) := sorry

theorem head'_eq_head {F : pfunctor} (x : M F) (n : ℕ) : approx.head' (M_intl.approx x (n + 1)) = head x := sorry

theorem truncate_approx {F : pfunctor} (x : M F) (n : ℕ) : approx.truncate (M_intl.approx x (n + 1)) = M_intl.approx x n :=
  approx.truncate_eq_of_agree (M_intl.approx x n) (M_intl.approx x (n + 1)) (M_intl.consistent x n)

/-- unfold an M-type -/
def dest {F : pfunctor} : M F → obj F (M F) :=
  sorry

namespace approx

/-- generates the approximations needed for `M.mk` -/
protected def s_mk {F : pfunctor} (x : obj F (M F)) (n : ℕ) : approx.cofix_a F n :=
  sorry

protected theorem P_mk {F : pfunctor} (x : obj F (M F)) : approx.all_agree (approx.s_mk x) := sorry

end approx

/-- constructor for M-types -/
protected def mk {F : pfunctor} (x : obj F (M F)) : M F :=
  M_intl.mk (approx.s_mk x) (approx.P_mk x)

/-- `agree' n` relates two trees of type `M F` that
are the same up to dept `n` -/
inductive agree' {F : pfunctor} : ℕ → M F → M F → Prop
where
| trivial : ∀ (x y : M F), agree' 0 x y
| step : ∀ {n : ℕ} {a : A F} (x y : B F a → M F) {x' y' : M F},
  x' = M.mk (sigma.mk a x) →
    y' = M.mk (sigma.mk a y) → (∀ (i : B F a), agree' n (x i) (y i)) → agree' (Nat.succ n) x' y'

@[simp] theorem dest_mk {F : pfunctor} (x : obj F (M F)) : dest (M.mk x) = x := sorry

@[simp] theorem mk_dest {F : pfunctor} (x : M F) : M.mk (dest x) = x := sorry

theorem mk_inj {F : pfunctor} {x : obj F (M F)} {y : obj F (M F)} (h : M.mk x = M.mk y) : x = y :=
  eq.mpr (id (Eq._oldrec (Eq.refl (x = y)) (Eq.symm (dest_mk x))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (dest (M.mk x) = y)) h))
      (eq.mpr (id (Eq._oldrec (Eq.refl (dest (M.mk y) = y)) (dest_mk y))) (Eq.refl y)))

/-- destructor for M-types -/
protected def cases {F : pfunctor} {r : M F → Sort w} (f : (x : obj F (M F)) → r (M.mk x)) (x : M F) : r x :=
  (fun (this : r (M.mk (dest x))) => eq.mpr sorry this) (f (dest x))

/-- destructor for M-types -/
protected def cases_on {F : pfunctor} {r : M F → Sort w} (x : M F) (f : (x : obj F (M F)) → r (M.mk x)) : r x :=
  M.cases f x

/-- destructor for M-types, similar to `cases_on` but also
gives access directly to the root and subtrees on an M-type -/
protected def cases_on' {F : pfunctor} {r : M F → Sort w} (x : M F) (f : (a : A F) → (f : B F a → M F) → r (M.mk (sigma.mk a f))) : r x :=
  M.cases_on x fun (_x : obj F (M F)) => sorry

theorem approx_mk {F : pfunctor} (a : A F) (f : B F a → M F) (i : ℕ) : M_intl.approx (M.mk (sigma.mk a f)) (Nat.succ i) = approx.cofix_a.intro a fun (j : B F a) => M_intl.approx (f j) i :=
  rfl

@[simp] theorem agree'_refl {F : pfunctor} {n : ℕ} (x : M F) : agree' n x x := sorry

theorem agree_iff_agree' {F : pfunctor} {n : ℕ} (x : M F) (y : M F) : approx.agree (M_intl.approx x n) (M_intl.approx y (n + 1)) ↔ agree' n x y := sorry

@[simp] theorem cases_mk {F : pfunctor} {r : M F → Sort u_1} (x : obj F (M F)) (f : (x : obj F (M F)) → r (M.mk x)) : M.cases f (M.mk x) = f x := sorry

@[simp] theorem cases_on_mk {F : pfunctor} {r : M F → Sort u_1} (x : obj F (M F)) (f : (x : obj F (M F)) → r (M.mk x)) : M.cases_on (M.mk x) f = f x :=
  cases_mk x f

@[simp] theorem cases_on_mk' {F : pfunctor} {r : M F → Sort u_1} {a : A F} (x : B F a → M F) (f : (a : A F) → (f : B F a → M F) → r (M.mk (sigma.mk a f))) : M.cases_on' (M.mk (sigma.mk a x)) f = f a x :=
  cases_mk (sigma.mk a x) fun (_x : obj F (M F)) => cases_on'._match_1 f _x

/-- `is_path p x` tells us if `p` is a valid path through `x` -/
inductive is_path {F : pfunctor} : approx.path F → M F → Prop
where
| nil : ∀ (x : M F), is_path [] x
| cons : ∀ (xs : approx.path F) {a : A F} (x : M F) (f : B F a → M F) (i : B F a),
  x = M.mk (sigma.mk a f) → is_path xs (f i) → is_path (sigma.mk a i :: xs) x

theorem is_path_cons {F : pfunctor} {xs : approx.path F} {a : A F} {a' : A F} {f : B F a → M F} {i : B F a'} (h : is_path (sigma.mk a' i :: xs) (M.mk (sigma.mk a f))) : a = a' := sorry

theorem is_path_cons' {F : pfunctor} {xs : approx.path F} {a : A F} {f : B F a → M F} {i : B F a} (h : is_path (sigma.mk a i :: xs) (M.mk (sigma.mk a f))) : is_path xs (f i) := sorry

/-- follow a path through a value of `M F` and return the subtree
found at the end of the path if it is a valid path for that value and
return a default tree -/
def isubtree {F : pfunctor} [DecidableEq (A F)] [Inhabited (M F)] : approx.path F → M F → M F :=
  sorry

/-- similar to `isubtree` but returns the data at the end of the path instead
of the whole subtree -/
def iselect {F : pfunctor} [DecidableEq (A F)] [Inhabited (M F)] (ps : approx.path F) : M F → A F :=
  fun (x : M F) => head (isubtree ps x)

theorem iselect_eq_default {F : pfunctor} [DecidableEq (A F)] [Inhabited (M F)] (ps : approx.path F) (x : M F) (h : ¬is_path ps x) : iselect ps x = head Inhabited.default := sorry

@[simp] theorem head_mk {F : pfunctor} (x : obj F (M F)) : head (M.mk x) = sigma.fst x := sorry

theorem children_mk {F : pfunctor} {a : A F} (x : B F a → M F) (i : B F (head (M.mk (sigma.mk a x)))) : children (M.mk (sigma.mk a x)) i =
  x
    (cast
      (eq.mpr (id (Eq._oldrec (Eq.refl (B F (head (M.mk (sigma.mk a x))) = B F a)) (head_mk (sigma.mk a x))))
        (Eq.refl (B F (sigma.fst (sigma.mk a x)))))
      i) := sorry

@[simp] theorem ichildren_mk {F : pfunctor} [DecidableEq (A F)] [Inhabited (M F)] (x : obj F (M F)) (i : Idx F) : ichildren i (M.mk x) = obj.iget x i := sorry

@[simp] theorem isubtree_cons {F : pfunctor} [DecidableEq (A F)] [Inhabited (M F)] (ps : approx.path F) {a : A F} (f : B F a → M F) {i : B F a} : isubtree (sigma.mk a i :: ps) (M.mk (sigma.mk a f)) = isubtree ps (f i) := sorry

@[simp] theorem iselect_nil {F : pfunctor} [DecidableEq (A F)] [Inhabited (M F)] {a : A F} (f : B F a → M F) : iselect [] (M.mk (sigma.mk a f)) = a :=
  Eq.refl (iselect [] (M.mk (sigma.mk a f)))

@[simp] theorem iselect_cons {F : pfunctor} [DecidableEq (A F)] [Inhabited (M F)] (ps : approx.path F) {a : A F} (f : B F a → M F) {i : B F a} : iselect (sigma.mk a i :: ps) (M.mk (sigma.mk a f)) = iselect ps (f i) := sorry

theorem corec_def {F : pfunctor} {X : Type u} (f : X → obj F X) (x₀ : X) : M.corec f x₀ = M.mk (M.corec f <$> f x₀) := sorry

theorem ext_aux {F : pfunctor} [Inhabited (M F)] [DecidableEq (A F)] {n : ℕ} (x : M F) (y : M F) (z : M F) (hx : agree' n z x) (hy : agree' n z y) (hrec : ∀ (ps : approx.path F), n = list.length ps → iselect ps x = iselect ps y) : M_intl.approx x (n + 1) = M_intl.approx y (n + 1) := sorry

theorem ext {F : pfunctor} [Inhabited (M F)] (x : M F) (y : M F) (H : ∀ (ps : approx.path F), iselect ps x = iselect ps y) : x = y := sorry

/-- Bisimulation is the standard proof technique for equality between
infinite tree-like structures -/
structure is_bisimulation {F : pfunctor} (R : M F → M F → Prop)
where
  head : ∀ {a a' : A F} {f : B F a → M F} {f' : B F a' → M F}, R (M.mk (sigma.mk a f)) (M.mk (sigma.mk a' f')) → a = a'
  tail : ∀ {a : A F} {f f' : B F a → M F}, R (M.mk (sigma.mk a f)) (M.mk (sigma.mk a f')) → ∀ (i : B F a), R (f i) (f' i)

theorem nth_of_bisim {F : pfunctor} (R : M F → M F → Prop) [Inhabited (M F)] (bisim : is_bisimulation R) (s₁ : M F) (s₂ : M F) (ps : approx.path F) : R s₁ s₂ →
  is_path ps s₁ ∨ is_path ps s₂ →
    iselect ps s₁ = iselect ps s₂ ∧
      ∃ (a : A F),
        ∃ (f : B F a → M F),
          ∃ (f' : B F a → M F),
            isubtree ps s₁ = M.mk (sigma.mk a f) ∧ isubtree ps s₂ = M.mk (sigma.mk a f') ∧ ∀ (i : B F a), R (f i) (f' i) := sorry

theorem eq_of_bisim {F : pfunctor} (R : M F → M F → Prop) [Nonempty (M F)] (bisim : is_bisimulation R) (s₁ : M F) (s₂ : M F) : R s₁ s₂ → s₁ = s₂ := sorry

/-- corecursor for `M F` with swapped arguments -/
def corec_on {F : pfunctor} {X : Type u_1} (x₀ : X) (f : X → obj F X) : M F :=
  M.corec f x₀

theorem dest_corec {P : pfunctor} {α : Type u} (g : α → obj P α) (x : α) : dest (M.corec g x) = M.corec g <$> g x := sorry

theorem bisim {P : pfunctor} (R : M P → M P → Prop) (h : ∀ (x y : M P),
  R x y →
    ∃ (a : A P),
      ∃ (f : B P a → M P),
        ∃ (f' : B P a → M P), dest x = sigma.mk a f ∧ dest y = sigma.mk a f' ∧ ∀ (i : B P a), R (f i) (f' i)) (x : M P) (y : M P) : R x y → x = y := sorry

theorem bisim' {P : pfunctor} {α : Type u_1} (Q : α → Prop) (u : α → M P) (v : α → M P) (h : ∀ (x : α),
  Q x →
    ∃ (a : A P),
      ∃ (f : B P a → M P),
        ∃ (f' : B P a → M P),
          dest (u x) = sigma.mk a f ∧
            dest (v x) = sigma.mk a f' ∧ ∀ (i : B P a), ∃ (x' : α), Q x' ∧ f i = u x' ∧ f' i = v x') (x : α) : Q x → u x = v x := sorry

-- for the record, show M_bisim follows from _bisim'

theorem bisim_equiv {P : pfunctor} (R : M P → M P → Prop) (h : ∀ (x y : M P),
  R x y →
    ∃ (a : A P),
      ∃ (f : B P a → M P),
        ∃ (f' : B P a → M P), dest x = sigma.mk a f ∧ dest y = sigma.mk a f' ∧ ∀ (i : B P a), R (f i) (f' i)) (x : M P) (y : M P) : R x y → x = y := sorry

theorem corec_unique {P : pfunctor} {α : Type u} (g : α → obj P α) (f : α → M P) (hyp : ∀ (x : α), dest (f x) = f <$> g x) : f = M.corec g := sorry

/-- corecursor where the state of the computation can be sent downstream
in the form of a recursive call -/
def corec₁ {P : pfunctor} {α : Type u} (F : (X : Type u) → (α → X) → α → obj P X) : α → M P :=
  M.corec (F α id)

/-- corecursor where it is possible to return a fully formed value at any point
of the computation -/
def corec' {P : pfunctor} {α : Type u} (F : {X : Type u} → (α → X) → α → M P ⊕ obj P X) (x : α) : M P :=
  corec₁
    (fun (X : Type u) (rec : M P ⊕ α → X) (a : M P ⊕ α) =>
      let y : M P ⊕ obj P X := a >>= F (rec ∘ sum.inr);
      sorry)
    (sum.inr x)


/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import algebraic_geometry.locally_ringed_space
import algebra.category.CommRing.constructions
import algebraic_geometry.open_immersion
import category_theory.limits.constructions.limits_of_products_and_equalizers

/-!
# Colimits of LocallyRingedSpace

We construct the explict coproducts and coequalizers of `LocallyRingedSpace`.
It then follows that `LocallyRingedSpace` has all colimits, and
`forget_to_SheafedSpace` preserves them.

-/

namespace algebraic_geometry

universes v u

open category_theory category_theory.limits opposite topological_space

namespace SheafedSpace

variables {C : Type u} [category.{v} C] [has_limits C]
variables {J : Type v} [category.{v} J] (F : J ⥤ SheafedSpace C)

lemma is_colimit_exists_rep {c : cocone F} (hc : is_colimit c) (x : c.X) :
  ∃ (i : J) (y : F.obj i), (c.ι.app i).base y = x :=
concrete.is_colimit_exists_rep (F ⋙ SheafedSpace.forget _)
  (is_colimit_of_preserves (SheafedSpace.forget _) hc) x

lemma colimit_exists_rep (x : colimit F) :
  ∃ (i : J) (y : F.obj i), (colimit.ι F i).base y = x :=
concrete.is_colimit_exists_rep (F ⋙ SheafedSpace.forget _)
  (is_colimit_of_preserves (SheafedSpace.forget _) (colimit.is_colimit F)) x

instance {X Y : SheafedSpace C} (f g : X ⟶ Y) : epi (coequalizer.π f g).base :=
begin
  erw ← (show _ = (coequalizer.π f g).base, from
    ι_comp_coequalizer_comparison f g (SheafedSpace.forget C)),
  rw ← preserves_coequalizer.iso_hom,
  apply epi_comp
end

end SheafedSpace

namespace LocallyRingedSpace

section has_coproducts

variables {ι : Type u} (F : discrete ι ⥤ LocallyRingedSpace.{u})

/-- The explicit coproduct for `F : discrete ι ⥤ LocallyRingedSpace`. -/
noncomputable
def coproduct : LocallyRingedSpace :=
{ to_SheafedSpace := colimit (F ⋙ forget_to_SheafedSpace : _),
  local_ring := λ x, begin
    obtain ⟨i, y, ⟨⟩⟩ := SheafedSpace.colimit_exists_rep (F ⋙ forget_to_SheafedSpace) x,
    haveI : _root_.local_ring (((F ⋙ forget_to_SheafedSpace).obj i).to_PresheafedSpace.stalk y) :=
      (F.obj i).local_ring _,
    exact (as_iso (PresheafedSpace.stalk_map (colimit.ι (F ⋙ forget_to_SheafedSpace) i : _) y)
      ).symm.CommRing_iso_to_ring_equiv.local_ring
  end }

/-- The explicit coproduct cofan for `F : discrete ι ⥤ LocallyRingedSpace`. -/
noncomputable
def coproduct_cofan : cocone F :=
{ X := coproduct F,
  ι := { app := λ j, ⟨colimit.ι (F ⋙ forget_to_SheafedSpace) j, infer_instance⟩ } }

/-- The explicit coproduct cofan constructed in `coproduct_cofan` is indeed a colimit. -/
noncomputable
def coproduct_cofan_is_colimit : is_colimit (coproduct_cofan F) :=
{ desc := λ s, ⟨colimit.desc (F ⋙ forget_to_SheafedSpace) (forget_to_SheafedSpace.map_cocone s),
  begin
    intro x,
    obtain ⟨i, y, ⟨⟩⟩ := SheafedSpace.colimit_exists_rep (F ⋙ forget_to_SheafedSpace) x,
    have := PresheafedSpace.stalk_map.comp (colimit.ι (F ⋙ forget_to_SheafedSpace) i : _)
      (colimit.desc (F ⋙ forget_to_SheafedSpace) (forget_to_SheafedSpace.map_cocone s)) y,
    rw ← is_iso.comp_inv_eq at this,
    erw [← this, PresheafedSpace.stalk_map.congr_hom _ _
      (colimit.ι_desc (forget_to_SheafedSpace.map_cocone s) i : _)],
    haveI : is_local_ring_hom (PresheafedSpace.stalk_map
      ((forget_to_SheafedSpace.map_cocone s).ι.app i) y) := (s.ι.app i).2 y,
    apply_instance
  end⟩,
  fac' := λ s j, subtype.eq (colimit.ι_desc _ _),
  uniq' := λ s f h, subtype.eq (is_colimit.uniq _ (forget_to_SheafedSpace.map_cocone s) f.1
    (λ j, congr_arg subtype.val (h j))) }

instance : has_coproducts LocallyRingedSpace.{u} :=
λ ι, ⟨λ F, ⟨⟨⟨_, coproduct_cofan_is_colimit F⟩⟩⟩⟩

noncomputable
instance (J : Type*) : preserves_colimits_of_shape (discrete J) forget_to_SheafedSpace :=
⟨λ G, preserves_colimit_of_preserves_colimit_cocone (coproduct_cofan_is_colimit G)
  ((colimit.is_colimit _).of_iso_colimit (cocones.ext (iso.refl _) (λ j, category.comp_id _)))⟩

end has_coproducts

section has_coequalizer

variables {X Y : LocallyRingedSpace.{u}} (f g : X ⟶ Y)

namespace has_coequalizer

instance coequalizer_π_app_is_local_ring_hom
  (U : topological_space.opens ((coequalizer f.val g.val).carrier)) :
  is_local_ring_hom ((coequalizer.π f.val g.val : _).c.app (op U)) :=
begin
  have := ι_comp_coequalizer_comparison f.1 g.1 SheafedSpace.forget_to_PresheafedSpace,
  rw ← preserves_coequalizer.iso_hom at this,
  erw SheafedSpace.congr_app this.symm (op U),
  rw [PresheafedSpace.comp_c_app,
    ← PresheafedSpace.colimit_presheaf_obj_iso_componentwise_limit_hom_π],
  apply_instance
end

/-!
We roughly follow the construction given in [MR0302656]. Given a pair `f, g : X ⟶ Y` of morphisms
of locally ringed spaces, we want to show that the stalk map of
`π = coequalizer.π f g` (as sheafed space homs) is a local ring hom. It then follows that
`coequalizer f g` is indeed a locally ringed space, and `coequalizer.π f g` is a morphism of
locally ringed space.

Given a germ `⟨U, s⟩` of `x : coequalizer f g` such that `π꙳ x : Y` is invertible, we ought to show
that `⟨U, s⟩` is invertible. That is, there exists an open set `U' ⊆ U` containing `x` such that the
restriction of `s` onto `U'` is invertible. This `U'` is given by `π '' V`, where `V` is the
basic open set of `π⋆x`.

Since `f ⁻¹' V = Y.basic_open (f ≫ π)꙳ x = Y.basic_open (g ≫ π)꙳ x = g ⁻¹' V`, we have
`π ⁻¹' (π '' V) = V` (as the underlying set map is merely the set-theoretic coequalizer).
This shows that `π '' V` is indeed open, and `s` is invertible on `π '' V` as the components of `π꙳`
are local ring homs.
-/
variable (U : opens ((coequalizer f.1 g.1).carrier))
variable (s : (coequalizer f.1 g.1).presheaf.obj (op U))

/-- (Implementation). The basic open set of the section `π꙳ s`. -/
noncomputable
def image_basic_open : opens Y := (Y.to_RingedSpace.basic_open
  (show Y.presheaf.obj (op (unop _)), from ((coequalizer.π f.1 g.1).c.app (op U)) s))

lemma image_basic_open_image_preimage :
  (coequalizer.π f.1 g.1).base ⁻¹' ((coequalizer.π f.1 g.1).base ''
    (image_basic_open f g U s).1) = (image_basic_open f g U s).1 :=
begin
  fapply types.coequalizer_preimage_image_eq_of_preimage_eq f.1.base g.1.base,
  { ext,
    simp_rw [types_comp_apply, ← Top.comp_app, ← PresheafedSpace.comp_base],
    congr' 2,
    exact coequalizer.condition f.1 g.1 },
  { apply is_colimit_cofork_map_of_is_colimit (forget Top),
    apply is_colimit_cofork_map_of_is_colimit (SheafedSpace.forget _),
    exact coequalizer_is_coequalizer f.1 g.1 },
  { suffices : (topological_space.opens.map f.1.base).obj (image_basic_open f g U s) =
      (topological_space.opens.map g.1.base).obj (image_basic_open f g U s),
    { injection this },
    delta image_basic_open,
    rw [preimage_basic_open f, preimage_basic_open g],
    dsimp only [functor.op, unop_op],
    rw [← comp_apply, ← SheafedSpace.comp_c_app', ← comp_apply, ← SheafedSpace.comp_c_app',
      SheafedSpace.congr_app (coequalizer.condition f.1 g.1), comp_apply],
    erw X.to_RingedSpace.basic_open_res,
    apply inf_eq_right.mpr,
    refine (RingedSpace.basic_open_subset _ _).trans _,
    rw coequalizer.condition f.1 g.1,
    exact λ _ h, h }
end

lemma image_basic_open_image_open :
  is_open ((coequalizer.π f.1 g.1).base '' (image_basic_open f g U s).1) :=
begin
  rw [← (Top.homeo_of_iso (preserves_coequalizer.iso (SheafedSpace.forget _) f.1 g.1))
      .is_open_preimage, Top.coequalizer_is_open_iff, ← set.preimage_comp],
  erw ← coe_comp,
  rw [preserves_coequalizer.iso_hom, ι_comp_coequalizer_comparison],
  dsimp only [SheafedSpace.forget],
  rw image_basic_open_image_preimage,
  exact (image_basic_open f g U s).2
end

instance coequalizer_π_stalk_is_local_ring_hom (x : Y) :
  is_local_ring_hom (PresheafedSpace.stalk_map (coequalizer.π f.val g.val : _) x) :=
begin
  constructor,
  rintros a ha,
  rcases Top.presheaf.germ_exist _ _ a with ⟨U, hU, s, rfl⟩,
  erw PresheafedSpace.stalk_map_germ_apply (coequalizer.π f.1 g.1 : _) U ⟨_, hU⟩ at ha,

  let V := image_basic_open f g U s,
  have hV : (coequalizer.π f.1 g.1).base ⁻¹' ((coequalizer.π f.1 g.1).base '' V.1) = V.1 :=
    image_basic_open_image_preimage f g U s,
  have hV' : V = ⟨(coequalizer.π f.1 g.1).base ⁻¹'
    ((coequalizer.π f.1 g.1).base '' V.1), hV.symm ▸ V.2⟩ := subtype.eq hV.symm,
  have V_open : is_open (((coequalizer.π f.val g.val).base) '' V.val) :=
    image_basic_open_image_open f g U s,
  have VleU :
    (⟨((coequalizer.π f.val g.val).base) '' V.val, V_open⟩ : topological_space.opens _) ≤ U,
  { exact set.image_subset_iff.mpr (Y.to_RingedSpace.basic_open_subset _) },
  have hxV : x ∈ V := ⟨⟨_, hU⟩, ha, rfl⟩,

  erw ← (coequalizer f.val g.val).presheaf.germ_res_apply (hom_of_le VleU)
    ⟨_, @set.mem_image_of_mem _ _ (coequalizer.π f.val g.val).base x V.1 hxV⟩ s,
  apply ring_hom.is_unit_map,
  rw [← is_unit_map_iff ((coequalizer.π f.val g.val : _).c.app _), ← comp_apply,
    nat_trans.naturality, comp_apply, Top.presheaf.pushforward_obj_map,
    ← is_unit_map_iff (Y.presheaf.map (eq_to_hom hV').op), ← comp_apply, ← functor.map_comp],
  convert @RingedSpace.is_unit_res_basic_open Y.to_RingedSpace (unop _)
    (((coequalizer.π f.val g.val).c.app (op U)) s),
  apply_instance
end

end has_coequalizer

/-- The coequalizer of two locally ringed space in the category of sheafed spaces is a locally
ringed space. -/
noncomputable
def coequalizer : LocallyRingedSpace :=
{ to_SheafedSpace := coequalizer f.1 g.1,
  local_ring := λ x,
  begin
    obtain ⟨y, rfl⟩ :=
      (Top.epi_iff_surjective (coequalizer.π f.val g.val).base).mp infer_instance x,
    exact (PresheafedSpace.stalk_map (coequalizer.π f.val g.val : _) y).domain_local_ring
  end }

/-- The explicit coequalizer cofork of locally ringed spaces. -/
noncomputable
def coequalizer_cofork : cofork f g :=
@cofork.of_π _ _ _ _ f g (coequalizer f g) ⟨coequalizer.π f.1 g.1, infer_instance⟩
  (subtype.eq (coequalizer.condition f.1 g.1))

lemma is_local_ring_hom_stalk_map_congr {X Y : RingedSpace} (f g : X ⟶ Y) (H : f = g)
  (x) (h : is_local_ring_hom (PresheafedSpace.stalk_map f x)) :
    is_local_ring_hom (PresheafedSpace.stalk_map g x) :=
by { rw PresheafedSpace.stalk_map.congr_hom _ _ H.symm x, apply_instance }

/-- The cofork constructed in `coequalizer_cofork` is indeed a colimit cocone. -/
noncomputable
def coequalizer_cofork_is_colimit : is_colimit (coequalizer_cofork f g) :=
begin
  apply cofork.is_colimit.mk',
  intro s,
  have e : f.val ≫ s.π.val = g.val ≫ s.π.val := by injection s.condition,
  use coequalizer.desc s.π.1 e,
  { intro x,
    rcases (Top.epi_iff_surjective (coequalizer.π f.val g.val).base).mp
      infer_instance x with ⟨y, rfl⟩,
    apply is_local_ring_hom_of_comp _ (PresheafedSpace.stalk_map (coequalizer_cofork f g).π.1 _),
    change is_local_ring_hom (_ ≫ PresheafedSpace.stalk_map (coequalizer_cofork f g).π.val y),
    erw ← PresheafedSpace.stalk_map.comp,
    apply is_local_ring_hom_stalk_map_congr _ _ (coequalizer.π_desc s.π.1 e).symm y,
    apply_instance },
  split,
  exact subtype.eq (coequalizer.π_desc _ _),
  intros m h,
  replace h : (coequalizer_cofork f g).π.1 ≫ m.1 = s.π.1 := by { rw ← h, refl },
  apply subtype.eq,
  apply (colimit.is_colimit (parallel_pair f.1 g.1)).uniq (cofork.of_π s.π.1 e) m.1,
  rintro ⟨⟩,
  { rw [← (colimit.cocone (parallel_pair f.val g.val)).w walking_parallel_pair_hom.left,
      category.assoc],
    change _ ≫ _ ≫ _ = _ ≫ _,
    congr,
    exact h },
  { exact h }
end

instance : has_coequalizer f g := ⟨⟨⟨_, coequalizer_cofork_is_colimit f g⟩⟩⟩

instance : has_coequalizers LocallyRingedSpace := has_coequalizers_of_has_colimit_parallel_pair _

noncomputable
instance preserves_coequalizer :
  preserves_colimits_of_shape walking_parallel_pair.{v} forget_to_SheafedSpace.{v} :=
⟨λ F, begin
  apply preserves_colimit_of_iso_diagram _ (diagram_iso_parallel_pair F).symm,
  apply preserves_colimit_of_preserves_colimit_cocone (coequalizer_cofork_is_colimit _ _),
  apply (is_colimit_map_cocone_cofork_equiv _ _).symm _,
  dsimp only [forget_to_SheafedSpace],
  exact coequalizer_is_coequalizer _ _
end⟩

end has_coequalizer

instance : has_colimits LocallyRingedSpace := colimits_from_coequalizers_and_coproducts

noncomputable
instance : preserves_colimits LocallyRingedSpace.forget_to_SheafedSpace :=
preserves_colimits_of_preserves_coequalizers_and_coproducts _

end LocallyRingedSpace

end algebraic_geometry


/-
Copyright (c) 2018 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Reid Barton, Bhavik Mehta
-/
import category_theory.over
import category_theory.adjunction.opposites
import category_theory.limits.preserves.basic
import category_theory.limits.shapes.pullbacks
import category_theory.limits.creates
import category_theory.limits.comma

/-!
# Limits and colimits in the over and under categories

Show that the forgetful functor `forget X : over X ⥤ C` creates colimits, and hence `over X` has
any colimits that `C` has (as well as the dual that `forget X : under X ⟶ C` creates limits).

Note that the folder `category_theory.limits.shapes.constructions.over` further shows that
`forget X : over X ⥤ C` creates connected limits (so `over X` has connected limits), and that
`over X` has `J`-indexed products if `C` has `J`-indexed wide pullbacks.

TODO: If `C` has binary products, then `forget X : over X ⥤ C` has a right adjoint.
-/
noncomputable theory

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

open category_theory category_theory.limits

variables {J : Type v} [small_category J]
variables {C : Type u} [category.{v} C]
variable {X : C}

namespace category_theory.over

instance has_colimit_of_has_colimit_comp_forget
  (F : J ⥤ over X) [i : has_colimit (F ⋙ forget X)] : has_colimit F :=
@@costructured_arrow.has_colimit _ _ _ _ i _

instance [has_colimits_of_shape J C] : has_colimits_of_shape J (over X) := {}
instance [has_colimits C] : has_colimits (over X) := ⟨infer_instance⟩

instance creates_colimits : creates_colimits (forget X) := costructured_arrow.creates_colimits

-- We can automatically infer that the forgetful functor preserves and reflects colimits.
example [has_colimits C] : preserves_colimits (forget X) := infer_instance
example : reflects_colimits (forget X) := infer_instance

section
variables [has_pullbacks C]

open tactic

/-- When `C` has pullbacks, a morphism `f : X ⟶ Y` induces a functor `over Y ⥤ over X`,
by pulling back a morphism along `f`. -/
@[simps]
def pullback {X Y : C} (f : X ⟶ Y) : over Y ⥤ over X :=
{ obj := λ g, over.mk (pullback.snd : pullback g.hom f ⟶ X),
  map := λ g h k,
    over.hom_mk
      (pullback.lift (pullback.fst ≫ k.left) pullback.snd (by simp [pullback.condition]))
      (by tidy) }

/-- `over.map f` is left adjoint to `over.pullback f`. -/
def map_pullback_adj {A B : C} (f : A ⟶ B) :
  over.map f ⊣ pullback f :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ g h,
  { to_fun := λ X, over.hom_mk (pullback.lift X.left g.hom (over.w X)) (pullback.lift_snd _ _ _),
    inv_fun := λ Y,
    begin
      refine over.hom_mk _ _,
      refine Y.left ≫ pullback.fst,
      dsimp,
      rw [← over.w Y, category.assoc, pullback.condition, category.assoc], refl,
    end,
    left_inv := λ X, by { ext, dsimp, simp, },
    right_inv := λ Y, begin
      ext, dsimp,
      simp only [pullback.lift_fst],
      dsimp,
      rw [pullback.lift_snd, ← over.w Y],
      refl,
    end } }

/-- pullback (𝟙 A) : over A ⥤ over A is the identity functor. -/
def pullback_id {A : C} : pullback (𝟙 A) ≅ 𝟭 _ :=
adjunction.right_adjoint_uniq
  (map_pullback_adj _)
  (adjunction.id.of_nat_iso_left over.map_id.symm)

/-- pullback commutes with composition (up to natural isomorphism). -/
def pullback_comp {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) :
  pullback (f ≫ g) ≅ pullback g ⋙ pullback f :=
adjunction.right_adjoint_uniq
  (map_pullback_adj _)
  (((map_pullback_adj _).comp _ _ (map_pullback_adj _)).of_nat_iso_left
    (over.map_comp _ _).symm)

instance pullback_is_right_adjoint {A B : C} (f : A ⟶ B) :
  is_right_adjoint (pullback f) :=
⟨_, map_pullback_adj f⟩

end

end category_theory.over

namespace category_theory.under

instance has_limit_of_has_limit_comp_forget
  (F : J ⥤ under X) [i : has_limit (F ⋙ forget X)] : has_limit F :=
@@structured_arrow.has_limit _ _ _ _ i _

instance [has_limits_of_shape J C] : has_limits_of_shape J (under X) := {}
instance [has_limits C] : has_limits (under X) := ⟨infer_instance⟩

instance creates_limits : creates_limits (forget X) := structured_arrow.creates_limits

-- We can automatically infer that the forgetful functor preserves and reflects limits.
example [has_limits C] : preserves_limits (forget X) := infer_instance
example : reflects_limits (forget X) := infer_instance

section
variables [has_pushouts C]

/-- When `C` has pushouts, a morphism `f : X ⟶ Y` induces a functor `under X ⥤ under Y`,
by pushing a morphism forward along `f`. -/
@[simps]
def pushout {X Y : C} (f : X ⟶ Y) : under X ⥤ under Y :=
{ obj := λ g, under.mk (pushout.inr : Y ⟶ pushout g.hom f),
  map := λ g h k,
    under.hom_mk
      (pushout.desc (k.right ≫ pushout.inl) pushout.inr (by { simp [←pushout.condition], }))
      (by tidy) }

end

end category_theory.under


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Johannes Hölzl, Simon Hudon, Kenny Lau

! This file was ported from Lean 3 source module data.multiset.functor
! leanprover-community/mathlib commit 1f0096e6caa61e9c849ec2adbd227e960e9dff58
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Multiset.Bind
import Mathlib.Control.Traversable.Lemmas
import Mathlib.Control.Traversable.Instances

/-!
# Functoriality of `Multiset`.
-/

universe u

namespace Multiset

open List

instance functor : Functor Multiset where map := @map

@[simp]
theorem fmap_def {α' β'} {s : Multiset α'} (f : α' → β') : f <$> s = s.map f :=
  rfl
#align multiset.fmap_def Multiset.fmap_def

instance : LawfulFunctor Multiset := by refine' { .. } <;> intros <;> simp ; rfl

open IsLawfulTraversable CommApplicative

variable {F : Type u → Type u} [Applicative F] [CommApplicative F]

variable {α' β' : Type u} (f : α' → F β')

/-- Map each element of a `Multiset` to an action, evaluate these actions in order,
    and collect the results.
-/
def traverse : Multiset α' → F (Multiset β') := by
  refine' Quotient.lift (Functor.map Coe.coe ∘ Traversable.traverse f) _
  introv p; unfold Function.comp
  induction p
  case nil => rfl
  case cons x l₁ l₂ _ h =>
    have :
      Multiset.cons <$> f x <*> Coe.coe <$> Traversable.traverse f l₁ =
        Multiset.cons <$> f x <*> Coe.coe <$> Traversable.traverse f l₂ := by rw [h]
    simpa [functor_norm] using this
  case swap x y l =>
    have :
      (fun a b (l : List β') ↦ (↑(a :: b :: l) : Multiset β')) <$> f y <*> f x =
        (fun a b l ↦ ↑(a :: b :: l)) <$> f x <*> f y := by
      rw [CommApplicative.commutative_map]
      congr
      funext a b l
      simpa [flip] using Perm.swap a b l
    simp [(· ∘ ·), this, functor_norm, Coe.coe]
  case trans => simp [*]
#align multiset.traverse Multiset.traverse

instance : Monad Multiset :=
  { Multiset.functor with
    pure := fun x ↦ {x}
    bind := @bind }

@[simp]
theorem pure_def {α} : (pure : α → Multiset α) = singleton :=
  rfl
#align multiset.pure_def Multiset.pure_def

@[simp]
theorem bind_def {α β} : (· >>= ·) = @bind α β :=
  rfl
#align multiset.bind_def Multiset.bind_def

instance : LawfulMonad Multiset := LawfulMonad.mk'
  (bind_pure_comp := fun _ _ ↦ by simp only [pure_def, bind_def, bind_singleton, fmap_def])
  (id_map := fun _ ↦ by simp only [fmap_def, id_eq, map_id'])
  (pure_bind := fun _ _ ↦ by simp only [pure_def, bind_def, singleton_bind])
  (bind_assoc := @bind_assoc)

open Functor

open Traversable IsLawfulTraversable

@[simp]
theorem lift_coe {α β : Type _} (x : List α) (f : List α → β)
    (h : ∀ a b : List α, a ≈ b → f a = f b) : Quotient.lift f h (x : Multiset α) = f x :=
  Quotient.lift_mk _ _ _
#align multiset.lift_coe Multiset.lift_coe

@[simp]
theorem map_comp_coe {α β} (h : α → β) :
    Functor.map h ∘ Coe.coe = (Coe.coe ∘ Functor.map h : List α → Multiset β) := by
  funext ; simp only [Function.comp_apply, Coe.coe, fmap_def, coe_map, List.map_eq_map]
#align multiset.map_comp_coe Multiset.map_comp_coe

theorem id_traverse {α : Type _} (x : Multiset α) : traverse (pure : α → Id α) x = x := by
  refine' Quotient.inductionOn x _
  intro
  simp [traverse, Coe.coe]
#align multiset.id_traverse Multiset.id_traverse

theorem comp_traverse {G H : Type _ → Type _} [Applicative G] [Applicative H] [CommApplicative G]
    [CommApplicative H] {α β γ : Type _} (g : α → G β) (h : β → H γ) (x : Multiset α) :
    traverse (Comp.mk ∘ Functor.map h ∘ g) x = Comp.mk (Functor.map (traverse h) (traverse g x)) :=
  by
  refine' Quotient.inductionOn x _
  intro
  simp only [traverse, quot_mk_to_coe, lift_coe, Coe.coe, Function.comp_apply, Functor.map_map,
    functor_norm]
  simp only [Function.comp, lift_coe]
#align multiset.comp_traverse Multiset.comp_traverse

theorem map_traverse {G : Type _ → Type _} [Applicative G] [CommApplicative G] {α β γ : Type _}
    (g : α → G β) (h : β → γ) (x : Multiset α) :
    Functor.map (Functor.map h) (traverse g x) = traverse (Functor.map h ∘ g) x := by
  refine' Quotient.inductionOn x _
  intro
  simp only [traverse, quot_mk_to_coe, lift_coe, Function.comp_apply, Functor.map_map, map_comp_coe]
  rw [LawfulFunctor.comp_map, Traversable.map_traverse']
  rfl
#align multiset.map_traverse Multiset.map_traverse

theorem traverse_map {G : Type _ → Type _} [Applicative G] [CommApplicative G] {α β γ : Type _}
    (g : α → β) (h : β → G γ) (x : Multiset α) : traverse h (map g x) = traverse (h ∘ g) x := by
  refine' Quotient.inductionOn x _
  intro
  simp only [traverse, quot_mk_to_coe, coe_map, lift_coe, Function.comp_apply]
  rw [← Traversable.traverse_map h g, List.map_eq_map]
#align multiset.traverse_map Multiset.traverse_map

theorem naturality {G H : Type _ → Type _} [Applicative G] [Applicative H] [CommApplicative G]
    [CommApplicative H] (eta : ApplicativeTransformation G H) {α β : Type _} (f : α → G β)
    (x : Multiset α) : eta (traverse f x) = traverse (@eta _ ∘ f) x := by
  refine' Quotient.inductionOn x _
  intro
  simp only [quot_mk_to_coe, traverse, lift_coe, Function.comp_apply,
    ApplicativeTransformation.preserves_map, IsLawfulTraversable.naturality]
#align multiset.naturality Multiset.naturality

end Multiset


import data.finsupp.basic

section

/-- An inductive type from which to index the variables of the mv_polynomials the proof manages -/
@[derive decidable_eq]
inductive vars : Type
| α : vars
| β : vars

lemma finsupp_vars_eq_ext (f g : vars →₀ ℕ) : f = g ↔
  f vars.α = g vars.α ∧ f vars.β = g vars.β :=
begin
  rw finsupp.ext_iff,
  split,
    {
      intro h,
      split, exact h vars.α,
      exact h vars.β,
    },
    {
      intro h,
      intro a,
      induction a,
      finish,
      finish,
    },
  -- induction,
end

end


import ..mcrl2_encap.mcrl2_encap
import ..transition.sum

open mcrl2

variable {α : Type}
variable [comm_semigroup_with_zero α]
variable {β : Type}

/- The proofs of the mcrl2 axioms for the quotient. -/
lemma mcrl2'.sum_idem {x : mcrl2 α} {D : set β} (h : ∃d, d ∈ D) :
sum D (λa, x) ≈ x := by exact R_add_congr (transition.sum_idem D h x)

lemma mcrl2'.sum_elem {f : β → mcrl2 α} {D : set β} {d} (h : d ∈ D) :
sum D f ≈ sum D f + f d := by exact R_add_congr (transition.sum_elem D f d h)

lemma mcrl2'.sum_alt  {f g : β → mcrl2 α} {D : set β} :
sum D (λa, f a + g a) ≈ sum D f + sum D g := by exact R_add_congr (transition.sum_alt D f g)

lemma mcrl2'.sum_seq {f : β → mcrl2 α} {x D} :
sum D f ⬝ x ≈ sum D (λa, f a ⬝ x) := by exact R_add_congr (transition.sum_seq D f x)

lemma mcrl2'.sum_parl {f : β → mcrl2 α} {x D} :
sum D f |_ x ≈ sum D (λa, f a |_ x) := by exact R_add_congr (transition.sum_parl D f x)

lemma mcrl2'.sum_comm {f : β → mcrl2 α} {x D} :
sum D f ∣ x ≈ sum D (λa, f a ∣ x) := by exact R_add_congr (transition.sum_comm D f x)

lemma mcrl2'.comm_sum {f : β → mcrl2 α} {x D} :
x ∣ sum D f  ≈ sum D (λa, x ∣ f a) := by exact R_add_congr (transition.comm_sum D f x)

lemma mcrl2'.encap_sum {f : β → mcrl2 α} {H D} :
encap H (sum D f) ≈ sum D (λa, encap H (f a)) := by exact R_add_congr (transition.encap_sum H D f)

inductive R_sum_ext {f g : β → mcrl2 α} {D : set β} (R_α : ∀a, a ∈ D → mcrl2 α → mcrl2 α → Prop) :
mcrl2 α → mcrl2 α → Prop
| R {x y a ha} (h : R_α a ha x y) : R_sum_ext x y
| basel : R_sum_ext (sum D f) (sum D g)
| baser : R_sum_ext (sum D g) (sum D f)
| refl {x} : R_sum_ext x x

lemma R_sum_ext_refl  {f g : β → mcrl2 α} {D : set β} (R_α : ∀a, a ∈ D → mcrl2 α → mcrl2 α → Prop) :
reflexive (@R_sum_ext α _ β f g D R_α) :=
begin
  intro x,
  apply R_sum_ext.refl
end

lemma R_sum_ext.symm  {f g : β → mcrl2 α} {D : set β} (R_α : ∀a, a ∈ D → mcrl2 α → mcrl2 α → Prop)
(R_α_symm : ∀a ha, symmetric (R_α a ha)) :
symmetric (@R_sum_ext α _ β f g D R_α) :=
begin
  intros x y h,
  cases h,
  { apply R_sum_ext.R,
    apply R_α_symm _ _,
    assumption},
  { exact R_sum_ext.baser},
  { exact R_sum_ext.basel},
  { assumption}
end

lemma mcrl2'.sum_ext {f g : β → mcrl2 α} {D : set β} (h : ∀d, d ∈ D → f d ≈ g d) :
sum D f ≈ sum D g :=
begin
  choose R R₁x R_bisim using h,
  apply exists.intro (R_sum_ext R),
  apply and.intro,
  exact R_sum_ext.basel,
  apply and.intro,
  { intros x y x' a h₁ h₂,
    cases h₁,
    { have h : ∃y', transition y a y' ∧ option.rel (R h₁_a h₁_ha) x' y',
      by exact bisim_lift (R_bisim _ _) h₁_h h₂,
      rcases h with ⟨w, haw, hRw⟩,
      apply exists.intro w,
      apply and.intro haw,
      apply option.rel.mono _ hRw,
      intros x y,
      exact R_sum_ext.R},
    { cases h₂,
      simp [transition.sum_iff, ← exists_and_distrib_right, and_assoc],
      have h : ∃y', transition (g h₂_a') a y' ∧ option.rel (R h₂_a' h₂_ha') x' y',
      by exact bisim_lift (R_bisim _ _) (R₁x _ _) h₂_h,
      rcases h with ⟨w, haw, hRw⟩,
      exact ⟨w, h₂_a', h₂_ha', haw, begin
        apply option.rel.mono _ hRw,
        intros x y,
        exact R_sum_ext.R
      end⟩},
    { cases h₂,
      simp [transition.sum_iff, ← exists_and_distrib_right, and_assoc],
      have h : ∃y', transition (f h₂_a') a y' ∧ option.rel (R h₂_a' h₂_ha') x' y',
      by exact bisim_lift (R_bisim _ _) ((R_bisim _ _).right (R₁x _ _)) h₂_h,
      rcases h with ⟨w, haw, hRw⟩,
      exact ⟨w, h₂_a', h₂_ha', haw, begin
        apply option.rel.mono _ hRw,
        intros x y,
        exact R_sum_ext.R
      end⟩},
    { exact ⟨x', h₂, by exact option.rel.refl (R_sum_ext_refl R)⟩}},
  { choose R_bisim R_symm using R_bisim,
    exact R_sum_ext.symm R R_symm}
end


meta def hello := con

namespace floaties
/- I added a `float` VM component. -/
    open native
    meta def x : float := 199
    #eval -x ^ (3 : float)
    #eval (199 / 400 : float) -- outputs 0.4975
    #eval ((23.45 : float) = (23.45 : float) : bool)

end floaties
∀  ∀l  αll
variables {α β : Type}
meta def Y {α : Type} : (α → α) → α | f := f (Y f)

universes u v

#eval to_string $ expr.subst ( (expr.var 1)) ```(nat.succ 0)

#eval to_string $ expr.is_internal_cnstr $ (expr.lam `hello binder_info.default (expr.var 1) $ expr.app (expr.app (expr.var 5) (expr.var 3)) `(4))

#eval to_string $ (expr.instantiate_var (expr.app (expr.var 5) (expr.var 2435)) `(1))
def e := Π a : Type u, Π b : Type v, a × b
#check e
#eval to_string $ expr.collect_univ_params $ expr.reflect e

#eval @undefined_core nat "wtf"

namespace hidden

definition cong (a b m : ℤ) : Prop := ∃ n : ℤ, b - a = m * n

notation a ` ≡ ` b ` mod ` m  := cong a b m
set_option trace.simplify true
theorem cong_refl (m : ℤ) : ∀ a : ℤ, a ≡ a mod m :=
begin
intro a,
unfold cong,
existsi (0:ℤ),
simp
end

meta def trace_simp_lemmas : tactic unit :=
do
    l ← tactic.get_simp_lemmas_or_default none,
    str ← simp_lemmas.pp l,
    tactic.trace str

example : true := begin trace_simp_lemmas, trivial  end

namespace my_namespace
    constant X : Type u
    constants x y : X
    constant f : X → X
    constants  (P : X → Prop) (Q : Prop)
    /--Hello world-/
    axiom my_axiom : ∀ (a:X) (p : P(a)) (q:Q), Q
    #check my_axiom
    #check expr.mvar
    meta def scratch_tac : tactic unit := do
        -- a ← tactic.resolve_name `my_axiom >>= tactic.to_expr,
        -- l ← tactic.apply_core a {},
        -- g ← tactic.target,
        -- tactic.set_tag g [`hello.world],
        -- e ← tactic.head_eta_expand a,
        -- tactic.trace e,
        tactic.mk_fresh_name >>= tactic.trace,
        pure()

    example : Q :=
    begin
        scratch_tac,
        scratch_tac,
        scratch_tac,
        scratch_tac,
        tactic.rotate_left 1,
        sorry
    end
    example : true := begin
        tactic.add_doc_string `nat "my dumb axiom is great at breaking maths yay.",
        tactic.doc_string `nat >>= tactic.trace,
        trivial
    end
    #check nat
section scratch

end scratch
end my_namespace

end hidden

example (P : α → Prop) (Q : Prop) (h₁ : ∃ x, P(x)) (h₂ : ∀ x, P(x) → Q) : Q :=
begin
    cases h₁,
    apply h₂ _, assumption
end

example : ∀ (n : nat), n = n :=
begin
  intro,
  induction n,
end

namespace field_idea_auto_param
    -- eventually a sophisticated tactic that figures out if an elt is ≠ 0
    meta def nz_tactic := tactic.assumption
    class dvr (R : Type u) extends (ring R) :=
    (inv(x:R) (p:x ≠ 0):  R)
    (inv_l : Π (x y : R) (p:y≠0), x * (inv y p)  = 1 )
    variables {R : Type u} [dvr R]
    def inv (y : R) (nz : y ≠ 0 . nz_tactic) : R := dvr.inv y nz

    def div (x y : R) (nz : y ≠ 0 . nz_tactic) : R := x * (inv y)
    infix ` /. `:50 := div

    variables {x y : R}
    variable (xz : x ≠ 0 . nz_tactic) -- I was really hoping that this would be allowed

    example (x y : R) (xz : x ≠ 0) (yz : y ≠ 0) : (1 /. (x * y)) = (1 /. x) * (1 /. y) := sorry

end field_idea_auto_param

namespace field_idea_class
    class my_division_ring (R : Type u) extends (integral_domain R) :=
    (inv : Π(x:R) [x ≠ 0],  R)
    (inv_l (x : R) [nz:x ≠ 0] : x * (@inv x nz)  = 1 )
    (inv_r (x : R) [nz:x ≠ 0] : (@inv x nz) * x  = 1 )

    variables {R : Type u} [my_division_ring R]
    def inv (y : R) [nz:y ≠ 0] : R := @my_division_ring.inv _ _ y nz

    def div (x y : R) [y ≠ 0] : R := x * (inv y)
    infix ` ÷ `:50 := div

    variables {x y : R} [x ≠ 0] [y ≠ 0]
    def asdf : ((x * y) ≠ 0) := mul_ne_zero ‹x ≠ 0› ‹y ≠ 0›

    example : (1 ÷ (x * y)) = (1 ÷ x) * (1 ÷ y) := sorry
    -- calc (1 ÷ (x * y)) = inv(x * y) * 1 : by sorry
    --      ...           = inv(x * y) * (x * inv(x)) * (y * inv(y)) : by sorry
    --      ...           = (inv(x * y) * (x * y)) * (inv(x) * inv(y)) : by ac_refl
    --      ...           = 1 * (1 * inv(x)) * (1 * inv(y)) : by sorry
    --      ...           = (1 ÷ x) * (1 ÷ y) : by sorry

end field_idea_class


import Structure.Generic.Axioms.Universes
import Structure.Generic.Axioms.AbstractFunctors
import Structure.Generic.Axioms.AbstractEquivalences
import Structure.Generic.Lemmas.DerivedFunctors
import Structure.Generic.Notation

set_option autoBoundImplicitLocal false
--set_option pp.universes true

universes u v

def GeneralizedProperty (α : Sort u) (V : Universe.{v}) := α → V

namespace GeneralizedProperty

  variable {α : Sort u} {V : Universe.{v}}

  instance hasInstances : HasInstances (GeneralizedProperty α V) := ⟨λ P => ∀ a, P a⟩

  section Properties

    variable (P : GeneralizedProperty α V)

    class HasInst where
    (inst (a : α) : P a)

  end Properties

end GeneralizedProperty

open GeneralizedProperty

-- TODO: Update comments

-- We want to formalize a very general "structure with equivalences", so we start with a very basic
-- abstraction for something that looks like an equivalence relation except that the codomain is
-- generalized to `Sort u` instead of `Prop`. Therefore, `⟨Equiv.refl, Equiv.symm, Equiv.trans⟩`, where
-- `Equiv` is the Lean 4 version of the `equiv` type in Lean 3 mathlib, is also an instance of this type
-- (with the restriction that both arguments must live in the same universe).
--
-- We actually need to generalize slightly further to a codomain that is not necessarily a sort but can be
-- coerced to a sort. This way, the codomain can be any Lean structure that bundles a sort, in particular
-- it can be our `Structure` type.

def GeneralizedRelation (α : Sort u) (V : Universe.{v}) := α → α → V

namespace GeneralizedRelation

  variable {α : Sort u} {V : Universe.{v}}

  instance hasInstances : HasInstances (GeneralizedRelation α V) := ⟨λ R => ∀ a b, R a b⟩

  section Properties

    variable (R : GeneralizedRelation α V)

    class HasRefl where
    (refl (a : α) : R a a)

    variable [HasInternalFunctors V]

    class HasTrans where
    (trans {a b c : α} : R a b ⟶ R b c ⟶ R a c)

    class IsPreorder extends HasRefl R, HasTrans R

    variable [HasInternalEquivalences V]

    class HasSymm where
    (symm {a b : α} : R a b ⟷ R b a)

    class IsEquivalence extends IsPreorder R, HasSymm R

  end Properties

  def HasTrans.revTrans {R : GeneralizedRelation α V} [HasInternalFunctors V] [HasLinearFunOp V] [h : HasTrans R]
                        {a b c : α} : R b c ⟶ R a b ⟶ R a c :=
  HasLinearFunOp.swapFunFun h.trans

  @[simp] theorem HasTrans.revTrans.eff {R : GeneralizedRelation α V} [HasInternalFunctors V] [HasLinearFunOp V] [h : HasTrans R]
                                        {a b c : α} (g : R b c) (f : R a b) :
    h.revTrans g f = h.trans f g :=
  by apply HasLinearFunOp.swapFunFun.effEff

  def HasTrans.trans' {R : GeneralizedRelation α V} [HasInternalFunctors V] [h : HasTrans R]
                      {a b c : α} (f : R a b) (g : R b c) : R a c := h.trans f g

  def HasSymm.symm' {R : GeneralizedRelation α V} [HasInternalFunctors V] [HasInternalEquivalences V] [h : HasSymm R]
                    {a b : α} (f : R a b) : R b a := HasInternalEquivalences.to h.symm f

  -- When reasoning about instances of `R a b`, we would like to write `trans` as composition, `refl` as
  -- identity, and `symm` as inverse.
  -- Note that `R` can be inferred from `f : R a b` by elaboration.

  section Notation

    @[reducible] def revComp {R : GeneralizedRelation α V} [HasInternalFunctors V] [h : HasTrans R] {a b c : α} (g : R b c) (f : R a b) : R a c := h.trans' f g
    infixr:90 " • " => revComp

    @[reducible] def ident (R : GeneralizedRelation α V) [h : HasRefl R] (a : α) : R a a := h.refl a

    @[reducible] def inv {R : GeneralizedRelation α V} [HasInternalFunctors V] [HasInternalEquivalences V] [h : HasSymm R] {a b : α} (f : R a b) : R b a := h.symm' f
    postfix:max "⁻¹" => inv

  end Notation

end GeneralizedRelation

open GeneralizedRelation

-- We can attach products, arrows, and/or equivalences to a given sort, in the form of generalized
-- relations satisfying appropriate properties.

section AttachedRelations

  variable (α : Sort u) (V : Universe.{v}) [HasInternalFunctors V]

  class HasArrows where
  (Arrow      : GeneralizedRelation α V)
  [isPreorder : IsPreorder Arrow]

  namespace HasArrows
    variable [h : HasArrows α V]
    instance arrowPreorder : IsPreorder h.Arrow := h.isPreorder
    instance hasArrow : HasArrow α α := ⟨h.Arrow⟩
    instance : HasInstances (HasArrow.γ α α) := Universe.instInst V
    instance : IsPreorder (@HasArrow.Arrow α α (hasArrow α V)) := h.isPreorder
  end HasArrows

  variable [HasInternalEquivalences V]

  class HasEquivalences where
  (Equiv   : GeneralizedRelation α V)
  [isEquiv : IsEquivalence Equiv]

  namespace HasEquivalences
    variable [h : HasEquivalences α V]
    instance equivEquivalence : IsEquivalence h.Equiv := h.isEquiv
    instance hasEquivalence : HasEquivalence α α := ⟨h.Equiv⟩
    instance : HasInstances (HasEquivalence.γ α α) := Universe.instInst V
    instance : IsEquivalence (@HasEquivalence.Equiv α α (hasEquivalence α V)) := h.isEquiv
  end HasEquivalences

  class HasProducts where
  (Product : GeneralizedRelation α V)
  [hasSymm : HasSymm Product]

  namespace HasProducts
    variable [h : HasProducts α V]
    instance productSymm : HasSymm h.Product := h.hasSymm
    instance hasProduct : HasProduct α α := ⟨h.Product⟩
    instance : HasInstances (HasProduct.γ α α) := Universe.instInst V
    instance : HasSymm (@HasProduct.Product α α (hasProduct α V)) := h.hasSymm
  end HasProducts

end AttachedRelations