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


/-
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


/-
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