import data.real.basic

--OUTPUT 1
theorem nesbitt_inequality {a b c : ℝ} (ha : 0 < a) (hb : 0 < b) (hc : 0 < c) : (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (3 / 2) :=
begin
  have h1 : a + b + c > 0, from by {apply add_pos ha hb, apply add_pos_of_pos_of_nonneg h1 hc},
  have h2 : (a + b + c) / 2 = (a + b + c) * (1 / 2), from by {rw mul_div_cancel, exact h1},
  have h3 : (a + b + c) * (1 / 2) = (a + b + c) * (2 / 4), from by {rw div_mul, exact h1},
  have h4 : (a + b + c) * (2 / 4) = (a + b + c) * (1 / 2), from by {rw mul_comm, rw div_mul, exact h1},
  have h5 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw h4, rw h3},
  have h6 : (a + b + c) / 2 = (a + b + c) * (1 / 2), from by {rw mul_div_cancel, exact h1},
  have h7 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw h6, rw h5},
  have h8 : (a + b + c) / 2 = (a + b + c) * (1 / 2), from by {rw ← h7},
  have h9 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h8},
  have h10 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h9},
  have h11 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h10},
  have h12 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h11},
  have h13 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h12},
  have h14 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h13},
  have h15 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h14},
  have h16 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h15},
  have h17 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h16},
  have h18 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h17},
  have h19 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h18},
  have h20 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h19},
  have h21 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h20},
  have h22 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h21},
  have h23 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h22},
  have h24 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h23},
  have h25 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h24},
  have h26 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h25},
  have h27 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h26},
  have h28 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h27},
  have h29 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h28},
  have h30 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h29},
  have h31 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h30},
  have h32 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h31},
  have h33 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h32},
  have h34 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h33},
  have h35 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h34},
  have h36 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h35},
  have h37 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h36},
  have h38 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h37},
  have h39 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h38},
  have h40 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h39},
  have h41 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h40},
  have h42 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h41},
  have h43 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h42},
  have h44 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h43},
  have h45 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h44},
  have h46 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h45},
  have h47 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h46},
  have h48 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h47},
  have h49 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h48},
  have h50 : (a + b + c) * (1 / 2) = (a + b + c) / 2, from by {rw ← h49},
  have h51 : (a +
end --Needs more than 2000 tokens!

--OUTPUT 2
theorem nesbitt_inequality {a b c : ℝ} (ha : 0 < a) (hb : 0 < b) (hc : 0 < c) : (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (3 / 2) :=
begin
  -- Let $a$, $b$ and $c$ be positive real numbers.
  assume ha : 0 < a, assume hb : 0 < b, assume hc : 0 < c,
  -- Then:
  have h1 : (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (3 / 2),
  -- $\leadstoandfrom$
  begin
    -- adding $3$
    calc (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) :
      by {rw [div_add_div_same,div_add_div_same,div_add_div_same], ring,},
    -- as $\dfrac {a + b + c} {\paren {b + c} + \paren {a + c} + \paren {a + b} } = \dfrac 1 2$
    have h2 : (a + b + c) / ((b + c) + (a + c) + (a + b)) = 1 / 2, from by {
      rw [div_eq_iff_mul_eq,mul_comm,← add_assoc], ring, },
    calc (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) :
      by {rw [div_add_div_same,div_add_div_same,div_add_div_same], ring,},
    -- dividing by $3 \paren {a + b + c}$
    calc (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) :
      by {rw [div_add_div_same,div_add_div_same,div_add_div_same], ring,},
    calc (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) :
      by {rw [div_add_div_same,div_add_div_same,div_add_div_same], ring,},
    -- These are the arithmetic mean and the harmonic mean of $\dfrac 1 {b + c}$, $\dfrac 1 {a + c}$ and $\dfrac 1 {a + b}$.
    calc (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) :
      by {rw [div_add_div_same,div_add_div_same,div_add_div_same], ring,},
    calc (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) :
      by {rw [div_add_div_same,div_add_div_same,div_add_div_same], ring,},
    calc (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) :
      by {rw [div_add_div_same,div_add_div_same,div_add_div_same], ring,},
    calc (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) :
      by {rw [div_add_div_same,div_add_div_same,div_add_div_same], ring,},
    calc (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) :
      by {rw [div_add_div_same,div_add_div_same,div_add_div_same], ring,},
    -- From Arithmetic Mean is Never Less than Harmonic Mean the last inequality is true.
    calc (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) :
      by {rw [div_add_div_same,div_add_div_same,div_add_div_same], ring,},
    calc (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) :
      by {rw [div_add_div_same,div_add_div_same,div_add_div_same], ring,},
    calc (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) :
      by {rw [div_add_div_same,div_add_div_same,div_add_div_same], ring,},
    calc (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) :
      by {rw [div_add_div_same,div_add_div_same,div_add_div_same], ring,},
    calc (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) :
      by {rw [div_add_div_same,div_add_div_same,div_add_div_same], ring,},
    calc (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) :
      by {rw [div_add_div_same,div_add_div_same,div_add_div_same], ring,},
    calc (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) :
      by {rw [div_add_div_same,div_add_div_same,div_add_div_same], ring,},
    calc (a / (b + c)) + (b /
end --Needs more than 2000 tokens!

--OUTPUT 3
theorem nesbitt_inequality {a b c : ℝ} (ha : 0 < a) (hb : 0 < b) (hc : 0 < c) : (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (3 / 2) :=
begin
  -- $\dfrac a {b + c} + \dfrac b {a + c} + \dfrac c {a + b} \ge \dfrac 3 2$
  have h1 : (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (3 / 2), from by {
    -- adding $3$
    have h2 : (a / (b + c)) + (b / (a + c)) + (c / (a + b)) + 3 = (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b), from by {
      rw [add_div,add_div,add_div,add_mul,add_mul,add_mul], ring,
    },
    -- as $\dfrac {a + b + c} {\paren {b + c} + \paren {a + c} + \paren {a + b} } = \dfrac 1 2$
    have h3 : (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) ≥ (9 / 2) * (1 / 2), from by {
      rw [div_mul_eq_div_mul_one,div_mul_eq_div_mul_one,div_mul_eq_div_mul_one],
      exact le_of_lt (div_lt_one_of_pos (by norm_num)),
    },
    -- dividing by $3 \paren {a + b + c}$
    have h4 : (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) ≥ (3 / (b + c + a + c + a + b)), from by {
      rw [div_mul_eq_div_mul_one,div_mul_eq_div_mul_one,div_mul_eq_div_mul_one],
      exact le_of_lt (div_lt_one_of_pos (by norm_num)),
    },
    -- These are the arithmetic mean and the harmonic mean of $\dfrac 1 {b + c}$, $\dfrac 1 {a + c}$ and $\dfrac 1 {a + b}$.
    have h5 : (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) ≥ (3 / (b + c + a + c + a + b)), from by {
      rw [div_mul_eq_div_mul_one,div_mul_eq_div_mul_one,div_mul_eq_div_mul_one],
      exact le_of_lt (div_lt_one_of_pos (by norm_num)),
    },
    -- From Arithmetic Mean is Never Less than Harmonic Mean the last inequality is true.
    have h6 : (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) ≥ (3 / (b + c + a + c + a + b)), from by {
      rw [div_mul_eq_div_mul_one,div_mul_eq_div_mul_one,div_mul_eq_div_mul_one],
      exact le_of_lt (div_lt_one_of_pos (by norm_num)),
    },
    -- Thus Nesbitt's Inequality holds.
    show (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (3 / 2), from by {
      rw [div_mul_eq_div_mul_one,div_mul_eq_div_mul_one,div_mul_eq_div_mul_one],
      exact le_of_lt (div_lt_one_of_pos (by norm_num)),
    },
  },
  show (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (3 / 2), from h1,
end

--OUTPUT 4
theorem nesbitt_inequality {a b c : ℝ} (ha : 0 < a) (hb : 0 < b) (hc : 0 < c) : (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (3 / 2) :=
begin
  -- The inequality is equivalent to:
  have h1 : (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (3 / 2), from by {
    -- adding $3$ to both sides gives:
    calc (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (3 / 2) : by obviously
    -- as $\dfrac {a + b + c} {\paren {b + c} + \paren {a + c} + \paren {a + b} } = \dfrac 1 2$
    ... ≥ (9 / 2) * ((a + b + c) / (b + c + a + c + a + b)) : by {rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm, rw mul_div_assoc, rw mul_comm
end --Needs more than 2000 tokens!

--OUTPUT 5
theorem nesbitt_inequality {a b c : ℝ} (ha : 0 < a) (hb : 0 < b) (hc : 0 < c) : (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (3 / 2) :=
begin
  -- $a$, $b$ and $c$ are positive real numbers
  assume (a b c : ℝ) (ha : 0 < a) (hb : 0 < b) (hc : 0 < c),
  -- $\dfrac a {b + c} + \dfrac b {a + c} + \dfrac c {a + b} \ge \dfrac 3 2$
  have h1 : (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (3 / 2), from by {
    -- adding $3$
    have h2 : (a / (b + c)) + (b / (a + c)) + (c / (a + b)) + 3 ≥ 3, from by {
      -- as $\dfrac {a + b + c} {\paren {b + c} + \paren {a + c} + \paren {a + b} } = \dfrac 1 2$
      have h3 : (a + b + c) / ((b + c) + (a + c) + (a + b)) = (1 / 2), from by {
        -- $\paren {b + c} + \paren {a + c} + \paren {a + b} = \paren {b + a} + \paren {c + a} + \paren {c + b}$
        have h4 : (b + c) + (a + c) + (a + b) = (b + a) + (c + a) + (c + b), from by {
          rw [add_assoc,add_comm (a + c) (a + b),add_assoc,add_comm (b + c) (a + b),
            add_assoc,add_comm (b + c) (c + a),add_assoc,add_comm (a + c) (c + a),add_assoc],
        },
        -- $\paren {b + c} + \paren {a + c} + \paren {a + b} = 3 a + 3 b + 3 c$
        have h5 : (b + c) + (a + c) + (a + b) = 3 * a + 3 * b + 3 * c, from by {
          rw h4, ring,
        },
        -- $\paren {a + b + c} = a + b + c$
        have h6 : (a + b + c) = a + b + c, from by {
          rw add_assoc,
        },
        -- $\paren {a + b + c} = 3 a + 3 b + 3 c$
        have h7 : (a + b + c) = 3 * a + 3 * b + 3 * c, from by {
          rw h6, ring,
        },
        -- $\dfrac {a + b + c} {\paren {b + c} + \paren {a + c} + \paren {a + b} } = \dfrac {3 a + 3 b + 3 c} {3 a + 3 b + 3 c}$
        have h8 : (a + b + c) / ((b + c) + (a + c) + (a + b)) = (3 * a + 3 * b + 3 * c) / (3 * a + 3 * b + 3 * c), from by {
          rw [h5,h7],
        },
        -- $\dfrac {a + b + c} {\paren {b + c} + \paren {a + c} + \paren {a + b} } = \dfrac 1 2$
        have h9 : (a + b + c) / ((b + c) + (a + c) + (a + b)) = (1 / 2), from by {
          rw [h8,div_eq_div_iff (by {norm_num}) (by {norm_num})],
        },
        show (a + b + c) / ((b + c) + (a + c) + (a + b)) = (1 / 2), from h9,
      },
      -- $\dfrac {a + b + c} {b + c} + \dfrac {a + b + c} {a + c} + \dfrac {a + b + c} {a + b} \ge \dfrac {9 \paren {a + b + c} } {\paren {b + c} + \paren {a + c} + \paren {a + b} }$
      have h10 : (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) ≥ (9 * (a + b + c)) / ((b + c) + (a + c) + (a + b)), from by {
        -- $\dfrac {a + b + c} {b + c} + \dfrac {a + b + c} {a + c} + \dfrac {a + b + c} {a + b} \ge \dfrac {9 \paren {a + b + c} } {\paren {b + c} + \paren {a + c} + \paren {a + b} }$
        have h11 : (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) ≥ (9 * (a + b + c)) / ((b + c) + (a + c) + (a + b)), from by {
          -- $\dfrac {a + b + c} {b + c} + \dfrac {a + b + c} {a + c} + \dfrac {a + b + c} {a + b} \ge \dfrac {3 \paren {a + b + c} } {\paren {b + c} }$
          have h12 : (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) ≥ (3 * (a + b + c)) / (b + c), from by {
            -- $\dfrac {a + b + c} {b + c} + \dfrac {a + b + c} {a + c} \ge \dfrac {2 \paren {a + b + c} } {\paren {b + c} }$
            have h13 : (a + b + c) / (b + c) + (a + b + c) / (a + c) ≥ (2 * (a + b + c)) / (b + c), from by {
              -- $\dfrac {a + b + c} {b + c} + \dfrac {a + b + c} {a + c} \ge \dfrac {2 \paren {a + b + c} } {\paren {b + c} }$
              have h14 : (a + b + c) / (b + c) + (a + b + c) / (a + c) ≥ (2 * (a + b + c)) / (b + c), from by {
                -- $\dfrac {a + b + c} {b + c} \ge \dfrac {a + b + c} {\paren {b + c} }$
                have h15 : (a + b + c) / (b + c) ≥ (a + b + c) / (b + c), from by {
                  norm_num,
                },
                -- $\dfrac {a + b + c} {b + c} + \dfrac {a + b + c} {a + c} \ge \dfrac {a + b + c} {\paren {b + c} } + \dfrac {a + b + c} {a + c}$
                have h16 : (a + b + c) / (b + c) + (a + b + c) / (a + c) ≥ (a + b + c) / (b + c) + (a + b + c) / (a + c), from by {
                  apply add_le_add h15,
                },
                -- $\dfrac {a + b + c} {b + c} + \dfrac {a + b + c} {a + c} \ge \dfrac {2 \paren {a + b + c} } {\paren {b + c} }$
                have h17 : (a + b + c) / (b + c) + (a + b + c) / (a + c) ≥ (2 * (a + b + c)) / (b
end --Needs more than 2000 tokens!

--OUTPUT 6
theorem nesbitt_inequality {a b c : ℝ} (ha : 0 < a) (hb : 0 < b) (hc : 0 < c) : (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (3 / 2) :=
begin
  have h1 : (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b), from by {
    rw [add_div,add_div,add_div], ring,
  },
  have h2 : (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) ≥ (9 / 2) * (a + b + c), from by {
    rw [add_div,add_div,add_div], rw add_mul, ring,
  },
  have h3 : (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) ≥ (3 / 2) * (b + c + a + c + a + b), from by {
    rw [add_div,add_div,add_div], rw add_mul, ring,
  },
  have h4 : (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) ≥ (3 / 2) * (b + c + a + b), from by {
    rw [add_div,add_div,add_div], rw add_mul, ring,
  },
  have h5 : (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) ≥ (3 / 2) * (b + c + a + b), from by {
    rw [add_div,add_div,add_div], rw add_mul, ring,
  },
  have h6 : (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) ≥ (3 / 2) * (b + c + a + b), from by {
    rw [add_div,add_div,add_div], rw add_mul, ring,
  },
  have h7 : (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) ≥ (3 / 2) * (b + c + a + b), from by {
    rw [add_div,add_div,add_div], rw add_mul, ring,
  },
  have h8 : (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) ≥ (3 / 2) * (b + c + a + b), from by {
    rw [add_div,add_div,add_div], rw add_mul, ring,
  },
  have h9 : (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) ≥ (3 / 2) * (b + c + a + b), from by {
    rw [add_div,add_div,add_div], rw add_mul, ring,
  },
  have h10 : (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) ≥ (3 / 2) * (b + c + a + b), from by {
    rw [add_div,add_div,add_div], rw add_mul, ring,
  },
  have h11 : (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) ≥ (3 / 2) * (b + c + a + b), from by {
    rw [add_div,add_div,add_div], rw add_mul, ring,
  },
  have h12 : (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) ≥ (3 / 2) * (b + c + a + b), from by {
    rw [add_div,add_div,add_div], rw add_mul, ring,
  },
  have h13 : (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) ≥ (3 / 2) * (b + c + a + b), from by {
    rw [add_div,add_div,add_div], rw add_mul, ring,
  },
  have h14 : (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) ≥ (3 / 2) * (b + c + a + b), from by {
    rw [add_div,add_div,add_div], rw add_mul, ring,
  },
  have h15 : (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) ≥ (3 / 2) * (b + c + a + b), from by {
    rw [add_div,add_div,add_div], rw add_mul, ring,
  },
  have h16 : (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) ≥ (3 / 2) * (b + c + a + b), from by {
    rw [add_div,add_div,add_div], rw add_mul, ring,
  },
  have h17 : (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) ≥ (3 / 2) * (b + c + a + b), from by {
    rw [add_div,add_div,add_div], rw add_mul, ring,
  },
  have h18 : (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) ≥ (3 / 2) * (b + c + a + b), from by {
    rw [add_div,add_div,add_div], rw add_mul, ring,
  },
  have h19 : (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) ≥ (3 / 2) * (b + c + a + b), from by {
    rw [add_div,add_div,add_div], rw add_mul, ring,
  },
  have h20 : (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) ≥ (3 / 2) * (b + c + a + b), from by {
    rw [add_div,add_div,add_div], rw add_mul, ring,
  },
  have h21 : (a + b + c) / (b + c) + (a + b + c) / (a + c) + (a + b + c) / (a + b) ≥ (3 / 2) * (b + c + a + b), from by {
    rw [add_div,add_div,add_div], rw add_mul, ring,
end --Needs more than 2000 tokens!

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

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

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

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

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

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

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  -- $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`
Nesbitt's inequality
Let $a$, $b$ and $c$ be positive real numbers.

Then:
:$\dfrac a {b + c} + \dfrac b {a + c} + \dfrac c {a + b} \ge \dfrac 3 2$

`proof`
{{begin-eqn}}
{{eqn | l = \frac a {b + c} + \frac b {a + c} + \frac c {a + b}
      | o = \ge
      | r = \dfrac 3 2
}}
{{eqn | ll= \leadstoandfrom
      | l = \frac {a + b + c} {b + c} + \frac {a + b + c} {a + c} + \frac {a + b + c} {a + b}
      | o = \ge
      | r = \frac 9 2
      | c = by adding $3$
}}
{{eqn | ll= \leadstoandfrom
      | l = \frac {a + b + c} {b + c} + \frac {a + b + c} {a + c} + \frac {a + b + c} {a + b}
      | o = \ge
      | r = \frac {9 \paren {a + b + c} } {\paren {b + c} + \paren {a + c} + \paren {a + b} }
      | c = as $\dfrac {a + b + c} {\paren {b + c} + \paren {a + c} + \paren {a + b} } = \dfrac 1 2$
}}
{{eqn | ll= \leadstoandfrom
      | l = \frac {\frac 1 {b + c} + \frac 1 {a + c} + \frac 1 {a + b} } 3
      | o = \ge
      | r = \frac 3 {\paren {b + c} + \paren {a + c} + \paren {a + b} }
      | c = dividing by $3 \paren {a + b + c}$
}}
{{end-eqn}}
These are the arithmetic mean and the harmonic mean of $\dfrac 1 {b + c}$, $\dfrac 1 {a + c}$ and $\dfrac 1 {a + b}$.

From Arithmetic Mean is Never Less than Harmonic Mean the last inequality is true.

Thus Nesbitt's Inequality holds.
{{qed}}

-/
theorem  nesbitt_inequality {a b c : ℝ} (ha : 0 < a) (hb : 0 < b) (hc : 0 < c) : (a / (b + c)) + (b / (a + c)) + (c / (a + b)) ≥ (3 / 2) :=
FEW SHOT PROMPTS TO CODEX(END)-/


/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import algebraic_geometry.AffineScheme
import ring_theory.nilpotent
import topology.sheaves.sheaf_condition.sites
import category_theory.limits.constructions.binary_products
import algebra.category.Ring.constructions
import ring_theory.integral_domain
import ring_theory.local_properties

/-!
# Basic properties of schemes

We provide some basic properties of schemes

## Main definition
* `algebraic_geometry.is_integral`: A scheme is integral if it is nontrivial and all nontrivial
  components of the structure sheaf are integral domains.
* `algebraic_geometry.is_reduced`: A scheme is reduced if all the components of the structure sheaf
  is reduced.
-/

open topological_space opposite category_theory category_theory.limits Top

namespace algebraic_geometry

variable (X : Scheme)

instance : t0_space X.carrier :=
begin
  rw t0_space_iff_inseparable,
  intros x y h,
  obtain ⟨U, R, ⟨e⟩⟩ := X.local_affine x,
  have hy : y ∈ U.val := (h.mem_open_iff U.1.2).1 U.2,
  erw ← subtype_inseparable_iff (⟨x, U.2⟩ : U.1.1) (⟨y, hy⟩ : U.1.1) at h,
  let e' : U.1 ≃ₜ prime_spectrum R :=
    homeo_of_iso ((LocallyRingedSpace.forget_to_SheafedSpace ⋙ SheafedSpace.forget _).map_iso e),
  have := t0_space_of_injective_of_continuous e'.injective e'.continuous,
  rw t0_space_iff_inseparable at this,
  by simpa only [subtype.mk_eq_mk] using this ⟨x, U.2⟩ ⟨y, hy⟩ h
end

instance : quasi_sober X.carrier :=
begin
  apply_with (quasi_sober_of_open_cover
    (set.range (λ x, set.range $ (X.affine_cover.map x).1.base)))
    { instances := ff },
  { rintro ⟨_,i,rfl⟩, exact (X.affine_cover.is_open i).base_open.open_range },
  { rintro ⟨_,i,rfl⟩,
    exact @@open_embedding.quasi_sober _ _ _
      (homeomorph.of_embedding _ (X.affine_cover.is_open i).base_open.to_embedding)
      .symm.open_embedding prime_spectrum.quasi_sober },
  { rw [set.top_eq_univ, set.sUnion_range, set.eq_univ_iff_forall],
    intro x, exact ⟨_, ⟨_, rfl⟩, X.affine_cover.covers x⟩ }
end

/-- A scheme `X` is reduced if all `𝒪ₓ(U)` are reduced. -/
class is_reduced : Prop :=
(component_reduced : ∀ U, _root_.is_reduced (X.presheaf.obj (op U)) . tactic.apply_instance)

attribute [instance] is_reduced.component_reduced

lemma is_reduced_of_stalk_is_reduced [∀ x : X.carrier, _root_.is_reduced (X.presheaf.stalk x)] :
  is_reduced X :=
begin
  refine ⟨λ U, ⟨λ s hs, _⟩⟩,
  apply presheaf.section_ext X.sheaf U s 0,
  intro x,
  rw ring_hom.map_zero,
  change X.presheaf.germ x s = 0,
  exact (hs.map _).eq_zero
end

instance stalk_is_reduced_of_reduced [is_reduced X] (x : X.carrier) :
  _root_.is_reduced (X.presheaf.stalk x) :=
begin
  constructor,
  rintros g ⟨n, e⟩,
  obtain ⟨U, hxU, s, rfl⟩ := X.presheaf.germ_exist x g,
  rw [← map_pow, ← map_zero (X.presheaf.germ ⟨x, hxU⟩)] at e,
  obtain ⟨V, hxV, iU, iV, e'⟩ := X.presheaf.germ_eq x hxU hxU _ 0 e,
  rw [map_pow, map_zero] at e',
  replace e' := (is_nilpotent.mk _ _ e').eq_zero,
  erw ← concrete_category.congr_hom (X.presheaf.germ_res iU ⟨x, hxV⟩) s,
  rw [comp_apply, e', map_zero]
end

lemma is_reduced_of_open_immersion {X Y : Scheme} (f : X ⟶ Y) [H : is_open_immersion f]
  [is_reduced Y] : is_reduced X :=
begin
  constructor,
  intro U,
  have : U = (opens.map f.1.base).obj (H.base_open.is_open_map.functor.obj U),
  { ext1, exact (set.preimage_image_eq _ H.base_open.inj).symm },
  rw this,
  exact is_reduced_of_injective (inv $ f.1.c.app (op $ H.base_open.is_open_map.functor.obj U))
    (as_iso $ f.1.c.app (op $ H.base_open.is_open_map.functor.obj U) : Y.presheaf.obj _ ≅ _).symm
      .CommRing_iso_to_ring_equiv.injective
end

instance {R : CommRing} [H : _root_.is_reduced R] : is_reduced (Scheme.Spec.obj $ op R) :=
begin
  apply_with is_reduced_of_stalk_is_reduced { instances := ff },
  intro x, dsimp,
  haveI : _root_.is_reduced (CommRing.of $ localization.at_prime (prime_spectrum.as_ideal x)),
  { dsimp, apply_instance },
  exact is_reduced_of_injective (structure_sheaf.stalk_iso R x).hom
    (structure_sheaf.stalk_iso R x).CommRing_iso_to_ring_equiv.injective,
end

lemma affine_is_reduced_iff (R : CommRing) :
  is_reduced (Scheme.Spec.obj $ op R) ↔ _root_.is_reduced R :=
begin
  refine ⟨_, λ h, by exactI infer_instance⟩,
  intro h,
  resetI,
  haveI : _root_.is_reduced (LocallyRingedSpace.Γ.obj (op $ Spec.to_LocallyRingedSpace.obj $ op R)),
  { change _root_.is_reduced ((Scheme.Spec.obj $ op R).presheaf.obj $ op ⊤), apply_instance },
  exact is_reduced_of_injective (to_Spec_Γ R)
    ((as_iso $ to_Spec_Γ R).CommRing_iso_to_ring_equiv.injective)
end

lemma is_reduced_of_is_affine_is_reduced [is_affine X]
  [h : _root_.is_reduced (X.presheaf.obj (op ⊤))] : is_reduced X :=
begin
  haveI : is_reduced (Scheme.Spec.obj (op (Scheme.Γ.obj (op X)))),
  { rw affine_is_reduced_iff, exact h },
  exact is_reduced_of_open_immersion X.iso_Spec.hom,
end

/-- To show that a statement `P` holds for all open subsets of all schemes, it suffices to show that
1. In any scheme `X`, if `P` holds for an open cover of `U`, then `P` holds for `U`.
2. For an open immerison `f : X ⟶ Y`, if `P` holds for the entire space of `X`, then `P` holds for
  the image of `f`.
3. `P` holds for the entire space of an affine scheme.
-/
lemma reduce_to_affine_global (P : ∀ (X : Scheme) (U : opens X.carrier), Prop)
  (h₁ : ∀ (X : Scheme) (U : opens X.carrier),
    (∀ (x : U), ∃ {V} (h : x.1 ∈ V) (i : V ⟶ U), P X V) → P X U)
  (h₂ : ∀ {X Y} (f : X ⟶ Y) [hf : is_open_immersion f], ∃ {U : set X.carrier} {V : set Y.carrier}
    (hU : U = ⊤) (hV : V = set.range f.1.base), P X ⟨U, hU.symm ▸ is_open_univ⟩ →
      P Y ⟨V, hV.symm ▸ hf.base_open.open_range⟩)
  (h₃ : ∀ (R : CommRing), P (Scheme.Spec.obj $ op R) ⊤) :
  ∀ (X : Scheme) (U : opens X.carrier), P X U :=
begin
  intros X U,
  apply h₁,
  intro x,
  obtain ⟨_,⟨j,rfl⟩,hx,i⟩ := X.affine_basis_cover_is_basis.exists_subset_of_mem_open x.prop U.2,
  let U' : opens _ := ⟨_, (X.affine_basis_cover.is_open j).base_open.open_range⟩,
  let i' : U' ⟶ U :=
    hom_of_le i,
  refine ⟨U', hx, i', _⟩,
  obtain ⟨_,_,rfl,rfl,h₂'⟩ := h₂ (X.affine_basis_cover.map j),
  apply h₂',
  apply h₃
end
.
lemma reduce_to_affine_nbhd (P : ∀ (X : Scheme) (x : X.carrier), Prop)
  (h₁ : ∀ (R : CommRing) (x : prime_spectrum R), P (Scheme.Spec.obj $ op R) x)
  (h₂ : ∀ {X Y} (f : X ⟶ Y) [is_open_immersion f] (x : X.carrier), P X x → P Y (f.1.base x)) :
  ∀ (X : Scheme) (x : X.carrier), P X x :=
begin
  intros X x,
  obtain ⟨y, e⟩ := X.affine_cover.covers x,
  convert h₂ (X.affine_cover.map (X.affine_cover.f x)) y _,
  { rw e },
  apply h₁,
end

lemma eq_zero_of_basic_open_empty {X : Scheme} [hX : is_reduced X] {U : opens X.carrier}
  (s : X.presheaf.obj (op U)) (hs : X.basic_open s = ∅) :
  s = 0 :=
begin
  apply Top.presheaf.section_ext X.sheaf U,
  simp_rw ring_hom.map_zero,
  unfreezingI { revert X U hX s },
  refine reduce_to_affine_global _ _ _ _,
  { intros X U hx hX s hs x,
    obtain ⟨V, hx, i, H⟩ := hx x,
    unfreezingI { specialize H (X.presheaf.map i.op s) },
    erw Scheme.basic_open_res at H,
    rw [hs, ← subtype.coe_injective.eq_iff, opens.empty_eq, opens.inter_eq, inf_bot_eq] at H,
    specialize H rfl ⟨x, hx⟩,
    erw Top.presheaf.germ_res_apply at H,
    exact H },
  { rintros X Y f hf,
    have e : (f.val.base) ⁻¹' set.range ⇑(f.val.base) = ⊤,
    { rw [← set.image_univ, set.preimage_image_eq _ hf.base_open.inj, set.top_eq_univ] },
    refine ⟨_, _, e, rfl, _⟩,
    rintros H hX s hs ⟨_, x, rfl⟩,
    unfreezingI { haveI := is_reduced_of_open_immersion f },
    specialize H (f.1.c.app _ s) _ ⟨x, by { change x ∈ (f.val.base) ⁻¹' _, rw e, trivial }⟩,
    { rw [← Scheme.preimage_basic_open, hs], ext1, simp [opens.map] },
    { erw ← PresheafedSpace.stalk_map_germ_apply f.1 ⟨_,_⟩ ⟨x,_⟩ at H,
      apply_fun (inv $ PresheafedSpace.stalk_map f.val x) at H,
      erw [category_theory.is_iso.hom_inv_id_apply, map_zero] at H,
      exact H } },
  { intros R hX s hs x,
    erw [basic_open_eq_of_affine', prime_spectrum.basic_open_eq_bot_iff] at hs,
    replace hs := (hs.map (Spec_Γ_identity.app R).inv),
    -- what the hell?!
    replace hs := @is_nilpotent.eq_zero _ _ _ _ (show _, from _) hs,
    rw iso.hom_inv_id_apply at hs,
    rw [hs, map_zero],
    exact @@is_reduced.component_reduced hX ⊤ }
end

@[simp]
lemma basic_open_eq_bot_iff {X : Scheme} [is_reduced X] {U : opens X.carrier}
  (s : X.presheaf.obj $ op U) :
  X.basic_open s = ⊥ ↔ s = 0 :=
begin
  refine ⟨eq_zero_of_basic_open_empty s, _⟩,
  rintro rfl,
  simp,
end

/-- A scheme `X` is integral if its carrier is nonempty,
and `𝒪ₓ(U)` is an integral domain for each `U ≠ ∅`. -/
class is_integral : Prop :=
(nonempty : nonempty X.carrier . tactic.apply_instance)
(component_integral : ∀ (U : opens X.carrier) [_root_.nonempty U],
  is_domain (X.presheaf.obj (op U)) . tactic.apply_instance)

attribute [instance] is_integral.component_integral is_integral.nonempty

instance [h : is_integral X] : is_domain (X.presheaf.obj (op ⊤)) :=
@@is_integral.component_integral _ _ (by simp)

@[priority 900]
instance is_reduced_of_is_integral [is_integral X] : is_reduced X :=
begin
  constructor,
  intro U,
  cases U.1.eq_empty_or_nonempty,
  { have : U = ∅ := subtype.eq h,
    haveI := CommRing.subsingleton_of_is_terminal (X.sheaf.is_terminal_of_eq_empty this),
    change _root_.is_reduced (X.sheaf.val.obj (op U)),
    apply_instance },
  { haveI : nonempty U := by simpa, apply_instance }
end

instance is_irreducible_of_is_integral [is_integral X] : irreducible_space X.carrier :=
begin
  by_contradiction H,
  replace H : ¬ is_preirreducible (⊤ : set X.carrier) := λ h,
    H { to_preirreducible_space := ⟨h⟩, to_nonempty := infer_instance },
  simp_rw [is_preirreducible_iff_closed_union_closed, not_forall, not_or_distrib] at H,
  rcases H with ⟨S, T, hS, hT, h₁, h₂, h₃⟩,
  erw not_forall at h₂ h₃,
  simp_rw not_forall at h₂ h₃,
  haveI : nonempty (⟨Sᶜ, hS.1⟩ : opens X.carrier) := ⟨⟨_, h₂.some_spec.some_spec⟩⟩,
  haveI : nonempty (⟨Tᶜ, hT.1⟩ : opens X.carrier) := ⟨⟨_, h₃.some_spec.some_spec⟩⟩,
  haveI : nonempty (⟨Sᶜ, hS.1⟩ ⊔ ⟨Tᶜ, hT.1⟩ : opens X.carrier) :=
    ⟨⟨_, or.inl h₂.some_spec.some_spec⟩⟩,
  let e : X.presheaf.obj _ ≅ CommRing.of _ := (X.sheaf.is_product_of_disjoint ⟨_, hS.1⟩ ⟨_, hT.1⟩ _)
    .cone_point_unique_up_to_iso (CommRing.prod_fan_is_limit _ _),
  apply_with false_of_nontrivial_of_product_domain { instances := ff },
  { exact e.symm.CommRing_iso_to_ring_equiv.is_domain _ },
  { apply X.to_LocallyRingedSpace.component_nontrivial },
  { apply X.to_LocallyRingedSpace.component_nontrivial },
  { ext x,
    split,
    { rintros ⟨hS,hT⟩,
      cases h₁ (show x ∈ ⊤, by trivial),
      exacts [hS h, hT h] },
    { intro x, exact x.rec _ } }
end

lemma is_integral_of_is_irreducible_is_reduced [is_reduced X] [H : irreducible_space X.carrier] :
  is_integral X :=
begin
  split, refine λ U hU, ⟨λ a b e, _,
    (@@LocallyRingedSpace.component_nontrivial X.to_LocallyRingedSpace U hU).1⟩,
  simp_rw [← basic_open_eq_bot_iff, ← opens.not_nonempty_iff_eq_bot],
  by_contra' h,
  obtain ⟨_, ⟨x, hx₁, rfl⟩, ⟨x, hx₂, e'⟩⟩ := @@nonempty_preirreducible_inter _ H.1
    (X.basic_open a).2 (X.basic_open b).2
    h.1 h.2,
  replace e' := subtype.eq e',
  subst e',
  replace e := congr_arg (X.presheaf.germ x) e,
  rw [ring_hom.map_mul, ring_hom.map_zero] at e,
  refine @zero_ne_one (X.presheaf.stalk x.1) _ _ (is_unit_zero_iff.1 _),
  convert hx₁.mul hx₂,
  exact e.symm
end

lemma is_integral_iff_is_irreducible_and_is_reduced :
  is_integral X ↔ irreducible_space X.carrier ∧ is_reduced X :=
⟨λ _, by exactI ⟨infer_instance, infer_instance⟩,
  λ ⟨_, _⟩, by exactI is_integral_of_is_irreducible_is_reduced X⟩

lemma is_integral_of_open_immersion {X Y : Scheme} (f : X ⟶ Y) [H : is_open_immersion f]
  [is_integral Y] [nonempty X.carrier] : is_integral X :=
begin
  constructor,
  intros U hU,
  have : U = (opens.map f.1.base).obj (H.base_open.is_open_map.functor.obj U),
  { ext1, exact (set.preimage_image_eq _ H.base_open.inj).symm },
  rw this,
  haveI : is_domain (Y.presheaf.obj (op (H.base_open.is_open_map.functor.obj U))),
  { apply_with is_integral.component_integral { instances := ff },
    apply_instance,
    refine ⟨⟨_, _, hU.some.prop, rfl⟩⟩ },
  exact (as_iso $ f.1.c.app (op $ H.base_open.is_open_map.functor.obj U) :
    Y.presheaf.obj _ ≅ _).symm.CommRing_iso_to_ring_equiv.is_domain _
end

instance {R : CommRing} [H : is_domain R] : is_integral (Scheme.Spec.obj $ op R) :=
begin
  apply_with is_integral_of_is_irreducible_is_reduced { instances := ff },
  { apply_instance },
  { dsimp [Spec.Top_obj],
    apply_instance },
end

lemma affine_is_integral_iff (R : CommRing) :
  is_integral (Scheme.Spec.obj $ op R) ↔ is_domain R :=
⟨λ h, by exactI ring_equiv.is_domain ((Scheme.Spec.obj $ op R).presheaf.obj _)
  (as_iso $ to_Spec_Γ R).CommRing_iso_to_ring_equiv, λ h, by exactI infer_instance⟩

lemma is_integral_of_is_affine_is_domain [is_affine X] [nonempty X.carrier]
  [h : is_domain (X.presheaf.obj (op ⊤))] : is_integral X :=
begin
  haveI : is_integral (Scheme.Spec.obj (op (Scheme.Γ.obj (op X)))),
  { rw affine_is_integral_iff, exact h },
  exact is_integral_of_open_immersion X.iso_Spec.hom,
end

lemma map_injective_of_is_integral [is_integral X] {U V : opens X.carrier} (i : U ⟶ V)
  [H : nonempty U] :
  function.injective (X.presheaf.map i.op) :=
begin
  rw injective_iff_map_eq_zero,
  intros x hx,
  rw ← basic_open_eq_bot_iff at ⊢ hx,
  rw Scheme.basic_open_res at hx,
  revert hx,
  contrapose!,
  simp_rw [← opens.not_nonempty_iff_eq_bot, not_not],
  apply nonempty_preirreducible_inter U.prop (RingedSpace.basic_open _ _).prop,
  simpa using H
end

end algebraic_geometry


import category_theory.types
import ..instances
import tidy.its
import tactic.interactive

open category_theory.universal

namespace category_theory.types

universe u

local attribute [forward] congr_fun

instance Types_has_Products : has_Products (Type u) :=
{ product := λ I φ, { product       := Π i : I, φ i,
                      projection    := λ i x, x i,
                      map           := λ Z f z i, f i z,
                      factorisation := begin
                                         -- `obviously'` says:
                                         intros,
                                         refl
                                       end,
                      uniqueness    := begin
                                        /- obviously says: -/
                                        intros Z f g witness,
                                        ext,
                                        have f_x_x_1 := f x x_1,
                                        have witness_x_1 := witness x_1,
                                        have congr_fun_witness_x_1_x := congr_fun witness_x_1 x,
                                        dsimp at *,
                                        solve_by_elim
                                       end } }

instance Types_has_Coproducts : has_Coproducts (Type u) :=
{ coproduct := λ I φ,
  { coproduct     := Σ i : I, φ i,
    inclusion     := λ i x, ⟨ i, x ⟩,
    map           := λ Z f p, f p.1 p.2,
    factorisation := begin /- `obviously'` says: -/ intros, refl end,
    uniqueness    := begin
                        /- obviously says: -/
                        intros Z f g witness,
                        ext,
                        cases x,
                        have witness_x_fst := witness x_fst,
                        have congr_fun_witness_x_fst_x_snd := congr_fun witness_x_fst x_snd,
                        dsimp at *,
                        solve_by_elim
                      end } }

-- Even though this can be automatically generated from `Types_has_Products`, this is a cleaner version.
instance Types_has_BinaryProducts : has_BinaryProducts.{u+1 u} (Type u) :=
{ binary_product := λ X Y,
  { product := X × Y,
    left_projection     := prod.fst,
    right_projection    := prod.snd,
    map                 := λ _ f g z, (f z, g z),
    left_factorisation  := begin /- `obviously'` says: -/ intros, refl end,
    right_factorisation := begin /- `obviously'` says: -/ intros, refl end,
    uniqueness          := begin
                            /- obviously says: -/
                            intros Z f g left_witness right_witness,
                            ext,
                            have congr_fun_left_witness_x := congr_fun left_witness x,
                            have congr_fun_right_witness_x := congr_fun right_witness x, -- superfluous!
                            dsimp at *,
                            solve_by_elim,
                            have congr_fun_left_witness_x := congr_fun left_witness x,
                            have congr_fun_right_witness_x := congr_fun right_witness x, -- superfluous!
                            dsimp at *,
                            solve_by_elim
                          end } }

instance Types_has_BinaryCoproducts : has_BinaryCoproducts.{u+1 u} (Type u) :=
{ binary_coproduct := λ X Y,
  { coproduct           := X ⊕ Y,
    left_inclusion      := sum.inl,
    right_inclusion     := sum.inr,
    map                 := λ _ f g z, sum.cases_on z f g,
    left_factorisation  := begin /- `obviously'` says: -/ intros, refl end,
    right_factorisation := begin /- `obviously'` says: -/ intros, refl end,
    uniqueness          := begin
                              /- obviously says: -/
                              intros Z f g left_witness right_witness,
                              ext,
                              cases x,
                              have congr_fun_lw_x := congr_fun left_witness x,
                              dsimp at *,
                              solve_by_elim,
                              have congr_fun_rw_x := congr_fun right_witness x,
                              dsimp at *,
                              solve_by_elim
                            end } }

instance Types_has_Equalizers : has_Equalizers.{u+1 u} (Type u) :=
{ equalizer := λ α β f g, { equalizer     := {x : α // f x = g x},
                            inclusion     := λ x, x.val,
                            map           := λ γ k h g, ⟨ k g, begin
                                                                 /- obviously says: -/
                                                                 have congr_fun_h_g := congr_fun h g,
                                                                 dsimp at *,
                                                                 solve_by_elim
                                                               end ⟩,
                            factorisation := begin /- `obviously'` says: -/ intros, refl end,
                            witness       := begin
                                               -- `obviously'` says:
                                               ext,
                                               automatic_induction,
                                               dsimp,
                                               solve_by_elim,
                                             end,
                            uniqueness    := begin
                                               /- obviously says: -/
                                               intros Z a b witness,
                                               ext,
                                               have congr_fun_witness_x := congr_fun witness x,
                                               dsimp at *,
                                               solve_by_elim
                                             end } }

@[back'] lemma constant_on_quotient {α β : Type u} (f g : α → β) {Z : Type u} (k : β → Z) (x y : β) (h : eqv_gen (λ (x y : β), ∃ (a : α), f a = x ∧ g a = y) x y) (w : k ∘ f = k ∘ g) : k x = k y :=
begin
  induction h,
  /- obviously says: -/
  cases h_a,
  have congr_fun_w_h_a_w := congr_fun w h_a_w,
  cases h_a_h,
  induction h_a_h_right,
  induction h_a_h_left,
  solve_by_elim,
  refl,
  solve_by_elim,
  erw [h_ih_a, h_ih_a_1]
end

instance Types_has_Coequalizers : has_Coequalizers.{u+1 u} (Type u) :=
{ coequalizer := λ α β f g, by
    letI s := eqv_gen.setoid (λ x y, ∃ a : α, f a = x ∧ g a = y);
    exact { coequalizer   := quotient s,
            projection    := begin /- `obviously'` says: -/ apply quotient.mk end,
            map           := λ Z k w, quotient.lift k begin
                                                        /- obviously says: -/
                                                        intros a b a_1,
                                                        apply category_theory.types.constant_on_quotient ; solve_by_elim
                                                      end,
            factorisation := begin /- `obviously'` says: -/ intros, refl end,
            witness       := begin
                                -- `obviously'` says:
                                ext,
                                apply quotient.sound,
                                dsimp at *,
                                apply eqv_gen.rel,
                                fsplit,
                                solve_by_elim,
                                simp at *
                              end,
            uniqueness    := begin
                                /- obviously says: -/
                                intros Z a b witness,
                                ext,
                                induction x,
                                have congr_fun_witness_x := congr_fun witness x,
                                dsimp at *,
                                solve_by_elim,
                                refl
                              end } }
end category_theory.types


import topology.path_connected

import to_mathlib.topology.misc

open set function int topological_space
open_locale big_operators topology unit_interval
noncomputable theory

variables {X X' Y Z : Type*} [topological_space X]
variables [topological_space X'] [topological_space Y] [topological_space Z]

namespace path

variables {x : X} {γ γ' : path x x} {t₀ t : I}

/-- A loop evaluated at `t / t` is equal to its endpoint. Note that `t / t = 0` for `t = 0`. -/
@[simp] lemma extend_div_self (γ : path x x) (t : ℝ) :
  γ.extend (t / t) = x :=
by by_cases h : t = 0; simp [h]

/-- Concatenation of two loops which moves through the first loop on `[0, t₀]` and
through the second one on `[t₀, 1]`. All endpoints are assumed to be the same so that this
function is also well-defined for `t₀ ∈ {0, 1}`.
`strans` stands either for a *s*kewed transitivity, or a transitivity with different *s*peeds. -/
def strans (γ γ' : path x x) (t₀ : I) : path x x :=
{ to_fun := λ t, if t ≤ t₀ then γ.extend (t / t₀) else γ'.extend ((t - t₀) / (1 - t₀)),
  continuous_to_fun :=
  begin
    refine continuous.if_le _ _ continuous_id continuous_const (by simp only [extend_div_self,
      Icc.mk_zero, zero_le_one, id.def, zero_div, forall_eq, extend_extends, path.source,
      left_mem_Icc, sub_self]),
    -- TODO: the following are provable by `continuity` but it is too slow
    exacts [γ.continuous_extend.comp (continuous_subtype_coe.div_const _),
      γ'.continuous_extend.comp ((continuous_subtype_coe.sub continuous_const).div_const _)]
  end,
  source' := by simp only [unit_interval.nonneg', Icc.coe_zero,
    Icc.mk_zero, zero_le_one,
    if_true, zero_div, comp_app, extend_extends, path.source, left_mem_Icc],
  target' := by simp only [unit_interval.le_one'.le_iff_eq.trans eq_comm, extend_div_self,
    Icc.coe_one, implies_true_iff, eq_self_iff_true, comp_app, ite_eq_right_iff]
    {contextual := tt}}

/-- Reformulate `strans` without using `extend`. This is useful to not have to prove that the
  arguments to `γ` lie in `I` after this. -/
lemma strans_def (γ γ' : path x x) : γ.strans γ' t₀ t =
  if h : t ≤ t₀ then γ ⟨t / t₀, unit_interval.div_mem t.2.1 t₀.2.1 h⟩ else
  γ' ⟨(t - t₀) / (1 - t₀), unit_interval.div_mem (sub_nonneg.mpr $ le_of_not_le h)
    (sub_nonneg.mpr t₀.2.2) (sub_le_sub_right t.2.2 t₀)⟩ :=
by split_ifs; simp [strans, h, ← extend_extends]

@[simp] lemma strans_of_ge (h : t₀ ≤ t) : γ.strans γ' t₀ t = γ'.extend ((t - t₀) / (1 - t₀)) :=
begin
  simp only [path.coe_mk, path.strans, ite_eq_right_iff],
  intro h2, obtain rfl := le_antisymm h h2, simp
end

lemma unit_interval.zero_le (x : I) : 0 ≤ x := x.prop.1

@[simp] lemma strans_zero (γ γ' : path x x) : γ.strans γ' 0 = γ' :=
by { ext t, simp only [strans_of_ge (unit_interval.zero_le t), Icc.coe_zero,
  div_one, extend_extends',
  unit_interval.nonneg'.le_iff_eq, sub_zero, div_zero, extend_zero, ite_eq_right_iff,
  show (t : ℝ) = 0 ↔ t = 0, from (@subtype.ext_iff _ _ t 0).symm, path.source, eq_self_iff_true,
  implies_true_iff] {contextual := tt} }

@[simp] lemma strans_one {x : X} (γ γ' : path x x) : γ.strans γ' 1 = γ :=
by { ext t, simp only [strans, unit_interval.le_one', path.coe_mk, if_pos, div_one,
  extend_extends', Icc.coe_one] }

@[simp] lemma strans_self {x : X} (γ γ' : path x x) (t₀ : I) : γ.strans γ' t₀ t₀ = x :=
by { simp only [strans, path.coe_mk, extend_div_self, if_pos, le_rfl], }

@[simp] lemma refl_strans_refl {x : X} {t₀ : I} : (refl x).strans (refl x) t₀ = refl x :=
by { ext s, simp [strans] }

lemma subset_range_strans_left {x : X} {γ γ' : path x x} {t₀ : I} (h : t₀ ≠ 0) :
  range γ ⊆ range (γ.strans γ' t₀) :=
by { rintro _ ⟨t, rfl⟩, use t * t₀,
  simp [strans, unit_interval.mul_le_right, unit_interval.coe_ne_zero.mpr h] }

lemma subset_range_strans_right {x : X} {γ γ' : path x x} {t₀ : I} (h : t₀ ≠ 1) :
  range γ' ⊆ range (γ.strans γ' t₀) :=
begin
  rintro _ ⟨t, rfl⟩,
  have := mul_nonneg t.2.1 (sub_nonneg.mpr t₀.2.2),
  let t' : I := ⟨t₀ + t * (1 - t₀), add_nonneg t₀.2.1 this, by { rw [add_comm, ← le_sub_iff_add_le],
    refine (mul_le_mul_of_nonneg_right t.2.2 $ sub_nonneg.mpr t₀.2.2).trans_eq (one_mul _) }⟩,
  have h2 : t₀ ≤ t' := le_add_of_nonneg_right this,
  have h3 := sub_ne_zero.mpr (unit_interval.coe_ne_one.mpr h).symm,
  use t',
  simp [h2, unit_interval.coe_ne_one.mpr h, h3],
end

lemma range_strans_subset {x : X} {γ γ' : path x x} {t₀ : I} :
  range (γ.strans γ' t₀) ⊆ range γ ∪ range γ' :=
begin
  rintro _ ⟨t, rfl⟩,
  by_cases h : t ≤ t₀,
  { rw [strans_def, dif_pos h], exact or.inl (mem_range_self _) },
  { rw [strans_def, dif_neg h], exact or.inr (mem_range_self _) }
end

lemma _root_.continuous.path_strans {X Y : Type*} [uniform_space X] [separated_space X]
  [locally_compact_space X] [uniform_space Y] {f : X → Y} {t : X → I} {s : X → I}
  {γ γ' : ∀ x, path (f x) (f x)}
  (hγ : continuous ↿γ)
  (hγ' : continuous ↿γ')
  (hγ0 : ∀ ⦃x s⦄, t x = 0 → γ x s = f x)
  (hγ'1 : ∀ ⦃x s⦄, t x = 1 → γ' x s = f x)
  (ht : continuous t)
  (hs : continuous s) :
  continuous (λ x, strans (γ x) (γ' x) (t x) (s x)) :=
begin
  have hγ0 : ∀ {x₀}, t x₀ = 0 → tendsto_uniformly (λ x, γ x) (λ _, f x₀) (𝓝 x₀),
  { intros x₀ hx₀, convert continuous.tendsto_uniformly (λ x, γ x) hγ _,
    ext t, rw [hγ0 hx₀] },
  have hγ'1 : ∀ {x₀}, t x₀ = 1 → tendsto_uniformly (λ x, γ' x) (λ _, f x₀) (𝓝 x₀),
  { intros x₀ hx₀, convert continuous.tendsto_uniformly (λ x, γ' x) hγ' _,
    ext t, rw [hγ'1 hx₀] },
  refine continuous.if_le _ _ hs ht _,
  { rw [continuous_iff_continuous_at],
    intro x,
    refine (continuous_subtype_coe.comp hs).continuous_at.comp_div_cases (λ x s, (γ x).extend s)
      (continuous_subtype_coe.comp ht).continuous_at _ _,
    { intro h,
      refine continuous_at.path_extend _ _ continuous_at_snd,
      exact hγ.continuous_at.comp (continuous_at_fst.fst.prod continuous_at_snd) },
    { intro h,
      have ht : t x = 0 := subtype.ext h,
      apply filter.tendsto.path_extend,
      dsimp only, rw [(proj_Icc_surjective _).filter_map_top, extend_zero],
      refine tendsto_prod_top_iff.mpr (hγ0 ht) } },
  { rw [continuous_iff_continuous_at],
    intro x,
    refine ((continuous_subtype_coe.comp hs).sub (continuous_subtype_coe.comp ht))
      .continuous_at.comp_div_cases (λ x s, (γ' x).extend s)
      (continuous_const.sub $ continuous_subtype_coe.comp ht).continuous_at _ _,
    { intro h,
      refine continuous_at.path_extend _ _ continuous_at_snd,
      exact hγ'.continuous_at.comp (continuous_at_fst.fst.prod continuous_at_snd) },
    { intro h,
      have ht : t x = 1 := subtype.ext (sub_eq_zero.mp h).symm,
      apply filter.tendsto.path_extend,
      dsimp only, rw [(proj_Icc_surjective _).filter_map_top, extend_zero],
      refine tendsto_prod_top_iff.mpr (hγ'1 ht) } },
  { rintro x h, rw [h, sub_self, zero_div, extend_div_self, extend_zero] },
end

end path


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

/-!

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

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

# Definitions/Theorems

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

-/

namespace category_theory
open category

universes v u -- morphism levels before object levels. See note [category_theory universes].
variables {C : Type u} [category.{v} C]

namespace Monad
local attribute [instance, reducible] endofunctor_monoidal_category

/-- To every `Monad C` we associated a monoid object in `C ⥤ C`.-/
@[simps]
def to_Mon : monad C → Mon_ (C ⥤ C) := λ M,
{ X := (M : C ⥤ C),
  one := M.η,
  mul := M.μ,
  mul_assoc' := by { ext, dsimp, simp [M.assoc] } }

variable (C)
/-- Passing from `Monad C` to `Mon_ (C ⥤ C)` is functorial. -/
@[simps]
def Monad_to_Mon : monad C ⥤ Mon_ (C ⥤ C) :=
{ obj := to_Mon,
  map := λ _ _ f, { hom := f.to_nat_trans } }
variable {C}

/-- To every monoid object in `C ⥤ C` we associate a `Monad C`. -/
@[simps]
def of_Mon : Mon_ (C ⥤ C) → monad C := λ M,
{ to_functor := M.X,
  η' := M.one,
  μ' := M.mul,
  left_unit' := λ X, by { rw [←M.one.id_hcomp_app, ←nat_trans.comp_app, M.mul_one], refl },
  right_unit' := λ X, by { rw [←M.one.hcomp_id_app, ←nat_trans.comp_app, M.one_mul], refl },
  assoc' := λ X, by { rw [←nat_trans.hcomp_id_app, ←nat_trans.comp_app], simp } }

variable (C)
/-- Passing from `Mon_ (C ⥤ C)` to `Monad C` is functorial. -/
@[simps]
def Mon_to_Monad : Mon_ (C ⥤ C) ⥤ monad C :=
{ obj := of_Mon,
  map := λ _ _ f,
  { app_η' := begin
      intro X,
      erw [←nat_trans.comp_app, f.one_hom],
      refl,
    end,
    app_μ' := begin
      intro X,
      erw [←nat_trans.comp_app, f.mul_hom],
      finish,
    end,
    ..f.hom } }

namespace Monad_Mon_equiv
variable {C}

/-- Isomorphism of functors used in `Monad_Mon_equiv` -/
@[simps {rhs_md := semireducible}]
def counit_iso : Mon_to_Monad C ⋙ Monad_to_Mon C ≅ 𝟭 _ :=
{ hom := { app := λ _, { hom := 𝟙 _ } },
  inv := { app := λ _, { hom := 𝟙 _ } } }

/-- Auxilliary definition for `Monad_Mon_equiv` -/
@[simps]
def unit_iso_hom : 𝟭 _ ⟶ Monad_to_Mon C ⋙ Mon_to_Monad C :=
{ app := λ _, { app := λ _, 𝟙 _ } }

/-- Auxilliary definition for `Monad_Mon_equiv` -/
@[simps]
def unit_iso_inv : Monad_to_Mon C ⋙ Mon_to_Monad C ⟶ 𝟭 _ :=
{ app := λ _, { app := λ _, 𝟙 _ } }

/-- Isomorphism of functors used in `Monad_Mon_equiv` -/
@[simps]
def unit_iso : 𝟭 _ ≅ Monad_to_Mon C ⋙ Mon_to_Monad C :=
{ hom := unit_iso_hom,
  inv := unit_iso_inv }

end Monad_Mon_equiv

open Monad_Mon_equiv

/-- Oh, monads are just monoids in the category of endofunctors (equivalence of categories). -/
@[simps]
def Monad_Mon_equiv : (monad C) ≌ (Mon_ (C ⥤ C)) :=
{ functor := Monad_to_Mon _,
  inverse := Mon_to_Monad _,
  unit_iso := unit_iso,
  counit_iso := counit_iso }

-- Sanity check
example (A : monad C) {X : C} : ((Monad_Mon_equiv C).unit_iso.app A).hom.app X = 𝟙 _ := rfl

end Monad
end category_theory


import tactic
import logic.basic
import category.nursery
import category.liftable

universes u v w

namespace medium

variables w : Type

inductive put_m' (w : Type) (α : Type u)
| pure {} : α → put_m'
| write : w → (unit → put_m') → put_m'

abbreviation put_m : Type → Type u := λ w, put_m' w punit

variables {w}

def put_m'.bind {α β} : put_m' w α → (α → put_m' w β) → put_m' w β
| (put_m'.pure x)   f := f x
| (put_m'.write w f) g := put_m'.write w $ λ u, put_m'.bind (f u) g

instance put_m'.monad : monad (put_m' w) :=
{ pure := λ α, put_m'.pure
, bind := @put_m'.bind w }

instance put_m'.is_lawful_monad : is_lawful_monad.{u} (put_m' w) :=
by { refine { .. }; intros;
       try { refl };
       dsimp [(<$>),(>>=)];
       induction x;
       try { refl },
     all_goals
     { dsimp [put_m'.bind], congr, ext, apply x_ih }, }

def put_m'.eval : put_m w → list w
| (put_m'.pure x) := []
| (put_m'.write w f) := w :: put_m'.eval (f punit.star)

variable w

inductive get_m : Type u → Type (u+1)
| fail {} {α} : get_m α
| pure {} {α} : α → get_m α
| read {α} : (w → get_m α) → get_m α
| loop {α β γ : Type u} : (β → w → get_m (α ⊕ β)) → (α → get_m γ) → β → get_m γ

variables {w}

def get_m.bind : Π {α β}, get_m w α → (α → get_m w β) → get_m w β
| _ _ (get_m.fail) _ := get_m.fail
| _ _ (get_m.pure x)   f := f x
| _ _ (get_m.read f) g := get_m.read $ λ w, get_m.bind (f w) g
| _ _ (get_m.loop f g x₀) h := get_m.loop f (λ r, get_m.bind (g r) h) x₀

def get_m.map : Π {α β : Type u}, (α → β) → get_m w α → get_m w β
| _ _ _ (get_m.fail) := get_m.fail
| _ _ f (get_m.pure x) := get_m.pure $ f x
| _ _ f (get_m.read g) := get_m.read $ λ w, get_m.map f (g w)
| _ _ h (get_m.loop f g x₀) := get_m.loop f (λ r, get_m.map h (g r)) x₀

@[simp]
def get_m.loop.rest {α β γ : Type u} (f : β → w → get_m w (α ⊕ β)) (g : α → get_m w γ) : α ⊕ β → get_m w γ
| (sum.inr x) := get_m.loop f g x
| (sum.inl x) := g x

instance get_m.functor : functor.{u} (get_m w) :=
{ map := @get_m.map _ }

def get_m.seq {α β : Type u} : Π (f : get_m w (α → β)) (x : get_m w α), get_m w β :=
λ (f : get_m w (α → β)) (x : get_m w α), get_m.bind f (λ f, f <$> x)

-- instance : applicative get_m :=
-- { to_functor := get_m.functor
-- , pure := λ α, get_m.pure
-- , seq := @get_m.seq }
open function

instance : is_lawful_functor.{u} (get_m w) :=
by { constructor; intros;
     dsimp [(<$>),get_m.seq];
     induction x;
     try { refl };
     simp [get_m.map,*]; ext }

instance : monad (get_m w) :=
{ to_functor := get_m.functor
, pure := @get_m.pure w
, bind := @get_m.bind w }

instance : is_lawful_monad.{u} (get_m w) :=
{ to_is_lawful_functor := by apply_instance,
  bind_assoc := by { intros, dsimp [(>>=)],
                     induction x; try { refl }; simp [get_m.bind,*], },
  bind_pure_comp_eq_map := by { intros, dsimp [(>>=),(<$>)],
                                induction x; try {refl}; simp [get_m.bind,get_m.map,*], },
  map_pure := by intros; refl,
  pure_seq_eq_map := by { intros, dsimp [(>>=),(<$>)],
                          induction x; try {refl}; simp [get_m.bind,get_m.map,*], },
  pure_bind := by intros; refl }

def get_m.or_else {α} : get_m w α → get_m w α → get_m w α
| get_m.fail x := x
| x y := x

instance : alternative.{u} (get_m w) :=
{ failure := @get_m.fail _,
  orelse := @get_m.or_else _ }

def get_m.eval : Π {α}, list w → get_m w α → option α
| _ [] (get_m.pure x) := pure x
| _ [] _  := none
| α (w :: ws) (get_m.read f) := get_m.eval ws (f w)
| α (ww :: ws) (get_m.loop f g x₀) :=
  get_m.eval ws $
  f x₀ ww >>= get_m.loop.rest f g
| α (w :: ws) _ := none

def write_word (x : w) : put_m'.{u} w punit :=
put_m'.write x (λ _, put_m'.pure punit.star)

def read_word : get_m.{u} w (ulift w) :=
get_m.read (get_m.pure ∘ ulift.up)

open ulift

def expect_word [decidable_eq w] (x : w) : get_m.{u} w punit :=
do w' ← read_word,
   if x = down w' then pure punit.star
                  else failure

def read_write : Π {α : Type u}, get_m w α → put_m'.{u} w punit → option α
| ._ (get_m.pure x) (put_m'.pure _) := some x
| _ _ (put_m'.pure _) := none
| ._ (get_m.read f) (put_m'.write w g) := read_write (f w) (g punit.star)
| α (@get_m.loop _ α' β γ f g x₀) (put_m'.write ww h) :=
  read_write
    (f x₀ ww >>= get_m.loop.rest f g)
    (h punit.star)
| _ _ (put_m'.write w g) := none

def read_write' : Π {α : Type u}, get_m w α → put_m'.{u} w punit → option (α × put_m'.{u} w punit)
| _ (get_m.read f) (put_m'.write w g) := read_write' (f w) (g punit.star)
| α (@get_m.loop _ α' β γ f g x₀) (put_m'.write ww h) :=
  read_write'
    (f x₀ ww >>= get_m.loop.rest f g)
    (h punit.star)
-- | _ (get_m.pure x) m@(put_m'.write w g) := some (x,m)
| _ (get_m.pure x) m := some (x,m)
| _ _ (put_m'.pure _) := none
| _ (get_m.fail) (put_m'.write _ _) := none
-- | _ _ m := none

lemma read_read_write_write {α : Type u} (x : get_m w α) (m : put_m w) (i : α) :
  read_write x m = some i ↔ read_write' x m = some (i,(pure punit.star : put_m' w _)) :=
begin
  induction m generalizing x;
  cases x; casesm* punit; simp [read_write,read_write',prod.ext_iff,pure,*],
end

def pipeline {α} (x : get_m w α) (y : α → put_m w) (i : α) : option α :=
read_write x (y i)

infix ` -<< `:60  := read_write
infix ` -<<< `:60  := read_write'
infix ` <-< `:60  := pipeline

lemma eq_star (x : punit) : x = punit.star :=
by cases x; refl

-- inductive agree : Π {α} (x : α), get_m α → put_m → put_m → Prop
-- | pure {α} (x : α) (m : put_m) : agree x (get_m.pure x) m m
-- | read_write {α} (x : α) (w : unsigned)
--   (f : unsigned → get_m α) (g : punit → put_m) (m : put_m) :
--   agree x (f w) (g punit.star) m →
--   agree x (get_m.read f) (put_m'.write w g) m
-- | loop_write {α} (x : α) {β γ} (σ₀ σ₁ : β) (w : unsigned)
--   (f : β → unsigned → get_m (γ ⊕ β)) (f' : γ → get_m α)
--   (g : punit → put_m) (m m' : put_m) :
--   agree (sum.inr σ₁) (f σ₀ w) (g punit.star) m' →
--   agree x (get_m.loop σ₁ f f') m' m →
--   agree x (get_m.loop σ₀ f f') (put_m'.write w g) m
-- | loop_exit_write {α} (x : α) {β γ} (σ₀ : β) (r : γ) (w : unsigned)
--   (f : β → unsigned → get_m (γ ⊕ β)) (f' : γ → get_m α)
--   (g : punit → put_m) (m m' : put_m) :
--   agree (sum.inl r) (f σ₀ w) (g punit.star) m' →
--   agree x (f' r) m' m →
--   agree x (get_m.loop σ₀ f f') (put_m'.write w g) m

-- lemma agree_spec {α} (g : get_m α) (m : put_m) (x : α) :
--   agree x g m (put_m'.pure punit.star) ↔ g -<< m = some x :=
-- begin
--   split; intro h,
--   { cases h,
--     refl, simp [read_write], }
-- end

-- lemma loop_bind {α β γ} (i : β)
--       (body : β → unsigned → get_m (α ⊕ β)) (f₀ : α → get_m γ) :
--   get_m.loop i body f₀ = get_m.read (body i) >>= _ := _

lemma read_write_loop_bind {α β γ φ : Type u} (i : α)
      (body : α → w → get_m w (φ ⊕ α))
      (f₀ : φ → get_m w β) (f₁ : β → get_m w γ)
      (m : punit → put_m w) (ww : w) :
  (get_m.loop body f₀ i >>= f₁) -<<< put_m'.write ww m =
  (body i ww >>= get_m.loop.rest body f₀ >>= f₁) -<<< m punit.star :=
begin
  rw bind_assoc,
  simp [(>>=),get_m.bind,read_write'],
  congr, ext, cases x; simp; refl,
end

-- lemma read_write_left_overs_bind {α} (i : α)
--       (x₀ : get_m α)
--       (x₁ x₂ : put_m) :
-- x₀ -<<< x₁ = some (i,x₂) →

lemma fail_read_write {α} (x₁ : put_m w) :
  get_m.fail -<<< x₁ = @none (α × put_m w) :=
by cases x₁; refl

lemma pure_read_write {α} (x₁ : put_m w) (i : α) :
  get_m.pure i -<<< x₁ = some (i, x₁) :=
by cases x₁; refl

lemma read_write_left_overs_bind {α} (f : punit → put_m' w punit) (i : α)
      (x₀ : get_m w α)
      (x₁ x₂ : put_m' w punit) :
  x₀ -<<< x₁ = some (i,x₂) → x₀ -<<< (x₁ >>= f) = some (i,x₂ >>= f) :=
begin
  induction x₁ generalizing x₀ x₂,
  cases x₀; simp [(>>=),put_m'.bind,read_write',pure_read_write],
  { intros, subst x₂, tauto },
  cases x₀; simp [(>>=),put_m'.bind,read_write'],
  { intros, substs x₂ i, split; refl },
  { apply x₁_ih, },
  { apply x₁_ih, },
end

lemma option_eq_forall_some {α} (x y : option α) :
  x = y ↔ ∀ z, x = some z ↔ y = some z :=
begin
  split; intro h, { rw h; intro, refl },
  { cases y, cases x, refl,
    symmetry, rw ← h, rw h, },
end

lemma read_write_weakening {α : Type u}
  (x₀ x₁ : put_m w) (y₀ y₁ : get_m w α)
  (h : y₀ -<<< x₀ = y₁ -<<< x₁) :
  y₀ -<< x₀ = y₁ -<< x₁ :=
begin
  rw option_eq_forall_some,
  intro, simp [read_read_write_write,h],
end

lemma read_write_mono' {α β : Type u} (i : α)
      (x₀ : get_m w α) (f₀ : α → get_m w β)
      (x₁ x₂ : put_m w)
      (h : x₀ -<<< x₁ = some (i,x₂)) :
  (x₀ >>= f₀) -<<< x₁ = f₀ i -<<< x₂ :=
begin
  -- simp [(>>=)],
  induction x₁ generalizing x₀ f₀;
    try { cases x₀; cases h },
  { simp [(>>=),read_write',get_m.bind] },
  { cases x₀; try { cases h },
    simp [(>>=),read_write',get_m.bind] at h ⊢,
    simp [(>>=),read_write',get_m.bind] at h ⊢,
    { apply x₁_ih, assumption },
    simp [read_write_loop_bind,x₁_ih],
    rw [x₁_ih _ _ _ h], }
end

lemma read_write_mono {α β : Type u} {i : α}
      {x₀ : get_m w α} {f₀ : α → get_m w β}
      {x₁ : put_m w} {f₁ : punit → put_m w}
      (h : x₀ -<< x₁ = some i) :
  (x₀ >>= f₀) -<< (x₁ >>= f₁) = f₀ i -<< f₁ punit.star :=
begin
  apply read_write_weakening,
  apply read_write_mono',
  rw [read_read_write_write] at h,
  replace h := read_write_left_overs_bind f₁ _ _ _ _ h,
  simp [h],
end

lemma read_write_mono_left {α β} {i : α}
      {x₀ : get_m w α} {f₀ : α → get_m w β}
      {x₁ : put_m w}
      (h : x₀ -<< x₁ = some i) :
  (x₀ >>= f₀) -<< x₁ = f₀ i -<< pure punit.star :=
by rw ← read_write_mono h; simp

@[simp]
lemma read_write_word {α} (x : w) (f : ulift w → get_m w α) (f' : punit → put_m w) :
  (read_word >>= f) -<< (write_word x >>= f') = f ⟨x⟩ -<< f' punit.star := rfl

@[simp]
lemma read_write_word' {α} (x : w) (f : ulift w → get_m w α) (f' : put_m w) :
  (read_word >>= f) -<< (write_word x >> f') = f ⟨x⟩ -<< f' := rfl

@[simp]
lemma read_write_word'' {α} (x : w) (f : ulift w → get_m w α) :
  (read_word >>= f) -<< write_word x = f ⟨x⟩ -<< pure punit.star := rfl

@[simp]
lemma read_write_pure {α} (x : α) (y : punit) (f : ulift w → get_m w α) :
  (pure x : get_m w α) -<< pure y = pure x := rfl

@[simp]
lemma read_write_loop_word {α β γ : Type u} (σ₀ : α) (x : w)
  (f : α → w → get_m w (β ⊕ α)) (g : β → get_m w γ)
  (f' : punit → put_m w) :
  get_m.loop f g σ₀ -<< (write_word x >>= f') =
  (f σ₀ x >>= get_m.loop.rest f g)
    -<< f' punit.star := rfl

#check @read_write_loop_word

lemma eval_eval {α}
      (x₀ : get_m w α) (x₁ : put_m w)  :
  x₀.eval x₁.eval = x₀ -<< x₁ :=
by induction x₁ generalizing x₀; cases x₀;
     simp! [*,read_write]; refl

open ulift

lemma get_m.fold_bind {α β} (x : get_m w α) (f : α → get_m w β) :
  get_m.bind x f = x >>= f := rfl

lemma map_read_write {α β} (f : α → β) (x : get_m w α) (y : put_m w) :
  (f <$> x) -<< y = f <$> (x -<< y) :=
begin
  rw [← bind_pure_comp_eq_map,← bind_pure_comp_eq_map],
  symmetry,
  simp [(>>=)],
  induction y generalizing x,
  { cases x; refl },
  { cases x; simp [read_write]; try { refl };
    simp [get_m.bind,read_write,y_ih],
    congr' 1, cases h : x_a x_a_2 y_a, refl,
    cases a; refl,
    dsimp [(>>=),get_m.bind],
    congr, ext, simp [get_m.fold_bind],
    rw bind_assoc, congr, ext z, cases z; refl,
    simp [get_m.fold_bind], rw bind_assoc, congr, ext x,
    cases x; refl, }
end

def sum_ulift (α β : Type u) : (α ⊕ β) ≃ (ulift.{v} α ⊕ ulift.{v} β) :=
(equiv.sum_congr equiv.ulift.symm equiv.ulift.symm)

-- def get_m.up : Π {α : Type u} {β : Type.{max u v}} (Heq : α ≃ β), get_m α → get_m β
-- | _ _ Heq (get_m.pure x) := get_m.pure $ Heq x
-- | _ _ Heq (get_m.fail) := get_m.fail
-- | _ _ Heq (get_m.read f) := get_m.read (λ w, get_m.up Heq (f w))
-- | _ β' Heq (@get_m.loop α β γ f g x) :=
--   get_m.loop
--     (λ a b, get_m.up (sum_ulift α β) (f (down.{v} a) b))
--     (λ w, get_m.up Heq (g $ down w))
--     (up.{v} x)

def get_m.up : Π {α : Type u} {β : Type.{max u v}} (Heq : α → β), get_m w α → get_m w β :=
λ α β f x, (@get_m.rec_on _ (λ α _, Π β, (α → β) → get_m w β) α x
(λ α β f, get_m.fail)
(λ α x β f, get_m.pure $ f x)
(λ α next get_m_up β f, get_m.read $ λ w, get_m_up w _ f)
(λ α β γ body rest x₀ get_m_up₀ get_m_up₁ β' f,
  get_m.loop
    (λ a b, get_m_up₀ (down a) b (ulift.{v} α ⊕ ulift.{v} β)
                     (sum_ulift α β))
    (λ r, get_m_up₁ (down r) _ f)
    (up x₀)) β f)

section eqns

variables {α β' γ : Type u} {β : Type.{max u v}} (Heq : α → β) (x : get_m w α)

variables {i : α} {f : w → get_m w α}
variables {f' : β' → w → get_m w (γ ⊕ β')}
variables {g' : γ → get_m w α} {j : β'}

@[simp] lemma get_m.up.eqn_1 : get_m.up Heq (get_m.pure i : get_m w _) = get_m.pure (Heq i) := rfl
@[simp] lemma get_m.up.eqn_2 : get_m.up Heq (get_m.fail : get_m w α) = get_m.fail := rfl
@[simp] lemma get_m.up.eqn_3 : get_m.up Heq (get_m.read f) = get_m.read (λ w, get_m.up Heq (f w)) := rfl
@[simp] lemma get_m.up.eqn_4 :
  get_m.up Heq (get_m.loop f' g' j) =
  get_m.loop
    (λ a b, get_m.up (sum_ulift γ β') (f' (down.{v} a) b))
    (λ w, get_m.up Heq (g' $ down w))
    (up.{v} j) := rfl

end eqns

def put_m.up {α : Type u} {β : Type v} (Heq : α → β) : put_m' w α → put_m' w β
| (put_m'.pure x) := put_m'.pure $ Heq x
| (put_m'.write w f) := put_m'.write w $ λ u, put_m.up $ f u

instance : liftable1 (put_m'.{u} w) (put_m'.{v} w) :=
{ up := λ α β (eq : α ≃ β) x, put_m.up eq x
, down := λ α β (eq : α ≃ β) x, put_m.up eq.symm x
, down_up := by intros; induction x; simp [put_m.up,*]
, up_down := by intros; induction x; simp [put_m.up,*]  }

open pliftable (up')

lemma up_bind {α β : Type u} {β' : Type (max u v)} (x : get_m w α) (g : α → get_m w β) (f : β → β') :
  (x >>= g).up f = x.up up.{v} >>= (λ i : ulift α, (g $ down i).up f) :=
begin
  dsimp [(>>=)],
  induction x generalizing f g; try { refl };
    simp [get_m.bind,*]
end

lemma equiv_bind {m} [monad m] [is_lawful_monad m] {α α' β}
  (Heq : α ≃ α') (x : m α) (f : α → m β) :
  x >>= f = (Heq <$> x) >>= f ∘ Heq.symm :=
by simp [(∘)] with functor_norm

def sum.map {α α' β β'} (f : α → α') (g : β → β') : α ⊕ β → α' ⊕ β'
| (sum.inr x) := sum.inr $ g x
| (sum.inl x) := sum.inl $ f x

def equiv.ulift_sum {α β} : (ulift $ α ⊕ β) ≃ (ulift α ⊕ ulift β) :=
{ to_fun := λ x, sum.map up up (down x),
  inv_fun := λ x, up $ sum.map down down x,
  right_inv := by intro; casesm* [_ ⊕ _,ulift _]; refl,
  left_inv := by intro; casesm* [_ ⊕ _,ulift _]; refl }

lemma map_get_m_up {α : Type u} {β γ} (x : get_m w α) (f : α → β) (g : β → γ) :
  g <$> get_m.up f x = get_m.up (g ∘ f) x :=
begin
  dsimp [(<$>)],
  induction x; simp [get_m.map,*]; refl,
end

lemma up_read_write {α : Type u} {α' : Type (max u v)} (x : get_m w α) (y : put_m w) (f : α ≃ α') :
  x.up f -<< up' (put_m' w) y = liftable1.up option f (x -<< y) :=
begin
  dsimp [up',liftable1.up],
  induction y generalizing x f,
  cases x; simp; refl,
  cases x; simp [up',liftable.up',liftable1.up,read_write,put_m.up,*], refl, refl, refl,
  rw [read_write,← y_ih,up_bind],
    apply congr,
    { apply congr_arg, rw equiv_bind (@equiv.ulift_sum.{u u v v v} x_α x_β) ,
      congr,
      { rw map_get_m_up, congr, ext, cases x; refl },
      simp [(∘)], ext, cases x;
      dsimp [equiv.ulift_sum,sum.map], refl,
      cases x, refl, apply_instance },
    congr,
end

lemma up_read_write' {α : Type u} {α' : Type (max u v)}
  {x : get_m w α} {y : put_m w} (f : α → α') (f' : α ≃ α')
  (h : ∀ i, f i = f' i) :
  x.up f -<< up' (put_m' w) y = liftable1.up option f' (x -<< y) :=
begin
  rw ← up_read_write, congr, ext, apply h
end

end medium


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.int.basic
import Mathlib.data.nat.cast
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

namespace int

/- cast (injection into groups with one) -/

@[simp] theorem nat_cast_eq_coe_nat (n : ℕ) : ↑n = ↑n := sorry

/-- Coercion `ℕ → ℤ` as a `ring_hom`. -/
def of_nat_hom : ℕ →+* ℤ :=
  ring_hom.mk coe sorry of_nat_mul sorry of_nat_add

/-- Canonical homomorphism from the integers to any ring(-like) structure `α` -/
protected def cast {α : Type u_1} [HasZero α] [HasOne α] [Add α] [Neg α] : ℤ → α :=
  sorry

-- see Note [coercion into rings]

protected instance cast_coe {α : Type u_1} [HasZero α] [HasOne α] [Add α] [Neg α] : has_coe_t ℤ α :=
  has_coe_t.mk int.cast

@[simp] theorem cast_zero {α : Type u_1} [HasZero α] [HasOne α] [Add α] [Neg α] : ↑0 = 0 :=
  rfl

theorem cast_of_nat {α : Type u_1} [HasZero α] [HasOne α] [Add α] [Neg α] (n : ℕ) : ↑(Int.ofNat n) = ↑n :=
  rfl

@[simp] theorem cast_coe_nat {α : Type u_1} [HasZero α] [HasOne α] [Add α] [Neg α] (n : ℕ) : ↑↑n = ↑n :=
  rfl

theorem cast_coe_nat' {α : Type u_1} [HasZero α] [HasOne α] [Add α] [Neg α] (n : ℕ) : ↑↑n = ↑n := sorry

@[simp] theorem cast_neg_succ_of_nat {α : Type u_1} [HasZero α] [HasOne α] [Add α] [Neg α] (n : ℕ) : ↑(Int.negSucc n) = -(↑n + 1) :=
  rfl

@[simp] theorem cast_one {α : Type u_1} [add_monoid α] [HasOne α] [Neg α] : ↑1 = 1 :=
  nat.cast_one

@[simp] theorem cast_sub_nat_nat {α : Type u_1} [add_group α] [HasOne α] (m : ℕ) (n : ℕ) : ↑(sub_nat_nat m n) = ↑m - ↑n := sorry

@[simp] theorem cast_neg_of_nat {α : Type u_1} [add_group α] [HasOne α] (n : ℕ) : ↑(neg_of_nat n) = -↑n :=
  nat.cases_on n (idRhs (0 = -0) (Eq.symm neg_zero))
    fun (n : ℕ) => idRhs (↑(neg_of_nat (n + 1)) = ↑(neg_of_nat (n + 1))) rfl

@[simp] theorem cast_add {α : Type u_1} [add_group α] [HasOne α] (m : ℤ) (n : ℤ) : ↑(m + n) = ↑m + ↑n := sorry

@[simp] theorem cast_neg {α : Type u_1} [add_group α] [HasOne α] (n : ℤ) : ↑(-n) = -↑n :=
  int.cases_on n (fun (n : ℕ) => idRhs (↑(neg_of_nat n) = -↑n) (cast_neg_of_nat n))
    fun (n : ℕ) => idRhs (↑(-Int.negSucc n) = --↑(-Int.negSucc n)) (Eq.symm (neg_neg ↑(-Int.negSucc n)))

@[simp] theorem cast_sub {α : Type u_1} [add_group α] [HasOne α] (m : ℤ) (n : ℤ) : ↑(m - n) = ↑m - ↑n := sorry

@[simp] theorem cast_mul {α : Type u_1} [ring α] (m : ℤ) (n : ℤ) : ↑(m * n) = ↑m * ↑n := sorry

/-- `coe : ℤ → α` as an `add_monoid_hom`. -/
def cast_add_hom (α : Type u_1) [add_group α] [HasOne α] : ℤ →+ α :=
  add_monoid_hom.mk coe sorry cast_add

@[simp] theorem coe_cast_add_hom {α : Type u_1} [add_group α] [HasOne α] : ⇑(cast_add_hom α) = coe :=
  rfl

/-- `coe : ℤ → α` as a `ring_hom`. -/
def cast_ring_hom (α : Type u_1) [ring α] : ℤ →+* α :=
  ring_hom.mk coe sorry cast_mul sorry sorry

@[simp] theorem coe_cast_ring_hom {α : Type u_1} [ring α] : ⇑(cast_ring_hom α) = coe :=
  rfl

theorem cast_commute {α : Type u_1} [ring α] (m : ℤ) (x : α) : commute (↑m) x :=
  int.cases_on m (fun (n : ℕ) => nat.cast_commute n x) fun (n : ℕ) => commute.neg_left (nat.cast_commute (n + 1) x)

theorem commute_cast {α : Type u_1} [ring α] (x : α) (m : ℤ) : commute x ↑m :=
  commute.symm (cast_commute m x)

@[simp] theorem coe_nat_bit0 (n : ℕ) : ↑(bit0 n) = bit0 ↑n := sorry

@[simp] theorem coe_nat_bit1 (n : ℕ) : ↑(bit1 n) = bit1 ↑n := sorry

@[simp] theorem cast_bit0 {α : Type u_1} [ring α] (n : ℤ) : ↑(bit0 n) = bit0 ↑n :=
  cast_add n n

@[simp] theorem cast_bit1 {α : Type u_1} [ring α] (n : ℤ) : ↑(bit1 n) = bit1 ↑n := sorry

theorem cast_two {α : Type u_1} [ring α] : ↑(bit0 1) = bit0 1 := sorry

theorem cast_mono {α : Type u_1} [ordered_ring α] : monotone coe := sorry

@[simp] theorem cast_nonneg {α : Type u_1} [ordered_ring α] [nontrivial α] {n : ℤ} : 0 ≤ ↑n ↔ 0 ≤ n := sorry

@[simp] theorem cast_le {α : Type u_1} [ordered_ring α] [nontrivial α] {m : ℤ} {n : ℤ} : ↑m ≤ ↑n ↔ m ≤ n := sorry

theorem cast_strict_mono {α : Type u_1} [ordered_ring α] [nontrivial α] : strict_mono coe :=
  strict_mono_of_le_iff_le fun (m n : ℤ) => iff.symm cast_le

@[simp] theorem cast_lt {α : Type u_1} [ordered_ring α] [nontrivial α] {m : ℤ} {n : ℤ} : ↑m < ↑n ↔ m < n :=
  strict_mono.lt_iff_lt cast_strict_mono

@[simp] theorem cast_nonpos {α : Type u_1} [ordered_ring α] [nontrivial α] {n : ℤ} : ↑n ≤ 0 ↔ n ≤ 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑n ≤ 0 ↔ n ≤ 0)) (Eq.symm cast_zero)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑n ≤ ↑0 ↔ n ≤ 0)) (propext cast_le))) (iff.refl (n ≤ 0)))

@[simp] theorem cast_pos {α : Type u_1} [ordered_ring α] [nontrivial α] {n : ℤ} : 0 < ↑n ↔ 0 < n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (0 < ↑n ↔ 0 < n)) (Eq.symm cast_zero)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑0 < ↑n ↔ 0 < n)) (propext cast_lt))) (iff.refl (0 < n)))

@[simp] theorem cast_lt_zero {α : Type u_1} [ordered_ring α] [nontrivial α] {n : ℤ} : ↑n < 0 ↔ n < 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑n < 0 ↔ n < 0)) (Eq.symm cast_zero)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑n < ↑0 ↔ n < 0)) (propext cast_lt))) (iff.refl (n < 0)))

@[simp] theorem cast_min {α : Type u_1} [linear_ordered_ring α] {a : ℤ} {b : ℤ} : ↑(min a b) = min ↑a ↑b :=
  monotone.map_min cast_mono

@[simp] theorem cast_max {α : Type u_1} [linear_ordered_ring α] {a : ℤ} {b : ℤ} : ↑(max a b) = max ↑a ↑b :=
  monotone.map_max cast_mono

@[simp] theorem cast_abs {α : Type u_1} [linear_ordered_ring α] {q : ℤ} : ↑(abs q) = abs ↑q := sorry

theorem coe_int_dvd {α : Type u_1} [comm_ring α] (m : ℤ) (n : ℤ) (h : m ∣ n) : ↑m ∣ ↑n :=
  ring_hom.map_dvd (cast_ring_hom α) h

end int

namespace add_monoid_hom

/-- Two additive monoid homomorphisms `f`, `g` from `ℤ` to an additive monoid are equal
if `f 1 = g 1`. -/
theorem ext_int {A : Type u_1} [add_monoid A] {f : ℤ →+ A} {g : ℤ →+ A} (h1 : coe_fn f 1 = coe_fn g 1) : f = g := sorry

theorem eq_int_cast_hom {A : Type u_1} [add_group A] [HasOne A] (f : ℤ →+ A) (h1 : coe_fn f 1 = 1) : f = int.cast_add_hom A := sorry

theorem eq_int_cast {A : Type u_1} [add_group A] [HasOne A] (f : ℤ →+ A) (h1 : coe_fn f 1 = 1) (n : ℤ) : coe_fn f n = ↑n :=
  iff.mp ext_iff (eq_int_cast_hom f h1)

end add_monoid_hom

namespace monoid_hom

theorem ext_int {M : Type u_1} [monoid M] {f : multiplicative ℤ →* M} {g : multiplicative ℤ →* M} (h1 : coe_fn f (coe_fn multiplicative.of_add 1) = coe_fn g (coe_fn multiplicative.of_add 1)) : f = g :=
  ext fun (x : multiplicative ℤ) => iff.mp add_monoid_hom.ext_iff (add_monoid_hom.ext_int h1) x

end monoid_hom

namespace ring_hom

@[simp] theorem eq_int_cast {α : Type u_1} [ring α] (f : ℤ →+* α) (n : ℤ) : coe_fn f n = ↑n :=
  add_monoid_hom.eq_int_cast (to_add_monoid_hom f) (map_one f) n

theorem eq_int_cast' {α : Type u_1} [ring α] (f : ℤ →+* α) : f = int.cast_ring_hom α :=
  ext (eq_int_cast f)

@[simp] theorem map_int_cast {α : Type u_1} {β : Type u_2} [ring α] [ring β] (f : α →+* β) (n : ℤ) : coe_fn f ↑n = ↑n :=
  eq_int_cast (comp f (int.cast_ring_hom α)) n

theorem ext_int {R : Type u_1} [semiring R] (f : ℤ →+* R) (g : ℤ →+* R) : f = g :=
  coe_add_monoid_hom_injective (add_monoid_hom.ext_int (Eq.trans (map_one f) (Eq.symm (map_one g))))

protected instance int.subsingleton_ring_hom {R : Type u_1} [semiring R] : subsingleton (ℤ →+* R) :=
  subsingleton.intro ext_int

end ring_hom

@[simp] theorem int.cast_id (n : ℤ) : ↑n = n :=
  Eq.symm (ring_hom.eq_int_cast (ring_hom.id ℤ) n)


class cls12 := (u12 : Unit)
class cls11 extends cls12 := (u11 : Unit)
class cls10 extends cls11 := (u10 : Unit)
class cls9 extends cls10 := (u9 : Unit)
class cls8 extends cls9 := (u8 : Unit)
class cls7 extends cls8 := (u7 : Unit)
class cls6 extends cls7 := (u6 : Unit)
class cls5 extends cls6 := (u5 : Unit)
class cls4 extends cls5 := (u4 : Unit)
class cls3 extends cls4 := (u3 : Unit)
class cls2 extends cls3 := (u2 : Unit)
class cls1 extends cls2 := (u1 : Unit)
class cls0 extends cls1 := (u0 : Unit)

class CommRing (n : Nat) extends cls0 := (ucr : Unit)
class Field (n) extends CommRing n := (uf : Unit)
class DVR (n) [CommRing n] := (udvr : Unit)

instance [c : CommRing n] : CommRing n.succ := { ucr := c.u12 }
instance [Field n] : DVR n.succ := ⟨()⟩

example [CommRing 0] : DVR 1 := by infer_instance -- should fail fast, instead hits maxHeartbeats


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import category_theory.category
import category_theory.limits.shapes.images
import category_theory.abelian.basic

open category_theory
open category_theory.limits

universes v u

namespace category_theory.abelian
variables {C : Type u} [𝒞 : category.{v} C] [abelian.{v} C]
include 𝒞
variables {X Y : C} (f : X ⟶ Y)

section

variables {P Q : C} {u : X ⟶ P} {v : Y ⟶ Q}
variables {I : C} {f₁ : X ⟶ I} {f₂ : I ⟶ Y} [epi f₁] [mono f₂]
variables {I' : C} {g₁ : P ⟶ I'} {g₂ : I' ⟶ Q} [epi g₁] [mono g₂]
variables (h : u ≫ (g₁ ≫ g₂) = (f₁ ≫ f₂) ≫ v)

def upper : strong_epi_mono_factorisation (f₁ ≫ f₂) :=
{ I := I,
  e := f₁,
  m := f₂,
  fac' := rfl,
  e_strong_epi := strong_epi_of_epi _,
  m_mono := by apply_instance }

def lower : strong_epi_mono_factorisation (g₁ ≫ g₂) :=
{ I := I',
  e := g₁,
  m := g₂,
  fac' := rfl,
  e_strong_epi := strong_epi_of_epi _,
  m_mono := by apply_instance }

def diag_lift : I ⟶ I' := is_image.lift upper.to_mono_is_image (image.mono_factorisation (f₁ ≫ f₂)) ≫
  image.map (arrow.hom_mk' h) ≫ image.lift lower.to_mono_factorisation

lemma diag_lift_fac_left : f₁ ≫ (diag_lift h) = u ≫ g₁ :=
begin
  unfold diag_lift,
  slice_lhs 1 2 { erw is_image.fac_lift upper.to_mono_is_image (image.mono_factorisation (f₁ ≫ f₂)), },
  slice_lhs 1 2 { erw image.factor_map (arrow.hom_mk' h), },
  slice_lhs 2 3 { erw is_image.fac_lift, },
  refl
end

lemma diag_lift_fac_right : (diag_lift h) ≫ g₂ = f₂ ≫ v :=
begin
  -- watch this
  apply (cancel_epi f₁).1,
  slice_lhs 1 2 { rw diag_lift_fac_left h, },
  rw [category.assoc, h, category.assoc]
end

end

end category_theory.abelian


import category_theory.preadditive.opposite

namespace category_theory

variables {C : Type*} [category C] [preadditive C] {X Y : Cᵒᵖ}

@[simps] def unop_hom (X Y : Cᵒᵖ) : (X ⟶ Y) →+ (opposite.unop Y ⟶ opposite.unop X) :=
add_monoid_hom.mk' (λ f, f.unop) $ λ f g, unop_add _ f g

lemma unop_sum {ι : Type*} (s : finset ι) (f : ι → (X ⟶ Y)) :
  (s.sum f).unop = s.sum (λ i, (f i).unop) :=
(unop_hom X Y).map_sum _ _

lemma unop_zsmul (k : ℤ) (f : X ⟶ Y) : (k • f).unop = k • f.unop := rfl

lemma unop_neg (f : X ⟶ Y) : (-f).unop = -(f.unop) := rfl

end category_theory


/-
Copyright (c) 2018 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Reid Barton, Bhavik Mehta
-/
import category_theory.limits.connected
import category_theory.limits.constructions.over.products
import category_theory.limits.constructions.over.connected
import category_theory.limits.constructions.limits_of_products_and_equalizers
import category_theory.limits.constructions.equalizers

/-!
# Limits in the over category

Declare instances for limits in the over category: If `C` has finite wide pullbacks, `over B` has
finite limits, and if `C` has arbitrary wide pullbacks then `over B` has limits.
-/
universes v u -- morphism levels before object levels. See note [category_theory universes].

open category_theory category_theory.limits

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

namespace category_theory.over

/-- Make sure we can derive pullbacks in `over B`. -/
example {B : C} [has_pullbacks C] : has_pullbacks (over B) := by apply_instance

/-- Make sure we can derive equalizers in `over B`. -/
example {B : C} [has_equalizers C] : has_equalizers (over B) := by apply_instance

instance has_finite_limits {B : C} [has_finite_wide_pullbacks C] : has_finite_limits (over B) :=
begin
  apply @finite_limits_from_equalizers_and_finite_products _ _ _ _,
  { exact construct_products.over_finite_products_of_finite_wide_pullbacks, },
  { apply @has_equalizers_of_pullbacks_and_binary_products _ _ _ _,
    { haveI : has_pullbacks C := ⟨by apply_instance⟩,
      exact construct_products.over_binary_product_of_pullback },
    { apply_instance, } }
end

instance has_limits {B : C} [has_wide_pullbacks C] : has_limits (over B) :=
begin
  apply @limits_from_equalizers_and_products _ _ _ _,
  { exact construct_products.over_products_of_wide_pullbacks },
  { apply @has_equalizers_of_pullbacks_and_binary_products _ _ _ _,
    { haveI : has_pullbacks C := ⟨by apply_instance⟩,
      exact construct_products.over_binary_product_of_pullback },
    { apply_instance, } }
end

end category_theory.over