import data.rat.basic
import data.real.basic
import analysis.special_functions.pow

/-
Romanian Mathematical Olympiad 1998, Problem 12

Find all functions u : ℝ → ℝ for which there exists a strictly monotonic
function f : ℝ → ℝ such that

  ∀ x,y ∈ ℝ, f(x + y) = f(x)u(y) + f(y)

-/

lemma abs_pos' {x y : ℝ} (hy : x ≠ y) : 0 < |x - y| :=
  abs_pos.mpr (sub_ne_zero.mpr hy)

lemma rationals_dense_in_reals : dense {r : ℝ | ∃ q:ℚ, (q:ℝ) = r} :=
begin
  intro x,
  exact rat.dense_range_cast _
end

lemma find_rational_in_ball_right (y δ : ℝ) (hδ : 0 < δ) :
     ∃ (z : ℚ), (y < z) ∧ (z : ℝ) ∈ metric.ball y δ :=
begin
  have hd := dense_iff_inter_open.mp rationals_dense_in_reals,
  let i := metric.ball (y + δ / 2) (δ/2),
  have io : is_open i := @metric.is_open_ball ℝ _ _ _,
  have ine : i.nonempty,
  { use (y + δ / 2), norm_num[half_pos hδ] },
  obtain ⟨y', hy1, hy2⟩ := hd i io ine,
  obtain ⟨yy, hyy⟩ := hy2,
  use yy,
  rw [hyy], clear hyy,
  have hy3 := metric.mem_ball.mp hy1,
  rw[real.dist_eq] at hy3,
  have hyy' : y < y',
  { obtain ⟨ha, ha'⟩ | ⟨hb,hb'⟩ := abs_cases (y' - (y + δ / 2)),
    { rw[ha] at hy3,
      linarith},
    { rw[hb] at hy3,
      linarith }},
  constructor,
  { exact hyy' },
  { apply metric.mem_ball.mpr,
    rw[real.dist_eq],
    have hy4 : 0 ≤ y' - y := by linarith,
    rw[abs_eq_self.mpr hy4],
    obtain ⟨ha, ha'⟩ | ⟨hb,hb'⟩ := abs_cases (y' - (y + δ / 2)),
    { rw[ha] at hy3,
      linarith},
    { rw[hb] at hy3,
      linarith}}
end

lemma find_rational_in_ball_left (y δ : ℝ) (hδ : 0 < δ) :
     ∃ (z : ℚ), ((z:ℝ) < y) ∧ (z : ℝ) ∈ metric.ball y δ :=
begin
  have hd := dense_iff_inter_open.mp rationals_dense_in_reals,
  let i := metric.ball (y - δ / 2) (δ/2),
  have io : is_open i := @metric.is_open_ball ℝ _ _ _,
  have ine : i.nonempty,
  { use (y - δ / 2), norm_num[half_pos hδ] },
  obtain ⟨y', hy1, hy2⟩ := hd i io ine,
  obtain ⟨yy, hyy⟩ := hy2,
  use yy,
  rw [hyy], clear hyy,
  have hy3 := metric.mem_ball.mp hy1,
  rw[real.dist_eq] at hy3,
  have hyy' : y' < y,
  { obtain ⟨ha, ha'⟩ | ⟨hb,hb'⟩ := abs_cases (y' - (y - δ / 2)),
    { rw[ha] at hy3,
      linarith},
    { rw[hb] at hy3,
      linarith }},
  constructor,
  { exact hyy' },
  { apply metric.mem_ball.mpr,
    rw[real.dist_eq],
    have hy4 : y' - y ≤ 0 := by linarith,
    rw[abs_eq_neg_self.mpr hy4],
    obtain ⟨ha, ha'⟩ | ⟨hb,hb'⟩ := abs_cases (y' - (y - δ / 2)),
    { rw[ha] at hy3,
      linarith},
    { rw[hb] at hy3,
      linarith}}
end

lemma extend_function_mono
   (u : ℝ → ℝ)
   (f : ℝ → ℝ)
   (u_mono : monotone u)
   (f_cont : continuous f)
   (h : ∀ x : ℚ, u x = f x) :
   ∀ x : ℝ, u x = f x :=
begin
  -- suppose not.
  by_contra hn, push_neg at hn,

  -- then there is y such that u y ≠ f y
  obtain ⟨y, hy⟩ := hn,
  let ε : ℝ := |u y - f y|,
  have hε : 0 < ε := abs_pos' hy,

  -- then find a δ such that for all z, |z-y| < δ implies that
  -- |f z - f y| < ε.
  have h_cont' := metric.continuous_iff'.mp f_cont y ε hε,
  have h_cont2 := filter.eventually_iff.mp h_cont',
  obtain ⟨s, hs, hs', hs''⟩ := mem_nhds_iff.mp h_cont2,

  obtain ⟨δ, hδ0, hδ⟩ := metric.is_open_iff.mp hs' y hs'',
  have hb := hδ.trans hs,

  obtain h1 | h2 | h3 := lt_trichotomy (u y) (f y),
  {  -- pick a rational point less than y that's in the ball s,
    have : ∃ z : ℚ, (z:ℝ) < y ∧ dist (z:ℝ) y < δ,
    { obtain ⟨z, hz1, hz2⟩ := find_rational_in_ball_left y δ hδ0,
      exact ⟨z, hz1, metric.mem_ball.mp hz2⟩ },

    obtain ⟨z, h_z_lt_y, hyz⟩ := this,
    -- then dist (f z) (f y) < ε.
    have hzb : (↑z) ∈ metric.ball y δ := metric.mem_ball.mpr hyz,
    have hbzb := hb hzb,
    rw[set.mem_set_of_eq, ← h z] at hbzb,
    have huzuy : u y < u z,
    { have hufp : u y - f y < 0 := by linarith,
      have hua : ε = -(u y - f y) := abs_of_neg hufp,
      rw [hua, real.dist_eq] at hbzb,
      obtain h5 | h6 := em (f y < u z),
      { have : 0 ≤ u z - f y := by linarith,
        linarith },
      { have : u z - f y ≤ 0 := by linarith,
        rw[abs_eq_neg_self.mpr this] at hbzb,
        linarith }},
    -- so u(z) < u(y), contradicting u_mono.
    have h_y_le_z := le_of_lt  h_z_lt_y,
    have := u_mono h_y_le_z,
    linarith },
  { exact hy h2 },
  { -- pick a rational point z greater than y that's in the ball s,
    have : ∃ z : ℚ, y < z ∧ dist (z:ℝ) y < δ,
    { obtain ⟨z, hz1, hz2⟩ := find_rational_in_ball_right y δ hδ0,
      use z,
      constructor,
      { exact hz1, },
      {exact metric.mem_ball.mp hz2,}},

    obtain ⟨z, h_y_lt_z, hyz⟩ := this,
    -- then dist (f z) (f y) < ε.
    have hzb : (↑z) ∈ metric.ball y δ := metric.mem_ball.mpr hyz,
    have hbzb := hb hzb,
    rw[set.mem_set_of_eq, ← h z] at hbzb,
    have huzuy : u z < u y,
    { have hufp : 0 < u y - f y := by linarith,
      have hua : ε = u y - f y := abs_of_pos hufp,
      rw [hua, real.dist_eq] at hbzb,
      cases em (f y < u z),
      { have : 0 ≤ u z - f y := by linarith,
        rw[abs_eq_self.mpr this] at hbzb,
        linarith,},
      { linarith,}},
    -- so u(z) < u(y), contradicting u_mono.
    have h_y_le_z := le_of_lt  h_y_lt_z,
    have := u_mono h_y_le_z,
    linarith,
  },
end

lemma extend_function_anti
   (u : ℝ → ℝ)
   (f : ℝ → ℝ)
   (u_anti : antitone u)
   (f_cont : continuous f)
   (h : ∀ x : ℚ, u x = f x) :
   ∀ x : ℝ, u x = f x :=
begin
  -- suppose not.
  by_contra hn, push_neg at hn,

  -- then there is y such that u y ≠ f y
  obtain ⟨y, hy⟩ := hn,
  let ε : ℝ := |u y - f y|,
  have hε : 0 < ε := abs_pos' hy,

  -- then find a δ such that for all z, |z-y| < δ implies that
  -- |f z - f y| < ε.
  have h_cont' := metric.continuous_iff'.mp f_cont y ε hε,
  have h_cont2 := filter.eventually_iff.mp h_cont',
  obtain ⟨s, hs, hs', hs''⟩ := mem_nhds_iff.mp h_cont2,

  obtain ⟨δ, hδ0, hδ⟩ := metric.is_open_iff.mp hs' y hs'',
  have hb := hδ.trans hs,

  obtain h1 | h2 | h3 := lt_trichotomy (u y) (f y),
  { -- pick a rational point z greater than y that's in the ball s,
    have : ∃ z : ℚ, y < z ∧ dist (z:ℝ) y < δ,
    { obtain ⟨z, hz1, hz2⟩ := find_rational_in_ball_right y δ hδ0,
      exact ⟨z, hz1, metric.mem_ball.mp hz2⟩},

    obtain ⟨z, h_y_lt_z, hyz⟩ := this,
    -- then dist (f z) (f y) < ε.
    have hzb : (↑z) ∈ metric.ball y δ := metric.mem_ball.mpr hyz,
    have hbzb := hb hzb,
    rw[set.mem_set_of_eq, ← h z] at hbzb,
    have huzuy : u y < u z,
    { have hufp : u y - f y < 0 := by linarith,
      have hua : ε = -(u y - f y) := abs_of_neg hufp,
      rw [hua, real.dist_eq] at hbzb,
      cases em (f y < u z),
      { have : 0 ≤ u z - f y := by linarith,
        linarith,},
      { have : u z - f y ≤ 0 := by linarith,
        rw[abs_eq_neg_self.mpr this] at hbzb,
        linarith }},
    have h_y_le_z := le_of_lt h_y_lt_z,
    have := u_anti h_y_le_z,
    linarith},
  { exact hy h2 },
  {  -- pick a rational point less than y that's in the ball s,
    have : ∃ z : ℚ, (z:ℝ) < y ∧ dist (z:ℝ) y < δ,
    { obtain ⟨z, hz1, hz2⟩ := find_rational_in_ball_left y δ hδ0,
      use z,
      constructor,
      { exact hz1, },
      {exact metric.mem_ball.mp hz2,}},

    obtain ⟨z, h_z_lt_y, hyz⟩ := this,
    -- then dist (f z) (f y) < ε.
    have hzb : (↑z) ∈ metric.ball y δ := metric.mem_ball.mpr hyz,
    have hbzb := hb hzb,
    rw[set.mem_set_of_eq, ← h z] at hbzb,
    have huzuy : u z < u y,
    { have hufp : 0 < u y - f y := by linarith,
      have hua : ε = u y - f y := abs_of_pos hufp,
      rw [hua, real.dist_eq] at hbzb,
      obtain h5 | h6 := em (f y < u z),
      { have : 0 ≤ u z - f y := by linarith,
        rw[abs_eq_self.mpr this] at hbzb,
        linarith },
      { have : u z - f y ≤ 0 := by linarith,
        rw[abs_eq_neg_self.mpr this] at hbzb,
        linarith }},
    have h_z_le_y := le_of_lt h_z_lt_y,
    have := u_anti h_z_le_y,
    linarith },
  -- in either case, we end up contradicting u_anti.
end

lemma int_dichotomy (z : ℤ) : ∃ n : ℕ, (n:ℤ) = z ∨ -(n:ℤ) = z :=
begin
  cases z,
  { use z, left, simp only [int.of_nat_eq_coe]},
  { use z + 1, right, refl },
end

lemma exp_characterization
    (u : ℝ → ℝ)
    (hu : ∀ x y : ℝ, u (x + y) = u x * u y)
    (hu0 : u 0 = 1)
    (hm : strict_mono u ∨ strict_anti u) :
    (∃ k : ℝ, ∀ x : ℝ, u x = real.exp (k * x)) :=
begin
  -- We have u(nx) = u(x)ⁿ for all n ∈ ℤ, x ∈ ℝ.
  have h1 : ∀ n : ℕ, ∀ x : ℝ, u (n * x) = (u x) ^ n,
  { intro n,
    induction n with pn hpn,
    { intro x,
      simp only [algebra_map.coe_zero, zero_mul, pow_zero],
      exact hu0, },
    { intro x,
      have hp1: ↑(pn.succ) * x = ↑pn * x + x,
      { have : ↑pn * x + x = (↑pn + 1) * x := by ring,
        rw[this, nat.cast_succ] },
      rw[hp1, hu (↑pn * x) x, hpn x, pow_succ, mul_comm] } },

  have h2 : ∀ x, (u x) * u (-x) = 1,
  { intro x,
    have := hu x (-x),
    rw[add_right_neg] at this,
    rw[← this],
    exact hu0 },

  have hunz : ∀ x, 0 < u x,
  { intro x,
    by_contra H, push_neg at H,
    have H1 := one_div_nonpos.mpr H,
    obtain hlt | heq | hgt := lt_trichotomy x 0,
    { have h10 := h2 x,
      have hx0 : 0 < -x := neg_pos.mpr hlt,
      cases hm; nlinarith [hm hx0, hm hlt]},
    { rw [heq, hu0] at H, linarith},
    { have h10 := h2 x,
      have hx0 : -x < 0 := neg_lt_zero.mpr hgt,
      cases hm; nlinarith [hm hx0, hm hgt]}},

  have h3 : ∀ x, u (-x) = 1 / (u x),
  { intro x,
    have := (ne_of_lt (hunz x)).symm,
    field_simp,
    rw[mul_comm],
    exact h2 x },

  have h4 : ∀ z : ℤ, ∀ x : ℝ, u (z * x) = (u x) ^ z,
  { intros z x,
    obtain ⟨n, hn⟩ := int_dichotomy z,
    cases hn,
    { rw[←hn],
      norm_cast,
      exact h1 _ _ },
    { have h10 := h1 n x,
      rw[←hn],
      have h11: ↑-((↑n):ℤ) * x = - (n * x) := by norm_num,
      rw[h11, h3 _],
      have := hunz (↑n * x),
      have : u (↑ n * x) ≠ (0:ℝ) := by linarith,
      field_simp,
      rw[←h10],
      field_simp}},

  -- Let eᵏ = u(1);
  have hek : ∃ k, real.exp k = u 1,
  { use real.log (u 1), exact real.exp_log (hunz 1)},
  obtain ⟨k,hk⟩ := hek,

  -- then u(n) = eᵏⁿ for all n ∈ ℕ
  have hnexp : ∀ n : ℕ, u n = real.exp (k * n),
  { intro n,
    have h10 := h4 n 1,
    rw[←hk, mul_one] at h10,
    norm_cast at h10,
    rw[h10, mul_comm],
    exact (real.exp_nat_mul _ _).symm },

  -- and u(p/q) = (u(p))^(1/q) = e^(k(p/q))
  -- for all p ∈ ℤ, q ∈ ℕ, so u(x) = e^(kx) for all x ∈ ℚ.

  have hzexp : ∀ z : ℤ, u z = real.exp (k * z),
  { intro z,
    obtain ⟨n, hn⟩ := int_dichotomy z,
    cases hn,
    { rw[←hn],
      norm_cast,
      exact hnexp n},
    { rw[←hn],
      have := h4 (-↑n) 1,
      rw[mul_one] at this,
      rw[this, ←hk],
      rw [real.exp_mul],
      norm_cast }},

  have hp : ∀ p : ℕ, 0 < p → ∀ x : ℝ, u (x / p) = (u x) ^ (1 / (p:ℝ)),
  { intros p hp x,
    cases p,
    { exfalso, exact nat.lt_asymm hp hp},
    have h12: ∀ n : ℕ, (u (x / p.succ))^n = u (x * n / p.succ),
    { intro n,
      induction n with pn hpn,
      { simp[hu0.symm] },
      { have h10: x * ↑(pn.succ) / ↑(p.succ) = x * ↑pn / ↑(p.succ) + x / ↑(p.succ),
        { field_simp, ring },
        rw[h10],
        have h11 := hu (x * ↑pn / ↑(p.succ)) (x / ↑(p.succ)),
        rw[h11, ← hpn],
        exact pow_succ' _ _}},
        replace h12 := h12 p.succ,
        have h13 : x * ↑(p.succ) / ↑(p.succ) = x,
        { have : (p.succ : ℝ) ≠ 0 := ne_zero.ne _,
          exact (div_eq_iff this).mpr rfl },
        rw[h13] at h12,
        rw[← h12],
        have h14: u (x / ↑(p.succ)) ^ p.succ = u (x / ↑(p.succ)) ^ (p.succ:ℝ) := by norm_cast,
        rw[h14],
        have h15 := le_of_lt (hunz (x / ↑(p.succ))),
        rw[←real.rpow_mul h15 _],
        have : ((p:ℝ) + 1) ≠ 0 := by { norm_cast, exact ne_of_gt hp },
        field_simp},

  have hq : ∀ q : ℚ, u q = real.exp (k * q),
  { intro q,
    rw[rat.cast_def q],
    rw[hp q.denom q.pos q.num],
    rw[hzexp q.num],
    rw[←real.exp_mul],
    ring_nf},

  use k,

  -- Since u in monotonic and the rationals are dense in ℝ, we have u(x) = e^(kx) for all x ∈ ℝ.
  -- Therefore all solutions of the form u(x) = e^(kx), k ∈ ℝ.
  let f := λ x, real.exp (k * x),
  have hf : ∀ q : ℚ, u q = f q,
  { intro q, exact hq q },

  have h20 : continuous (real.exp) := real.continuous_exp,
  have h21 : continuous (λ x : ℝ, k * x) := continuous_mul_left k,
  have hfm : continuous f := continuous.comp h20 h21,

  cases hm,
  { have hmu : monotone u := strict_mono.monotone hm,
    exact extend_function_mono u f hmu hfm hf },
  { have hau : antitone u := strict_anti.antitone hm,
    exact extend_function_anti u f hau hfm hf }
end

lemma exp_strict_mono' (k x y : ℝ) (hkp: 0 < k) (h : x < y) :
    real.exp(k * x) < real.exp(k * y) :=
  real.exp_lt_exp.mpr ((mul_lt_mul_left hkp).mpr h)

lemma exp_strict_anti' (k x y : ℝ) (hkp: k < 0) (h : x < y) :
    real.exp(k * y) < real.exp(k * x) :=
  real.exp_lt_exp.mpr (mul_lt_mul_of_neg_left h hkp)

lemma romania1998_q12_mp (u : ℝ → ℝ) :
    (∃ f : ℝ → ℝ, (strict_mono f ∨ strict_anti f)
        ∧ ∀ x y : ℝ, f (x + y) = f x * u y + f y) →
    (∃ k : ℝ, ∀ x : ℝ, u x = real.exp (k * x)) :=
begin
  intro h,
  obtain ⟨f, hm, hf⟩ := h,
  -- First, letting y = 0, we obtain f(x) = f(x)u(0) + f(0) for all x ∈ ℝ,
  have hy0 : ∀ x : ℝ, f x = f x * u 0 + f 0,
  { intro x, have := hf x 0, rw [ add_zero] at this, exact this },

  -- thus u(0) ≠ 1 would imply f(x) = f(0) / (1 - u(0)) for all x,
  have h0 : (u 0 ≠ 1) → ∀ x : ℝ, f x = f 0 / (1 - u 0),
  { intros hu0 x,
    have hy0x := hy0 x,
    have hy0x1 := calc f 0
         = f x - f x * u 0 : (sub_eq_of_eq_add' (hy0 x)).symm
     ... = f x * (1 - u 0) : by { ring },
    rw[hy0x1],
    have : 1 - u 0 ≠ 0,
    { intro hz,
      exact hu0 (by linarith) },
    field_simp },

  -- which implies that f is constant, which we know is not the case
  have h0' : (u 0 ≠ 1) → false,
  { intros hu0,
    have hu0' := h0 hu0,
    cases hm;
    { have hu00 := hu0' 0,
      have hu01 := hu0' 1,
      have hm0 := @hm 0 1 (by norm_num),
      linarith } },

  -- so we must have u(0) = 1
  have h00 : u 0 = 1 := not_not.mp h0',
  clear h0 h0',
  rw [h00] at hy0,

  -- and f(0) = 0.
  have hf0 : f 0 = 0 := by { have := hy0 0, linarith },

  -- Then f(x) ≠ 0 for all x ≠ 0.
  have hfx0 : ∀ x, x ≠ 0 → f x ≠ 0,
  { intros x hx,
    cases hm with hm1 hm2,
    { obtain h1 | h2 | h3 := lt_trichotomy x 0,
      { rw [←hf0],
        exact ne_of_lt (hm1 h1)},
      { exfalso, exact hx h2},
      { rw [←hf0],
        exact (ne_of_lt (hm1 h3)).symm }},
    { obtain h1 | h2 | h3 := lt_trichotomy x 0,
      { have := hm2 h1,
        rw [hf0] at this,
        exact (ne_of_lt this).symm},
      { exfalso, exact hx h2},
      { have := hm2 h3,
        rw [hf0] at this,
        exact (ne_of_lt this) }}},

  -- Next, we have
  -- f(x)u(y) + f(y) = f (x + y) = f(x) + f(y)u(x)
  have h1 : ∀ x y : ℝ, f x * u y + f y = f x + f y * u x,
  { intros x y,
    rw[(hf x y).symm, add_comm],
    linarith[hf y x] },

  -- so f(x)(u(y) - 1) = f(y)(u(x) - 1) for all x,y ∈ ℝ.
  have h2 : ∀ x y : ℝ, f x * (u y - 1) = f y * (u x - 1) := by
  { intros x y, have := h1 x y, linarith },

  -- Thus for any x ≠ 0, y ≠ 0, we have (u(x) - 1) / f(x) = (u(y) - 1) / f(y).
  have h3 : ∀ x y : ℝ, x ≠ 0 → y ≠ 0 → (u x - 1) / f x =  (u y - 1) / f y,
  { intros x y hx hy,
    have hx1 := hfx0 x hx,
    have hy1 := hfx0 y hy,
    have := h2 x y,
    field_simp,
    linarith },

  -- So there exists C ∈ ℝ such that (u(x) - 1) / f(x) = C for all x ≠ 0.
  have h4: ∃ C : ℝ, ∀ x : ℝ, x ≠ 0 → (u x - 1) / f x = C,
  { use (u 1 - 1) / f 1,
    intros x hx,
    exact h3 x 1 hx one_ne_zero },
  obtain ⟨C, hC⟩ := h4,

  -- So u(x) = 1 + C f(x) for x ≠ 0;
  have h5 : ∀ x : ℝ, x ≠ 0 → u x = 1 + C * f x,
  { intros x hx,
    have hc1 := hC x hx,
    have hx1 := hfx0 x hx,
    field_simp at hc1,
    linarith },

  -- since u(0) = 1, f(0) = 0, this equation also holds for x = 0.
  have h6 : ∀ x : ℝ, u x = 1 + C * f x,
  { intro x,
    cases em (x = 0) with hz hnz,
    { rw [hz, hf0, h00], ring},
    { exact h5 x hnz } },

  -- If C = 0, then u(x) = 1 for all x and we are done.
  cases em (C = 0) with hCz hCnz,
  { use 0,
    intro x,
    rw [zero_mul, real.exp_zero],
    have := h6 x,
    rwa[hCz, zero_mul, add_zero] at this},

  -- Otherwise, observe
  --     u(x + y) = 1 + C f(x + y)
  --              = 1 + C f(x) u(y) + f(y)
  --              = u(y) + C f(x) u(y)
  --              = u(x) u(y)
  -- for all x,y ∈ ℝ.
  have h7 : ∀ x y : ℝ, u (x + y) = u x * u y,
  { intros x y,
    calc u (x + y) = 1 + C * f (x + y) : h6 (x + y)
              ...  = 1 + C * (f x * u y  + f y) : by {rw [hf x y]}
              ...  = u y + C * f x * u y : by { rw[h6 y], ring}
              ...  = u y * (1 + C * f x) : by ring
              ...  = u y * u x : by rw [h6 x]
              ...  = u x * u y : mul_comm (u y) (u x) },

  have hum : (strict_mono u ∨ strict_anti u),
  { cases hm,
    { obtain h1 | h2 | h3 := lt_trichotomy C 0,
      { right, intros x y hxy, nlinarith[hm hxy, h6 x, h6 y] },
      { rw[h2] at hCnz, exfalso, apply hCnz, refl},
      { left, intros x y hxy, nlinarith[hm hxy, h6 x, h6 y] }},
    { obtain h1 | h2 | h3 := lt_trichotomy C 0,
      { left, intros x y hxy, nlinarith[hm hxy, h6 x, h6 y] },
      { rw[h2] at hCnz, exfalso, apply hCnz, refl},
      { right, intros x y hxy, nlinarith[hm hxy, h6 x, h6 y] }}},

  exact exp_characterization u h7 h00 hum
end

lemma romania1998_q12_mpr (u : ℝ → ℝ) :
 (∃ k : ℝ, ∀ x : ℝ, u x = real.exp (k * x)) →
    (∃ f : ℝ → ℝ, (strict_mono f ∨ strict_anti f)
        ∧ ∀ x y : ℝ, f (x + y) = f x * u y + f y)
     :=
begin
  intro h,
  obtain ⟨k, hk⟩ := h,
  cases classical.em (k = 0) with hkz hknz,
  { -- k = 0
    use id,
    split,
    { left, exact strict_mono_id},
    { intros x y,
      rw [hk y, hkz, zero_mul, real.exp_zero, mul_one, id.def, id.def, id.def] }},
   { -- k ≠ 0
     let f : ℝ → ℝ := λ x, real.exp (k * x) - 1,
     have hfm : (strict_mono f ∨ strict_anti f),
     { cases classical.em (0 < k) with hkp hkn,
       { left,
         intros x y hxy,
         have := exp_strict_mono' k x y hkp hxy,
         exact sub_lt_sub_right this 1 },
       { right,
         intros x y hxy,
         have hkn' : k < 0, {
              simp only [not_lt] at *,
              exact ne.lt_of_le hknz hkn,
         },
         have := exp_strict_anti' k x y hkn' hxy,
         exact sub_lt_sub_right this 1 }
     },
     use f,
     use hfm,
     intros x y,
     rw [hk y],
     calc real.exp (k * (x + y)) - 1
             = real.exp (k * x + k * y) - 1 : by {rw[mul_add]}
         ... = real.exp (k * x) * real.exp (k * y) - 1 : by {rw[real.exp_add]}
         ... = (real.exp (k * x) - 1) * real.exp (k * y) +
                  (real.exp (k * y) - 1) : by ring
   }
end

theorem romania1998_q12 (u : ℝ → ℝ) :
  (∃ f : ℝ → ℝ, (strict_mono f ∨ strict_anti f)
        ∧ ∀ x y : ℝ, f (x + y) = f x * u y + f y) ↔
  (∃ k : ℝ, ∀ x : ℝ, u x = real.exp (k * x)) :=
⟨romania1998_q12_mp u, romania1998_q12_mpr u⟩


/-
Copyright (c) 2021 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.adjunction.basic
import category_theory.punit
import category_theory.structured_arrow

/-!
# Properties of comma categories relating to adjunctions

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This file shows that for a functor `G : D ⥤ C` the data of an initial object in each
`structured_arrow` category on `G` is equivalent to a left adjoint to `G`, as well as the dual.

Specifically, `adjunction_of_structured_arrow_initials` gives the left adjoint assuming the
appropriate initial objects exist, and `mk_initial_of_left_adjoint` constructs the initial objects
provided a left adjoint.

The duals are also shown.
-/
universes v₁ v₂ u₁ u₂

noncomputable theory

namespace category_theory
open limits

variables {C : Type u₁} {D : Type u₂} [category.{v₁} C] [category.{v₂} D] (G : D ⥤ C)

section of_initials
variables [∀ A, has_initial (structured_arrow A G)]

/--
Implementation: If each structured arrow category on `G` has an initial object, an equivalence
which is helpful for constructing a left adjoint to `G`.
-/
@[simps]
def left_adjoint_of_structured_arrow_initials_aux (A : C) (B : D) :
  ((⊥_ (structured_arrow A G)).right ⟶ B) ≃ (A ⟶ G.obj B) :=
{ to_fun := λ g, (⊥_ (structured_arrow A G)).hom ≫ G.map g,
  inv_fun := λ f, comma_morphism.right (initial.to (structured_arrow.mk f)),
  left_inv := λ g,
  begin
    let B' : structured_arrow A G :=
      structured_arrow.mk ((⊥_ (structured_arrow A G)).hom ≫ G.map g),
    let g' : ⊥_ (structured_arrow A G) ⟶ B' := structured_arrow.hom_mk g rfl,
    have : initial.to _ = g',
    { apply colimit.hom_ext, rintro ⟨⟨⟩⟩ },
    change comma_morphism.right (initial.to B') = _,
    rw this,
    refl
  end,
  right_inv := λ f,
  begin
    let B' : structured_arrow A G := structured_arrow.mk f,
    apply (comma_morphism.w (initial.to B')).symm.trans (category.id_comp _),
  end }

/--
If each structured arrow category on `G` has an initial object, construct a left adjoint to `G`. It
is shown that it is a left adjoint in `adjunction_of_structured_arrow_initials`.
-/
def left_adjoint_of_structured_arrow_initials : C ⥤ D :=
adjunction.left_adjoint_of_equiv (left_adjoint_of_structured_arrow_initials_aux G) (λ _ _, by simp)

/--
If each structured arrow category on `G` has an initial object, we have a constructed left adjoint
to `G`.
-/
def adjunction_of_structured_arrow_initials :
  left_adjoint_of_structured_arrow_initials G ⊣ G :=
adjunction.adjunction_of_equiv_left _ _

/-- If each structured arrow category on `G` has an initial object, `G` is a right adjoint. -/
def is_right_adjoint_of_structured_arrow_initials : is_right_adjoint G :=
{ left := _, adj := adjunction_of_structured_arrow_initials G }

end of_initials

section of_terminals
variables [∀ A, has_terminal (costructured_arrow G A)]

/--
Implementation: If each costructured arrow category on `G` has a terminal object, an equivalence
which is helpful for constructing a right adjoint to `G`.
-/
@[simps]
def right_adjoint_of_costructured_arrow_terminals_aux (B : D) (A : C) :
  (G.obj B ⟶ A) ≃ (B ⟶ (⊤_ (costructured_arrow G A)).left) :=
{ to_fun := λ g, comma_morphism.left (terminal.from (costructured_arrow.mk g)),
  inv_fun := λ g, G.map g ≫ (⊤_ (costructured_arrow G A)).hom,
  left_inv := by tidy,
  right_inv := λ g,
  begin
    let B' : costructured_arrow G A :=
      costructured_arrow.mk (G.map g ≫ (⊤_ (costructured_arrow G A)).hom),
    let g' : B' ⟶ ⊤_ (costructured_arrow G A) := costructured_arrow.hom_mk g rfl,
    have : terminal.from _ = g',
    { apply limit.hom_ext, rintro ⟨⟨⟩⟩ },
    change comma_morphism.left (terminal.from B') = _,
    rw this,
    refl
  end }

/--
If each costructured arrow category on `G` has a terminal object, construct a right adjoint to `G`.
It is shown that it is a right adjoint in `adjunction_of_structured_arrow_initials`.
-/
def right_adjoint_of_costructured_arrow_terminals : C ⥤ D :=
adjunction.right_adjoint_of_equiv (right_adjoint_of_costructured_arrow_terminals_aux G)
  (λ B₁ B₂ A f g, by { rw ←equiv.eq_symm_apply, simp })

/--
If each costructured arrow category on `G` has a terminal object, we have a constructed right
adjoint to `G`.
-/
def adjunction_of_costructured_arrow_terminals :
  G ⊣ right_adjoint_of_costructured_arrow_terminals G :=
adjunction.adjunction_of_equiv_right _ _

/-- If each costructured arrow category on `G` has an terminal object, `G` is a left adjoint. -/
def is_left_adjoint_of_costructured_arrow_terminals : is_left_adjoint G :=
{ right := right_adjoint_of_costructured_arrow_terminals G,
  adj := adjunction.adjunction_of_equiv_right _ _ }

end of_terminals

section
variables {F : C ⥤ D}

local attribute [tidy] tactic.discrete_cases

/-- Given a left adjoint to `G`, we can construct an initial object in each structured arrow
category on `G`. -/
def mk_initial_of_left_adjoint (h : F ⊣ G) (A : C) :
  is_initial (structured_arrow.mk (h.unit.app A) : structured_arrow A G) :=
{ desc := λ B, structured_arrow.hom_mk ((h.hom_equiv _ _).symm B.X.hom) (by tidy),
  uniq' := λ s m w,
  begin
    ext,
    dsimp,
    rw [equiv.eq_symm_apply, adjunction.hom_equiv_unit],
    apply structured_arrow.w m,
  end }

/-- Given a right adjoint to `F`, we can construct a terminal object in each costructured arrow
category on `F`. -/
def mk_terminal_of_right_adjoint (h : F ⊣ G) (A : D) :
  is_terminal (costructured_arrow.mk (h.counit.app A) : costructured_arrow F A) :=
{ lift := λ B, costructured_arrow.hom_mk (h.hom_equiv _ _ B.X.hom) (by tidy),
  uniq' := λ s m w,
  begin
    ext,
    dsimp,
    rw [h.eq_hom_equiv_apply, adjunction.hom_equiv_counit],
    exact costructured_arrow.w m,
  end }

end

lemma nonempty_is_right_adjoint_iff_has_initial_structured_arrow {G : D ⥤ C} :
  nonempty (is_right_adjoint G) ↔ ∀ A, has_initial (structured_arrow A G) :=
⟨λ ⟨h⟩ A, by exactI (mk_initial_of_left_adjoint _ h.adj A).has_initial,
 λ h, by exactI ⟨is_right_adjoint_of_structured_arrow_initials _⟩⟩

lemma nonempty_is_left_adjoint_iff_has_terminal_costructured_arrow {F : C ⥤ D} :
  nonempty (is_left_adjoint F) ↔ ∀ A, has_terminal (costructured_arrow F A) :=
⟨λ ⟨h⟩ A, by exactI (mk_terminal_of_right_adjoint _ h.adj A).has_terminal,
 λ h, by exactI ⟨is_left_adjoint_of_costructured_arrow_terminals _⟩⟩

end category_theory


import data.real.basic tactic.ring

example (a b l m : ℝ) :
  abs(a + (b + (-l - m))) = abs(a + (-l + (b - m))) :=
-- by ring -- I think this used to work but now it doesn't
by congr' 1; ring


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.semiquot
import data.rat.floor
/-!
# Implementation of floating-point numbers (experimental).
-/

def int.shift2 (a b : ℕ) : ℤ → ℕ × ℕ
| (int.of_nat e) := (a.shiftl e, b)
| -[1+ e] := (a, b.shiftl e.succ)

namespace fp

@[derive inhabited]
inductive rmode
| NE -- round to nearest even

class float_cfg :=
(prec emax : ℕ)
(prec_pos : 0 < prec)
(prec_max : prec ≤ emax)

variable [C : float_cfg]
include C

def prec := C.prec
def emax := C.emax
def emin : ℤ := 1 - C.emax

def valid_finite (e : ℤ) (m : ℕ) : Prop :=
emin ≤ e + prec - 1 ∧ e + prec - 1 ≤ emax ∧ e = max (e + m.size - prec) emin

instance dec_valid_finite (e m) : decidable (valid_finite e m) :=
by unfold valid_finite; apply_instance

inductive float
| inf : bool → float
| nan : float
| finite : bool → Π e m, valid_finite e m → float

def float.is_finite : float → bool
| (float.finite s e m f) := tt
| _ := ff

def to_rat : Π (f : float), f.is_finite → ℚ
| (float.finite s e m f) _ :=
  let (n, d) := int.shift2 m 1 e,
      r := rat.mk_nat n d in
  if s then -r else r

theorem float.zero.valid : valid_finite emin 0 :=
⟨begin
  rw add_sub_assoc,
  apply le_add_of_nonneg_right,
  apply sub_nonneg_of_le,
  apply int.coe_nat_le_coe_nat_of_le,
  exact C.prec_pos
end,
suffices prec ≤ 2 * emax,
begin
  rw ← int.coe_nat_le at this,
  rw ← sub_nonneg at *,
  simp only [emin, emax] at *,
  ring_nf,
  assumption
end, le_trans C.prec_max (nat.le_mul_of_pos_left dec_trivial),
by rw max_eq_right; simp [sub_eq_add_neg]⟩

def float.zero (s : bool) : float :=
float.finite s emin 0 float.zero.valid

instance : inhabited float := ⟨float.zero tt⟩

protected def float.sign' : float → semiquot bool
| (float.inf s) := pure s
| float.nan := ⊤
| (float.finite s e m f) := pure s

protected def float.sign : float → bool
| (float.inf s) := s
| float.nan := ff
| (float.finite s e m f) := s

protected def float.is_zero : float → bool
| (float.finite s e 0 f) := tt
| _ := ff

protected def float.neg : float → float
| (float.inf s) := float.inf (bnot s)
| float.nan := float.nan
| (float.finite s e m f) := float.finite (bnot s) e m f

def div_nat_lt_two_pow (n d : ℕ) : ℤ → bool
| (int.of_nat e) := n < d.shiftl e
| -[1+ e] := n.shiftl e.succ < d

-- TODO(Mario): Prove these and drop 'meta'
meta def of_pos_rat_dn (n : ℕ+) (d : ℕ+) : float × bool :=
begin
  let e₁ : ℤ := n.1.size - d.1.size - prec,
  cases h₁ : int.shift2 d.1 n.1 (e₁ + prec) with d₁ n₁,
  let e₂ := if n₁ < d₁ then e₁ - 1 else e₁,
  let e₃ := max e₂ emin,
  cases h₂ : int.shift2 d.1 n.1 (e₃ + prec) with d₂ n₂,
  let r := rat.mk_nat n₂ d₂,
  let m := r.floor,
  refine (float.finite ff e₃ (int.to_nat m) _, r.denom = 1),
  { exact undefined }
end

meta def next_up_pos (e m) (v : valid_finite e m) : float :=
let m' := m.succ in
if ss : m'.size = m.size then
  float.finite ff e m' (by unfold valid_finite at *; rw ss; exact v)
else if h : e = emax then
  float.inf ff
else
  float.finite ff e.succ (nat.div2 m') undefined

meta def next_dn_pos (e m) (v : valid_finite e m) : float :=
match m with
| 0 := next_up_pos _ _ float.zero.valid
| nat.succ m' :=
  if ss : m'.size = m.size then
    float.finite ff e m' (by unfold valid_finite at *; rw ss; exact v)
  else if h : e = emin then
    float.finite ff emin m' undefined
  else
    float.finite ff e.pred (bit1 m') undefined
end

meta def next_up : float → float
| (float.finite ff e m f) := next_up_pos e m f
| (float.finite tt e m f) := float.neg $ next_dn_pos e m f
| f := f

meta def next_dn : float → float
| (float.finite ff e m f) := next_dn_pos e m f
| (float.finite tt e m f) := float.neg $ next_up_pos e m f
| f := f

meta def of_rat_up : ℚ → float
| ⟨0, _, _, _⟩          := float.zero ff
| ⟨nat.succ n, d, h, _⟩ :=
  let (f, exact) := of_pos_rat_dn n.succ_pnat ⟨d, h⟩ in
  if exact then f else next_up f
| ⟨-[1+n], d, h, _⟩     := float.neg (of_pos_rat_dn n.succ_pnat ⟨d, h⟩).1

meta def of_rat_dn (r : ℚ) : float :=
float.neg $ of_rat_up (-r)

meta def of_rat : rmode → ℚ → float
| rmode.NE r :=
  let low := of_rat_dn r, high := of_rat_up r in
  if hf : high.is_finite then
    if r = to_rat _ hf then high else
    if lf : low.is_finite then
      if r - to_rat _ lf > to_rat _ hf - r then high else
      if r - to_rat _ lf < to_rat _ hf - r then low else
      match low, lf with float.finite s e m f, _ :=
        if 2 ∣ m then low else high
      end
    else float.inf tt
  else float.inf ff

namespace float

instance : has_neg float := ⟨float.neg⟩

meta def add (mode : rmode) : float → float → float
| nan      _        := nan
| _        nan      := nan
| (inf tt) (inf ff) := nan
| (inf ff) (inf tt) := nan
| (inf s₁) _        := inf s₁
| _        (inf s₂) := inf s₂
| (finite s₁ e₁ m₁ v₁) (finite s₂ e₂ m₂ v₂) :=
  let f₁ := finite s₁ e₁ m₁ v₁, f₂ := finite s₂ e₂ m₂ v₂ in
  of_rat mode (to_rat f₁ rfl + to_rat f₂ rfl)

meta instance : has_add float := ⟨float.add rmode.NE⟩

meta def sub (mode : rmode) (f1 f2 : float) : float :=
add mode f1 (-f2)

meta instance : has_sub float := ⟨float.sub rmode.NE⟩

meta def mul (mode : rmode) : float → float → float
| nan      _        := nan
| _        nan      := nan
| (inf s₁) f₂       := if f₂.is_zero then nan else inf (bxor s₁ f₂.sign)
| f₁       (inf s₂) := if f₁.is_zero then nan else inf (bxor f₁.sign s₂)
| (finite s₁ e₁ m₁ v₁) (finite s₂ e₂ m₂ v₂) :=
  let f₁ := finite s₁ e₁ m₁ v₁, f₂ := finite s₂ e₂ m₂ v₂ in
  of_rat mode (to_rat f₁ rfl * to_rat f₂ rfl)

meta def div (mode : rmode) : float → float → float
| nan      _        := nan
| _        nan      := nan
| (inf s₁) (inf s₂) := nan
| (inf s₁) f₂       := inf (bxor s₁ f₂.sign)
| f₁       (inf s₂) := zero (bxor f₁.sign s₂)
| (finite s₁ e₁ m₁ v₁) (finite s₂ e₂ m₂ v₂) :=
  let f₁ := finite s₁ e₁ m₁ v₁, f₂ := finite s₂ e₂ m₂ v₂ in
  if f₂.is_zero then inf (bxor s₁ s₂) else
  of_rat mode (to_rat f₁ rfl / to_rat f₂ rfl)

end float

end fp


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.rat
import data.semiquot
/-!
# Implementation of floating-point numbers (experimental).
-/

def int.shift2 (a b : ℕ) : ℤ → ℕ × ℕ
| (int.of_nat e) := (a.shiftl e, b)
| -[1+ e] := (a, b.shiftl e.succ)

namespace fp

@[derive inhabited]
inductive rmode
| NE -- round to nearest even

class float_cfg :=
(prec emax : ℕ)
(prec_pos : 0 < prec)
(prec_max : prec ≤ emax)

variable [C : float_cfg]
include C

def prec := C.prec
def emax := C.emax
def emin : ℤ := 1 - C.emax

def valid_finite (e : ℤ) (m : ℕ) : Prop :=
emin ≤ e + prec - 1 ∧ e + prec - 1 ≤ emax ∧ e = max (e + m.size - prec) emin

instance dec_valid_finite (e m) : decidable (valid_finite e m) :=
by unfold valid_finite; apply_instance

inductive float
| inf : bool → float
| nan : float
| finite : bool → Π e m, valid_finite e m → float

def float.is_finite : float → bool
| (float.finite s e m f) := tt
| _ := ff

def to_rat : Π (f : float), f.is_finite → ℚ
| (float.finite s e m f) _ :=
  let (n, d) := int.shift2 m 1 e,
      r := rat.mk_nat n d in
  if s then -r else r

theorem float.zero.valid : valid_finite emin 0 :=
⟨begin
  rw add_sub_assoc,
  apply le_add_of_nonneg_right,
  apply sub_nonneg_of_le,
  apply int.coe_nat_le_coe_nat_of_le,
  exact C.prec_pos
end,
suffices prec ≤ 2 * emax,
begin
  rw ← int.coe_nat_le at this,
  rw ← sub_nonneg at *,
  simp only [emin, emax] at *,
  ring_nf,
  assumption
end, le_trans C.prec_max (nat.le_mul_of_pos_left dec_trivial),
by rw max_eq_right; simp [sub_eq_add_neg]⟩

def float.zero (s : bool) : float :=
float.finite s emin 0 float.zero.valid

instance : inhabited float := ⟨float.zero tt⟩

protected def float.sign' : float → semiquot bool
| (float.inf s) := pure s
| float.nan := ⊤
| (float.finite s e m f) := pure s

protected def float.sign : float → bool
| (float.inf s) := s
| float.nan := ff
| (float.finite s e m f) := s

protected def float.is_zero : float → bool
| (float.finite s e 0 f) := tt
| _ := ff

protected def float.neg : float → float
| (float.inf s) := float.inf (bnot s)
| float.nan := float.nan
| (float.finite s e m f) := float.finite (bnot s) e m f

def div_nat_lt_two_pow (n d : ℕ) : ℤ → bool
| (int.of_nat e) := n < d.shiftl e
| -[1+ e] := n.shiftl e.succ < d

-- TODO(Mario): Prove these and drop 'meta'
meta def of_pos_rat_dn (n : ℕ+) (d : ℕ+) : float × bool :=
begin
  let e₁ : ℤ := n.1.size - d.1.size - prec,
  cases h₁ : int.shift2 d.1 n.1 (e₁ + prec) with d₁ n₁,
  let e₂ := if n₁ < d₁ then e₁ - 1 else e₁,
  let e₃ := max e₂ emin,
  cases h₂ : int.shift2 d.1 n.1 (e₃ + prec) with d₂ n₂,
  let r := rat.mk_nat n₂ d₂,
  let m := r.floor,
  refine (float.finite ff e₃ (int.to_nat m) _, r.denom = 1),
  { exact undefined }
end

meta def next_up_pos (e m) (v : valid_finite e m) : float :=
let m' := m.succ in
if ss : m'.size = m.size then
  float.finite ff e m' (by unfold valid_finite at *; rw ss; exact v)
else if h : e = emax then
  float.inf ff
else
  float.finite ff e.succ (nat.div2 m') undefined

meta def next_dn_pos (e m) (v : valid_finite e m) : float :=
match m with
| 0 := next_up_pos _ _ float.zero.valid
| nat.succ m' :=
  if ss : m'.size = m.size then
    float.finite ff e m' (by unfold valid_finite at *; rw ss; exact v)
  else if h : e = emin then
    float.finite ff emin m' undefined
  else
    float.finite ff e.pred (bit1 m') undefined
end

meta def next_up : float → float
| (float.finite ff e m f) := next_up_pos e m f
| (float.finite tt e m f) := float.neg $ next_dn_pos e m f
| f := f

meta def next_dn : float → float
| (float.finite ff e m f) := next_dn_pos e m f
| (float.finite tt e m f) := float.neg $ next_up_pos e m f
| f := f

meta def of_rat_up : ℚ → float
| ⟨0, _, _, _⟩          := float.zero ff
| ⟨nat.succ n, d, h, _⟩ :=
  let (f, exact) := of_pos_rat_dn n.succ_pnat ⟨d, h⟩ in
  if exact then f else next_up f
| ⟨-[1+n], d, h, _⟩     := float.neg (of_pos_rat_dn n.succ_pnat ⟨d, h⟩).1

meta def of_rat_dn (r : ℚ) : float :=
float.neg $ of_rat_up (-r)

meta def of_rat : rmode → ℚ → float
| rmode.NE r :=
  let low := of_rat_dn r, high := of_rat_up r in
  if hf : high.is_finite then
    if r = to_rat _ hf then high else
    if lf : low.is_finite then
      if r - to_rat _ lf > to_rat _ hf - r then high else
      if r - to_rat _ lf < to_rat _ hf - r then low else
      match low, lf with float.finite s e m f, _ :=
        if 2 ∣ m then low else high
      end
    else float.inf tt
  else float.inf ff

namespace float

instance : has_neg float := ⟨float.neg⟩

meta def add (mode : rmode) : float → float → float
| nan      _        := nan
| _        nan      := nan
| (inf tt) (inf ff) := nan
| (inf ff) (inf tt) := nan
| (inf s₁) _        := inf s₁
| _        (inf s₂) := inf s₂
| (finite s₁ e₁ m₁ v₁) (finite s₂ e₂ m₂ v₂) :=
  let f₁ := finite s₁ e₁ m₁ v₁, f₂ := finite s₂ e₂ m₂ v₂ in
  of_rat mode (to_rat f₁ rfl + to_rat f₂ rfl)

meta instance : has_add float := ⟨float.add rmode.NE⟩

meta def sub (mode : rmode) (f1 f2 : float) : float :=
add mode f1 (-f2)

meta instance : has_sub float := ⟨float.sub rmode.NE⟩

meta def mul (mode : rmode) : float → float → float
| nan      _        := nan
| _        nan      := nan
| (inf s₁) f₂       := if f₂.is_zero then nan else inf (bxor s₁ f₂.sign)
| f₁       (inf s₂) := if f₁.is_zero then nan else inf (bxor f₁.sign s₂)
| (finite s₁ e₁ m₁ v₁) (finite s₂ e₂ m₂ v₂) :=
  let f₁ := finite s₁ e₁ m₁ v₁, f₂ := finite s₂ e₂ m₂ v₂ in
  of_rat mode (to_rat f₁ rfl * to_rat f₂ rfl)

meta def div (mode : rmode) : float → float → float
| nan      _        := nan
| _        nan      := nan
| (inf s₁) (inf s₂) := nan
| (inf s₁) f₂       := inf (bxor s₁ f₂.sign)
| f₁       (inf s₂) := zero (bxor f₁.sign s₂)
| (finite s₁ e₁ m₁ v₁) (finite s₂ e₂ m₂ v₂) :=
  let f₁ := finite s₁ e₁ m₁ v₁, f₂ := finite s₂ e₂ m₂ v₂ in
  if f₂.is_zero then inf (bxor s₁ s₂) else
  of_rat mode (to_rat f₁ rfl / to_rat f₂ rfl)

end float

end fp


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

! This file was ported from Lean 3 source module order.category.FinPartOrd
! leanprover-community/mathlib commit e8ac6315bcfcbaf2d19a046719c3b553206dac75
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Fintype
import Mathbin.Order.Category.PartOrd

/-!
# The category of finite partial orders

This defines `FinPartOrd`, the category of finite partial orders.

Note: `FinPartOrd` is NOT a subcategory of `BddOrd` because its morphisms do not
preserve `⊥` and `⊤`.

## TODO

`FinPartOrd` is equivalent to a small category.
-/

universe u v

open CategoryTheory

/-- The category of finite partial orders with monotone functions. -/
structure FinPartOrd where
  toPartOrd : PartOrd
  [isFintype : Fintype to_PartOrd]
#align FinPartOrd FinPartOrd

namespace FinPartOrd

instance : CoeSort FinPartOrd (Type _) :=
  ⟨fun X => X.toPartOrd⟩

instance (X : FinPartOrd) : PartialOrder X :=
  X.toPartOrd.str

attribute [instance] FinPartOrd.isFintype

@[simp]
theorem coe_toPartOrd (X : FinPartOrd) : ↥X.toPartOrd = ↥X :=
  rfl
#align FinPartOrd.coe_to_PartOrd FinPartOrd.coe_toPartOrd

/-- Construct a bundled `FinPartOrd` from `fintype` + `partial_order`. -/
def of (α : Type _) [PartialOrder α] [Fintype α] : FinPartOrd :=
  ⟨⟨α⟩⟩
#align FinPartOrd.of FinPartOrd.of

@[simp]
theorem coe_of (α : Type _) [PartialOrder α] [Fintype α] : ↥(of α) = α :=
  rfl
#align FinPartOrd.coe_of FinPartOrd.coe_of

instance : Inhabited FinPartOrd :=
  ⟨of PUnit⟩

instance largeCategory : LargeCategory FinPartOrd :=
  InducedCategory.category FinPartOrd.toPartOrd
#align FinPartOrd.large_category FinPartOrd.largeCategory

instance concreteCategory : ConcreteCategory FinPartOrd :=
  InducedCategory.concreteCategory FinPartOrd.toPartOrd
#align FinPartOrd.concrete_category FinPartOrd.concreteCategory

instance hasForgetToPartOrd : HasForget₂ FinPartOrd PartOrd :=
  InducedCategory.hasForget₂ FinPartOrd.toPartOrd
#align FinPartOrd.has_forget_to_PartOrd FinPartOrd.hasForgetToPartOrd

instance hasForgetToFintype : HasForget₂ FinPartOrd FintypeCat
    where forget₂ :=
    { obj := fun X => ⟨X⟩
      map := fun X Y => coeFn }
#align FinPartOrd.has_forget_to_Fintype FinPartOrd.hasForgetToFintype

/-- Constructs an isomorphism of finite partial orders from an order isomorphism between them. -/
@[simps]
def Iso.mk {α β : FinPartOrd.{u}} (e : α ≃o β) : α ≅ β
    where
  Hom := e
  inv := e.symm
  hom_inv_id' := by
    ext
    exact e.symm_apply_apply _
  inv_hom_id' := by
    ext
    exact e.apply_symm_apply _
#align FinPartOrd.iso.mk FinPartOrd.Iso.mk

/-- `order_dual` as a functor. -/
@[simps]
def dual : FinPartOrd ⥤ FinPartOrd where
  obj X := of Xᵒᵈ
  map X Y := OrderHom.dual
#align FinPartOrd.dual FinPartOrd.dual

/-- The equivalence between `FinPartOrd` and itself induced by `order_dual` both ways. -/
@[simps Functor inverse]
def dualEquiv : FinPartOrd ≌ FinPartOrd :=
  Equivalence.mk dual dual
    (NatIso.ofComponents (fun X => Iso.mk <| OrderIso.dualDual X) fun X Y f => rfl)
    (NatIso.ofComponents (fun X => Iso.mk <| OrderIso.dualDual X) fun X Y f => rfl)
#align FinPartOrd.dual_equiv FinPartOrd.dualEquiv

end FinPartOrd

theorem finPartOrd_dual_comp_forget_to_partOrd :
    FinPartOrd.dual ⋙ forget₂ FinPartOrd PartOrd = forget₂ FinPartOrd PartOrd ⋙ PartOrd.dual :=
  rfl
#align FinPartOrd_dual_comp_forget_to_PartOrd finPartOrd_dual_comp_forget_to_partOrd


/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro
-/
import data.rat.order
import data.rat.lemmas
import data.int.char_zero
import algebra.group_with_zero.power
import algebra.field.opposite
import algebra.order.field.basic

/-!
# Casts for Rational Numbers

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

## Summary

We define the canonical injection from ℚ into an arbitrary division ring and prove various
casting lemmas showing the well-behavedness of this injection.

## Notations

- `/.` is infix notation for `rat.mk`.

## Tags

rat, rationals, field, ℚ, numerator, denominator, num, denom, cast, coercion, casting
-/

variables {F ι α β : Type*}

namespace rat
open_locale rat

section with_div_ring
variable [division_ring α]

@[simp, norm_cast] theorem cast_coe_int (n : ℤ) : ((n : ℚ) : α) = n :=
(cast_def _).trans $ show (n / (1:ℕ) : α) = n, by rw [nat.cast_one, div_one]

@[simp, norm_cast] theorem cast_coe_nat (n : ℕ) : ((n : ℚ) : α) = n :=
by rw [← int.cast_coe_nat, cast_coe_int, int.cast_coe_nat]

@[simp, norm_cast] lemma cast_zero : ((0 : ℚ) : α) = 0 := (cast_coe_int _).trans int.cast_zero
@[simp, norm_cast] lemma cast_one : ((1 : ℚ) : α) = 1 := (cast_coe_int _).trans int.cast_one

theorem cast_commute (r : ℚ) (a : α) : commute ↑r a :=
by simpa only [cast_def] using (r.1.cast_commute a).div_left (r.2.cast_commute a)

theorem cast_comm (r : ℚ) (a : α) : (r : α) * a = a * r :=
(cast_commute r a).eq

theorem commute_cast (a : α) (r : ℚ) : commute a r :=
(r.cast_commute a).symm

@[norm_cast] theorem cast_mk_of_ne_zero (a b : ℤ)
  (b0 : (b:α) ≠ 0) : (a /. b : α) = a / b :=
begin
  have b0' : b ≠ 0, { refine mt _ b0, simp {contextual := tt} },
  cases e : a /. b with n d h c,
  have d0 : (d:α) ≠ 0,
  { intro d0,
    have dd := denom_dvd a b,
    cases (show (d:ℤ) ∣ b, by rwa e at dd) with k ke,
    have : (b:α) = (d:α) * (k:α), {rw [ke, int.cast_mul, int.cast_coe_nat]},
    rw [d0, zero_mul] at this, contradiction },
  rw [num_denom'] at e,
  have := congr_arg (coe : ℤ → α) ((mk_eq b0' $ ne_of_gt $ int.coe_nat_pos.2 h).1 e),
  rw [int.cast_mul, int.cast_mul, int.cast_coe_nat] at this,
  symmetry,
  rw [cast_def, div_eq_mul_inv, eq_div_iff_mul_eq d0, mul_assoc, (d.commute_cast _).eq,
      ← mul_assoc, this, mul_assoc, mul_inv_cancel b0, mul_one]
end

@[norm_cast] theorem cast_add_of_ne_zero : ∀ {m n : ℚ},
  (m.denom : α) ≠ 0 → (n.denom : α) ≠ 0 → ((m + n : ℚ) : α) = m + n
| ⟨n₁, d₁, h₁, c₁⟩ ⟨n₂, d₂, h₂, c₂⟩ := λ (d₁0 : (d₁:α) ≠ 0) (d₂0 : (d₂:α) ≠ 0), begin
  have d₁0' : (d₁:ℤ) ≠ 0 := int.coe_nat_ne_zero.2 (λ e, by rw e at d₁0; exact d₁0 nat.cast_zero),
  have d₂0' : (d₂:ℤ) ≠ 0 := int.coe_nat_ne_zero.2 (λ e, by rw e at d₂0; exact d₂0 nat.cast_zero),
  rw [num_denom', num_denom', add_def d₁0' d₂0'],
  suffices : (n₁ * (d₂ * (d₂⁻¹ * d₁⁻¹)) +
    n₂ * (d₁ * d₂⁻¹) * d₁⁻¹ : α) = n₁ * d₁⁻¹ + n₂ * d₂⁻¹,
  { rw [cast_mk_of_ne_zero, cast_mk_of_ne_zero, cast_mk_of_ne_zero],
    { simpa [division_def, left_distrib, right_distrib, mul_inv_rev, d₁0, d₂0, mul_assoc] },
    all_goals {simp [d₁0, d₂0]} },
  rw [← mul_assoc (d₂:α), mul_inv_cancel d₂0, one_mul,
      (nat.cast_commute _ _).eq], simp [d₁0, mul_assoc]
end

@[simp, norm_cast] theorem cast_neg : ∀ n, ((-n : ℚ) : α) = -n
| ⟨n, d, h, c⟩ := by simpa only [cast_def] using show (↑-n / d : α) = -(n / d),
  by rw [div_eq_mul_inv, div_eq_mul_inv, int.cast_neg, neg_mul_eq_neg_mul]

@[norm_cast] theorem cast_sub_of_ne_zero {m n : ℚ}
  (m0 : (m.denom : α) ≠ 0) (n0 : (n.denom : α) ≠ 0) : ((m - n : ℚ) : α) = m - n :=
have ((-n).denom : α) ≠ 0, by cases n; exact n0,
by simp [sub_eq_add_neg, (cast_add_of_ne_zero m0 this)]

@[norm_cast] theorem cast_mul_of_ne_zero : ∀ {m n : ℚ},
  (m.denom : α) ≠ 0 → (n.denom : α) ≠ 0 → ((m * n : ℚ) : α) = m * n
| ⟨n₁, d₁, h₁, c₁⟩ ⟨n₂, d₂, h₂, c₂⟩ := λ (d₁0 : (d₁:α) ≠ 0) (d₂0 : (d₂:α) ≠ 0), begin
  have d₁0' : (d₁:ℤ) ≠ 0 := int.coe_nat_ne_zero.2 (λ e, by rw e at d₁0; exact d₁0 nat.cast_zero),
  have d₂0' : (d₂:ℤ) ≠ 0 := int.coe_nat_ne_zero.2 (λ e, by rw e at d₂0; exact d₂0 nat.cast_zero),
  rw [num_denom', num_denom', mul_def d₁0' d₂0'],
  suffices : (n₁ * ((n₂ * d₂⁻¹) * d₁⁻¹) : α) = n₁ * (d₁⁻¹ * (n₂ * d₂⁻¹)),
  { rw [cast_mk_of_ne_zero, cast_mk_of_ne_zero, cast_mk_of_ne_zero],
    { simpa [division_def, mul_inv_rev, d₁0, d₂0, mul_assoc] },
    all_goals {simp [d₁0, d₂0]} },
  rw [(d₁.commute_cast (_:α)).inv_right₀.eq]
end

@[simp] theorem cast_inv_nat (n : ℕ) : ((n⁻¹ : ℚ) : α) = n⁻¹ :=
begin
  cases n, { simp },
  simp_rw [coe_nat_eq_mk, inv_def, mk, mk_nat, dif_neg n.succ_ne_zero, mk_pnat],
  simp [cast_def]
end

@[simp] theorem cast_inv_int (n : ℤ) : ((n⁻¹ : ℚ) : α) = n⁻¹ :=
begin
  cases n,
  { simp [cast_inv_nat] },
  { simp only [int.cast_neg_succ_of_nat, ← nat.cast_succ, cast_neg, inv_neg, cast_inv_nat] }
end

@[norm_cast] theorem cast_inv_of_ne_zero : ∀ {n : ℚ},
  (n.num : α) ≠ 0 → (n.denom : α) ≠ 0 → ((n⁻¹ : ℚ) : α) = n⁻¹
| ⟨n, d, h, c⟩ := λ (n0 : (n:α) ≠ 0) (d0 : (d:α) ≠ 0), begin
  have n0' : (n:ℤ) ≠ 0 := λ e, by rw e at n0; exact n0 int.cast_zero,
  have d0' : (d:ℤ) ≠ 0 := int.coe_nat_ne_zero.2 (λ e, by rw e at d0; exact d0 nat.cast_zero),
  rw [num_denom', inv_def],
  rw [cast_mk_of_ne_zero, cast_mk_of_ne_zero, inv_div];
  simp [n0, d0]
end

@[norm_cast] theorem cast_div_of_ne_zero {m n : ℚ} (md : (m.denom : α) ≠ 0)
  (nn : (n.num : α) ≠ 0) (nd : (n.denom : α) ≠ 0) : ((m / n : ℚ) : α) = m / n :=
have (n⁻¹.denom : ℤ) ∣ n.num,
by conv in n⁻¹.denom { rw [←(@num_denom n), inv_def] };
   apply denom_dvd,
have (n⁻¹.denom : α) = 0 → (n.num : α) = 0, from
λ h, let ⟨k, e⟩ := this in
  by have := congr_arg (coe : ℤ → α) e;
     rwa [int.cast_mul, int.cast_coe_nat, h, zero_mul] at this,
by rw [division_def, cast_mul_of_ne_zero md (mt this nn), cast_inv_of_ne_zero nn nd, division_def]

@[simp, norm_cast] theorem cast_inj [char_zero α] : ∀ {m n : ℚ}, (m : α) = n ↔ m = n
| ⟨n₁, d₁, h₁, c₁⟩ ⟨n₂, d₂, h₂, c₂⟩ := begin
  refine ⟨λ h, _, congr_arg _⟩,
  have d₁0 : d₁ ≠ 0 := ne_of_gt h₁,
  have d₂0 : d₂ ≠ 0 := ne_of_gt h₂,
  have d₁a : (d₁:α) ≠ 0 := nat.cast_ne_zero.2 d₁0,
  have d₂a : (d₂:α) ≠ 0 := nat.cast_ne_zero.2 d₂0,
  rw [num_denom', num_denom'] at h ⊢,
  rw [cast_mk_of_ne_zero, cast_mk_of_ne_zero] at h; simp [d₁0, d₂0] at h ⊢,
  rwa [eq_div_iff_mul_eq d₂a, division_def, mul_assoc, (d₁.cast_commute (d₂:α)).inv_left₀.eq,
    ← mul_assoc, ← division_def, eq_comm, eq_div_iff_mul_eq d₁a, eq_comm,
    ← int.cast_coe_nat d₁, ← int.cast_mul, ← int.cast_coe_nat d₂, ← int.cast_mul,
    int.cast_inj, ← mk_eq (int.coe_nat_ne_zero.2 d₁0) (int.coe_nat_ne_zero.2 d₂0)] at h
end

theorem cast_injective [char_zero α] : function.injective (coe : ℚ → α)
| m n := cast_inj.1

@[simp] theorem cast_eq_zero [char_zero α] {n : ℚ} : (n : α) = 0 ↔ n = 0 :=
by rw [← cast_zero, cast_inj]

theorem cast_ne_zero [char_zero α] {n : ℚ} : (n : α) ≠ 0 ↔ n ≠ 0 :=
not_congr cast_eq_zero

@[simp, norm_cast] theorem cast_add [char_zero α] (m n) :
  ((m + n : ℚ) : α) = m + n :=
cast_add_of_ne_zero (nat.cast_ne_zero.2 $ ne_of_gt m.pos) (nat.cast_ne_zero.2 $ ne_of_gt n.pos)

@[simp, norm_cast] theorem cast_sub [char_zero α] (m n) :
  ((m - n : ℚ) : α) = m - n :=
cast_sub_of_ne_zero (nat.cast_ne_zero.2 $ ne_of_gt m.pos) (nat.cast_ne_zero.2 $ ne_of_gt n.pos)

@[simp, norm_cast] theorem cast_mul [char_zero α] (m n) :
  ((m * n : ℚ) : α) = m * n :=
cast_mul_of_ne_zero (nat.cast_ne_zero.2 $ ne_of_gt m.pos) (nat.cast_ne_zero.2 $ ne_of_gt n.pos)

@[simp, norm_cast] theorem cast_bit0 [char_zero α] (n : ℚ) :
  ((bit0 n : ℚ) : α) = bit0 n :=
cast_add _ _

@[simp, norm_cast] theorem cast_bit1 [char_zero α] (n : ℚ) :
  ((bit1 n : ℚ) : α) = bit1 n :=
by rw [bit1, cast_add, cast_one, cast_bit0]; refl

variables (α) [char_zero α]

/-- Coercion `ℚ → α` as a `ring_hom`. -/
def cast_hom : ℚ →+* α := ⟨coe, cast_one, cast_mul, cast_zero, cast_add⟩

variable {α}

@[simp] lemma coe_cast_hom : ⇑(cast_hom α) = coe := rfl

@[simp, norm_cast] theorem cast_inv (n) : ((n⁻¹ : ℚ) : α) = n⁻¹ := map_inv₀ (cast_hom α) _
@[simp, norm_cast] theorem cast_div (m n) : ((m / n : ℚ) : α) = m / n := map_div₀ (cast_hom α) _ _
@[simp, norm_cast] theorem cast_zpow (q : ℚ) (n : ℤ) : ((q ^ n : ℚ) : α) = q ^ n :=
map_zpow₀ (cast_hom α) q n

@[norm_cast] theorem cast_mk (a b : ℤ) : ((a /. b) : α) = a / b :=
by simp only [mk_eq_div, cast_div, cast_coe_int]

@[simp, norm_cast] theorem cast_pow (q) (k : ℕ) : ((q ^ k : ℚ) : α) = q ^ k :=
(cast_hom α).map_pow q k

end with_div_ring

section linear_ordered_field

variables {K : Type*} [linear_ordered_field K]

lemma cast_pos_of_pos {r : ℚ} (hr : 0 < r) : (0 : K) < r :=
begin
  rw [rat.cast_def],
  exact div_pos (int.cast_pos.2 $ num_pos_iff_pos.2 hr) (nat.cast_pos.2 r.pos)
end

@[mono] lemma cast_strict_mono : strict_mono (coe : ℚ → K) :=
λ m n, by simpa only [sub_pos, cast_sub] using @cast_pos_of_pos K _ (n - m)

@[mono] lemma cast_mono : monotone (coe : ℚ → K) := cast_strict_mono.monotone

/-- Coercion from `ℚ` as an order embedding. -/
@[simps] def cast_order_embedding : ℚ ↪o K := order_embedding.of_strict_mono coe cast_strict_mono

@[simp, norm_cast] theorem cast_le {m n : ℚ} : (m : K) ≤ n ↔ m ≤ n := cast_order_embedding.le_iff_le
@[simp, norm_cast] theorem cast_lt {m n : ℚ} : (m : K) < n ↔ m < n := cast_strict_mono.lt_iff_lt

@[simp] theorem cast_nonneg {n : ℚ} : 0 ≤ (n : K) ↔ 0 ≤ n := by norm_cast
@[simp] theorem cast_nonpos {n : ℚ} : (n : K) ≤ 0 ↔ n ≤ 0 := by norm_cast
@[simp] theorem cast_pos {n : ℚ} : (0 : K) < n ↔ 0 < n := by norm_cast
@[simp] theorem cast_lt_zero {n : ℚ} : (n : K) < 0 ↔ n < 0 := by norm_cast

@[simp, norm_cast] theorem cast_min {a b : ℚ} : (↑(min a b) : K) = min a b :=
(@cast_mono K _).map_min

@[simp, norm_cast] theorem cast_max {a b : ℚ} : (↑(max a b) : K) = max a b :=
(@cast_mono K _).map_max

@[simp, norm_cast] theorem cast_abs {q : ℚ} : ((|q| : ℚ) : K) = |q| := by simp [abs_eq_max_neg]

open set

@[simp] lemma preimage_cast_Icc (a b : ℚ) : coe ⁻¹' (Icc (a : K) b) = Icc a b := by { ext x, simp }
@[simp] lemma preimage_cast_Ico (a b : ℚ) : coe ⁻¹' (Ico (a : K) b) = Ico a b := by { ext x, simp }
@[simp] lemma preimage_cast_Ioc (a b : ℚ) : coe ⁻¹' (Ioc (a : K) b) = Ioc a b := by { ext x, simp }
@[simp]

end linear_ordered_field

@[norm_cast] theorem cast_id (n : ℚ) : (↑n : ℚ) = n := by rw [cast_def, num_div_denom]
@[simp] theorem cast_eq_id : (coe : ℚ → ℚ) = id := funext cast_id
@[simp] lemma cast_hom_rat : cast_hom ℚ = ring_hom.id ℚ := ring_hom.ext cast_id

end rat

open rat

@[simp] lemma map_rat_cast [division_ring α] [division_ring β] [ring_hom_class F α β]
  (f : F) (q : ℚ) : f q = q :=
by rw [cast_def, map_div₀, map_int_cast, map_nat_cast, cast_def]

@[simp] lemma eq_rat_cast {k} [division_ring k] [ring_hom_class F ℚ k] (f : F) (r : ℚ) : f r = r :=
by rw [← map_rat_cast f, rat.cast_id]

namespace monoid_with_zero_hom

variables {M₀ : Type*} [monoid_with_zero M₀] [monoid_with_zero_hom_class F ℚ M₀] {f g : F}
include M₀

/-- If `f` and `g` agree on the integers then they are equal `φ`. -/
theorem ext_rat' (h : ∀ m : ℤ, f m = g m) : f = g :=
fun_like.ext f g $ λ r, by rw [← r.num_div_denom, div_eq_mul_inv, map_mul, map_mul, h,
  ← int.cast_coe_nat, eq_on_inv₀ f g (h _)]

/-- If `f` and `g` agree on the integers then they are equal `φ`.

See note [partially-applied ext lemmas] for why `comp` is used here. -/
@[ext] theorem ext_rat {f g : ℚ →*₀ M₀}
  (h : f.comp (int.cast_ring_hom ℚ : ℤ →*₀ ℚ) = g.comp (int.cast_ring_hom ℚ)) : f = g :=
ext_rat' $ congr_fun h

/-- Positive integer values of a morphism `φ` and its value on `-1` completely determine `φ`. -/
theorem ext_rat_on_pnat
  (same_on_neg_one : f (-1) = g (-1)) (same_on_pnat : ∀ n : ℕ, 0 < n → f n = g n) : f = g :=
ext_rat' $ fun_like.congr_fun $ show (f : ℚ →*₀ M₀).comp (int.cast_ring_hom ℚ : ℤ →*₀ ℚ) =
  (g : ℚ →*₀ M₀).comp (int.cast_ring_hom ℚ : ℤ →*₀ ℚ),
  from ext_int' (by simpa) (by simpa)

end monoid_with_zero_hom

/-- Any two ring homomorphisms from `ℚ` to a semiring are equal. If the codomain is a division ring,
then this lemma follows from `eq_rat_cast`. -/
lemma ring_hom.ext_rat {R : Type*} [semiring R] [ring_hom_class F ℚ R] (f g : F) : f = g :=
monoid_with_zero_hom.ext_rat' $ ring_hom.congr_fun $
  ((f : ℚ →+* R).comp (int.cast_ring_hom ℚ)).ext_int ((g : ℚ →+* R).comp (int.cast_ring_hom ℚ))

instance rat.subsingleton_ring_hom {R : Type*} [semiring R] : subsingleton (ℚ →+* R) :=
⟨ring_hom.ext_rat⟩

section smul

namespace rat

variables {K : Type*} [division_ring K]

@[priority 100]
instance distrib_smul  : distrib_smul ℚ K :=
{ smul := (•),
  smul_zero := λ a, by rw [smul_def, mul_zero],
  smul_add := λ a x y, by simp only [smul_def, mul_add, cast_add] }

instance is_scalar_tower_right : is_scalar_tower ℚ K K :=
⟨λ a x y, by simp only [smul_def, smul_eq_mul, mul_assoc]⟩

end rat

end smul


import classes.unrestricted.basics.lifting
import utilities.list_utils

variables {T : Type}

protected def union_grammar (g₁ g₂ : grammar T) : grammar T :=
grammar.mk (option (g₁.nt ⊕ g₂.nt)) none (
  ⟨ [], none, [], [symbol.nonterminal (some (sum.inl (g₁.initial)))] ⟩ :: (
  ⟨ [], none, [], [symbol.nonterminal (some (sum.inr (g₂.initial)))] ⟩ :: (
  (list.map (lift_rule_ (some ∘ sum.inl)) g₁.rules) ++
  (list.map (lift_rule_ (some ∘ sum.inr)) g₂.rules)
)))

variables {g₁ g₂ : grammar T}

private def oN₁_of_N : (union_grammar g₁ g₂).nt → (option g₁.nt)
| none               := none
| (some (sum.inl n)) := some n
| (some (sum.inr _)) := none

private def oN₂_of_N : (union_grammar g₁ g₂).nt → (option g₂.nt)
| none               := none
| (some (sum.inl _)) := none
| (some (sum.inr n)) := some n

private def lg₁ : lifted_grammar_ T :=
lifted_grammar_.mk g₁ (union_grammar g₁ g₂) (option.some ∘ sum.inl) oN₁_of_N (by
{
  intros x y h,
  apply sum.inl_injective,
  apply option.some_injective,
  exact h,
}
) (by
{
  intros x y hyp,
  cases x,
  {
    right,
    refl,
  },
  cases x, swap,
  {
    right,
    refl,
  },
  cases y,
  {
    rw hyp,
    right,
    refl,
  },
  cases y, swap,
  {
    tauto,
  },
  left,
  simp only [oN₁_of_N] at hyp,
  apply congr_arg,
  apply congr_arg,
  exact hyp,
}
) (by
{
  intro,
  refl,
}
) (by
{
  intros r h,
  apply list.mem_cons_of_mem,
  apply list.mem_cons_of_mem,
  apply list.mem_append_left,
  rw list.mem_map,
  use r,
  split,
  {
    exact h,
  },
  refl,
}
) (by
{
  rintros r ⟨rin, n₀, rnt⟩,
  cases rin,
  {
    exfalso,
    rw rin at rnt,
    exact option.no_confusion rnt,
  },
  cases rin,
  {
    exfalso,
    rw rin at rnt,
    exact option.no_confusion rnt,
  },
  change r ∈ (
      list.map (lift_rule_ (some ∘ sum.inl)) g₁.rules ++
      list.map (lift_rule_ (some ∘ sum.inr)) g₂.rules
    ) at rin,
  rw list.mem_append at rin,
  cases rin,
  {
    rw list.mem_map at rin,
    rcases rin with ⟨r₁, r₁_in, r₁_lift⟩,
    use r₁,
    split,
    {
      exact r₁_in,
    },
    exact r₁_lift,
  },
  {
    exfalso,
    rw list.mem_map at rin,
    rcases rin with ⟨r₂, r₂_in, r₂_lift⟩,
    rw ←r₂_lift at rnt,
    unfold lift_rule_ at rnt,
    dsimp only at rnt,
    have rnti := option.some.inj rnt,
    exact sum.no_confusion rnti,
  },
})

private def lg₂ : lifted_grammar_ T :=
lifted_grammar_.mk g₂ (union_grammar g₁ g₂) (option.some ∘ sum.inr) oN₂_of_N (by
{
  intros x y h,
  apply sum.inr_injective,
  apply option.some_injective,
  exact h,
}
) (by
{
  intros x y hyp,
  cases x,
  {
    right,
    refl,
  },
  cases x,
  {
    right,
    refl,
  },
  cases y,
  {
    right,
    rw hyp,
    refl,
  },
  cases y,
  {
    tauto,
  },
  left,
  simp only [oN₂_of_N] at hyp,
  apply congr_arg,
  apply congr_arg,
  exact hyp,
}
) (by
{
  intro,
  refl,
}
) (by
{
  intros r h,
  apply list.mem_cons_of_mem,
  apply list.mem_cons_of_mem,
  apply list.mem_append_right,
  rw list.mem_map,
  use r,
  split,
  {
    exact h,
  },
  refl,
}
) (by
{
  rintros r ⟨rin, n₀, rnt⟩,
  cases rin,
  {
    exfalso,
    rw rin at rnt,
    exact option.no_confusion rnt,
  },
  cases rin,
  {
    exfalso,
    rw rin at rnt,
    exact option.no_confusion rnt,
  },
  change r ∈ (
      list.map (lift_rule_ (some ∘ sum.inl)) g₁.rules ++
      list.map (lift_rule_ (some ∘ sum.inr)) g₂.rules
    ) at rin,
  rw list.mem_append at rin,
  cases rin,
  {
    exfalso,
    rw list.mem_map at rin,
    rcases rin with ⟨r₁, r₁_in, r₁_lift⟩,
    rw ←r₁_lift at rnt,
    unfold lift_rule_ at rnt,
    dsimp only at rnt,
    have rnti := option.some.inj rnt,
    exact sum.no_confusion rnti,
  },
  {
    rw list.mem_map at rin,
    rcases rin with ⟨r₂, r₂_in, r₂_lift⟩,
    use r₂,
    split,
    {
      exact r₂_in,
    },
    exact r₂_lift,
  },
})

protected lemma in_L₁_or_L₂_of_in_union {w : list T} (ass : w ∈ grammar_language (union_grammar g₁ g₂)) :
  w ∈ grammar_language g₁  ∨  w ∈ grammar_language g₂  :=
begin
  unfold grammar_language at ass ⊢,
  rw set.mem_set_of_eq at ⊢ ass,
  rw set.mem_set_of_eq at ⊢,
  unfold grammar_generates at ass ⊢,
  have hyp := grammar_tran_or_id_of_deri ass,
  clear ass,
  cases hyp,
  {
    exfalso,
    have zeroth := congr_fun (congr_arg list.nth hyp) 0,
    cases w,
    {
      exact option.no_confusion zeroth,
    },
    {
      rw [list.nth, list.map_cons, list.nth] at zeroth,
      have nt_eq_ter := option.some.inj zeroth,
      exact symbol.no_confusion nt_eq_ter,
    },
  },
  rcases hyp with ⟨i, ⟨r, rin, u, v, bef, aft⟩, deri⟩,

  have uv_nil :  u = []  ∧  v = [],
  {
    have bef_len := congr_arg list.length bef,
    clear_except bef_len,
    rw list.length_singleton at bef_len,
    repeat {
      rw list.length_append at bef_len
    },
    rw list.length_singleton at bef_len,
    split;
    {
      rw ←list.length_eq_zero,
      linarith,
    },
  },
  rw [uv_nil.1, list.nil_append, uv_nil.2, list.append_nil] at bef aft,

  have same_nt : (union_grammar g₁ g₂).initial = r.input_N,
  {
    clear_except bef,
    have elemeq : [symbol.nonterminal (union_grammar g₁ g₂).initial] = [symbol.nonterminal r.input_N],
    {
      have bef_len := congr_arg list.length bef,
      rw [list.length_append_append, list.length_singleton, list.length_singleton] at bef_len,
      have rl_first : r.input_L.length = 0,
      {
        clear_except bef_len,
        linarith,
      },
      have rl_third : r.input_R.length = 0,
      {
        clear_except bef_len,
        linarith,
      },
      rw list.length_eq_zero at rl_first rl_third,
      rw [rl_first, rl_third] at bef,
      exact bef,
    },
    exact symbol.nonterminal.inj (list.head_eq_of_cons_eq elemeq),
  },

  cases rin,
  {
    rw rin at aft,
    dsimp only at aft,
    rw aft at deri,
    left,

    have sinked := sink_deri_ lg₁ deri,
    clear_except sinked,
    specialize sinked (by {
      unfold good_string_,
      simp only [list.mem_singleton, forall_eq],
      use g₁.initial,
      refl,
    }),
    convert sinked,

    unfold sink_string_,
    rw list.filter_map_map,
    convert_to list.map symbol.terminal w = list.filter_map (option.some ∘ symbol.terminal) w,
    rw ←list.filter_map_map,
    rw list.filter_map_some,
  },
  cases rin,
  {
    rw rin at aft,
    dsimp only at aft,
    rw aft at deri,
    right,

    have sinked := sink_deri_ lg₂ deri,
    clear_except sinked,
    specialize sinked (by {
      unfold good_string_,
      simp only [list.mem_singleton, forall_eq],
      use g₂.initial,
      refl,
    }),
    convert sinked,

    unfold sink_string_,
    rw list.filter_map_map,
    convert_to list.map symbol.terminal w = list.filter_map (option.some ∘ symbol.terminal) w,
    rw ←list.filter_map_map,
    rw list.filter_map_some,
  },
  exfalso,
  clear_except rin bef,

  change r ∈ (
      list.map (lift_rule_ (some ∘ sum.inl)) g₁.rules ++
      list.map (lift_rule_ (some ∘ sum.inr)) g₂.rules
    ) at rin,
  rw list.mem_append at rin,
  cases rin;
  rw list.mem_map at rin;
  rcases rin with ⟨ror, rri, rli⟩;
  rw ←rli at bef;
  clear_except bef,

  {
    have inb := congr_arg
      (λ z, symbol.nonterminal (lift_rule_ (option.some ∘ sum.inl) ror).input_N ∈ z)
      bef,
    apply false_of_true_eq_false,
    convert inb.symm,
    {
      simp,
    },
    rw list.mem_singleton,
    rw symbol.nonterminal.inj_eq,
    change false = (_ = option.none),
    unfold lift_rule_,
    clear_except,
    norm_num,
  },
  {
    have inb := congr_arg
      (λ z, symbol.nonterminal (lift_rule_ (option.some ∘ sum.inr) ror).input_N ∈ z)
      bef,
    apply false_of_true_eq_false,
    convert inb.symm,
    {
      simp,
    },
    rw list.mem_singleton,
    rw symbol.nonterminal.inj_eq,
    change false = (_ = option.none),
    unfold lift_rule_,
    clear_except,
    norm_num,
  },
end

protected lemma in_union_of_in_L₁ {w : list T} (ass : w ∈ grammar_language g₁) :
  w ∈ grammar_language (union_grammar g₁ g₂) :=
begin
  unfold grammar_language at ass ⊢,
  rw set.mem_set_of_eq at ass ⊢,
  unfold grammar_generates at ass ⊢,
  apply grammar_deri_of_tran_deri,
  {
    use ⟨ [], none, [], [symbol.nonterminal (some (sum.inl (g₁.initial)))] ⟩,
    split,
    {
      apply list.mem_cons_self,
    },
    use [[], []],
    split;
    refl,
  },
  dsimp only,
  rw [list.nil_append, list.append_nil],
  have lifted := lift_deri_ (@lg₁ _ _ g₂) ass,
  change
    grammar_derives lg₁.g
      (lift_string_ lg₁.lift_nt [symbol.nonterminal g₁.initial])
      (list.map symbol.terminal w),
  have equiv_out : (lift_string_ lg₁.lift_nt (list.map symbol.terminal w)) = (list.map symbol.terminal w),
  {
    unfold lift_string_,
    rw list.map_map,
    refl,
  },
  rw equiv_out at lifted,
  exact lifted,
end

protected lemma in_union_of_in_L₂ {w : list T} (ass : w ∈ grammar_language g₂) :
  w ∈ grammar_language (union_grammar g₁ g₂) :=
begin
  unfold grammar_language at ass ⊢,
  rw set.mem_set_of_eq at ass ⊢,
  unfold grammar_generates at ass ⊢,
  apply grammar_deri_of_tran_deri,
  {
    use ⟨ [], none, [], [symbol.nonterminal (some (sum.inr (g₂.initial)))] ⟩,
    split,
    {
      apply list.mem_cons_of_mem,
      apply list.mem_cons_self,
    },
    use [[], []],
    split;
    refl,
  },
  dsimp only,
  rw [list.nil_append, list.append_nil],
  have lifted := lift_deri_ (@lg₂ _ g₁ _) ass,
  change
    grammar_derives lg₂.g
      (lift_string_ lg₂.lift_nt [symbol.nonterminal g₂.initial])
      (list.map symbol.terminal w),
  have equiv_out : (lift_string_ lg₂.lift_nt (list.map symbol.terminal w)) = (list.map symbol.terminal w),
  {
    unfold lift_string_,
    rw list.map_map,
    refl,
  },
  rw equiv_out at lifted,
  exact lifted,
end

/-- The class of recursively-enumerable languages is closed under union. -/
theorem RE_of_RE_u_RE (L₁ : language T) (L₂ : language T) :
  is_RE L₁  ∧  is_RE L₂   →   is_RE (L₁ + L₂)   :=
begin
  rintro ⟨⟨g₁, eq_L₁⟩, ⟨g₂, eq_L₂⟩⟩,

  unfold is_RE,
  use union_grammar g₁ g₂,

  apply set.eq_of_subset_of_subset,
  {
    intros w ass,
    rw language.mem_add,
    rw [←eq_L₁, ←eq_L₂],
    exact in_L₁_or_L₂_of_in_union ass,
  },
  {
    intros w ass,
    cases ass with case₁ case₂,
    {
      rw ←eq_L₁ at case₁,
      exact in_union_of_in_L₁ case₁,
    },
    {
      rw ←eq_L₂ at case₂,
      exact in_union_of_in_L₂ case₂,
    },
  },
end


theorem ex1 (p q r : Prop) (h1 : p ∨ q) (h2 : p → q) : q :=
  have : q := by -- Error here
    skip
  by skip -- Error here
     skip

theorem ex2 (p q r : Prop) (h1 : p ∨ q) (h2 : p → q) : q :=
  have : q := by {
    skip
  } -- Error here
  by skip -- Error here
     skip

theorem ex3 (p q r : Prop) (h1 : p ∨ q) (h2 : p → q) : q := by
  cases h1
  { skip
    skip } -- Error here
  { skip
    skip } -- Error here

theorem ex4 (p q r : Prop) (h1 : p ∨ q) (h2 : p → q) : q := by
  first | done | apply ex3 p q r h1 h2

theorem ex5 (p q r : Prop) (h1 : p ∨ q) (h2 : p → q) : q := by
  cases h1
  · skip  -- Error here
    skip
  · skip  -- Error here
    skip


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.preadditive.default
import category_theory.preadditive.single_obj
import category_theory.preadditive.additive_functor
import category_theory.limits.shapes.biproducts
import category_theory.Fintype
import algebra.big_operators.basic
import data.matrix.notation

/-!
# Matrices over a category.

When `C` is a preadditive category, `Mat_ C` is the preadditive category
whose objects are finite tuples of objects in `C`, and
whose morphisms are matrices of morphisms from `C`.

There is a functor `Mat_.embedding : C ⥤ Mat_ C` sending morphisms to one-by-one matrices.

`Mat_ C` has finite biproducts.

## The additive envelope

We show that this construction is the "additive envelope" of `C`,
in the sense that any additive functor `F : C ⥤ D` to a category `D` with biproducts
lifts to a functor `Mat_.lift F : Mat_ C ⥤ D`,
Moreover, this functor is unique (up to natural isomorphisms) amongst functors `L : Mat_ C ⥤ D`
such that `embedding C ⋙ L ≅ F`.
(As we don't have 2-category theory, we can't explicitly state that `Mat_ C` is
the initial object in the 2-category of categories under `C` which have biproducts.)

As a consequence, when `C` already has finite biproducts we have `Mat_ C ≌ C`.

## Future work

We should provide a more convenient `Mat R`, when `R` is a ring,
as a category with objects `n : FinType`,
and whose morphisms are matrices with components in `R`.

Ideally this would conveniently interact with both `Mat_` and `matrix`.

-/

open category_theory category_theory.preadditive
open_locale big_operators
noncomputable theory

namespace category_theory

universes w v₁ v₂ u₁ u₂
variables (C : Type u₁) [category.{v₁} C] [preadditive C]

/--
An object in `Mat_ C` is a finite tuple of objects in `C`.
-/
structure Mat_ : Type (max (v₁+1) u₁) :=
(ι : Type v₁)
[F : fintype ι]
[D : decidable_eq ι]
(X : ι → C)

attribute [instance] Mat_.F Mat_.D

namespace Mat_

variables {C}

/-- A morphism in `Mat_ C` is a dependently typed matrix of morphisms. -/
@[nolint has_inhabited_instance]
def hom (M N : Mat_ C) : Type v₁ := dmatrix M.ι N.ι (λ i j, M.X i ⟶ N.X j)

namespace hom

/-- The identity matrix consists of identity morphisms on the diagonal, and zeros elsewhere. -/
def id (M : Mat_ C) : hom M M := λ i j, if h : i = j then eq_to_hom (congr_arg M.X h) else 0

/-- Composition of matrices using matrix multiplication. -/
def comp {M N K : Mat_ C} (f : hom M N) (g : hom N K) : hom M K :=
λ i k, ∑ j : N.ι, f i j ≫ g j k

end hom

section
local attribute [simp] hom.id hom.comp

instance : category.{v₁} (Mat_ C) :=
{ hom := hom,
  id := hom.id,
  comp := λ M N K f g, f.comp g,
  id_comp' := λ M N f, by simp [dite_comp],
  comp_id' := λ M N f, by simp [comp_dite],
  assoc' := λ M N K L f g h, begin
    ext i k,
    simp_rw [hom.comp, sum_comp, comp_sum, category.assoc],
    rw finset.sum_comm,
  end, }.

lemma id_def (M : Mat_ C) :
  (𝟙 M : hom M M) = λ i j, if h : i = j then eq_to_hom (congr_arg M.X h) else 0 :=
rfl

lemma id_apply (M : Mat_ C) (i j : M.ι) :
  (𝟙 M : hom M M) i j = if h : i = j then eq_to_hom (congr_arg M.X h) else 0 :=
rfl

@[simp] lemma id_apply_self (M : Mat_ C) (i : M.ι) :
  (𝟙 M : hom M M) i i = 𝟙 _ :=
by simp [id_apply]

@[simp] lemma id_apply_of_ne (M : Mat_ C) (i j : M.ι) (h : i ≠ j) :
  (𝟙 M : hom M M) i j = 0 :=
by simp [id_apply, h]

lemma comp_def {M N K : Mat_ C} (f : M ⟶ N) (g : N ⟶ K) :
  (f ≫ g) = λ i k, ∑ j : N.ι, f i j ≫ g j k := rfl

@[simp] lemma comp_apply {M N K : Mat_ C} (f : M ⟶ N) (g : N ⟶ K) (i k) :
  (f ≫ g) i k = ∑ j : N.ι, f i j ≫ g j k := rfl

instance (M N : Mat_ C) : inhabited (M ⟶ N) := ⟨λ i j, (0 : M.X i ⟶ N.X j)⟩

end

instance : preadditive (Mat_ C) :=
{ hom_group := λ M N, by { change add_comm_group (dmatrix M.ι N.ι _), apply_instance, },
  add_comp' := λ M N K f f' g, by { ext, simp [finset.sum_add_distrib], },
  comp_add' := λ M N K f g g', by { ext, simp [finset.sum_add_distrib], }, }

@[simp] lemma add_apply {M N : Mat_ C} (f g : M ⟶ N) (i j) : (f + g) i j = f i j + g i j := rfl

open category_theory.limits

/--
We now prove that `Mat_ C` has finite biproducts.

Be warned, however, that `Mat_ C` is not necessarily Krull-Schmidt,
and so the internal indexing of a biproduct may have nothing to do with the external indexing,
even though the construction we give uses a sigma type.
See however `iso_biproduct_embedding`.
-/
instance has_finite_biproducts : has_finite_biproducts (Mat_ C) :=
{ has_biproducts_of_shape := λ J 𝒟 ℱ, by exactI
  { has_biproduct := λ f,
    has_biproduct_of_total
    { X := ⟨Σ j : J, (f j).ι, λ p, (f p.1).X p.2⟩,
      π := λ j x y,
      begin
        dsimp at x ⊢,
        refine if h : x.1 = j then _ else 0,
        refine if h' : (@eq.rec J x.1 (λ j, (f j).ι) x.2 _ h) = y then _ else 0,
        apply eq_to_hom,
        substs h h', -- Notice we were careful not to use `subst` until we had a goal in `Prop`.
      end,
      ι := λ j x y,
      begin
        dsimp at y ⊢,
        refine if h : y.1 = j then _ else 0,
        refine if h' : (@eq.rec J y.1 (λ j, (f j).ι) y.2 _ h) = x then _ else 0,
        apply eq_to_hom,
        substs h h',
      end,
      ι_π := λ j j',
      begin
        ext x y,
        dsimp,
        simp_rw [dite_comp, comp_dite],
        simp only [if_t_t, dite_eq_ite, dif_ctx_congr, limits.comp_zero, limits.zero_comp,
          eq_to_hom_trans, finset.sum_congr],
        erw finset.sum_sigma,
        dsimp,
        simp only [if_congr, if_true, dif_ctx_congr, finset.sum_dite_irrel, finset.mem_univ,
          finset.sum_const_zero, finset.sum_congr, finset.sum_dite_eq'],
        split_ifs with h h',
        { substs h h', simp, },
        { subst h, simp at h', simp [h'], },
        { refl, },
      end, }
    begin
      funext i₁,
      dsimp at i₁ ⊢,
      rcases i₁ with ⟨j₁, i₁⟩,
      -- I'm not sure why we can't just `simp` by `finset.sum_apply`: something doesn't quite match
      convert finset.sum_apply _ _ _,
      { refl, },
      { apply heq_of_eq,
        symmetry,
        funext i₂,
        rcases i₂ with ⟨j₂, i₂⟩,
        simp only [comp_apply, dite_comp, comp_dite,
          if_t_t, dite_eq_ite, if_congr, if_true, dif_ctx_congr,
          finset.sum_dite_irrel, finset.sum_dite_eq, finset.mem_univ, finset.sum_const_zero,
          finset.sum_congr, finset.sum_dite_eq, finset.sum_apply,
          limits.comp_zero, limits.zero_comp, eq_to_hom_trans, Mat_.id_apply],
        by_cases h : j₁ = j₂,
        { subst h, simp, },
        { simp [h], }, },
    end }}.

end Mat_

namespace functor
variables {C} {D : Type*} [category.{v₁} D] [preadditive D]

local attribute [simp] Mat_.id_apply

/--
A functor induces a functor of matrix categories.
-/
@[simps]
def map_Mat_ (F : C ⥤ D) [functor.additive F] : Mat_ C ⥤ Mat_ D :=
{ obj := λ M, ⟨M.ι, λ i, F.obj (M.X i)⟩,
  map := λ M N f i j, F.map (f i j),
  map_comp' := λ M N K f g, by { ext i k, simp,}, }

/--
The identity functor induces the identity functor on matrix categories.
-/
@[simps]
def map_Mat_id : (𝟭 C).map_Mat_ ≅ 𝟭 (Mat_ C) :=
nat_iso.of_components (λ M, eq_to_iso (by { cases M, refl, }))
(λ M N f, begin
  ext i j,
  cases M, cases N,
  simp [comp_dite, dite_comp],
end)

/--
Composite functors induce composite functors on matrix categories.
-/
@[simps]
def map_Mat_comp {E : Type*} [category.{v₁} E] [preadditive E]
  (F : C ⥤ D) [functor.additive F] (G : D ⥤ E) [functor.additive G] :
  (F ⋙ G).map_Mat_ ≅ F.map_Mat_ ⋙ G.map_Mat_ :=
nat_iso.of_components (λ M, eq_to_iso (by { cases M, refl, }))
(λ M N f, begin
  ext i j,
  cases M, cases N,
  simp [comp_dite, dite_comp],
end)

end functor

namespace Mat_

variables (C)

/-- The embedding of `C` into `Mat_ C` as one-by-one matrices.
(We index the summands by `punit`.) -/
@[simps]
def embedding : C ⥤ Mat_ C :=
{ obj := λ X, ⟨punit, λ _, X⟩,
  map := λ X Y f, λ _ _, f,
  map_id' := λ X, by { ext ⟨⟩ ⟨⟩, simp, },
  map_comp' := λ X Y Z f g, by { ext ⟨⟩ ⟨⟩, simp, }, }

namespace embedding

instance : faithful (embedding C) :=
{ map_injective' := λ X Y f g h, congr_fun (congr_fun h punit.star) punit.star, }

instance : full (embedding C) :=
{ preimage := λ X Y f, f punit.star punit.star, }

instance : functor.additive (embedding C) := {}

end embedding

instance [inhabited C] : inhabited (Mat_ C) := ⟨(embedding C).obj (default C)⟩

open category_theory.limits

variables {C}

/--
Every object in `Mat_ C` is isomorphic to the biproduct of its summands.
-/
@[simps]
def iso_biproduct_embedding (M : Mat_ C) : M ≅ ⨁ (λ i, (embedding C).obj (M.X i)) :=
{ hom := biproduct.lift (λ i j k, if h : j = i then eq_to_hom (congr_arg M.X h) else 0),
  inv := biproduct.desc (λ i j k, if h : i = k then eq_to_hom (congr_arg M.X h) else 0),
  hom_inv_id' :=
  begin
    simp only [biproduct.lift_desc],
    funext i,
    dsimp,
    convert finset.sum_apply _ _ _,
    { dsimp, refl, },
    { apply heq_of_eq,
      symmetry,
      funext j,
      simp only [finset.sum_apply],
      dsimp,
      simp [dite_comp, comp_dite, Mat_.id_apply], }
  end,
  inv_hom_id' :=
  begin
    apply biproduct.hom_ext,
    intro i,
    apply biproduct.hom_ext',
    intro j,
    simp only [category.id_comp, category.assoc,
      biproduct.lift_π, biproduct.ι_desc_assoc, biproduct.ι_π],
    ext ⟨⟩ ⟨⟩,
    simp [dite_comp, comp_dite],
    split_ifs,
    { subst h, simp, },
    { simp [h], },
  end, }.

variables {D : Type u₁} [category.{v₁} D] [preadditive D]

/-- Every `M` is a direct sum of objects from `C`, and `F` preserves biproducts. -/
@[simps]
def additive_obj_iso_biproduct (F : Mat_ C ⥤ D) [functor.additive F] (M : Mat_ C) :
  F.obj M ≅ ⨁ (λ i, F.obj ((embedding C).obj (M.X i))) :=
(F.map_iso (iso_biproduct_embedding M)) ≪≫ (F.map_biproduct _)

variables [has_finite_biproducts D]

@[reassoc] lemma additive_obj_iso_biproduct_naturality (F : Mat_ C ⥤ D) [functor.additive F]
  {M N : Mat_ C} (f : M ⟶ N) :
  F.map f ≫ (additive_obj_iso_biproduct F N).hom =
    (additive_obj_iso_biproduct F M).hom ≫
      biproduct.matrix (λ i j, F.map ((embedding C).map (f i j))) :=
begin
  -- This is disappointingly tedious.
  ext,
  dsimp [embedding],
  simp only [←F.map_comp, biproduct.lift_π, biproduct.matrix_π, category.assoc],
  simp only [←F.map_comp, ←F.map_sum, biproduct.lift_desc, biproduct.lift_π_assoc, comp_sum],
  simp only [comp_def, comp_dite, comp_zero, finset.sum_dite_eq', finset.mem_univ, if_true],
  dsimp,
  simp only [finset.sum_singleton, dite_comp, zero_comp],
  congr,
  symmetry,
  convert finset.sum_fn _ _, -- It's hard to use this as a simp lemma!
  simp only [finset.sum_fn, finset.sum_dite_eq],
  ext,
  simp,
end

@[reassoc] lemma additive_obj_iso_biproduct_naturality' (F : Mat_ C ⥤ D) [functor.additive F]
  {M N : Mat_ C} (f : M ⟶ N) :
  (additive_obj_iso_biproduct F M).inv ≫ F.map f =
    biproduct.matrix (λ i j, F.map ((embedding C).map (f i j)) : _) ≫
      (additive_obj_iso_biproduct F N).inv :=
by rw [iso.inv_comp_eq, ←category.assoc, iso.eq_comp_inv, additive_obj_iso_biproduct_naturality]

/-- Any additive functor `C ⥤ D` to a category `D` with finite biproducts extends to
a functor `Mat_ C ⥤ D`. -/
@[simps]
def lift (F : C ⥤ D) [functor.additive F] : Mat_ C ⥤ D :=
{ obj := λ X, ⨁ (λ i, F.obj (X.X i)),
  map := λ X Y f, biproduct.matrix (λ i j, F.map (f i j)),
  map_id' := λ X, begin
    ext i j,
    by_cases h : i = j,
    { subst h, simp, },
    { simp [h, Mat_.id_apply], },
  end,
  map_comp' := λ X Y Z f g, by { ext i j, simp, }, }.

instance lift_additive (F : C ⥤ D) [functor.additive F] : functor.additive (lift F) := {}

/-- An additive functor `C ⥤ D` factors through its lift to `Mat_ C ⥤ D`. -/
@[simps]
def embedding_lift_iso (F : C ⥤ D) [functor.additive F] : embedding C ⋙ lift F ≅ F :=
nat_iso.of_components (λ X,
  { hom := biproduct.desc (λ P, 𝟙 (F.obj X)),
    inv := biproduct.lift (λ P, 𝟙 (F.obj X)), })
(λ X Y f, begin
  dsimp,
  ext,
  simp only [category.id_comp, biproduct.ι_desc_assoc],
  erw biproduct.ι_matrix_assoc, -- Not sure why this doesn't fire via `simp`.
  simp,
end).

/--
`Mat_.lift F` is the unique additive functor `L : Mat_ C ⥤ D` such that `F ≅ embedding C ⋙ L`.
-/
def lift_unique (F : C ⥤ D) [functor.additive F] (L : Mat_ C ⥤ D) [functor.additive L]
  (α : embedding C ⋙ L ≅ F) :
  L ≅ lift F :=
nat_iso.of_components
  (λ M, (additive_obj_iso_biproduct L M) ≪≫
    (biproduct.map_iso (λ i, α.app (M.X i))) ≪≫
    (biproduct.map_iso (λ i, (embedding_lift_iso F).symm.app (M.X i))) ≪≫
    (additive_obj_iso_biproduct (lift F) M).symm)
(λ M N f, begin
  dsimp only [iso.trans_hom, iso.symm_hom, biproduct.map_iso_hom],
  simp only [additive_obj_iso_biproduct_naturality_assoc],
  simp only [biproduct.matrix_map_assoc, category.assoc],
  simp only [additive_obj_iso_biproduct_naturality'],
  simp only [biproduct.map_matrix_assoc, category.assoc],
  congr,
  ext j k ⟨⟩,
  dsimp, simp,
  convert α.hom.naturality (f j k),
  erw [biproduct.matrix_π],
  simp,
end).

-- TODO is there some uniqueness statement for the natural isomorphism in `lift_unique`?

/-- Two additive functors `Mat_ C ⥤ D` are naturally isomorphic if
their precompositions with `embedding C` are naturally isomorphic as functors `C ⥤ D`. -/
@[ext]
def ext {F G : Mat_ C ⥤ D} [functor.additive F] [functor.additive G]
  (α : embedding C ⋙ F ≅ embedding C ⋙ G) : F ≅ G :=
(lift_unique (embedding C ⋙ G) _ α) ≪≫ (lift_unique _ _ (iso.refl _)).symm

/--
Natural isomorphism needed in the construction of `equivalence_self_of_has_finite_biproducts`.
-/
def equivalence_self_of_has_finite_biproducts_aux [has_finite_biproducts C] :
  embedding C ⋙ 𝟭 (Mat_ C) ≅ embedding C ⋙ lift (𝟭 C) ⋙ embedding C :=
functor.right_unitor _ ≪≫
  (functor.left_unitor _).symm ≪≫
  (iso_whisker_right (embedding_lift_iso _).symm _) ≪≫
  functor.associator _ _ _

/--
A preadditive category that already has finite biproducts is equivalent to its additive envelope.

Note that we only prove this for a large category;
otherwise there are universe issues that I haven't attempted to sort out.
-/
def equivalence_self_of_has_finite_biproducts
  (C : Type (u₁+1)) [large_category C] [preadditive C] [has_finite_biproducts C] :
  Mat_ C ≌ C :=
equivalence.mk -- I suspect this is already an adjoint equivalence, but it seems painful to verify.
  (lift (𝟭 C))
  (embedding C)
  (ext equivalence_self_of_has_finite_biproducts_aux)
  (embedding_lift_iso (𝟭 C))

@[simp] lemma equivalence_self_of_has_finite_biproducts_functor
  {C : Type (u₁+1)} [large_category C] [preadditive C] [has_finite_biproducts C] :
  (equivalence_self_of_has_finite_biproducts C).functor = lift (𝟭 C) :=
rfl

@[simp] lemma equivalence_self_of_has_finite_biproducts_inverse
  {C : Type (u₁+1)} [large_category C] [preadditive C] [has_finite_biproducts C] :
  (equivalence_self_of_has_finite_biproducts C).inverse = embedding C :=
rfl

end Mat_

end category_theory


/-
  Specifications file for signature_recover_public_key_spec.cairo

  Do not modify the constant definitions, structure definitions, or automatic specifications.
  Do not change the name or arguments of the user specifications and soundness theorems.

  You may freely move the definitions around in the file.
  You may add definitions and theorems wherever you wish in this file.
-/
import starkware.cairo.lean.semantics.soundness.prelude
import starkware.cairo.common.cairo_secp.bigint_spec
import starkware.cairo.common.cairo_secp.ec_spec
import starkware.cairo.common.cairo_secp.signature_spec
import starkware.cairo.common.cairo_secp.field_spec
import starkware.cairo.common.math_spec

open starkware.cairo.common.cairo_secp.bigint
open starkware.cairo.common.cairo_secp.ec
open starkware.cairo.common.cairo_secp.signature
open starkware.cairo.common.cairo_secp.field
open starkware.cairo.common.math
namespace starkware.cairo.common.cairo_secp.verification.signature_recover_public_key

variables {F : Type} [field F] [decidable_eq F] [prelude_hyps F]

-- End of automatically generated prelude.

/-
-- Function: call_recover_public_key
-/

/- call_recover_public_key autogenerated specification -/

-- Do not change this definition.
def auto_spec_call_recover_public_key (mem : F → F) (κ : ℕ) (range_check_ptr : F) (msg_hash r s : BigInt3 F) (v ρ_range_check_ptr : F) (ρ_public_key_point : EcPoint F) : Prop :=
  ∃ (κ₁ : ℕ), spec_recover_public_key mem κ₁ range_check_ptr msg_hash r s v ρ_range_check_ptr ρ_public_key_point ∧
  κ₁ + 13 ≤ κ

-- You may change anything in this definition except the name and arguments.
def spec_call_recover_public_key (mem : F → F) (κ : ℕ) (range_check_ptr : F) (msg_hash r s : BigInt3 F) (v ρ_range_check_ptr : F) (ρ_public_key_point : EcPoint F) : Prop :=
  auto_spec_call_recover_public_key mem κ range_check_ptr msg_hash r s v ρ_range_check_ptr ρ_public_key_point

/- call_recover_public_key soundness theorem -/

-- Do not change the statement of this theorem. You may change the proof.
theorem sound_call_recover_public_key
    {mem : F → F}
    (κ : ℕ)
    (range_check_ptr : F) (msg_hash r s : BigInt3 F) (v ρ_range_check_ptr : F) (ρ_public_key_point : EcPoint F)
    (h_auto : auto_spec_call_recover_public_key mem κ range_check_ptr msg_hash r s v ρ_range_check_ptr ρ_public_key_point) :
  spec_call_recover_public_key mem κ range_check_ptr msg_hash r s v ρ_range_check_ptr ρ_public_key_point :=
begin
  exact h_auto
end

end starkware.cairo.common.cairo_secp.verification.signature_recover_public_key


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import meta.univs
import tactic.lint
import tactic.ext
import logic.function.basic

/-!
# Sigma types

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This file proves basic results about sigma types.

A sigma type is a dependent pair type. Like `α × β` but where the type of the second component
depends on the first component. This can be seen as a generalization of the sum type `α ⊕ β`:
* `α ⊕ β` is made of stuff which is either of type `α` or `β`.
* Given `α : ι → Type*`, `sigma α` is made of stuff which is of type `α i` for some `i : ι`. One
  effectively recovers a type isomorphic to `α ⊕ β` by taking a `ι` with exactly two elements. See
  `equiv.sum_equiv_sigma_bool`.

`Σ x, A x` is notation for `sigma A` (note the difference with the big operator `∑`).
`Σ x y z ..., A x y z ...` is notation for `Σ x, Σ y, Σ z, ..., A x y z ...`. Here we have
`α : Type*`, `β : α → Type*`, `γ : Π a : α, β a → Type*`, ...,
`A : Π (a : α) (b : β a) (c : γ a b) ..., Type*`  with `x : α` `y : β x`, `z : γ x y`, ...

## Notes

The definition of `sigma` takes values in `Type*`. This effectively forbids `Prop`- valued sigma
types. To that effect, we have `psigma`, which takes value in `Sort*` and carries a more complicated
universe signature in consequence.
-/

section sigma
variables {α α₁ α₂ : Type*} {β : α → Type*} {β₁ : α₁ → Type*} {β₂ : α₂ → Type*}

namespace sigma

instance [inhabited α] [inhabited (β default)] : inhabited (sigma β) :=
⟨⟨default, default⟩⟩

instance [h₁ : decidable_eq α] [h₂ : ∀a, decidable_eq (β a)] : decidable_eq (sigma β)
| ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ := match a₁, b₁, a₂, b₂, h₁ a₁ a₂ with
  | _, b₁, _, b₂, is_true (eq.refl a) :=
    match b₁, b₂, h₂ a b₁ b₂ with
    | _, _, is_true (eq.refl b) := is_true rfl
    | b₁, b₂, is_false n := is_false (assume h, sigma.no_confusion h (λe₁ e₂, n $ eq_of_heq e₂))
    end
  | a₁, _, a₂, _, is_false n := is_false (assume h, sigma.no_confusion h (λe₁ e₂, n e₁))
  end

@[simp, nolint simp_nf] -- sometimes the built-in injectivity support does not work
theorem mk.inj_iff {a₁ a₂ : α} {b₁ : β a₁} {b₂ : β a₂} :
  sigma.mk a₁ b₁ = ⟨a₂, b₂⟩ ↔ (a₁ = a₂ ∧ b₁ == b₂) :=
by simp

@[simp] theorem eta : ∀ x : Σ a, β a, sigma.mk x.1 x.2 = x
| ⟨i, x⟩ := rfl

@[ext]
lemma ext {x₀ x₁ : sigma β} (h₀ : x₀.1 = x₁.1) (h₁ : x₀.2 == x₁.2) : x₀ = x₁ :=
by { cases x₀, cases x₁, cases h₀, cases h₁, refl }

lemma ext_iff {x₀ x₁ : sigma β} : x₀ = x₁ ↔ x₀.1 = x₁.1 ∧ x₀.2 == x₁.2 :=
by { cases x₀, cases x₁, exact sigma.mk.inj_iff }

/-- A specialized ext lemma for equality of sigma types over an indexed subtype. -/
@[ext]
lemma subtype_ext {β : Type*} {p : α → β → Prop} :
  ∀ {x₀ x₁ : Σ a, subtype (p a)}, x₀.fst = x₁.fst → (x₀.snd : β) = x₁.snd → x₀ = x₁
| ⟨a₀, b₀, hb₀⟩ ⟨a₁, b₁, hb₁⟩ rfl rfl := rfl

lemma subtype_ext_iff {β : Type*} {p : α → β → Prop} {x₀ x₁ : Σ a, subtype (p a)} :
  x₀ = x₁ ↔ x₀.fst = x₁.fst ∧ (x₀.snd : β) = x₁.snd :=
⟨λ h, h ▸ ⟨rfl, rfl⟩, λ ⟨h₁, h₂⟩, subtype_ext h₁ h₂⟩

@[simp] theorem «forall» {p : (Σ a, β a) → Prop} :
  (∀ x, p x) ↔ (∀ a b, p ⟨a, b⟩) :=
⟨assume h a b, h ⟨a, b⟩, assume h ⟨a, b⟩, h a b⟩

@[simp] theorem «exists» {p : (Σ a, β a) → Prop} :
  (∃ x, p x) ↔ (∃ a b, p ⟨a, b⟩) :=
⟨assume ⟨⟨a, b⟩, h⟩, ⟨a, b, h⟩, assume ⟨a, b, h⟩, ⟨⟨a, b⟩, h⟩⟩

/-- Map the left and right components of a sigma -/
def map (f₁ : α₁ → α₂) (f₂ : Πa, β₁ a → β₂ (f₁ a)) (x : sigma β₁) : sigma β₂ :=
⟨f₁ x.1, f₂ x.1 x.2⟩

end sigma

lemma sigma_mk_injective {i : α} : function.injective (@sigma.mk α β i)
| _ _ rfl := rfl

lemma function.injective.sigma_map {f₁ : α₁ → α₂} {f₂ : Πa, β₁ a → β₂ (f₁ a)}
  (h₁ : function.injective f₁) (h₂ : ∀ a, function.injective (f₂ a)) :
  function.injective (sigma.map f₁ f₂)
| ⟨i, x⟩ ⟨j, y⟩ h :=
begin
  obtain rfl : i = j, from h₁ (sigma.mk.inj_iff.mp h).1,
  obtain rfl : x = y, from h₂ i (sigma_mk_injective h),
  refl
end

lemma function.injective.of_sigma_map {f₁ : α₁ → α₂} {f₂ : Πa, β₁ a → β₂ (f₁ a)}
  (h : function.injective (sigma.map f₁ f₂)) (a : α₁) : function.injective (f₂ a) :=
λ x y hxy, sigma_mk_injective $ @h ⟨a, x⟩ ⟨a, y⟩ (sigma.ext rfl (heq_iff_eq.2 hxy))

lemma function.injective.sigma_map_iff {f₁ : α₁ → α₂} {f₂ : Πa, β₁ a → β₂ (f₁ a)}
  (h₁ : function.injective f₁) :
  function.injective (sigma.map f₁ f₂) ↔ ∀ a, function.injective (f₂ a) :=
⟨λ h, h.of_sigma_map, h₁.sigma_map⟩

lemma function.surjective.sigma_map {f₁ : α₁ → α₂} {f₂ : Πa, β₁ a → β₂ (f₁ a)}
  (h₁ : function.surjective f₁) (h₂ : ∀ a, function.surjective (f₂ a)) :
  function.surjective (sigma.map f₁ f₂) :=
begin
  simp only [function.surjective, sigma.forall, h₁.forall],
  exact λ i, (h₂ _).forall.2 (λ x, ⟨⟨i, x⟩, rfl⟩)
end

/-- Interpret a function on `Σ x : α, β x` as a dependent function with two arguments.

This also exists as an `equiv` as `equiv.Pi_curry γ`. -/
def sigma.curry {γ : Π a, β a → Type*} (f : Π x : sigma β, γ x.1 x.2) (x : α) (y : β x) : γ x y :=
f ⟨x,y⟩

/-- Interpret a dependent function with two arguments as a function on `Σ x : α, β x`.

This also exists as an `equiv` as `(equiv.Pi_curry γ).symm`. -/
def sigma.uncurry {γ : Π a, β a → Type*} (f : Π x (y : β x), γ x y) (x : sigma β) : γ x.1 x.2 :=
f x.1 x.2

@[simp]
lemma sigma.uncurry_curry {γ : Π a, β a → Type*} (f : Π x : sigma β, γ x.1 x.2) :
  sigma.uncurry (sigma.curry f) = f :=
funext $ λ ⟨i, j⟩, rfl

@[simp]
lemma sigma.curry_uncurry {γ : Π a, β a → Type*} (f : Π x (y : β x), γ x y) :
  sigma.curry (sigma.uncurry f) = f :=
rfl

/-- Convert a product type to a Σ-type. -/
def prod.to_sigma {α β} (p : α × β) : Σ _ : α, β := ⟨p.1, p.2⟩

@[simp] lemma prod.fst_comp_to_sigma {α β} : sigma.fst ∘ @prod.to_sigma α β = prod.fst := rfl
@[simp] lemma prod.fst_to_sigma {α β} (x : α × β) : (prod.to_sigma x).fst = x.fst := rfl
@[simp] lemma prod.snd_to_sigma {α β} (x : α × β) : (prod.to_sigma x).snd = x.snd := rfl
@[simp] lemma prod.to_sigma_mk {α β} (x : α) (y : β) : (x, y).to_sigma = ⟨x, y⟩ := rfl

-- we generate this manually as `@[derive has_reflect]` fails
@[instance]
protected meta def {u v} sigma.reflect [reflected_univ.{u}] [reflected_univ.{v}]
  {α : Type u} (β : α → Type v)
  [reflected _ α] [reflected _ β] [hα : has_reflect α] [hβ : Π i, has_reflect (β i)] :
  has_reflect (Σ a, β a) :=
λ ⟨a, b⟩, (by reflect_name : reflected _ @sigma.mk.{u v}).subst₄ `(α) `(β) `(a) `(b)

end sigma

section psigma
variables {α : Sort*} {β : α → Sort*}

namespace psigma

/-- Nondependent eliminator for `psigma`. -/
def elim {γ} (f : ∀ a, β a → γ) (a : psigma β) : γ :=
psigma.cases_on a f

@[simp] theorem elim_val {γ} (f : ∀ a, β a → γ) (a b) : psigma.elim f ⟨a, b⟩ = f a b := rfl

instance [inhabited α] [inhabited (β default)] : inhabited (psigma β) :=
⟨⟨default, default⟩⟩

instance [h₁ : decidable_eq α] [h₂ : ∀a, decidable_eq (β a)] : decidable_eq (psigma β)
| ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ := match a₁, b₁, a₂, b₂, h₁ a₁ a₂ with
  | _, b₁, _, b₂, is_true (eq.refl a) :=
    match b₁, b₂, h₂ a b₁ b₂ with
    | _, _, is_true (eq.refl b) := is_true rfl
    | b₁, b₂, is_false n := is_false (assume h, psigma.no_confusion h (λe₁ e₂, n $ eq_of_heq e₂))
    end
  | a₁, _, a₂, _, is_false n := is_false (assume h, psigma.no_confusion h (λe₁ e₂, n e₁))
  end

theorem mk.inj_iff {a₁ a₂ : α} {b₁ : β a₁} {b₂ : β a₂} :
  @psigma.mk α β a₁ b₁ = @psigma.mk α β a₂ b₂ ↔ (a₁ = a₂ ∧ b₁ == b₂) :=
iff.intro psigma.mk.inj $
  assume ⟨h₁, h₂⟩, match a₁, a₂, b₁, b₂, h₁, h₂ with _, _, _, _, eq.refl a, heq.refl b := rfl end

@[ext]
lemma ext {x₀ x₁ : psigma β} (h₀ : x₀.1 = x₁.1) (h₁ : x₀.2 == x₁.2) : x₀ = x₁ :=
by { cases x₀, cases x₁, cases h₀, cases h₁, refl }

lemma ext_iff {x₀ x₁ : psigma β} : x₀ = x₁ ↔ x₀.1 = x₁.1 ∧ x₀.2 == x₁.2 :=
by { cases x₀, cases x₁, exact psigma.mk.inj_iff }

@[simp] theorem «forall» {p : (Σ' a, β a) → Prop} :
  (∀ x, p x) ↔ (∀ a b, p ⟨a, b⟩) :=
⟨assume h a b, h ⟨a, b⟩, assume h ⟨a, b⟩, h a b⟩

@[simp] theorem «exists» {p : (Σ' a, β a) → Prop} :
  (∃ x, p x) ↔ (∃ a b, p ⟨a, b⟩) :=
⟨assume ⟨⟨a, b⟩, h⟩, ⟨a, b, h⟩, assume ⟨a, b, h⟩, ⟨⟨a, b⟩, h⟩⟩

/-- A specialized ext lemma for equality of psigma types over an indexed subtype. -/
@[ext]
lemma subtype_ext {β : Sort*} {p : α → β → Prop} :
  ∀ {x₀ x₁ : Σ' a, subtype (p a)}, x₀.fst = x₁.fst → (x₀.snd : β) = x₁.snd → x₀ = x₁
| ⟨a₀, b₀, hb₀⟩ ⟨a₁, b₁, hb₁⟩ rfl rfl := rfl

lemma subtype_ext_iff {β : Sort*} {p : α → β → Prop} {x₀ x₁ : Σ' a, subtype (p a)} :
  x₀ = x₁ ↔ x₀.fst = x₁.fst ∧ (x₀.snd : β) = x₁.snd :=
⟨λ h, h ▸ ⟨rfl, rfl⟩, λ ⟨h₁, h₂⟩, subtype_ext h₁ h₂⟩

variables {α₁ : Sort*} {α₂ : Sort*} {β₁ : α₁ → Sort*} {β₂ : α₂ → Sort*}

/-- Map the left and right components of a sigma -/
def map (f₁ : α₁ → α₂) (f₂ : Πa, β₁ a → β₂ (f₁ a)) : psigma β₁ → psigma β₂
| ⟨a, b⟩ := ⟨f₁ a, f₂ a b⟩

end psigma

end psigma


import data.fintype.basic
import algebra.power_mod
import group_theory.group_action
import algebra.group_power
import algebra.big_operators
import data.zmod.basic
import tactic.ring tactic.abel
import group_theory.self_map
import group_theory.action_instances
import group_theory.burnside_count
import group_theory.dihedral
import data.fin_extra
import data.enumeration
import order.lattice order.lattice_extra

open group_theory

namespace MAS114
namespace exercises_2
namespace Q01

def finset.mk' {α : Type*} (l : list α) (h : l.nodup) : finset α :=
  finset.mk l h

lemma finset.eq_iff_veq {α : Type*} (s₀ s₁ : finset α) :
  s₀ = s₁ ↔ s₀.val = s₁.val :=
⟨ λ h, by rw[h], λ h, finset.eq_of_veq h⟩

lemma finset.eq_iff_perm {α : Type*} (l₀ l₁ : list α) (h₀ : l₀.nodup) (h₁ : l₁.nodup) :
  finset.mk' l₀ h₀ = finset.mk' l₁ h₁ ↔ list.perm l₀ l₁ :=
begin
  rw [finset.eq_iff_veq],
  change (l₀ : multiset α) = (l₁ : multiset α) ↔ _,
  split,
  exact quotient.exact,
  exact @quotient.sound (list α) (list.is_setoid α) l₀ l₁
end

def X := (fin 4) × (fin 4)

namespace X

instance : decidable_eq X    := by { dsimp [X], apply_instance }
instance : fintype X         := by { dsimp [X], apply_instance }
instance : has_repr X        := ⟨λ ij, ij.1.val.repr ++ ij.2.val.repr⟩
instance : distrib_lattice X := by { dsimp [X], apply_instance }
instance : bounded_order X   := by { dsimp [X], apply_instance }

/-
instance : linear_order X :=
  by { dsimp [X], exact lex_order }
-/

def s : self_map X := λ ij, ⟨ij.1, ij.2.reflect⟩
def r : self_map X := λ ij, ⟨ij.2.reflect, ij.1⟩

def p : dihedral.prehom 4 (self_map X) :=
begin
 refine_struct {
  r := r,
  s := s
 }; funext ij; rcases ij with ⟨i,j⟩;
 simp [self_map.one_app, self_map.mul_app, r, s, pow_succ, fin.reflect_reflect];
 refl
end

instance : mul_action (dihedral 4) X := self_map.mul_action_of_hom p.to_hom

lemma smul_s (ij : X) : (dihedral.s (0 : zmod 4)) • ij = ⟨ij.1, ij.2.reflect⟩ := rfl
lemma smul_r (ij : X) : (dihedral.r (1 : zmod 4)) • ij = ⟨ij.2.reflect, ij.1⟩ := rfl

def F : (finset (orbits (dihedral 4) X)) := finset.univ
def L (o : orbits (dihedral 4) X) : finset X :=
  finset.univ.filter (λ x, o = orbit x)
#eval F.image L

end X

def Y := finset X

namespace Y
instance : decidable_eq Y := by { dsimp [Y], apply_instance }
instance : fintype Y      := by { dsimp [Y], apply_instance }
instance : has_repr Y     := by { dsimp [Y], apply_instance }

def bounding_box : Y → X × X :=
  λ (xs : finset X), ⟨xs.inf id,xs.sup id⟩

def size  (y : Y) : ℕ × ℕ :=
  let b := y.bounding_box in prod.mk (b.2.1 - b.1.1) (b.2.2 - b.1.2)

def is_horizontal (y : Y) : bool := y.size.2 = 0
def is_vertical   (y : Y) : bool := y.size.1  = 0

instance : mul_action (dihedral 4) Y :=
  _root_.mul_action.finset_action
end Y

@[derive decidable_eq]
inductive Z_single
| H : (fin 3) → (fin 4) → Z_single
| V : (fin 4) → (fin 3) → Z_single

namespace Z_single

def to_string : Z_single → string
| (H i j) := "H" ++ i.val.repr ++ j.val.repr
| (V i j) := "V" ++ i.val.repr ++ j.val.repr

instance : has_repr Z_single := ⟨to_string⟩

def bounding_box : Z_single → X × X
| (H i j) := ⟨⟨i.inc,j⟩,⟨i.succ,j⟩⟩
| (V i j) := ⟨⟨i,j.inc⟩,⟨i,j.succ⟩⟩

def size : Z_single → ℕ × ℕ
| (H _ _) := ⟨1,0⟩
| (V _ _) := ⟨0,1⟩

instance : enumeration Z_single := {
  elems :=
   ((enumeration.elems : list (fin 3)).bind
      (λ i, (enumeration.elems : list (fin 4)).map (Z_single.H i))) ++
   ((enumeration.elems : list (fin 4)).bind
      (λ i, (enumeration.elems : list (fin 3)).map (Z_single.V i))),
  nodup := dec_trivial,
  complete := λ z,
  begin
    cases z with i j i j; rw [list.mem_append],
    { left,
      exact @list.mem_bind_of_mem (fin 3) Z_single (H i j)
        (enumeration.elems : list (fin 3))
        (λ i, (enumeration.elems : list (fin 4)).map (Z_single.H i))
        i (enumeration.complete i)
        (list.mem_map_of_mem (H i) (enumeration.complete j)) },
    { right,
      exact @list.mem_bind_of_mem (fin 4) Z_single (V i j)
        (enumeration.elems : list (fin 4))
        (λ i, (enumeration.elems : list (fin 3)).map (Z_single.V i))
        i (enumeration.complete i)
        (list.mem_map_of_mem (V i) (enumeration.complete j)) },
  end
}

def to_Y₀ : ∀ (z : Z_single), list X
| (H i j) := [prod.mk i.inc j, prod.mk i.succ j]
| (V i j) := [prod.mk i j.inc, prod.mk i j.succ]

lemma to_Y₀_nodup (z : Z_single) : z.to_Y₀.nodup :=
begin
 have : ∀ {n : ℕ} (k : fin n), k.inc ≠ k.succ :=
   λ n k, ne_of_lt k.inc_lt_succ,
 cases z with i j i j; dsimp[to_Y₀];
 simp [fin.eq_iff_veq,(nat.succ_ne_self i.val).symm, this]
end

def to_Y (z : Z_single) : Y := @finset.mk X z.to_Y₀ z.to_Y₀_nodup

lemma to_Y_card (z : Z_single) : z.to_Y.card = 2 :=
by { cases z with i j i j; refl }

lemma to_Y_bounding_box (z : Z_single) :
  z.to_Y.bounding_box = z.bounding_box :=
begin
  cases z with i j i j,
  focus {
    let u : X := ⟨i.inc,j⟩, let v : X := ⟨i.succ,j⟩,
    have huv : u ≤ v := ⟨le_of_lt i.inc_lt_succ,le_refl j⟩, },
  swap, focus
  { let u : X := ⟨i,j.inc⟩, let v : X := ⟨i,j.succ⟩,
    have huv : u ≤ v := ⟨le_refl i,le_of_lt j.inc_lt_succ⟩ },
  all_goals {
    change prod.mk (u ⊓ (v ⊓ ⊤)) (u ⊔ (v ⊔ ⊥)) = ⟨u,v⟩,
    rw [inf_top_eq, sup_bot_eq],
    rw [inf_of_le_left huv, sup_of_le_right huv] }
end

lemma to_Y_size (z : Z_single) :
  z.to_Y.size = z.size :=
begin
  dsimp [Y.size], rw [to_Y_bounding_box],
  rcases z with ⟨⟨i,hi⟩,⟨j,hj⟩⟩ | ⟨⟨i,hi⟩,⟨j,hj⟩⟩,
  { change prod.mk ((i + 1) - i) (j - j) = ⟨1,0⟩,
    rw [nat.sub_self, nat.add_sub_cancel_left] },
  { change prod.mk (i - i) ((j + 1) - j) = ⟨0,1⟩,
    rw [nat.sub_self, nat.add_sub_cancel_left] }
end

lemma to_Y_inj : function.injective to_Y :=
begin
  intros z₀ z₁ he,
  have hb := congr_arg Y.bounding_box he,
  rw [to_Y_bounding_box, to_Y_bounding_box] at hb, clear he,
  cases z₀ with i₀ j₀ i₀ j₀; cases z₁ with i₁ j₁ i₁ j₁,
  all_goals {
    simp only [bounding_box] at hb,
    injection hb  with hb₀ hb₁,
    injection hb₀ with hb₂ hb₃,
    injection hb₁ with hb₄ hb₅ },
  { replace hb₄ := fin.succ_inj.mp hb₄, cc },
  { exfalso, exact ne_of_lt (fin.inc_lt_succ i₀) (hb₂.trans hb₄.symm) },
  { exfalso, exact ne_of_lt (fin.inc_lt_succ j₀) (hb₃.trans hb₅.symm) },
  { replace hb₅ := fin.succ_inj.mp hb₅, cc }
end

def s : Z_single → Z_single
| (H i j) := H i j.reflect
| (V i j) := V i j.reflect

def r : Z_single → Z_single
| (H i j) := V j.reflect i
| (V i j) := H j.reflect i

lemma to_Y_s (z : Z_single) :
  (s z).to_Y = (dihedral.s (0 : zmod 4)) • z.to_Y :=
begin
  cases z with i j i j; dsimp[s, to_Y, to_Y₀] ;
  change finset.mk (_ : multiset X) _ = _;
  ext x;
  simp only [
      mul_action.mem_smul_finset', dihedral.s_inv,
      finset.mem_mk, multiset.mem_coe,
      list.mem_cons_iff, list.mem_singleton,
      mul_action.smul_eq_iff_eq_smul_inv];
  simp only [
      fin.reflect_inc, fin.reflect_succ, X.smul_s, or_comm],
end

lemma to_Y_r (z : Z_single) :
  (r z).to_Y = (dihedral.r (1 : zmod 4)) • z.to_Y :=
begin
  cases z with i j i j; dsimp[s, to_Y, to_Y₀] ;
  change finset.mk (([_,_] : list X) : multiset X) _ = _;
  ext x;
  simp only [
      mul_action.mem_smul_finset', dihedral.r_inv, neg_neg,
      finset.mem_mk, multiset.mem_coe,
      list.mem_cons_iff, list.mem_singleton,
      mul_action.smul_eq_iff_eq_smul_inv];
  simp only [
      fin.reflect_inc, fin.reflect_succ, X.smul_r, X.smul_r, or.comm],
end

end Z_single

end Q01
end exercises_2
end MAS114