import number_theory.bernoulli

--OUTPUT 1
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  apply nat.strong_induction_on n,
  assume d hd,
  have h1 : (d + 1) * (1 + x)^d - (d + 1) * x^d =
            (d + 1) * (1 + x)^d - (d + 1) * x^d,
  {
    rw add_comm,
    ring,
  },
  have h2 : (d + 1) * (1 + x)^d - (d + 1) * x^d =
            (d + 1) * ((1 + x)^d - x^d),
  {
    ring,
  },
  rw h2,
  clear h2,
  have h3 : (1 + x)^d = x^d + d * x^(d - 1) + (↑d : ℚ) * x^d,
  {
    rw hd,
    ring,
  },
  rw h3,
  have h4 : (d + 1) * ((1 + x)^d - x^d) = (d + 1) * (x^d + d * x^(d - 1) + (↑d : ℚ) * x^d - x^d),
  {
    ring,
  },
  rw h4,
  clear h4,
  rw ←polynomial.eval_sum,
  {
    have h5 : (d + 1) * (x^d + d * x^(d - 1) + (↑d : ℚ) * x^d - x^d) =
              (d + 1) * (x^d + d * x^(d - 1)) + (d + 1) * (↑d : ℚ) * x^d - (d + 1) * x^d,
    {
      ring,
    },
    rw h5,
    clear h5,
    have h6 : (d + 1) * (x^d + d * x^(d - 1)) + (d + 1) * (↑d : ℚ) * x^d - (d + 1) * x^d =
              (d + 1) * (x^d + d * x^(d - 1)) + (d + 1) * (↑d : ℚ) * x^d - (d + 1) * x^d,
    {
      ring,
    },
    rw h6,
    clear h6,
    have h7 : (d + 1) * (x^d + d * x^(d - 1)) + (d + 1) * (↑d : ℚ) * x^d - (d + 1) * x^d =
              (d + 1) * (x^d + d * x^(d - 1)) + (d + 1) * (↑d : ℚ) * x^d - (d + 1) * x^d,
    {
      ring,
    },
    rw h7,
    clear h7,
    have h8 : (d + 1) * (x^d + d * x^(d - 1)) + (d + 1) * (↑d : ℚ) * x^d - (d + 1) * x^d =
              (d + 1) * (x^d + d * x^(d - 1)) + (d + 1) * (↑d : ℚ) * x^d - (d + 1) * x^d,
    {
      ring,
    },
    rw h8,
    clear h8,
    have h9 : (d + 1) * (x^d + d * x^(d - 1)) + (d + 1) * (↑d : ℚ) * x^d - (d + 1) * x^d =
              (d + 1) * (x^d + d * x^(d - 1)) + (d + 1) * (↑d : ℚ) * x^d - (d + 1) * x^d,
    {
      ring,
    },
    rw h9,
    clear h9,
    have h10 : (d + 1) * (x^d + d * x^(d - 1)) + (d + 1) * (↑d : ℚ) * x^d - (d + 1) * x^d =
              (d + 1) * (x^d + d * x^(d - 1)) + (d + 1) * (↑d : ℚ) * x^d - (d + 1) * x^d,
    {
      ring,
    },
    rw h10,
    clear h10,
    have h11 : (d + 1) * (x^d + d * x^(d - 1)) + (d + 1) * (↑d : ℚ) * x^d - (d + 1) * x^d =
              (d + 1) * (x^d + d * x^(d - 1)) + (d + 1) * (↑d : ℚ) * x^d - (d + 1) * x^d,
    {
      ring,
    },
    rw h11,
    clear h11,
    have h12 : (d + 1) * (x^d + d * x^(d - 1)) + (d + 1) * (↑d : ℚ) * x^d - (d + 1) * x^d =
              (d + 1) * (x^d + d * x^(d - 1)) + (d + 1) * (↑d : ℚ) * x^d - (d + 1) * x^d,
    {
      ring,
    },
    rw h12,
    clear h12,
    have h13 : (d + 1) * (x^d + d * x^(d - 1)) + (d + 1) * (↑d : ℚ) * x^d - (d + 1) * x^d =
              (d + 1) * (x^d + d * x^(d - 1)) + (d + 1) * (↑d : ℚ) * x^d - (d + 1) * x^d,
    {
      ring,
    },
    rw h13,
    clear h13,
    have h14 : (d + 1) * (x^d + d * x^(d - 1)) + (d + 1) * (↑d : ℚ) * x^d - (d + 1) * x^d =
              (d + 1) * (x^d + d * x^(d - 1)) + (d + 1) * (↑d : ℚ) * x^d - (d + 1) * x^d,
    {
      ring,
    },
    rw h14,
    clear h14,
    have h15 : (d + 1) * (x^d + d * x^(d - 1)) + (d + 1) * (↑d : ℚ) * x^d - (d + 1) * x^d =
              (d + 1) * (x^d + d * x^(d - 1)) + (d + 1) * (↑d : ℚ) * x^d - (d + 1) * x^d,
    {
      ring,
    },
    rw h15,
    clear h15,
    have h16 : (d + 1) * (x^d + d * x^(d - 1)) + (d + 1) * (↑d : ℚ) * x^d - (d + 1) * x^d =
              (d + 1) * (x^d + d * x^(d - 1)) + (d + 1) * (↑d : ℚ) * x^d - (d + 1) * x^d,
    {
      ring,
    },
    rw h16,
    clear h16,
    have h17 : (d + 1) * (x^d + d * x^(d - 1)) + (d + 1) * (↑d : ℚ) * x^d - (d + 1) * x^d =
              (d + 1) * (x^d + d * x^(d - 1)) + (d + 1) * (↑d : ℚ) * x^d - (d
end --Needs more than 2000 tokens!

--OUTPUT 2
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  have h1 : ∀ m : ℕ, m < n → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from
    assume (m : ℕ) (hm : m < n),
    begin
      induction m with hm hih,
      { rw [polynomial.bernoulli,eval_C,add_zero,add_zero], },
      { rw [polynomial.bernoulli,eval_C,add_zero,add_zero],
        exact hih hm,
      }
    end,
  have h2 : ∀ l : ℕ, (polynomial.bernoulli l).eval 1 = l, from
    assume (l : ℕ), (polynomial.bernoulli l).eval 1,
  have h3 : ∀ l : ℕ, (polynomial.bernoulli l).eval x = 0, from
    assume (l : ℕ), (polynomial.bernoulli l).eval x,
  have h4 : ∀ l : ℕ, (polynomial.bernoulli l).eval (1 + x) = (polynomial.bernoulli l).eval 1 + (polynomial.bernoulli l).eval x, from
    assume (l : ℕ), (polynomial.bernoulli l).eval (1 + x),
  have h5 : ∀ l : ℕ, (polynomial.bernoulli l).eval (1 + x) = (polynomial.bernoulli l).eval 1, from
    assume (l : ℕ), eq.trans (h4 l) (add_zero (polynomial.bernoulli l).eval 1),
  have h6 : ∀ l : ℕ, (polynomial.bernoulli l).eval (1 + x) = l, from
    assume (l : ℕ), eq.trans (h5 l) (h2 l),
  have h7 : ∀ l : ℕ, (polynomial.bernoulli l).eval (1 + x) = (polynomial.bernoulli l).eval x, from
    assume (l : ℕ), eq.trans (h4 l) (add_zero (polynomial.bernoulli l).eval x),
  have h8 : ∀ l : ℕ, (polynomial.bernoulli l).eval (1 + x) = 0, from
    assume (l : ℕ), eq.trans (h7 l) (h3 l),
  have h9 : ∀ l : ℕ, (polynomial.bernoulli l).eval (1 + x) = (polynomial.bernoulli l).eval x + l * x^(l - 1), from
    assume (l : ℕ), eq.trans (h4 l) (add_mul  (polynomial.bernoulli l).eval 1 x (l - 1)),
  have h10 : ∀ l : ℕ, (polynomial.bernoulli l).eval (1 + x) = l * x^(l - 1), from
    assume (l : ℕ), eq.trans (h9 l) (add_right_cancel (polynomial.bernoulli l).eval x),
  have h11 : ∀ l : ℕ, (polynomial.bernoulli l).eval (1 + x) = l * x^(l - 1), from
    assume (l : ℕ), by {rw [← h6 l,← h8 l], ring},

  have h12 : (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1), from
    by {rw [← h11 n, ← mul_one (polynomial.bernoulli n).eval (1 + x), ← add_mul (polynomial.bernoulli n).eval 1 x (n - 1)], ring},
  show (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1), from
    by {rw [← h4 n, ← add_mul (polynomial.bernoulli n).eval 1 x (n - 1)], ring},
end

--OUTPUT 3
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  -- use strong induction
  apply nat.strong_induction_on n,
  assume (d : ℕ) (ih : ∀ m : ℕ, m < d → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1)),
  have h1 : ∀ l : ℕ, (d + 1) * (1 + x)^l - (d + 1) * x^l = ∑ k in finset.range (l + 1), (l + 1) * (finset.nat_fintype.choose k d) * x^k, from assume (l : ℕ),
    calc
    (d + 1) * (1 + x)^l - (d + 1) * x^l = (d + 1) * ∑ k in finset.range (l + 1), (finset.nat_fintype.choose k l) * x^k : by rw polynomial.eval_sum (1 + x) l
    ... = ∑ k in finset.range (l + 1), (d + 1) * (finset.nat_fintype.choose k l) * x^k : by rw ← finset.sum_mul_distrib
    ... = ∑ k in finset.range (l + 1), (finset.nat_fintype.choose k l) * ((d + 1) * x^k) : by rw finset.sum_mul_distrib
    ... = ∑ k in finset.range (l + 1), (finset.nat_fintype.choose k d) * ((d + 1) * x^k) : by {rw finset.nat_fintype.choose_succ, rw finset.nat_fintype.choose_zero},
  have h2 : ∀ l : ℕ, ∑ k in finset.range (l + 1), (l + 1) * (finset.nat_fintype.choose k d) * x^k = ∑ k in finset.range (l + 1), (l + 1) * k * (finset.nat_fintype.choose k (d - 1)) * x^(k - 1), from assume (l : ℕ),
    calc
    ∑ k in finset.range (l + 1), (l + 1) * (finset.nat_fintype.choose k d) * x^k = ∑ k in finset.range (l + 1), (l + 1) * (finset.nat_fintype.choose k d) * x^(k - 1 + 1) : by rw finset.sum_mul_distrib
    ... = ∑ k in finset.range (l + 1), (l + 1) * (finset.nat_fintype.choose k d) * x^(k - 1) * x : by rw finset.sum_mul_distrib
    ... = ∑ k in finset.range (l + 1), (l + 1) * x^(k - 1) * (finset.nat_fintype.choose k d) * x : by rw finset.sum_mul_distrib
    ... = ∑ k in finset.range (l + 1), (l + 1) * x^(k - 1) * (finset.nat_fintype.choose (k - 1) d) * x : by rw finset.nat_fintype.choose_succ
    ... = ∑ k in finset.range (l + 1), (l + 1) * x^(k - 1) * (finset.nat_fintype.choose (k - 1) (d - 1)) * x : by rw finset.nat_fintype.choose_succ
    ... = ∑ k in finset.range (l + 1), (l + 1) * k * (finset.nat_fintype.choose (k - 1) (d - 1)) * x^(k - 1) : by rw finset.nat_fintype.choose_zero,
  have h3 : ∀ l : ℕ, ∑ k in finset.range (l + 1), (l + 1) * k * (finset.nat_fintype.choose k (d - 1)) * x^(k - 1) = ∑ k in finset.range (l + 1), (l + 1) * (finset.nat_fintype.choose k (d - 1)) * (k * x^(k - 1)), from assume (l : ℕ),
    calc
    ∑ k in finset.range (l + 1), (l + 1) * k * (finset.nat_fintype.choose k (d - 1)) * x^(k - 1) = ∑ k in finset.range (l + 1), (l + 1) * (finset.nat_fintype.choose k (d - 1)) * (k * x^(k - 1)) : by rw finset.sum_mul_distrib,
  have h4 : ∀ l : ℕ, ∑ k in finset.range (l + 1), (l + 1) * (finset.nat_fintype.choose k (d - 1)) * (k * x^(k - 1)) = ∑ k in finset.range (l + 1), (l + 1) * k * (finset.nat_fintype.choose k (d - 1)) * x^(k - 1), from assume (l : ℕ),
    calc
    ∑ k in finset.range (l + 1), (l + 1) * (finset.nat_fintype.choose k (d - 1)) * (k * x^(k - 1)) = ∑ k in finset.range (l + 1), (l + 1) * (finset.nat_fintype.choose k (d - 1)) * x^(k - 1) * k : by rw finset.sum_mul_distrib
    ... = ∑ k in finset.range (l + 1), (l + 1) * k * (finset.nat_fintype.choose k (d - 1)) * x^(k - 1) : by rw finset.sum_mul_distrib,
  have h5 : ∀ l : ℕ, ∑ k in finset.range (l + 1), (l + 1) * (finset.nat_fintype.choose k (d - 1)) * (k * x^(k - 1)) = ∑ k in finset.range (l + 1), (l + 1) * (finset.nat_fintype.choose k (d - 1)) * ((k - 1 + 1) * x^(k - 1)), from assume (l : ℕ),
    calc
    ∑ k in finset.range (l + 1), (l + 1) * (finset.nat_fintype.choose k (d - 1)) * (k * x^(k - 1)) = ∑ k in finset.range (l + 1), (l + 1) * (finset.nat_fintype.choose k (d - 1)) * ((k - 1) * x^(k - 1)) + (l + 1) * (finset.nat_fintype.choose k (d - 1)) * x^(k - 1) : by rw finset.sum_distrib
    ... = ∑ k in finset.range (l + 1), (l + 1) * (finset.nat_fintype.choose k (d - 1)) * ((k - 1) * x^(k - 1)) + (l + 1) * (finset.nat_fintype.choose (k - 1) (d - 1)) * x^(k - 1) : by rw finset.nat_fintype.choose_succ
    ... = ∑ k in finset.range (l + 1), (l + 1) * (finset.nat_fintype.choose k (d - 1)) * ((k - 1) * x^(
end --Needs more than 2000 tokens!

--OUTPUT 4
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  -- strong induction
  have h : ∀ n : ℕ, ∀ x : ℚ, n < (polynomial.bernoulli n).nat_degree →
    (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1), from
      assume (n : ℕ) (x : ℚ) (h : n < (polynomial.bernoulli n).nat_degree),
      have h1 : ∀ m < n, (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from
          assume (m : ℕ) (h : m < n), show (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from
          begin
            induction m with m hm,
            show (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x + 0 * x^(0 - 1), from rfl,
            show (polynomial.bernoulli (nat.succ m)).eval (1 + x) = (polynomial.bernoulli (nat.succ m)).eval x + (nat.succ m) * x^(nat.succ m - 1), from
            begin
              rw [polynomial.bernoulli, polynomial.eval_add, polynomial.eval_add, polynomial.eval_add, polynomial.eval_add, polynomial.eval_add, polynomial.eval_add, polynomial.eval_add],
              rw [polynomial.eval_C, polynomial.eval_C, polynomial.eval_C, polynomial.eval_C, polynomial.eval_C, polynomial.eval_C, polynomial.eval_C, polynomial.eval_C, polynomial.eval_C, polynomial.eval_C, polynomial.eval_C, polynomial.eval_C, polynomial.eval_C],
              rw [polynomial.eval_X, polynomial.eval_X, polynomial.eval_X, polynomial.eval_X, polynomial.eval_X, polynomial.eval_X, polynomial.eval_X, polynomial.eval_X, polynomial.eval_X, polynomial.eval_X, polynomial.eval_X, polynomial.eval_X, polynomial.eval_X],
              rw [polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul],
              rw [polynomial.eval_add, polynomial.eval_add, polynomial.eval_add, polynomial.eval_add, polynomial.eval_add, polynomial.eval_add, polynomial.eval_add, polynomial.eval_add, polynomial.eval_add, polynomial.eval_add, polynomial.eval_add, polynomial.eval_add, polynomial.eval_add],
              rw [polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul],
              rw [polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul],
              rw [polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul],
              rw [polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul],
              rw [polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul],
              rw [polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul],
              rw [polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul],
              rw [polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul],
              rw [polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul, polynomial.eval_mul],
              rw [polynomial.eval_mul, polynomial.eval_mul, polynomial.eval
end --Needs more than 2000 tokens!

--OUTPUT 5
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  -- We apply strong induction on $n$. So, for all $m < d$, we have $B_{m} (1 + x) = B_{m} (x) + m x^{m - 1}$ and we want to show that $$B_{d} (1 + x) = B_{d} (x) + d x^{d - 1}$$
  induction n with d hd,
  { -- base case
    assume x : ℚ,
    calc (polynomial.bernoulli 0).eval (1 + x) = ((polynomial.bernoulli 0).eval 1) + x : by {
      have h1 : ∀ x : ℚ, (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval 1 + x, from by {
        assume x : ℚ,
        rw [polynomial.bernoulli,eval_add,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_C,eval_X,eval_
end --Needs more than 2000 tokens!

--OUTPUT 6
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  -- We apply strong induction on $n$.
  induction n with d hd,
  -- So, for all $m < d$, we have `B_{m} (1 + x) = B_{m} (x) + m * x^(m - 1)`
  assume h1 : ∀ (m : ℕ) (x : ℚ), m < d → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1),
  -- and we want to show that `B_{d} (1 + x) = B_{d} (x) + d * x^(d - 1)`
  have h2 : (polynomial.bernoulli d).eval (1 + x) = (polynomial.bernoulli d).eval x + d * x^(d - 1),
  -- Multiplying both sides by `d + 1`, and using the fact that, for all `l` in `ℕ`, `∑_{k = 0}^{l} {l + 1 choose k} * (polynomial.bernoulli k) = (l + 1) * X^l` (where `B_k` is the $k$-th Bernoulli number),
  begin
    -- we get that
    calc (polynomial.bernoulli d).eval (1 + x) = (polynomial.bernoulli d).eval x + d * x^(d - 1) :
    -- $$ (d + 1) (1 + x)^d - (d + 1) x^d = \sum_{l = 0}^{d} {d + 1 \choose l} l x^{l - 1} $$
    begin
      -- we get that
      have h3 : (d + 1) * (1 + x)^d - (d + 1) * x^d = ∑ (k : ℕ) in finset.range (d + 1), (d + 1) * (polynomial.choose_nat (d + 1) k) * (polynomial.bernoulli k).eval x, from
        begin
          -- we get that
          have h31 : (d + 1) * (1 + x)^d - (d + 1) * x^d = (d + 1) * (((1 + x)^d - x^d) : polynomial ℚ), from
            by { rw [← polynomial.coeff_mul_X_pow, polynomial.coeff_sub (d + 1)], ring },
          -- we get that
          have h32 : (1 + x)^d - x^d = polynomial.coeff_mul_X_pow (d + 1) (∑ (k : ℕ) in finset.range (d + 1), (polynomial.choose_nat (d + 1) k) * (polynomial.bernoulli k) : polynomial ℚ), from
            begin
              -- we get that
              have h321 : (1 + x)^d - x^d = polynomial.coeff_mul_X_pow (d + 1) (∑ (k : ℕ) in finset.range (d + 1), (polynomial.choose_nat (d + 1) k) * (polynomial.bernoulli k : polynomial ℚ)), from
                by { apply polynomial.coeff_sub (d + 1), simp [polynomial.coeff_mul_X_pow],
                rw [← polynomial.coeff_mul_X_pow, polynomial.coeff_sub (d + 1)], ring },
              -- we get that
              have h322 : (1 + x)^d - x^d = polynomial.coeff_mul_X_pow (d + 1) (∑ (k : ℕ) in finset.range (d + 1), (polynomial.choose_nat (d + 1) k) * (polynomial.bernoulli k) : polynomial ℚ), from
                begin
                  -- we get that
                  have h3221 : (1 + x)^d - x^d = polynomial.coeff_mul_X_pow (d + 1) (∑ (k : ℕ) in finset.range (d + 1), (polynomial.choose_nat (d + 1) k) * (polynomial.bernoulli k : polynomial ℚ)), from
                    by { apply polynomial.coeff_sub (d + 1), simp [polynomial.coeff_mul_X_pow],
                    rw [← polynomial.coeff_mul_X_pow, polynomial.coeff_sub (d + 1)], ring },
                  -- we get that
                  have h3222 : (1 + x)^d - x^d = polynomial.coeff_mul_X_pow (d + 1) (∑ (k : ℕ) in finset.range (d + 1), (polynomial.choose_nat (d + 1) k) * (polynomial.bernoulli k) : polynomial ℚ), from
                    begin
                      -- we get that
                      have h32221 : (1 + x)^d - x^d = polynomial.coeff_mul_X_pow (d + 1) (∑ (k : ℕ) in finset.range (d + 1), (polynomial.choose_nat (d + 1) k) * (polynomial.bernoulli k) : polynomial ℚ), from
                        by { apply polynomial.coeff_sub (d + 1), simp [polynomial.coeff_mul_X_pow],
                        rw [← polynomial.coeff_mul_X_pow, polynomial.coeff_sub (d + 1)], ring },
                      -- we get that
                      have h32222 : (1 + x)^d - x^d = polynomial.coeff_mul_X_pow (d + 1) (∑ (k : ℕ) in finset.range (d + 1), (polynomial.choose_nat (d + 1) k) * (polynomial.bernoulli k) : polynomial ℚ), from
                        begin
                          -- we get that
                          have h322221 : (1 + x)^d - x^d = polynomial.coeff_mul_X_pow (d + 1) (∑ (k : ℕ) in finset.range (d + 1), (polynomial.choose_nat (d + 1) k) * (polynomial.bernoulli k) : polynomial ℚ), from
                            by { apply polynomial.coeff_sub (d + 1), simp [polynomial.coeff_mul_X_pow],
                            rw [← polynomial.coeff_mul_X_pow, polynomial.coeff_sub (d + 1)], ring },
                          -- we get that
                          have h322222 : (1 + x)^d - x^d = polynomial.coeff_mul_X_pow (d + 1) (∑ (k : ℕ) in finset.range (d + 1), (polynomial.choose_nat (d + 1) k) * (polynomial.bernoulli k) : polynomial ℚ), from
                            begin
                              -- we get that
                              have h3222221 : (1 + x)^d - x^d = polynomial.coeff_mul_X_pow (d + 1) (∑ (k : ℕ) in finset.range (d + 1), (polynomial.choose_nat (d + 1) k) * (polynomial.bernoulli k) : polynomial ℚ), from
                                by { apply polynomial.coeff_sub (d + 1), simp [polynomial.coeff_mul_X_pow],
                                rw [← polynomial.coeff_mul_X_pow, po
end --Needs more than 2000 tokens!

--OUTPUT 7
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  -- Applying strong induction on $n$
  induction n with d hd,
  -- For $n = 0$, the conclusion is trivial.
  show (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x + 0 * x^(0 - 1),
  from by obviously,

  -- So, for all $m < d$, we have $B_{m} (1 + x) = B_{m} (x) + m x^{m - 1}$ and we want to show that $$B_{d} (1 + x) = B_{d} (x) + d x^{d - 1}$$
  assume d hd : ∀ m < d, (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1),
  have h1 : (polynomial.bernoulli d).eval (1 + x) = (polynomial.bernoulli d).eval x + d * x^(d - 1), from by {
    -- Multiplying both sides by $d + 1$,
    rw [show (d+1)*(polynomial.bernoulli d).eval (1 + x) = (d+1)*((polynomial.bernoulli d).eval x + d * x^(d - 1)),
    from eq.trans (mul_right_inj (d+1)).mp (mul_add ((polynomial.bernoulli d).eval x) (d * x^(d - 1)) (d+1)),
    show (d+1)*(polynomial.bernoulli d).eval (1 + x) = (d+1)*(polynomial.bernoulli d).eval x + (d+1)*(d * x^(d - 1)),
    from by ring,],
    -- and using the fact that, for all $l \in \mathbb{N}$, $\sum_{k = 0}^{l} {l + 1 \choose k} B_k = (l + 1) X^l$ (where $B_k$ is the $k$-th Bernoulli number), we get that
    rw [show (d+1)*(polynomial.bernoulli d).eval x + (d+1)*(d * x^(d - 1)) =
    (d+1)*((polynomial.bernoulli d).eval x + (d+1)*(d * x^(d - 1)) - (d+1)*(polynomial.bernoulli d).eval x),
    from by simp [add_mul],
    show (d+1)*((polynomial.bernoulli d).eval x + (d+1)*(d * x^(d - 1)) - (d+1)*(polynomial.bernoulli d).eval x) =
    (d+1)*(polynomial.bernoulli d).eval x + (d+1)*(d * x^(d - 1)) - (d+1)*(polynomial.bernoulli d).eval x,
    from by ring,],
    rw [show (d+1)*((polynomial.bernoulli d).eval x + (d+1)*(d * x^(d - 1)) - (polynomial.bernoulli d).eval x) =
    (d+1)*((polynomial.bernoulli d).eval x + (d+1)*(d * x^(d - 1)) - (polynomial.bernoulli d).eval x) +
    (d+1)*(polynomial.bernoulli d).eval x - (d+1)*(polynomial.bernoulli d).eval x,
    from by ring,],
    rw [show (d+1)*((polynomial.bernoulli d).eval x + (d+1)*(d * x^(d - 1)) - (polynomial.bernoulli d).eval x) =
    (d+1)*((polynomial.bernoulli d).eval x + (d+1)*(d * x^(d - 1)) - (polynomial.bernoulli d).eval x) +
    (d+1)*(polynomial.bernoulli d).eval x - (d+1)*(polynomial.bernoulli d).eval x,
    from by ring,],
    -- we get that
    -- $$ (d + 1) (1 + x)^d - (d + 1) x^d = \sum_{l = 0}^{d} {d + 1 \choose l} l x^{l - 1} $$
    rw [show (d+1)*((polynomial.bernoulli d).eval x + (d+1)*(d * x^(d - 1)) - (polynomial.bernoulli d).eval x) =
    (d+1)*(polynomial.bernoulli d).eval x - (d+1)*(polynomial.bernoulli d).eval x,
    from by ring,
    show (d+1)*(polynomial.bernoulli d).eval x - (d+1)*(polynomial.bernoulli d).eval x =
    (d+1)*(polynomial.bernoulli d).eval x + (d+1)*(d * x^(d - 1)) - (d+1)*(polynomial.bernoulli d).eval x,
    from by ring,
    show (d+1)*(polynomial.bernoulli d).eval x + (d+1)*(d * x^(d - 1)) - (d+1)*(polynomial.bernoulli d).eval x =
    (d+1)*(polynomial.bernoulli d).eval x + (d+1)*(d * x^(d - 1)) - (d+1)*(polynomial.bernoulli d).eval x,
    from by ring,
    show (d+1)*(polynomial.bernoulli d).eval x + (d+1)*(d * x^(d - 1)) - (d+1)*(polynomial.bernoulli d).eval x =
    (d+1)*((polynomial.bernoulli d).eval x + (d+1)*(d * x^(d - 1)) - (polynomial.bernoulli d).eval x),
    from by ring,],
    rw [show (polynomial.bernoulli d).eval (1 + x) = (polynomial.bernoulli d).eval x + (d+1)*(d * x^(d - 1)) - (polynomial.bernoulli d).eval x,
    from by ring,
    show (polynomial.bernoulli d).eval (1 + x) = (polynomial.bernoulli d).eval x + (d+1)*(d * x^(d - 1)),
    from by ring,],
    rw [show (polynomial.bernoulli d).eval (1 + x) = (polynomial.bernoulli d).eval x + (d+1)*(d * x^(d - 1)),
    from by ring,
    show (polynomial.bernoulli d).eval (1 + x) = (polynomial.bernoulli d).eval x + d * x^(d - 1),
    from by ring,],
  },
  show (polynomial.bernoulli (d+1)).eval (1 + x) = (polynomial.bernoulli (d+1)).eval x + (d+1) * x^(d - 1 + 1),
  from by rw [show d + 1 = (d - 1 + 1) + 1, from by ring,
    show (polynomial.bernoulli (d - 1 + 1 + 1)).eval (1 + x) = (polynomial.bernoulli (d - 1 + 1 + 1)).eval x + (d - 1 + 1 + 1) * x^(d - 1 + 1 + 1 - 1),
    from by rw [show d = d - 1 + 1, from by ring,
      show (polynomial.bernoulli (d - 1 + 1 + 1)).eval (1 + x) = (polynomial.bernoulli (d - 1 + 1 + 1)).eval x + (d - 1 + 1 + 1) * x^(d - 1 + 1),
      from
end --Needs more than 2000 tokens!

--OUTPUT 8
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  have h1 : ∀ m : ℕ, m < n → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from by {
    assume m : ℕ,
    assume hm : m < n,
    induction m with m hm,
    show (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x + 0 * x^(-1 + 0), by {
      simp,
    },
    show (polynomial.bernoulli (m + 1)).eval (1 + x) = (polynomial.bernoulli (m + 1)).eval x + (m + 1) * x^(-1 + m + 1), from by {
      simp,
      have h1 : (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from by {
        apply hm,
        apply nat.lt_succ_of_lt hm,
      },
      rw h1,
      ring,
    },
  },
  have h2 : (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1), from by {
    apply h1,
    apply nat.lt_succ_self,
  },
  show (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1), from by {
    apply h2,
  },
end

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

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

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

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

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

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

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  -- $A$ and $B$ are sets. $A$ and $B$ belong to power set of $S$
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  -- Then $A ⊆ S$ and $B ⊆ S$, by power set definition
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from by {split,apply set.subset_of_mem_powerset,exact hA,apply set.subset_of_mem_powerset,exact hB},
  -- Then $(A ∩ B) ⊆ A$, by intersection of set is a subset
  have h2 : (A ∩ B) ⊆ A, from by apply set.inter_subset_left,
  -- Then $(A ∩ B) ⊆ S$, by subset relation is transitive
  have h3 : (A ∩ B) ⊆ S, from by {apply set.subset.trans h2 h1.left},
  -- Hence $(A ∩ B) ∈  𝒫 S$, by power set definition
  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
  -- expand the power
  calc (x + y)^2 = (x+y)*(x+y) : by rw sq
  -- distributive property of multiplication over addition gives:
  ... = x*(x+y) + y*(x+y) : by rw add_mul
  -- applying the above property further gives:
  ... = 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}
  -- rearranging the terms using commutativity and adding gives:
  ... = 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
  -- Group has Latin Square Property
  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, },

  -- Setting $b = a$, this becomes:
  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,

  -- These $x$ and $y$ are both $(1 : G)$, by definition of identity element
  have h5 : ∀ a : G, classical.some (h3 a).exists = (1 : G), from 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`
Bernoulli polynomial evaluation
Given a natural number $n$ and a rational $x$, let $B_n (x)$ denote the $n$-th Bernoulli polynomial evaluated at $x$. Then, $$B_n (1 + x) = B_n (x) + n x^{n - 1}$$
`proof`
We apply strong induction on $n$. So, for all $m < d$, we have $B_{m} (1 + x) = B_{m} (x) + m x^{m - 1}$ and we want to show that $$B_{d} (1 + x) = B_{d} (x) + d x^{d - 1}$$
Multiplying both sides by $d + 1$, and using the fact that, for all $l \in \mathbb{N}$, $\sum_{k = 0}^{l} {l + 1 \choose k} B_k = (l + 1) X^l$ (where $B_k$ is the $k$-th Bernoulli number), we get that
$$ (d + 1) (1 + x)^d - (d + 1) x^d = \sum_{l = 0}^{d} {d + 1 \choose l} l x^{l - 1} $$
The conclusion then follows easily.

QED

-/
theorem  bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
FEW SHOT PROMPTS TO CODEX(END)-/


/-
Copyright (c) 2022 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson

! This file was ported from Lean 3 source module model_theory.ultraproducts
! leanprover-community/mathlib commit f1ae620609496a37534c2ab3640b641d5be8b6f0
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.ModelTheory.Quotients
import Mathbin.Order.Filter.Germ
import Mathbin.Order.Filter.Ultrafilter

/-! # Ultraproducts and Łoś's Theorem

## Main Definitions
* `first_order.language.ultraproduct.Structure` is the ultraproduct structure on `filter.product`.

## Main Results
* Łoś's Theorem: `first_order.language.ultraproduct.sentence_realize`. An ultraproduct models a
sentence `φ` if and only if the set of structures in the product that model `φ` is in the
ultrafilter.

## Tags
ultraproduct, Los's theorem

-/

universe u v

variable {α : Type _} (M : α → Type _) (u : Ultrafilter α)

open FirstOrder Filter

open Filter

namespace FirstOrder

namespace Language

open Structure

variable {L : Language.{u, v}} [∀ a, L.Structure (M a)]

namespace Ultraproduct

instance setoidPrestructure : L.Prestructure ((u : Filter α).productSetoid M) :=
  {
    (u : Filter α).productSetoid
      M with
    toStructure :=
      { funMap := fun n f x a => funMap f fun i => x i a
        rel_map := fun n r x => ∀ᶠ a : α in u, RelMap r fun i => x i a }
    fun_equiv := fun n f x y xy =>
      by
      refine' mem_of_superset (Inter_mem.2 xy) fun a ha => _
      simp only [Set.mem_interᵢ, Set.mem_setOf_eq] at ha
      simp only [Set.mem_setOf_eq, ha]
    rel_equiv := fun n r x y xy => by
      rw [← iff_eq_eq]
      refine' ⟨fun hx => _, fun hy => _⟩
      · refine' mem_of_superset (inter_mem hx (Inter_mem.2 xy)) _
        rintro a ⟨ha1, ha2⟩
        simp only [Set.mem_interᵢ, Set.mem_setOf_eq] at *
        rw [← funext ha2]
        exact ha1
      · refine' mem_of_superset (inter_mem hy (Inter_mem.2 xy)) _
        rintro a ⟨ha1, ha2⟩
        simp only [Set.mem_interᵢ, Set.mem_setOf_eq] at *
        rw [funext ha2]
        exact ha1 }
#align first_order.language.ultraproduct.setoid_prestructure FirstOrder.Language.Ultraproduct.setoidPrestructure

variable {M} {u}

instance structure : L.Structure ((u : Filter α).product M) :=
  Language.quotientStructure
#align first_order.language.ultraproduct.Structure FirstOrder.Language.Ultraproduct.structure

theorem funMap_cast {n : ℕ} (f : L.Functions n) (x : Fin n → ∀ a, M a) :
    (funMap f fun i => (x i : (u : Filter α).product M)) = fun a => funMap f fun i => x i a := by
  apply fun_map_quotient_mk
#align first_order.language.ultraproduct.fun_map_cast FirstOrder.Language.Ultraproduct.funMap_cast

theorem term_realize_cast {β : Type _} (x : β → ∀ a, M a) (t : L.term β) :
    (t.realize fun i => (x i : (u : Filter α).product M)) = fun a => t.realize fun i => x i a :=
  by
  convert@term.realize_quotient_mk L _ ((u : Filter α).productSetoid M)
      (ultraproduct.setoid_prestructure M u) _ t x
  ext a
  induction t
  · rfl
  · simp only [term.realize, t_ih]
    rfl
#align first_order.language.ultraproduct.term_realize_cast FirstOrder.Language.Ultraproduct.term_realize_cast

variable [∀ a : α, Nonempty (M a)]

theorem boundedFormula_realize_cast {β : Type _} {n : ℕ} (φ : L.BoundedFormula β n)
    (x : β → ∀ a, M a) (v : Fin n → ∀ a, M a) :
    (φ.realize (fun i : β => (x i : (u : Filter α).product M)) fun i => v i) ↔
      ∀ᶠ a : α in u, φ.realize (fun i : β => x i a) fun i => v i a :=
  by
  letI := (u : Filter α).productSetoid M
  induction' φ with _ _ _ _ _ _ _ _ m _ _ ih ih' k φ ih
  · simp only [bounded_formula.realize, eventually_const]
  · have h2 : ∀ a : α, (Sum.elim (fun i : β => x i a) fun i => v i a) = fun i => Sum.elim x v i a :=
      fun a => funext fun i => Sum.casesOn i (fun i => rfl) fun i => rfl
    simp only [bounded_formula.realize, (Sum.comp_elim coe x v).symm, h2, term_realize_cast]
    exact Quotient.eq''
  · have h2 : ∀ a : α, (Sum.elim (fun i : β => x i a) fun i => v i a) = fun i => Sum.elim x v i a :=
      fun a => funext fun i => Sum.casesOn i (fun i => rfl) fun i => rfl
    simp only [bounded_formula.realize, (Sum.comp_elim coe x v).symm, term_realize_cast, h2]
    exact rel_map_quotient_mk _ _
  · simp only [bounded_formula.realize, ih v, ih' v]
    rw [Ultrafilter.eventually_imp]
  · simp only [bounded_formula.realize]
    trans
      ∀ m : ∀ a : α, M a,
        φ.realize (fun i : β => (x i : (u : Filter α).product M))
          (Fin.snoc (coe ∘ v) (↑m : (u : Filter α).product M))
    · exact forall_quotient_iff
    have h' :
      ∀ (m : ∀ a, M a) (a : α),
        (fun i : Fin (k + 1) => (Fin.snoc v m : _ → ∀ a, M a) i a) =
          Fin.snoc (fun i : Fin k => v i a) (m a) :=
      by
      refine' fun m a => funext (Fin.reverseInduction _ fun i hi => _)
      · simp only [Fin.snoc_last]
      · simp only [Fin.snoc_cast_succ]
    simp only [← Fin.comp_snoc, ih, h']
    refine' ⟨fun h => _, fun h m => _⟩
    · contrapose! h
      simp_rw [← Ultrafilter.eventually_not, not_forall] at h
      refine'
        ⟨fun a : α =>
          Classical.epsilon fun m : M a =>
            ¬φ.realize (fun i => x i a) (Fin.snoc (fun i => v i a) m),
          _⟩
      rw [← Ultrafilter.eventually_not]
      exact Filter.mem_of_superset h fun a ha => Classical.epsilon_spec ha
    · rw [Filter.eventually_iff] at *
      exact Filter.mem_of_superset h fun a ha => ha (m a)
#align first_order.language.ultraproduct.bounded_formula_realize_cast FirstOrder.Language.Ultraproduct.boundedFormula_realize_cast

theorem realize_formula_cast {β : Type _} (φ : L.Formula β) (x : β → ∀ a, M a) :
    (φ.realize fun i => (x i : (u : Filter α).product M)) ↔
      ∀ᶠ a : α in u, φ.realize fun i => x i a :=
  by
  simp_rw [formula.realize, ← bounded_formula_realize_cast φ x, iff_eq_eq]
  exact congr rfl (Subsingleton.elim _ _)
#align first_order.language.ultraproduct.realize_formula_cast FirstOrder.Language.Ultraproduct.realize_formula_cast

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- Łoś's Theorem : A sentence is true in an ultraproduct if and only if the set of structures it is
  true in is in the ultrafilter. -/
theorem sentence_realize (φ : L.Sentence) : (u : Filter α).product M ⊨ φ ↔ ∀ᶠ a : α in u, M a ⊨ φ :=
  by
  simp_rw [sentence.realize, ← realize_formula_cast φ, iff_eq_eq]
  exact congr rfl (Subsingleton.elim _ _)
#align first_order.language.ultraproduct.sentence_realize FirstOrder.Language.Ultraproduct.sentence_realize

instance : Nonempty ((u : Filter α).product M) :=
  letI : ∀ a, Inhabited (M a) := fun _ => Classical.inhabited_of_nonempty'
  instNonempty

end Ultraproduct

end Language

end FirstOrder


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot, Scott Morrison, Mario Carneiro, Andrew Yang
-/
import topology.category.Top.epi_mono
import category_theory.category.ulift
import category_theory.limits.concrete_category
import category_theory.concrete_category.elementwise

/-!
# The category of topological spaces has all limits and colimits

Further, these limits and colimits are preserved by the forgetful functor --- that is, the
underlying types are just the limits in the category of types.
-/

open topological_space
open category_theory
open category_theory.limits
open opposite

universes u v w

noncomputable theory

namespace Top

variables {J : Type v} [small_category J]

local notation `forget` := forget Top

/--
A choice of limit cone for a functor `F : J ⥤ Top`.
Generally you should just use `limit.cone F`, unless you need the actual definition
(which is in terms of `types.limit_cone`).
-/
def limit_cone (F : J ⥤ Top.{max v u}) : cone F :=
{ X := Top.of {u : Π j : J, F.obj j | ∀ {i j : J} (f : i ⟶ j), F.map f (u i) = u j},
  π :=
  { app := λ j,
    { to_fun := λ u, u.val j,
      continuous_to_fun := show continuous ((λ u : Π j : J, F.obj j, u j) ∘ subtype.val),
        by continuity } } }

/--
A choice of limit cone for a functor `F : J ⥤ Top` whose topology is defined as an
infimum of topologies infimum.
Generally you should just use `limit.cone F`, unless you need the actual definition
(which is in terms of `types.limit_cone`).
-/
def limit_cone_infi (F : J ⥤ Top.{max v u}) : cone F :=
{ X := ⟨(types.limit_cone (F ⋙ forget)).X, ⨅j,
        (F.obj j).str.induced ((types.limit_cone (F ⋙ forget)).π.app j)⟩,
  π :=
  { app := λ j, ⟨(types.limit_cone (F ⋙ forget)).π.app j,
                 continuous_iff_le_induced.mpr (infi_le _ _)⟩,
    naturality' := λ j j' f, continuous_map.coe_injective
      ((types.limit_cone (F ⋙ forget)).π.naturality f) } }

/--
The chosen cone `Top.limit_cone F` for a functor `F : J ⥤ Top` is a limit cone.
Generally you should just use `limit.is_limit F`, unless you need the actual definition
(which is in terms of `types.limit_cone_is_limit`).
-/
def limit_cone_is_limit (F : J ⥤ Top.{max v u}) : is_limit (limit_cone F) :=
{ lift := λ S, { to_fun := λ x, ⟨λ j, S.π.app _ x, λ i j f, by { dsimp, erw ← S.w f, refl }⟩ },
  uniq' := λ S m h, by { ext : 3, simpa [← h] } }

/--
The chosen cone `Top.limit_cone_infi F` for a functor `F : J ⥤ Top` is a limit cone.
Generally you should just use `limit.is_limit F`, unless you need the actual definition
(which is in terms of `types.limit_cone_is_limit`).
-/
def limit_cone_infi_is_limit (F : J ⥤ Top.{max v u}) : is_limit (limit_cone_infi F) :=
by { refine is_limit.of_faithful forget (types.limit_cone_is_limit _) (λ s, ⟨_, _⟩) (λ s, rfl),
     exact continuous_iff_coinduced_le.mpr (le_infi $ λ j,
       coinduced_le_iff_le_induced.mp $ (continuous_iff_coinduced_le.mp (s.π.app j).continuous :
         _) ) }

instance Top_has_limits_of_size : has_limits_of_size.{v} Top.{max v u} :=
{ has_limits_of_shape := λ J 𝒥, by exactI
  { has_limit := λ F, has_limit.mk { cone := limit_cone F, is_limit := limit_cone_is_limit F } } }

instance Top_has_limits : has_limits Top.{u} := Top.Top_has_limits_of_size.{u u}

instance forget_preserves_limits_of_size :
  preserves_limits_of_size.{v v} (forget : Top.{max v u} ⥤ Type (max v u)) :=
{ preserves_limits_of_shape := λ J 𝒥,
  { preserves_limit := λ F,
    by exactI preserves_limit_of_preserves_limit_cone
      (limit_cone_is_limit F) (types.limit_cone_is_limit (F ⋙ forget)) } }

instance forget_preserves_limits : preserves_limits (forget : Top.{u} ⥤ Type u) :=
Top.forget_preserves_limits_of_size.{u u}

/--
A choice of colimit cocone for a functor `F : J ⥤ Top`.
Generally you should just use `colimit.coone F`, unless you need the actual definition
(which is in terms of `types.colimit_cocone`).
-/
def colimit_cocone (F : J ⥤ Top.{max v u}) : cocone F :=
{ X := ⟨(types.colimit_cocone (F ⋙ forget)).X, ⨆ j,
        (F.obj j).str.coinduced ((types.colimit_cocone (F ⋙ forget)).ι.app j)⟩,
  ι :=
  { app := λ j, ⟨(types.colimit_cocone (F ⋙ forget)).ι.app j,
                 continuous_iff_coinduced_le.mpr (le_supr _ j)⟩,
    naturality' := λ j j' f, continuous_map.coe_injective
      ((types.colimit_cocone (F ⋙ forget)).ι.naturality f) } }

/--
The chosen cocone `Top.colimit_cocone F` for a functor `F : J ⥤ Top` is a colimit cocone.
Generally you should just use `colimit.is_colimit F`, unless you need the actual definition
(which is in terms of `types.colimit_cocone_is_colimit`).
-/
def colimit_cocone_is_colimit (F : J ⥤ Top.{max v u}) : is_colimit (colimit_cocone F) :=
by { refine is_colimit.of_faithful forget (types.colimit_cocone_is_colimit _) (λ s, ⟨_, _⟩)
       (λ s, rfl),
     exact continuous_iff_le_induced.mpr (supr_le $ λ j,
       coinduced_le_iff_le_induced.mp $ (continuous_iff_coinduced_le.mp (s.ι.app j).continuous :
         _) ) }

instance Top_has_colimits_of_size : has_colimits_of_size.{v} Top.{max v u} :=
{ has_colimits_of_shape := λ J 𝒥, by exactI
  { has_colimit := λ F, has_colimit.mk { cocone := colimit_cocone F, is_colimit :=
    colimit_cocone_is_colimit F } } }

instance Top_has_colimits : has_colimits Top.{u} := Top.Top_has_colimits_of_size.{u u}

instance forget_preserves_colimits_of_size :
  preserves_colimits_of_size.{v v} (forget : Top.{max v u} ⥤ Type (max v u)) :=
{ preserves_colimits_of_shape := λ J 𝒥,
  { preserves_colimit := λ F,
    by exactI preserves_colimit_of_preserves_colimit_cocone
      (colimit_cocone_is_colimit F) (types.colimit_cocone_is_colimit (F ⋙ forget)) } }

instance forget_preserves_colimits : preserves_colimits (forget : Top.{u} ⥤ Type u) :=
Top.forget_preserves_colimits_of_size.{u u}

/-- The projection from the product as a bundled continous map. -/
abbreviation pi_π {ι : Type v} (α : ι → Top.{max v u}) (i : ι) : Top.of (Π i, α i) ⟶ α i :=
⟨λ f, f i, continuous_apply i⟩

/-- The explicit fan of a family of topological spaces given by the pi type. -/
@[simps X π_app]
def pi_fan {ι : Type v} (α : ι → Top.{max v u}) : fan α :=
fan.mk (Top.of (Π i, α i)) (pi_π α)

/-- The constructed fan is indeed a limit -/
def pi_fan_is_limit {ι : Type v} (α : ι → Top.{max v u}) : is_limit (pi_fan α) :=
{ lift := λ S, { to_fun := λ s i, S.π.app ⟨i⟩ s },
  uniq' := by { intros S m h, ext x i, simp [← h ⟨i⟩] },
  fac' := λ s j, by { cases j, tidy, }, }

/--
The product is homeomorphic to the product of the underlying spaces,
equipped with the product topology.
-/
def pi_iso_pi {ι : Type v} (α : ι → Top.{max v u}) : ∏ α ≅ Top.of (Π i, α i) :=
(limit.is_limit _).cone_point_unique_up_to_iso (pi_fan_is_limit α)

@[simp, reassoc]
lemma pi_iso_pi_inv_π {ι : Type v} (α : ι → Top.{max v u}) (i : ι) :
  (pi_iso_pi α).inv ≫ pi.π α i = pi_π α i :=
by simp [pi_iso_pi]

@[simp]
lemma pi_iso_pi_inv_π_apply {ι : Type v} (α : ι → Top.{max v u}) (i : ι) (x : Π i, α i) :
  (pi.π α i : _) ((pi_iso_pi α).inv x) = x i :=
concrete_category.congr_hom (pi_iso_pi_inv_π α i) x

@[simp]
lemma pi_iso_pi_hom_apply {ι : Type v} (α : ι → Top.{max v u}) (i : ι) (x : ∏ α) :
  (pi_iso_pi α).hom x i = (pi.π α i : _) x :=
begin
  have := pi_iso_pi_inv_π α i,
  rw iso.inv_comp_eq at this,
  exact concrete_category.congr_hom this x
end

/-- The inclusion to the coproduct as a bundled continous map. -/
abbreviation sigma_ι {ι : Type v} (α : ι → Top.{max v u}) (i : ι) : α i ⟶ Top.of (Σ i, α i) :=
⟨sigma.mk i⟩

/-- The explicit cofan of a family of topological spaces given by the sigma type. -/
@[simps X ι_app]
def sigma_cofan {ι : Type v} (α : ι → Top.{max v u}) : cofan α :=
cofan.mk (Top.of (Σ i, α i)) (sigma_ι α)

/-- The constructed cofan is indeed a colimit -/
def sigma_cofan_is_colimit {ι : Type v} (α : ι → Top.{max v u}) : is_colimit (sigma_cofan α) :=
{ desc := λ S, { to_fun := λ s, S.ι.app ⟨s.1⟩ s.2,
    continuous_to_fun := continuous_sigma $ λ i, map_continuous (S.ι.app ⟨i⟩) },
  uniq' := by { intros S m h,  ext ⟨i, x⟩, simp [← h ⟨i⟩] },
  fac' := λ s j, by { cases j, tidy, }, }

/--
The coproduct is homeomorphic to the disjoint union of the topological spaces.
-/
def sigma_iso_sigma {ι : Type v} (α : ι → Top.{max v u}) : ∐ α ≅ Top.of (Σ i, α i) :=
(colimit.is_colimit _).cocone_point_unique_up_to_iso (sigma_cofan_is_colimit α)

@[simp, reassoc]
lemma sigma_iso_sigma_hom_ι {ι : Type v} (α : ι → Top.{max v u}) (i : ι) :
  sigma.ι α i ≫ (sigma_iso_sigma α).hom = sigma_ι α i :=
by simp [sigma_iso_sigma]

@[simp]
lemma sigma_iso_sigma_hom_ι_apply {ι : Type v} (α : ι → Top.{max v u}) (i : ι) (x : α i) :
  (sigma_iso_sigma α).hom ((sigma.ι α i : _) x) = sigma.mk i x :=
concrete_category.congr_hom (sigma_iso_sigma_hom_ι α i) x

@[simp]
lemma sigma_iso_sigma_inv_apply {ι : Type v} (α : ι → Top.{max v u}) (i : ι) (x : α i) :
  (sigma_iso_sigma α).inv ⟨i, x⟩ = (sigma.ι α i : _) x :=
by { rw [← sigma_iso_sigma_hom_ι_apply, ← comp_app], simp, }

lemma induced_of_is_limit {F : J ⥤ Top.{max v u}} (C : cone F) (hC : is_limit C) :
  C.X.topological_space = ⨅ j, (F.obj j).topological_space.induced (C.π.app j) :=
begin
  let homeo := homeo_of_iso (hC.cone_point_unique_up_to_iso (limit_cone_infi_is_limit F)),
  refine homeo.inducing.induced.trans _,
  change induced homeo (⨅ (j : J), _) = _,
  simpa [induced_infi, induced_compose],
end

lemma limit_topology (F : J ⥤ Top.{max v u}) :
  (limit F).topological_space = ⨅ j, (F.obj j).topological_space.induced (limit.π F j) :=
induced_of_is_limit _ (limit.is_limit F)

section prod

/-- The first projection from the product. -/
abbreviation prod_fst {X Y : Top.{u}} : Top.of (X × Y) ⟶ X := ⟨prod.fst⟩

/-- The second projection from the product. -/
abbreviation prod_snd {X Y : Top.{u}} : Top.of (X × Y) ⟶ Y := ⟨prod.snd⟩

/-- The explicit binary cofan of `X, Y` given by `X × Y`. -/
def prod_binary_fan (X Y : Top.{u}) : binary_fan X Y :=
binary_fan.mk prod_fst prod_snd

/-- The constructed binary fan is indeed a limit -/
def prod_binary_fan_is_limit (X Y : Top.{u}) : is_limit (prod_binary_fan X Y) :=
{ lift := λ (S : binary_fan X Y), { to_fun := λ s, (S.fst s, S.snd s) },
  fac' := begin
    rintros S (_|_),
    tidy
  end,
  uniq' := begin
    intros S m h,
    ext x,
    { specialize h ⟨walking_pair.left⟩,
      apply_fun (λ e, (e x)) at h,
      exact h },
     { specialize h ⟨walking_pair.right⟩,
      apply_fun (λ e, (e x)) at h,
      exact h },
  end }

/--
The homeomorphism between `X ⨯ Y` and the set-theoretic product of `X` and `Y`,
equipped with the product topology.
-/
def prod_iso_prod (X Y : Top.{u}) : X ⨯ Y ≅ Top.of (X × Y) :=
(limit.is_limit _).cone_point_unique_up_to_iso (prod_binary_fan_is_limit X Y)

@[simp, reassoc] lemma prod_iso_prod_hom_fst (X Y : Top.{u}) :
  (prod_iso_prod X Y).hom ≫ prod_fst = limits.prod.fst :=
by simpa [← iso.eq_inv_comp, prod_iso_prod]

@[simp, reassoc] lemma prod_iso_prod_hom_snd (X Y : Top.{u}) :
  (prod_iso_prod X Y).hom ≫ prod_snd = limits.prod.snd :=
by simpa [← iso.eq_inv_comp, prod_iso_prod]

@[simp] lemma prod_iso_prod_hom_apply {X Y : Top.{u}} (x : X ⨯ Y) :
  (prod_iso_prod X Y).hom x =
    ((limits.prod.fst : X ⨯ Y ⟶ _) x, (limits.prod.snd : X ⨯ Y ⟶ _) x) :=
begin
  ext,
  { exact concrete_category.congr_hom (prod_iso_prod_hom_fst X Y) x },
  { exact concrete_category.congr_hom (prod_iso_prod_hom_snd X Y) x }
end

@[simp, reassoc, elementwise] lemma prod_iso_prod_inv_fst (X Y : Top.{u}) :
  (prod_iso_prod X Y).inv ≫ limits.prod.fst = prod_fst :=
by simp [iso.inv_comp_eq]

@[simp, reassoc, elementwise] lemma prod_iso_prod_inv_snd (X Y : Top.{u}) :
  (prod_iso_prod X Y).inv ≫ limits.prod.snd = prod_snd :=
by simp [iso.inv_comp_eq]

lemma prod_topology {X Y : Top} :
  (X ⨯ Y).topological_space =
    induced (limits.prod.fst : X ⨯ Y ⟶ _) X.topological_space ⊓
      induced (limits.prod.snd : X ⨯ Y ⟶ _) Y.topological_space :=
begin
  let homeo := homeo_of_iso (prod_iso_prod X Y),
  refine homeo.inducing.induced.trans _,
  change induced homeo (_ ⊓ _) = _,
  simpa [induced_compose]
end

lemma range_prod_map {W X Y Z : Top.{u}} (f : W ⟶ Y) (g : X ⟶ Z) :
  set.range (limits.prod.map f g) =
    (limits.prod.fst : Y ⨯ Z ⟶ _) ⁻¹' (set.range f) ∩
      (limits.prod.snd : Y ⨯ Z ⟶ _) ⁻¹' (set.range g) :=
begin
  ext,
  split,
  { rintros ⟨y, rfl⟩,
    simp only [set.mem_preimage, set.mem_range, set.mem_inter_iff, ←comp_apply],
    simp only [limits.prod.map_fst, limits.prod.map_snd,
      exists_apply_eq_apply, comp_apply, and_self] },
  { rintros ⟨⟨x₁, hx₁⟩, ⟨x₂, hx₂⟩⟩,
    use (prod_iso_prod W X).inv (x₁, x₂),
    apply concrete.limit_ext,
    rintro ⟨⟨⟩⟩,
    { simp only [← comp_apply, category.assoc], erw limits.prod.map_fst, simp [hx₁] },
    { simp only [← comp_apply, category.assoc], erw limits.prod.map_snd, simp [hx₂] } }
end

lemma inducing_prod_map {W X Y Z : Top} {f : W ⟶ X} {g : Y ⟶ Z}
  (hf : inducing f) (hg : inducing g) : inducing (limits.prod.map f g) :=
begin
  constructor,
  simp only [prod_topology, induced_compose, ←coe_comp, limits.prod.map_fst, limits.prod.map_snd,
    induced_inf],
  simp only [coe_comp],
  rw [← @induced_compose _ _ _ _ _ f, ← @induced_compose _ _ _ _ _ g, ← hf.induced, ← hg.induced]
end

lemma embedding_prod_map {W X Y Z : Top} {f : W ⟶ X} {g : Y ⟶ Z}
  (hf : embedding f) (hg : embedding g) : embedding (limits.prod.map f g) :=
⟨inducing_prod_map hf.to_inducing hg.to_inducing,
begin
  haveI := (Top.mono_iff_injective _).mpr hf.inj,
  haveI := (Top.mono_iff_injective _).mpr hg.inj,
  exact (Top.mono_iff_injective _).mp infer_instance
end⟩

end prod

section pullback

variables {X Y Z : Top.{u}}

/-- The first projection from the pullback. -/
abbreviation pullback_fst (f : X ⟶ Z) (g : Y ⟶ Z) : Top.of { p : X × Y // f p.1 = g p.2 } ⟶ X :=
⟨prod.fst ∘ subtype.val⟩

/-- The second projection from the pullback. -/
abbreviation pullback_snd (f : X ⟶ Z) (g : Y ⟶ Z) : Top.of { p : X × Y // f p.1 = g p.2 } ⟶ Y :=
⟨prod.snd ∘ subtype.val⟩

/-- The explicit pullback cone of `X, Y` given by `{ p : X × Y // f p.1 = g p.2 }`. -/
def pullback_cone (f : X ⟶ Z) (g : Y ⟶ Z) : pullback_cone f g :=
pullback_cone.mk (pullback_fst f g) (pullback_snd f g) (by { ext ⟨x, h⟩, simp [h] })

/-- The constructed cone is a limit. -/
def pullback_cone_is_limit (f : X ⟶ Z) (g : Y ⟶ Z) :
  is_limit (pullback_cone f g) := pullback_cone.is_limit_aux' _
begin
  intro s,
  split, swap,
  exact { to_fun := λ x, ⟨⟨s.fst x, s.snd x⟩,
    by simpa using concrete_category.congr_hom s.condition x⟩ },
  refine ⟨_,_,_⟩,
  { ext, delta pullback_cone, simp },
  { ext, delta pullback_cone, simp },
  { intros m h₁ h₂,
    ext x,
    { simpa using concrete_category.congr_hom h₁ x },
    { simpa using concrete_category.congr_hom h₂ x } }
end

/-- The pullback of two maps can be identified as a subspace of `X × Y`. -/
def pullback_iso_prod_subtype (f : X ⟶ Z) (g : Y ⟶ Z) :
  pullback f g ≅ Top.of { p : X × Y // f p.1 = g p.2 } :=
(limit.is_limit _).cone_point_unique_up_to_iso (pullback_cone_is_limit f g)

@[simp, reassoc] lemma pullback_iso_prod_subtype_inv_fst (f : X ⟶ Z) (g : Y ⟶ Z) :
  (pullback_iso_prod_subtype f g).inv ≫ pullback.fst = pullback_fst f g :=
by simpa [pullback_iso_prod_subtype]

@[simp] lemma pullback_iso_prod_subtype_inv_fst_apply (f : X ⟶ Z) (g : Y ⟶ Z)
  (x : { p : X × Y // f p.1 = g p.2 }) :
  (pullback.fst : pullback f g ⟶ _) ((pullback_iso_prod_subtype f g).inv x) = (x : X × Y).fst :=
concrete_category.congr_hom (pullback_iso_prod_subtype_inv_fst f g) x

@[simp, reassoc] lemma pullback_iso_prod_subtype_inv_snd (f : X ⟶ Z) (g : Y ⟶ Z) :
  (pullback_iso_prod_subtype f g).inv ≫ pullback.snd = pullback_snd f g :=
by simpa [pullback_iso_prod_subtype]

@[simp] lemma pullback_iso_prod_subtype_inv_snd_apply (f : X ⟶ Z) (g : Y ⟶ Z)
  (x : { p : X × Y // f p.1 = g p.2 }) :
  (pullback.snd : pullback f g ⟶ _) ((pullback_iso_prod_subtype f g).inv x) = (x : X × Y).snd :=
concrete_category.congr_hom (pullback_iso_prod_subtype_inv_snd f g) x

lemma pullback_iso_prod_subtype_hom_fst (f : X ⟶ Z) (g : Y ⟶ Z) :
  (pullback_iso_prod_subtype f g).hom ≫ pullback_fst f g = pullback.fst :=
by rw [←iso.eq_inv_comp, pullback_iso_prod_subtype_inv_fst]

lemma pullback_iso_prod_subtype_hom_snd (f : X ⟶ Z) (g : Y ⟶ Z) :
  (pullback_iso_prod_subtype f g).hom ≫ pullback_snd f g = pullback.snd :=
by rw [←iso.eq_inv_comp, pullback_iso_prod_subtype_inv_snd]

@[simp] lemma pullback_iso_prod_subtype_hom_apply {f : X ⟶ Z} {g : Y ⟶ Z}
  (x : pullback f g) : (pullback_iso_prod_subtype f g).hom x =
    ⟨⟨(pullback.fst : pullback f g ⟶ _) x, (pullback.snd : pullback f g ⟶ _) x⟩,
      by simpa using concrete_category.congr_hom pullback.condition x⟩ :=
begin
  ext,
  exacts [concrete_category.congr_hom (pullback_iso_prod_subtype_hom_fst f g) x,
    concrete_category.congr_hom (pullback_iso_prod_subtype_hom_snd f g) x]
end

lemma pullback_topology {X Y Z : Top.{u}} (f : X ⟶ Z) (g : Y ⟶ Z) :
  (pullback f g).topological_space =
    induced (pullback.fst : pullback f g ⟶ _) X.topological_space ⊓
      induced (pullback.snd : pullback f g ⟶ _) Y.topological_space :=
begin
  let homeo := homeo_of_iso (pullback_iso_prod_subtype f g),
  refine homeo.inducing.induced.trans _,
  change induced homeo (induced _ (_ ⊓ _)) = _,
  simpa [induced_compose]
end

lemma range_pullback_to_prod {X Y Z : Top} (f : X ⟶ Z) (g : Y ⟶ Z) :
  set.range (prod.lift pullback.fst pullback.snd : pullback f g ⟶ X ⨯ Y) =
  { x | (limits.prod.fst ≫ f) x = (limits.prod.snd ≫ g) x } :=
begin
  ext x,
  split,
  { rintros ⟨y, rfl⟩,
    simp only [←comp_apply, set.mem_set_of_eq],
    congr' 1,
    simp [pullback.condition] },
  { intro h,
    use (pullback_iso_prod_subtype f g).inv ⟨⟨_, _⟩, h⟩,
    apply concrete.limit_ext,
    rintro ⟨⟨⟩⟩; simp, }
end

lemma inducing_pullback_to_prod {X Y Z : Top} (f : X ⟶ Z) (g : Y ⟶ Z) :
  inducing ⇑(prod.lift pullback.fst pullback.snd : pullback f g ⟶ X ⨯ Y) :=
⟨by simp [prod_topology, pullback_topology, induced_compose, ←coe_comp]⟩

lemma embedding_pullback_to_prod {X Y Z : Top} (f : X ⟶ Z) (g : Y ⟶ Z) :
  embedding ⇑(prod.lift pullback.fst pullback.snd : pullback f g ⟶ X ⨯ Y) :=
⟨inducing_pullback_to_prod f g, (Top.mono_iff_injective _).mp infer_instance⟩

/-- If the map `S ⟶ T` is mono, then there is a description of the image of `W ×ₛ X ⟶ Y ×ₜ Z`. -/
lemma range_pullback_map {W X Y Z S T : Top} (f₁ : W ⟶ S) (f₂ : X ⟶ S)
  (g₁ : Y ⟶ T) (g₂ : Z ⟶ T) (i₁ : W ⟶ Y) (i₂ : X ⟶ Z) (i₃ : S ⟶ T) [H₃ : mono i₃]
  (eq₁ : f₁ ≫ i₃ = i₁ ≫ g₁) (eq₂ : f₂ ≫ i₃ = i₂ ≫ g₂) :
  set.range (pullback.map f₁ f₂ g₁ g₂ i₁ i₂ i₃ eq₁ eq₂) =
    (pullback.fst : pullback g₁ g₂ ⟶ _) ⁻¹' (set.range i₁) ∩
      (pullback.snd : pullback g₁ g₂ ⟶ _) ⁻¹' (set.range i₂) :=
begin
  ext,
  split,
  { rintro ⟨y, rfl⟩, simp, },
  rintros ⟨⟨x₁, hx₁⟩, ⟨x₂, hx₂⟩⟩,
  have : f₁ x₁ = f₂ x₂,
  { apply (Top.mono_iff_injective _).mp H₃,
    simp only [←comp_apply, eq₁, eq₂],
    simp only [comp_apply, hx₁, hx₂],
    simp only [←comp_apply, pullback.condition] },
  use (pullback_iso_prod_subtype f₁ f₂).inv ⟨⟨x₁, x₂⟩, this⟩,
  apply concrete.limit_ext,
  rintros (_|_|_),
  { simp only [Top.comp_app, limit.lift_π_apply, category.assoc, pullback_cone.mk_π_app_one,
      hx₁, pullback_iso_prod_subtype_inv_fst_apply, subtype.coe_mk],
    simp only [← comp_apply],
    congr,
    apply limit.w _ walking_cospan.hom.inl },
  { simp [hx₁] },
  { simp [hx₂] },
end

lemma pullback_fst_range {X Y S : Top} (f : X ⟶ S) (g : Y ⟶ S) :
  set.range (pullback.fst : pullback f g ⟶ _) = { x : X | ∃ y : Y, f x = g y} :=
begin
  ext x,
  split,
  { rintro ⟨y, rfl⟩,
    use (pullback.snd : pullback f g ⟶ _) y,
    exact concrete_category.congr_hom pullback.condition y },
  { rintro ⟨y, eq⟩,
    use (Top.pullback_iso_prod_subtype f g).inv ⟨⟨x, y⟩, eq⟩,
    simp },
end

lemma pullback_snd_range {X Y S : Top} (f : X ⟶ S) (g : Y ⟶ S) :
  set.range (pullback.snd : pullback f g ⟶ _) = { y : Y | ∃ x : X, f x = g y} :=
begin
  ext y,
  split,
  { rintro ⟨x, rfl⟩,
    use (pullback.fst : pullback f g ⟶ _) x,
    exact concrete_category.congr_hom pullback.condition x },
  { rintro ⟨x, eq⟩,
    use (Top.pullback_iso_prod_subtype f g).inv ⟨⟨x, y⟩, eq⟩,
    simp },
end

/--
If there is a diagram where the morphisms `W ⟶ Y` and `X ⟶ Z` are embeddings,
then the induced morphism `W ×ₛ X ⟶ Y ×ₜ Z` is also an embedding.

  W  ⟶  Y
    ↘      ↘
      S  ⟶  T
    ↗      ↗
  X  ⟶  Z
-/
lemma pullback_map_embedding_of_embeddings {W X Y Z S T : Top}
  (f₁ : W ⟶ S) (f₂ : X ⟶ S) (g₁ : Y ⟶ T) (g₂ : Z ⟶ T) {i₁ : W ⟶ Y} {i₂ : X ⟶ Z}
  (H₁ : embedding i₁) (H₂ : embedding i₂) (i₃ : S ⟶ T)
  (eq₁ : f₁ ≫ i₃ = i₁ ≫ g₁) (eq₂ : f₂ ≫ i₃ = i₂ ≫ g₂) :
  embedding (pullback.map f₁ f₂ g₁ g₂ i₁ i₂ i₃ eq₁ eq₂) :=
begin
  refine embedding_of_embedding_compose (continuous_map.continuous_to_fun _)
    (show continuous (prod.lift pullback.fst pullback.snd : pullback g₁ g₂ ⟶ Y ⨯ Z), from
      continuous_map.continuous_to_fun _) _,
  suffices : embedding
    (prod.lift pullback.fst pullback.snd ≫ limits.prod.map i₁ i₂ : pullback f₁ f₂ ⟶ _),
  { simpa [←coe_comp] using this },
  rw coe_comp,
  refine embedding.comp (embedding_prod_map H₁ H₂)
    (embedding_pullback_to_prod _ _)
end

/--
If there is a diagram where the morphisms `W ⟶ Y` and `X ⟶ Z` are open embeddings, and `S ⟶ T`
is mono, then the induced morphism `W ×ₛ X ⟶ Y ×ₜ Z` is also an open embedding.
  W  ⟶  Y
    ↘      ↘
      S  ⟶  T
    ↗       ↗
  X  ⟶  Z
-/
lemma pullback_map_open_embedding_of_open_embeddings {W X Y Z S T : Top}
  (f₁ : W ⟶ S) (f₂ : X ⟶ S) (g₁ : Y ⟶ T) (g₂ : Z ⟶ T) {i₁ : W ⟶ Y} {i₂ : X ⟶ Z}
  (H₁ : open_embedding i₁) (H₂ : open_embedding i₂) (i₃ : S ⟶ T) [H₃ : mono i₃]
  (eq₁ : f₁ ≫ i₃ = i₁ ≫ g₁) (eq₂ : f₂ ≫ i₃ = i₂ ≫ g₂) :
  open_embedding (pullback.map f₁ f₂ g₁ g₂ i₁ i₂ i₃ eq₁ eq₂) :=
begin
  split,
  { apply pullback_map_embedding_of_embeddings
      f₁ f₂ g₁ g₂ H₁.to_embedding H₂.to_embedding i₃ eq₁ eq₂ },
  { rw range_pullback_map,
    apply is_open.inter; apply continuous.is_open_preimage,
    continuity,
    exacts [H₁.open_range, H₂.open_range] }
end

lemma snd_embedding_of_left_embedding {X Y S : Top}
  {f : X ⟶ S} (H : embedding f) (g : Y ⟶ S) :
  embedding ⇑(pullback.snd : pullback f g ⟶ Y) :=
begin
  convert (homeo_of_iso (as_iso (pullback.snd : pullback (𝟙 S) g ⟶ _))).embedding.comp
    (pullback_map_embedding_of_embeddings f g (𝟙 _) g H
      (homeo_of_iso (iso.refl _)).embedding (𝟙 _) rfl (by simp)),
  erw ←coe_comp,
  simp
end

lemma fst_embedding_of_right_embedding {X Y S : Top}
  (f : X ⟶ S) {g : Y ⟶ S} (H : embedding g) :
  embedding ⇑(pullback.fst : pullback f g ⟶ X) :=
begin
  convert (homeo_of_iso (as_iso (pullback.fst : pullback f (𝟙 S) ⟶ _))).embedding.comp
    (pullback_map_embedding_of_embeddings f g f (𝟙 _)
      (homeo_of_iso (iso.refl _)).embedding H (𝟙 _) rfl (by simp)),
  erw ←coe_comp,
  simp
end

lemma embedding_of_pullback_embeddings {X Y S : Top}
  {f : X ⟶ S} {g : Y ⟶ S} (H₁ : embedding f) (H₂ : embedding g) :
  embedding (limit.π (cospan f g) walking_cospan.one) :=
begin
  convert H₂.comp (snd_embedding_of_left_embedding H₁ g),
  erw ←coe_comp,
  congr,
  exact (limit.w _ walking_cospan.hom.inr).symm
end

lemma snd_open_embedding_of_left_open_embedding {X Y S : Top}
  {f : X ⟶ S} (H : open_embedding f) (g : Y ⟶ S) :
  open_embedding ⇑(pullback.snd : pullback f g ⟶ Y) :=
begin
  convert (homeo_of_iso (as_iso (pullback.snd : pullback (𝟙 S) g ⟶ _))).open_embedding.comp
    (pullback_map_open_embedding_of_open_embeddings f g (𝟙 _) g H
      (homeo_of_iso (iso.refl _)).open_embedding (𝟙 _) rfl (by simp)),
  erw ←coe_comp,
  simp
end

lemma fst_open_embedding_of_right_open_embedding {X Y S : Top}
  (f : X ⟶ S) {g : Y ⟶ S} (H : open_embedding g) :
  open_embedding ⇑(pullback.fst : pullback f g ⟶ X) :=
begin
  convert (homeo_of_iso (as_iso (pullback.fst : pullback f (𝟙 S) ⟶ _))).open_embedding.comp
    (pullback_map_open_embedding_of_open_embeddings f g f (𝟙 _)
      (homeo_of_iso (iso.refl _)).open_embedding H (𝟙 _) rfl (by simp)),
  erw ←coe_comp,
  simp
end

/-- If `X ⟶ S`, `Y ⟶ S` are open embeddings, then so is `X ×ₛ Y ⟶ S`. -/
lemma open_embedding_of_pullback_open_embeddings {X Y S : Top}
  {f : X ⟶ S} {g : Y ⟶ S} (H₁ : open_embedding f) (H₂ : open_embedding g) :
  open_embedding (limit.π (cospan f g) walking_cospan.one) :=
begin
  convert H₂.comp (snd_open_embedding_of_left_open_embedding H₁ g),
  erw ←coe_comp,
  congr,
  exact (limit.w _ walking_cospan.hom.inr).symm
end

lemma fst_iso_of_right_embedding_range_subset {X Y S : Top} (f : X ⟶ S) {g : Y ⟶ S}
  (hg : embedding g) (H : set.range f ⊆ set.range g) : is_iso (pullback.fst : pullback f g ⟶ X) :=
begin
  let : (pullback f g : Top) ≃ₜ X :=
    (homeomorph.of_embedding _ (fst_embedding_of_right_embedding f hg)).trans
    { to_fun := coe,
      inv_fun := (λ x, ⟨x,
        by { rw pullback_fst_range, exact ⟨_, (H (set.mem_range_self x)).some_spec.symm⟩ }⟩),
      left_inv := λ ⟨_,_⟩, rfl,
      right_inv := λ x, rfl },
  convert is_iso.of_iso (iso_of_homeo this),
  ext,
  refl
end

lemma snd_iso_of_left_embedding_range_subset {X Y S : Top} {f : X ⟶ S} (hf : embedding f)
  (g : Y ⟶ S) (H : set.range g ⊆ set.range f) : is_iso (pullback.snd : pullback f g ⟶ Y) :=
begin
  let : (pullback f g : Top) ≃ₜ Y :=
    (homeomorph.of_embedding _ (snd_embedding_of_left_embedding hf g)).trans
    { to_fun := coe,
      inv_fun := (λ x, ⟨x,
        by { rw pullback_snd_range, exact ⟨_, (H (set.mem_range_self x)).some_spec⟩ }⟩),
      left_inv := λ ⟨_,_⟩, rfl,
      right_inv := λ x, rfl },
  convert is_iso.of_iso (iso_of_homeo this),
  ext,
  refl
end

lemma pullback_snd_image_fst_preimage (f : X ⟶ Z) (g : Y ⟶ Z) (U : set X) :
  (pullback.snd : pullback f g ⟶ _) '' ((pullback.fst : pullback f g ⟶ _) ⁻¹' U) =
    g ⁻¹' (f '' U) :=
begin
  ext x,
  split,
  { rintros ⟨y, hy, rfl⟩,
    exact ⟨(pullback.fst : pullback f g ⟶ _) y, hy,
    concrete_category.congr_hom pullback.condition y⟩ },
  { rintros ⟨y, hy, eq⟩,
    exact ⟨(Top.pullback_iso_prod_subtype f g).inv ⟨⟨_,_⟩, eq⟩, by simpa, by simp⟩ },
end

lemma pullback_fst_image_snd_preimage (f : X ⟶ Z) (g : Y ⟶ Z) (U : set Y) :
  (pullback.fst : pullback f g ⟶ _) '' ((pullback.snd : pullback f g ⟶ _) ⁻¹' U) =
    f ⁻¹' (g '' U) :=
begin
  ext x,
  split,
  { rintros ⟨y, hy, rfl⟩,
    exact ⟨(pullback.snd : pullback f g ⟶ _) y, hy,
    (concrete_category.congr_hom pullback.condition y).symm⟩ },
  { rintros ⟨y, hy, eq⟩,
    exact ⟨(Top.pullback_iso_prod_subtype f g).inv ⟨⟨_,_⟩,eq.symm⟩, by simpa, by simp⟩ },
end

end pullback

/-- The terminal object of `Top` is `punit`. -/
def is_terminal_punit : is_terminal (Top.of punit.{u+1}) :=
begin
  haveI : ∀ X, unique (X ⟶ Top.of punit.{u+1}) :=
    λ X, ⟨⟨⟨λ x, punit.star, by continuity⟩⟩, λ f, by ext⟩,
  exact limits.is_terminal.of_unique _,
end

/-- The terminal object of `Top` is `punit`. -/
def terminal_iso_punit : ⊤_ Top.{u} ≅ Top.of punit :=
terminal_is_terminal.unique_up_to_iso is_terminal_punit

/-- The initial object of `Top` is `pempty`. -/
def is_initial_pempty : is_initial (Top.of pempty.{u+1}) :=
begin
  haveI : ∀ X, unique (Top.of pempty.{u+1} ⟶ X) :=
    λ X, ⟨⟨⟨λ x, x.elim, by continuity⟩⟩, λ f, by ext ⟨⟩⟩,
  exact limits.is_initial.of_unique _,
end

/-- The initial object of `Top` is `pempty`. -/
def initial_iso_pempty : ⊥_ Top.{u} ≅ Top.of pempty :=
initial_is_initial.unique_up_to_iso is_initial_pempty

/-- The binary coproduct cofan in `Top`. -/
protected
def binary_cofan (X Y : Top.{u}) : binary_cofan X Y :=
binary_cofan.mk (⟨sum.inl⟩ : X ⟶ Top.of (X ⊕ Y)) ⟨sum.inr⟩

/-- The constructed binary coproduct cofan in `Top` is the coproduct. -/
def binary_cofan_is_colimit (X Y : Top.{u}) : is_colimit (Top.binary_cofan X Y) :=
begin
  refine limits.binary_cofan.is_colimit_mk (λ s, ⟨sum.elim s.inl s.inr⟩) _ _ _,
  { intro s, ext, refl },
  { intro s, ext, refl },
  { intros s m h₁ h₂, ext (x|x),
    exacts [(concrete_category.congr_hom h₁ x : _), (concrete_category.congr_hom h₂ x : _)] },
end

lemma binary_cofan_is_colimit_iff {X Y : Top} (c : binary_cofan X Y) :
  nonempty (is_colimit c) ↔
    open_embedding c.inl ∧ open_embedding c.inr ∧ is_compl (set.range c.inl) (set.range c.inr) :=
begin
  classical,
  split,
  { rintro ⟨h⟩,
    rw [← show _ = c.inl, from h.comp_cocone_point_unique_up_to_iso_inv
      (binary_cofan_is_colimit X Y) ⟨walking_pair.left⟩,
      ← show _ = c.inr, from h.comp_cocone_point_unique_up_to_iso_inv
      (binary_cofan_is_colimit X Y) ⟨walking_pair.right⟩],
    dsimp,
    refine
    ⟨(homeo_of_iso $ h.cocone_point_unique_up_to_iso (binary_cofan_is_colimit X Y)).symm
      .open_embedding.comp open_embedding_inl, (homeo_of_iso $ h.cocone_point_unique_up_to_iso
        (binary_cofan_is_colimit X Y)).symm.open_embedding.comp open_embedding_inr, _⟩,
    erw [set.range_comp, ← eq_compl_iff_is_compl, set.range_comp _ sum.inr, ← set.image_compl_eq
      (homeo_of_iso $ h.cocone_point_unique_up_to_iso (binary_cofan_is_colimit X Y))
      .symm.bijective],
    congr' 1,
    exact set.compl_range_inr.symm },
  { rintros ⟨h₁, h₂, h₃⟩,
    have : ∀ x, x ∈ set.range c.inl ∨ x ∈ set.range c.inr,
    { rw [eq_compl_iff_is_compl.mpr h₃.symm], exact λ _, or_not },
    refine ⟨binary_cofan.is_colimit.mk _ _ _ _ _⟩,
    { intros T f g,
      refine continuous_map.mk _ _,
      { exact λ x, if h : x ∈ set.range c.inl
        then f ((equiv.of_injective _ h₁.inj).symm ⟨x, h⟩)
        else g ((equiv.of_injective _ h₂.inj).symm ⟨x, (this x).resolve_left h⟩) },
      rw continuous_iff_continuous_at,
      intro x,
      by_cases x ∈ set.range c.inl,
      { revert h x,
      apply (is_open.continuous_on_iff _).mp,
      { rw continuous_on_iff_continuous_restrict,
        convert_to continuous (f ∘ (homeomorph.of_embedding _ h₁.to_embedding).symm),
        { ext ⟨x, hx⟩, exact dif_pos hx },
        continuity },
      { exact h₁.open_range } },
    { revert h x,
      apply (is_open.continuous_on_iff _).mp,
      { rw continuous_on_iff_continuous_restrict,
        have : ∀ a, a ∉ set.range c.inl → a ∈ set.range c.inr,
        { rintros a (h : a ∈ (set.range c.inl)ᶜ), rwa eq_compl_iff_is_compl.mpr h₃.symm },
        convert_to continuous
          (g ∘ (homeomorph.of_embedding _ h₂.to_embedding).symm ∘ subtype.map _ this),
        { ext ⟨x, hx⟩, exact dif_neg hx },
        continuity,
        rw embedding_subtype_coe.to_inducing.continuous_iff,
        exact continuous_subtype_coe },
      { change is_open (set.range c.inl)ᶜ, rw ← eq_compl_iff_is_compl.mpr h₃.symm,
        exact h₂.open_range } } },
    { intros T f g, ext x, refine (dif_pos _).trans _, { exact ⟨x, rfl⟩ },
        { rw equiv.of_injective_symm_apply } },
    { intros T f g, ext x, refine (dif_neg _).trans _,
      { rintro ⟨y, e⟩, have : c.inr x ∈ set.range c.inl ⊓ set.range c.inr := ⟨⟨_, e⟩, ⟨_, rfl⟩⟩,
        rwa disjoint_iff.mp h₃.1 at this },
      { exact congr_arg g (equiv.of_injective_symm_apply _ _) } },
    { rintro T _ _ m rfl rfl, ext x, change m x = dite _ _ _,
      split_ifs; exact congr_arg _ (equiv.apply_of_injective_symm _ ⟨_, _⟩).symm } }
end

--TODO: Add analogous constructions for `pushout`.

lemma coinduced_of_is_colimit {F : J ⥤ Top.{max v u}} (c : cocone F) (hc : is_colimit c) :
  c.X.topological_space = ⨆ j, (F.obj j).topological_space.coinduced (c.ι.app j) :=
begin
  let homeo := homeo_of_iso (hc.cocone_point_unique_up_to_iso (colimit_cocone_is_colimit F)),
  ext,
  refine homeo.symm.is_open_preimage.symm.trans (iff.trans _ is_open_supr_iff.symm),
  exact is_open_supr_iff
end

lemma colimit_topology (F : J ⥤ Top.{max v u}) :
  (colimit F).topological_space = ⨆ j, (F.obj j).topological_space.coinduced (colimit.ι F j) :=
coinduced_of_is_colimit _ (colimit.is_colimit F)

lemma colimit_is_open_iff (F : J ⥤ Top.{max v u}) (U : set ((colimit F : _) : Type (max v u))) :
  is_open U ↔ ∀ j, is_open (colimit.ι F j ⁻¹' U) :=
begin
  conv_lhs { rw colimit_topology F },
  exact is_open_supr_iff
end

lemma coequalizer_is_open_iff (F : walking_parallel_pair ⥤ Top.{u})
  (U : set ((colimit F : _) : Type u)) :
  is_open U ↔ is_open (colimit.ι F walking_parallel_pair.one ⁻¹' U) :=
begin
  rw colimit_is_open_iff.{u},
  split,
  { intro H, exact H _ },
  { intros H j,
    cases j,
    { rw ←colimit.w F walking_parallel_pair_hom.left,
      exact (F.map walking_parallel_pair_hom.left).continuous_to_fun.is_open_preimage _ H },
    { exact H } }
end

end Top

namespace Top

section cofiltered_limit

variables {J : Type v} [small_category J] [is_cofiltered J] (F : J ⥤ Top.{max v u})
  (C : cone F) (hC : is_limit C)

include hC

/--
Given a *compatible* collection of topological bases for the factors in a cofiltered limit
which contain `set.univ` and are closed under intersections, the induced *naive* collection
of sets in the limit is, in fact, a topological basis.
-/
theorem is_topological_basis_cofiltered_limit
  (T : Π j, set (set (F.obj j))) (hT : ∀ j, is_topological_basis (T j))
  (univ : ∀ (i : J), set.univ ∈ T i)
  (inter : ∀ i (U1 U2 : set (F.obj i)), U1 ∈ T i → U2 ∈ T i → U1 ∩ U2 ∈ T i)
  (compat : ∀ (i j : J) (f : i ⟶ j) (V : set (F.obj j)) (hV : V ∈ T j), (F.map f) ⁻¹' V ∈ T i) :
  is_topological_basis { U : set C.X | ∃ j (V : set (F.obj j)), V ∈ T j ∧ U = C.π.app j ⁻¹' V } :=
begin
  classical,
  -- The limit cone for `F` whose topology is defined as an infimum.
  let D := limit_cone_infi F,
  -- The isomorphism between the cone point of `C` and the cone point of `D`.
  let E : C.X ≅ D.X := hC.cone_point_unique_up_to_iso (limit_cone_infi_is_limit _),
  have hE : inducing E.hom := (Top.homeo_of_iso E).inducing,
  -- Reduce to the assertion of the theorem with `D` instead of `C`.
  suffices : is_topological_basis
    { U : set D.X | ∃ j (V : set (F.obj j)), V ∈ T j ∧ U = D.π.app j ⁻¹' V },
  { convert this.inducing hE,
    ext U0,
    split,
    { rintro ⟨j, V, hV, rfl⟩,
      refine ⟨D.π.app j ⁻¹' V, ⟨j, V, hV, rfl⟩, rfl⟩ },
    { rintro ⟨W, ⟨j, V, hV, rfl⟩, rfl⟩,
      refine ⟨j, V, hV, rfl⟩ } },
  -- Using `D`, we can apply the characterization of the topological basis of a
  -- topology defined as an infimum...
  convert is_topological_basis_infi hT (λ j (x : D.X), D.π.app j x),
  ext U0,
  split,
  { rintros  ⟨j, V, hV, rfl⟩,
    let U : Π i, set (F.obj i) := λ i, if h : i = j then (by {rw h, exact V}) else set.univ,
    refine ⟨U,{j},_,_⟩,
    { rintro i h,
      rw finset.mem_singleton at h,
      dsimp [U],
      rw dif_pos h,
      subst h,
      exact hV },
    { dsimp [U],
      simp } },
  { rintros ⟨U, G, h1, h2⟩,
    obtain ⟨j, hj⟩ := is_cofiltered.inf_objs_exists G,
    let g : ∀ e (he : e ∈ G), j ⟶ e := λ _ he, (hj he).some,
    let Vs : J → set (F.obj j) := λ e, if h : e ∈ G then F.map (g e h) ⁻¹' (U e) else set.univ,
    let V : set (F.obj j) := ⋂ (e : J) (he : e ∈ G), Vs e,
    refine ⟨j, V, _, _⟩,
    { -- An intermediate claim used to apply induction along `G : finset J` later on.
      have : ∀ (S : set (set (F.obj j))) (E : finset J) (P : J → set (F.obj j))
        (univ : set.univ ∈ S)
        (inter : ∀ A B : set (F.obj j), A ∈ S → B ∈ S → A ∩ B ∈ S)
        (cond : ∀ (e : J) (he : e ∈ E), P e ∈ S), (⋂ e (he : e ∈ E), P e) ∈ S,
      { intros S E,
        apply E.induction_on,
        { intros P he hh,
          simpa },
        { intros a E ha hh1 hh2 hh3 hh4 hh5,
          rw finset.set_bInter_insert,
          refine hh4 _ _ (hh5 _ (finset.mem_insert_self _ _)) (hh1 _ hh3 hh4 _),
          intros e he,
          exact hh5 e (finset.mem_insert_of_mem he) } },
      -- use the intermediate claim to finish off the goal using `univ` and `inter`.
      refine this _ _ _ (univ _) (inter _) _,
      intros e he,
      dsimp [Vs],
      rw dif_pos he,
      exact compat j e (g e he) (U e) (h1 e he), },
    { -- conclude...
      rw h2,
      dsimp [V],
      rw set.preimage_Inter,
      congr' 1,
      ext1 e,
      rw set.preimage_Inter,
      congr' 1,
      ext1 he,
      dsimp [Vs],
      rw [dif_pos he, ← set.preimage_comp],
      congr' 1,
      change _ = ⇑(D.π.app j ≫ F.map (g e he)),
      rw D.w } }
end

end cofiltered_limit

section topological_konig

/-!
## Topological Kőnig's lemma

A topological version of Kőnig's lemma is that the inverse limit of nonempty compact Hausdorff
spaces is nonempty.  (Note: this can be generalized further to inverse limits of nonempty compact
T0 spaces, where all the maps are closed maps; see [Stone1979] --- however there is an erratum
for Theorem 4 that the element in the inverse limit can have cofinally many components that are
not closed points.)

We give this in a more general form, which is that cofiltered limits
of nonempty compact Hausdorff spaces are nonempty
(`nonempty_limit_cone_of_compact_t2_cofiltered_system`).

This also applies to inverse limits, where `{J : Type u} [preorder J] [is_directed J (≤)]` and
`F : Jᵒᵖ ⥤ Top`.

The theorem is specialized to nonempty finite types (which are compact Hausdorff with the
discrete topology) in lemmas `nonempty_sections_of_finite_cofiltered_system` and
`nonempty_sections_of_finite_inverse_system` in the file `category_theory.cofiltered_system`.

(See <https://stacks.math.columbia.edu/tag/086J> for the Set version.)
-/

variables {J : Type u} [small_category J]
variables (F : J ⥤ Top.{u})

private abbreviation finite_diagram_arrow {J : Type u} [small_category J] (G : finset J) :=
Σ' (X Y : J) (mX : X ∈ G) (mY : Y ∈ G), X ⟶ Y
private abbreviation finite_diagram (J : Type u) [small_category J] :=
Σ (G : finset J), finset (finite_diagram_arrow G)

/--
Partial sections of a cofiltered limit are sections when restricted to
a finite subset of objects and morphisms of `J`.
-/
def partial_sections {J : Type u} [small_category J] (F : J ⥤ Top.{u})
  {G : finset J} (H : finset (finite_diagram_arrow G)) : set (Π j, F.obj j) :=
{ u | ∀ {f : finite_diagram_arrow G} (hf : f ∈ H), F.map f.2.2.2.2 (u f.1) = u f.2.1 }

lemma partial_sections.nonempty [is_cofiltered_or_empty J] [h : Π (j : J), nonempty (F.obj j)]
  {G : finset J} (H : finset (finite_diagram_arrow G)) :
  (partial_sections F H).nonempty :=
begin
  classical,
  casesI is_empty_or_nonempty J,
  { exact ⟨is_empty_elim, λ j, is_empty.elim' infer_instance j.1⟩ },
  haveI : is_cofiltered J := ⟨⟩,
  use λ (j : J), if hj : j ∈ G
                 then F.map (is_cofiltered.inf_to G H hj) (h (is_cofiltered.inf G H)).some
                 else (h _).some,
  rintros ⟨X, Y, hX, hY, f⟩ hf,
  dsimp only,
  rwa [dif_pos hX, dif_pos hY, ←comp_app, ←F.map_comp,
       @is_cofiltered.inf_to_commutes _ _ _ G H],
end

lemma partial_sections.directed :
  directed superset (λ (G : finite_diagram J), partial_sections F G.2) :=
begin
  classical,
  intros A B,
  let ιA : finite_diagram_arrow A.1 → finite_diagram_arrow (A.1 ⊔ B.1) :=
    λ f, ⟨f.1, f.2.1, finset.mem_union_left _ f.2.2.1, finset.mem_union_left _ f.2.2.2.1,
          f.2.2.2.2⟩,
  let ιB : finite_diagram_arrow B.1 → finite_diagram_arrow (A.1 ⊔ B.1) :=
    λ f, ⟨f.1, f.2.1, finset.mem_union_right _ f.2.2.1, finset.mem_union_right _ f.2.2.2.1,
          f.2.2.2.2⟩,
  refine ⟨⟨A.1 ⊔ B.1, A.2.image ιA ⊔ B.2.image ιB⟩, _, _⟩,
  { rintro u hu f hf,
    have : ιA f ∈ A.2.image ιA ⊔ B.2.image ιB,
    { apply finset.mem_union_left,
      rw finset.mem_image,
      refine ⟨f, hf, rfl⟩ },
    exact hu this },
  { rintro u hu f hf,
    have : ιB f ∈ A.2.image ιA ⊔ B.2.image ιB,
    { apply finset.mem_union_right,
      rw finset.mem_image,
      refine ⟨f, hf, rfl⟩ },
    exact hu this }
end

lemma partial_sections.closed [Π (j : J), t2_space (F.obj j)]
  {G : finset J} (H : finset (finite_diagram_arrow G)) :
  is_closed (partial_sections F H) :=
begin
  have : partial_sections F H =
    ⋂ {f : finite_diagram_arrow G} (hf : f ∈ H), { u | F.map f.2.2.2.2 (u f.1) = u f.2.1 },
  { ext1,
    simp only [set.mem_Inter, set.mem_set_of_eq],
    refl, },
  rw this,
  apply is_closed_bInter,
  intros f hf,
  apply is_closed_eq,
  continuity,
end

/--
Cofiltered limits of nonempty compact Hausdorff spaces are nonempty topological spaces.
-/
lemma nonempty_limit_cone_of_compact_t2_cofiltered_system
  [is_cofiltered_or_empty J]
  [Π (j : J), nonempty (F.obj j)]
  [Π (j : J), compact_space (F.obj j)]
  [Π (j : J), t2_space (F.obj j)] :
  nonempty (Top.limit_cone.{u} F).X :=
begin
  classical,
  obtain ⟨u, hu⟩ := is_compact.nonempty_Inter_of_directed_nonempty_compact_closed
    (λ G, partial_sections F _)
    (partial_sections.directed F)
    (λ G, partial_sections.nonempty F _)
    (λ G, is_closed.is_compact (partial_sections.closed F _))
    (λ G, partial_sections.closed F _),
  use u,
  intros X Y f,
  let G : finite_diagram J :=
    ⟨{X, Y},
     {⟨X, Y,
      by simp only [true_or, eq_self_iff_true, finset.mem_insert],
      by simp only [eq_self_iff_true, or_true, finset.mem_insert, finset.mem_singleton],
      f⟩}⟩,
  exact hu _ ⟨G, rfl⟩ (finset.mem_singleton_self _),
end

end topological_konig

end Top


/-
Copyright (c) 2019 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Simon Hudon, Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.equiv.basic
import Mathlib.control.bifunctor
import Mathlib.PostPort

universes u v w

namespace Mathlib

/-!
# Functor and bifunctors can be applied to `equiv`s.

We define
```lean
def functor.map_equiv (f : Type u → Type v) [functor f] [is_lawful_functor f] :
  α ≃ β → f α ≃ f β
```
and
```lean
def bifunctor.map_equiv (F : Type u → Type v → Type w) [bifunctor F] [is_lawful_bifunctor F] :
  α ≃ β → α' ≃ β' → F α α' ≃ F β β'
```
-/

namespace functor

/-- Apply a functor to an `equiv`. -/
def map_equiv {α : Type u} {β : Type u} (f : Type u → Type v) [Functor f] [is_lawful_functor f]
    (h : α ≃ β) : f α ≃ f β :=
  equiv.mk (Functor.map ⇑h) (Functor.map ⇑(equiv.symm h)) sorry sorry

@[simp] theorem map_equiv_apply {α : Type u} {β : Type u} (f : Type u → Type v) [Functor f]
    [is_lawful_functor f] (h : α ≃ β) (x : f α) : coe_fn (map_equiv f h) x = ⇑h <$> x :=
  rfl

@[simp] theorem map_equiv_symm_apply {α : Type u} {β : Type u} (f : Type u → Type v) [Functor f]
    [is_lawful_functor f] (h : α ≃ β) (y : f β) :
    coe_fn (equiv.symm (map_equiv f h)) y = ⇑(equiv.symm h) <$> y :=
  rfl

@[simp] theorem map_equiv_refl {α : Type u} (f : Type u → Type v) [Functor f]
    [is_lawful_functor f] : map_equiv f (equiv.refl α) = equiv.refl (f α) :=
  sorry

end functor

namespace bifunctor

/-- Apply a bifunctor to a pair of `equiv`s. -/
def map_equiv {α : Type u} {β : Type u} {α' : Type v} {β' : Type v} (F : Type u → Type v → Type w)
    [bifunctor F] [is_lawful_bifunctor F] (h : α ≃ β) (h' : α' ≃ β') : F α α' ≃ F β β' :=
  equiv.mk (bimap ⇑h ⇑h') (bimap ⇑(equiv.symm h) ⇑(equiv.symm h')) sorry sorry

@[simp] theorem map_equiv_apply {α : Type u} {β : Type u} {α' : Type v} {β' : Type v}
    (F : Type u → Type v → Type w) [bifunctor F] [is_lawful_bifunctor F] (h : α ≃ β) (h' : α' ≃ β')
    (x : F α α') : coe_fn (map_equiv F h h') x = bimap (⇑h) (⇑h') x :=
  rfl

@[simp] theorem map_equiv_symm_apply {α : Type u} {β : Type u} {α' : Type v} {β' : Type v}
    (F : Type u → Type v → Type w) [bifunctor F] [is_lawful_bifunctor F] (h : α ≃ β) (h' : α' ≃ β')
    (y : F β β') :
    coe_fn (equiv.symm (map_equiv F h h')) y = bimap (⇑(equiv.symm h)) (⇑(equiv.symm h')) y :=
  rfl

@[simp] theorem map_equiv_refl_refl {α : Type u} {α' : Type v} (F : Type u → Type v → Type w)
    [bifunctor F] [is_lawful_bifunctor F] :
    map_equiv F (equiv.refl α) (equiv.refl α') = equiv.refl (F α α') :=
  sorry

end Mathlib


/-
Copyright (c) 2020 Kenji Nakagawa. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenji Nakagawa, Anne Baanen, Filippo A. E. Nuccio
-/
import ring_theory.ideal.over
import ring_theory.polynomial.rational_root

/-!
# Dedekind domains

This file defines the notion of a Dedekind domain (or Dedekind ring),
as a Noetherian integrally closed commutative ring of Krull dimension at most one.

## Main definitions

 - `is_dedekind_domain` defines a Dedekind domain as a commutative ring that is
   Noetherian, integrally closed in its field of fractions and has Krull dimension at most one.
   `is_dedekind_domain_iff` shows that this does not depend on the choice of field of fractions.

## Implementation notes

The definitions that involve a field of fractions choose a canonical field of fractions,
but are independent of that choice. The `..._iff` lemmas express this independence.

Often, definitions assume that Dedekind domains are not fields. We found it more practical
to add a `(h : ¬ is_field A)` assumption whenever this is explicitly needed.

## References

* [D. Marcus, *Number Fields*][marcus1977number]
* [J.W.S. Cassels, A. Frölich, *Algebraic Number Theory*][cassels1967algebraic]
* [J. Neukirch, *Algebraic Number Theory*][Neukirch1992]

## Tags

dedekind domain, dedekind ring
-/

variables (R A K : Type*) [comm_ring R] [comm_ring A] [field K]

open_locale non_zero_divisors polynomial

/-- A ring `R` has Krull dimension at most one if all nonzero prime ideals are maximal. -/
def ring.dimension_le_one : Prop :=
∀ p ≠ (⊥ : ideal R), p.is_prime → p.is_maximal

open ideal ring

namespace ring

lemma dimension_le_one.principal_ideal_ring
  [is_domain A] [is_principal_ideal_ring A] : dimension_le_one A :=
λ p nonzero prime, by { haveI := prime, exact is_prime.to_maximal_ideal nonzero }

lemma dimension_le_one.is_integral_closure (B : Type*) [comm_ring B] [is_domain B]
  [nontrivial R] [algebra R A] [algebra R B] [algebra B A] [is_scalar_tower R B A]
  [is_integral_closure B R A] (h : dimension_le_one R) :
  dimension_le_one B :=
λ p ne_bot prime, by exactI
  is_integral_closure.is_maximal_of_is_maximal_comap A p
    (h _ (is_integral_closure.comap_ne_bot A ne_bot) infer_instance)

lemma dimension_le_one.integral_closure [nontrivial R] [is_domain A] [algebra R A]
  (h : dimension_le_one R) : dimension_le_one (integral_closure R A) :=
h.is_integral_closure R A (integral_closure R A)

end ring

variables [is_domain A]

/--
A Dedekind domain is an integral domain that is Noetherian, integrally closed, and
has Krull dimension at most one.

This is definition 3.2 of [Neukirch1992].

The integral closure condition is independent of the choice of field of fractions:
use `is_dedekind_domain_iff` to prove `is_dedekind_domain` for a given `fraction_map`.

This is the default implementation, but there are equivalent definitions,
`is_dedekind_domain_dvr` and `is_dedekind_domain_inv`.
TODO: Prove that these are actually equivalent definitions.
-/
class is_dedekind_domain : Prop :=
(is_noetherian_ring : is_noetherian_ring A)
(dimension_le_one : dimension_le_one A)
(is_integrally_closed : is_integrally_closed A)

-- See library note [lower instance priority]
attribute [instance, priority 100]
  is_dedekind_domain.is_noetherian_ring is_dedekind_domain.is_integrally_closed

/-- An integral domain is a Dedekind domain iff and only if it is
Noetherian, has dimension ≤ 1, and is integrally closed in a given fraction field.
In particular, this definition does not depend on the choice of this fraction field. -/
lemma is_dedekind_domain_iff (K : Type*) [field K] [algebra A K] [is_fraction_ring A K] :
  is_dedekind_domain A ↔ is_noetherian_ring A ∧ dimension_le_one A ∧
    (∀ {x : K}, is_integral A x → ∃ y, algebra_map A K y = x) :=
⟨λ ⟨hr, hd, hi⟩, ⟨hr, hd, λ x, (is_integrally_closed_iff K).mp hi⟩,
 λ ⟨hr, hd, hi⟩, ⟨hr, hd, (is_integrally_closed_iff K).mpr @hi⟩⟩

@[priority 100] -- See library note [lower instance priority]
instance is_principal_ideal_ring.is_dedekind_domain [is_principal_ideal_ring A] :
  is_dedekind_domain A :=
⟨principal_ideal_ring.is_noetherian_ring,
 ring.dimension_le_one.principal_ideal_ring A,
 unique_factorization_monoid.is_integrally_closed⟩


/-
Copyright (c) 2019 Robert A. Spencer. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert A. Spencer, Markus Himmel
-/
import algebra.category.Group.basic
import category_theory.concrete_category
import category_theory.limits.shapes.kernels
import category_theory.linear
import linear_algebra.basic

/-!
# The category of `R`-modules

`Module.{v} R` is the category of bundled `R`-modules with carrier in the universe `v`. We show
that it is preadditive and show that being an isomorphism, monomorphism and epimorphism is
equivalent to being a linear equivalence, an injective linear map and a surjective linear map,
respectively.

## Implementation details

To construct an object in the category of `R`-modules from a type `M` with an instance of the
`module` typeclass, write `of R M`. There is a coercion in the other direction.

Similarly, there is a coercion from morphisms in `Module R` to linear maps.

Unfortunately, Lean is not smart enough to see that, given an object `M : Module R`, the expression
`of R M`, where we coerce `M` to the carrier type, is definitionally equal to `M` itself.
This means that to go the other direction, i.e., from linear maps/equivalences to (iso)morphisms
in the category of `R`-modules, we have to take care not to inadvertently end up with an
`of R M` where `M` is already an object. Hence, given `f : M →ₗ[R] N`,
* if `M N : Module R`, simply use `f`;
* if `M : Module R` and `N` is an unbundled `R`-module, use `↿f` or `as_hom_left f`;
* if `M` is an unbundled `R`-module and `N : Module R`, use `↾f` or `as_hom_right f`;
* if `M` and `N` are unbundled `R`-modules, use `↟f` or `as_hom f`.

Similarly, given `f : M ≃ₗ[R] N`, use `to_Module_iso`, `to_Module_iso'_left`, `to_Module_iso'_right`
or `to_Module_iso'`, respectively.

The arrow notations are localized, so you may have to `open_locale Module` to use them. Note that
the notation for `as_hom_left` clashes with the notation used to promote functions between types to
morphisms in the category `Type`, so to avoid confusion, it is probably a good idea to avoid having
the locales `Module` and `category_theory.Type` open at the same time.

If you get an error when trying to apply a theorem and the `convert` tactic produces goals of the
form `M = of R M`, then you probably used an incorrect variant of `as_hom` or `to_Module_iso`.

-/

open category_theory
open category_theory.limits
open category_theory.limits.walking_parallel_pair

universes v u

variables (R : Type u) [ring R]

/-- The category of R-modules and their morphisms.

 Note that in the case of `R = ℤ`, we can not
impose here that the `ℤ`-multiplication field from the module structure is defeq to the one coming
from the `is_add_comm_group` structure (contrary to what we do for all module structures in
mathlib), which creates some difficulties down the road. -/
structure Module :=
(carrier : Type v)
[is_add_comm_group : add_comm_group carrier]
[is_module : module R carrier]

attribute [instance] Module.is_add_comm_group Module.is_module

namespace Module

instance : has_coe_to_sort (Module.{v} R) :=
{ S := Type v, coe := Module.carrier }

instance Module_category : category (Module.{v} R) :=
{ hom   := λ M N, M →ₗ[R] N,
  id    := λ M, 1,
  comp  := λ A B C f g, g.comp f }

instance Module_concrete_category : concrete_category.{v} (Module.{v} R) :=
{ forget := { obj := λ R, R, map := λ R S f, (f : R → S) },
  forget_faithful := { } }

instance has_forget_to_AddCommGroup : has_forget₂ (Module R) AddCommGroup :=
{ forget₂ :=
  { obj := λ M, AddCommGroup.of M,
    map := λ M₁ M₂ f, linear_map.to_add_monoid_hom f } }

/-- The object in the category of R-modules associated to an R-module -/
def of (X : Type v) [add_comm_group X] [module R X] : Module R := ⟨X⟩

instance : has_zero (Module R) := ⟨of R punit⟩
instance : inhabited (Module R) := ⟨0⟩

@[simp]
lemma coe_of (X : Type u) [add_comm_group X] [module R X] : (of R X : Type u) = X := rfl

variables {R}

/-- Forgetting to the underlying type and then building the bundled object returns the original
module. -/
@[simps]
def of_self_iso (M : Module R) : Module.of R M ≅ M :=
{ hom := 𝟙 M, inv := 𝟙 M }

instance : subsingleton (of R punit) :=
by { rw coe_of R punit, apply_instance }

instance : has_zero_object (Module.{v} R) :=
{ zero := 0,
  unique_to := λ X,
  { default := (0 : punit →ₗ[R] X),
    uniq := λ _, linear_map.ext $ λ x,
      have h : x = 0, from dec_trivial,
      by simp only [h, linear_map.map_zero]},
  unique_from := λ X,
  { default := (0 : X →ₗ[R] punit),
    uniq := λ _, linear_map.ext $ λ x, dec_trivial } }

variables {R} {M N U : Module.{v} R}

@[simp] lemma id_apply (m : M) : (𝟙 M : M → M) m = m := rfl

@[simp] lemma coe_comp (f : M ⟶ N) (g : N ⟶ U) :
  ((f ≫ g) : M → U) = g ∘ f := rfl

lemma comp_def (f : M ⟶ N) (g : N ⟶ U) : f ≫ g = g.comp f := rfl

end Module

variables {R}
variables {X₁ X₂ : Type v}

/-- Reinterpreting a linear map in the category of `R`-modules. -/
def Module.as_hom [add_comm_group X₁] [module R X₁] [add_comm_group X₂] [module R X₂] :
  (X₁ →ₗ[R] X₂) → (Module.of R X₁ ⟶ Module.of R X₂) := id

localized "notation `↟` f : 1024 := Module.as_hom f" in Module

/-- Reinterpreting a linear map in the category of `R`-modules. -/
def Module.as_hom_right [add_comm_group X₁] [module R X₁] {X₂ : Module.{v} R} :
  (X₁ →ₗ[R] X₂) → (Module.of R X₁ ⟶ X₂) := id

localized "notation `↾` f : 1024 := Module.as_hom_right f" in Module

/-- Reinterpreting a linear map in the category of `R`-modules. -/
def Module.as_hom_left {X₁ : Module.{v} R} [add_comm_group X₂] [module R X₂] :
  (X₁ →ₗ[R] X₂) → (X₁ ⟶ Module.of R X₂) := id

localized "notation `↿` f : 1024 := Module.as_hom_left f" in Module

/-- Build an isomorphism in the category `Module R` from a `linear_equiv` between `module`s. -/
@[simps]
def linear_equiv.to_Module_iso
  {g₁ : add_comm_group X₁} {g₂ : add_comm_group X₂} {m₁ : module R X₁} {m₂ : module R X₂}
  (e : X₁ ≃ₗ[R] X₂) :
  Module.of R X₁ ≅ Module.of R X₂ :=
{ hom := (e : X₁ →ₗ[R] X₂),
  inv := (e.symm : X₂ →ₗ[R] X₁),
  hom_inv_id' := begin ext, exact e.left_inv x, end,
  inv_hom_id' := begin ext, exact e.right_inv x, end, }

/--
Build an isomorphism in the category `Module R` from a `linear_equiv` between `module`s.

This version is better than `linear_equiv_to_Module_iso` when applicable, because Lean can't see
`Module.of R M` is defeq to `M` when `M : Module R`. -/
@[simps]
def linear_equiv.to_Module_iso' {M N : Module.{v} R} (i : M ≃ₗ[R] N) : M ≅ N :=
{ hom := i,
  inv := i.symm,
  hom_inv_id' := linear_map.ext $ λ x, by simp,
  inv_hom_id' := linear_map.ext $ λ x, by simp }

/--
Build an isomorphism in the category `Module R` from a `linear_equiv` between `module`s.

This version is better than `linear_equiv_to_Module_iso` when applicable, because Lean can't see
`Module.of R M` is defeq to `M` when `M : Module R`. -/
@[simps]
def linear_equiv.to_Module_iso'_left {X₁ : Module.{v} R} {g₂ : add_comm_group X₂} {m₂ : module R X₂}
  (e : X₁ ≃ₗ[R] X₂) : X₁ ≅ Module.of R X₂ :=
{ hom := (e : X₁ →ₗ[R] X₂),
  inv := (e.symm : X₂ →ₗ[R] X₁),
  hom_inv_id' := linear_map.ext $ λ x, by simp,
  inv_hom_id' := linear_map.ext $ λ x, by simp }

/--
Build an isomorphism in the category `Module R` from a `linear_equiv` between `module`s.

This version is better than `linear_equiv_to_Module_iso` when applicable, because Lean can't see
`Module.of R M` is defeq to `M` when `M : Module R`. -/
@[simps]
def linear_equiv.to_Module_iso'_right {g₁ : add_comm_group X₁} {m₁ : module R X₁}
  {X₂ : Module.{v} R} (e : X₁ ≃ₗ[R] X₂) : Module.of R X₁ ≅ X₂ :=
{ hom := (e : X₁ →ₗ[R] X₂),
  inv := (e.symm : X₂ →ₗ[R] X₁),
  hom_inv_id' := linear_map.ext $ λ x, by simp,
  inv_hom_id' := linear_map.ext $ λ x, by simp }

namespace category_theory.iso

/-- Build a `linear_equiv` from an isomorphism in the category `Module R`. -/
@[simps]
def to_linear_equiv {X Y : Module R} (i : X ≅ Y) : X ≃ₗ[R] Y :=
{ to_fun    := i.hom,
  inv_fun   := i.inv,
  left_inv  := by tidy,
  right_inv := by tidy,
  map_add'  := by tidy,
  map_smul' := by tidy, }.

end category_theory.iso

/-- linear equivalences between `module`s are the same as (isomorphic to) isomorphisms
in `Module` -/
@[simps]
def linear_equiv_iso_Module_iso {X Y : Type u} [add_comm_group X] [add_comm_group Y] [module R X]
  [module R Y] :
  (X ≃ₗ[R] Y) ≅ (Module.of R X ≅ Module.of R Y) :=
{ hom := λ e, e.to_Module_iso,
  inv := λ i, i.to_linear_equiv, }

namespace Module

instance : preadditive (Module.{v} R) :=
{ add_comp' := λ P Q R f f' g,
    show (f + f') ≫ g = f ≫ g + f' ≫ g, by { ext, simp },
  comp_add' := λ P Q R f g g',
    show f ≫ (g + g') = f ≫ g + f ≫ g', by { ext, simp } }

section
variables {S : Type u} [comm_ring S]

instance : linear S (Module.{v} S) :=
{ hom_module := λ X Y, linear_map.module,
  smul_comp' := by { intros, ext, simp },
  comp_smul' := by { intros, ext, simp }, }

end

end Module

instance (M : Type u) [add_comm_group M] [module R M] : has_coe (submodule R M) (Module R) :=
⟨ λ N, Module.of R N ⟩