import data.nat.prime

open nat

-- BEGIN
example {m n : ℕ} (h : m ∣ n ∧ m ≠ n) :
  m ∣ n ∧ ¬ n ∣ m :=
begin
  cases h with h1 h2,
  sorry,
end
-- END


import data.hash_map
import data.nat.basic
import data.rat.basic
import data.real.basic
import data.real.sqrt
import data.rat.sqrt
import analysis.normed.group.basic

import core.util
import core.point
import core.grid

def pt_in_ball (p q : point) (c : ℕ⁺) (qs : list point) : Prop :=
  q ∈ qs ∧
  q ≠ p ∧
  ∥q - p∥ ≤ c

-- def min_dist_pair_aux : list (point × ℚ) → option (point × ℚ)
-- | [] := none
-- | ((p, d) :: pds) :=
--     match min_dist_pair_aux pds with
--     | none :=
--         some (p, d)
--     | some (p', d') :=
--         some (if d < d' then (p, d) else (p', d'))
--     end

-- def min_dist_pair : list (point × ℚ) → option point
-- | [] := none
-- | pds := min_dist_pair_aux pds >>= (λ (p : point × ℚ), some p.1)

def min_dist_pair (p : point) : list point → option (point × point)
| [] := none
| (q :: ps') :=
    let pq' := min_dist_pair ps' in
    if point_lt' (p, q) pq' then some (p, q) else pq'

/-
  All points within distance `c` from the current point are included in the list.
-/

/-
  Get minimum distance pair, wrt the grid `g`, with `p` as the center of the
  pair, and only considering the neighbors of `p`.
-/
def mdp_with (p : point) (g : grid_2D) : option (point × point) :=
  let ps := get_neighbs p g in
  min_dist_pair p ps

lemma range_in_hypercube :
  ∀ (i j : ℤ) (n : ℕ),
    ((-(↑n) ≤ i) ∧ (i ≤ n) ∧
     (-(↑n) ≤ j) ∧ (j ≤ n))
    ↔
    (i, j) ∈ (get_hypercube n) := sorry

lemma norm_bd_on_coords :
  ∀ (a b : ℤ) (c : ℕ),
    ∥(a, b)∥ ≤ c →
    a*a ≤ c ∧ b*b ≤ c := sorry
  -- (Something bounding `a` and `b` below and above by (+|-)nat.sqrt(c) (not sure whether inclusive or exclusive))

-- lemma nat_sqrt_plus_one_sq_gt_nat :
--   ∀ (c : ℕ),
--     ((nat.sqrt c) + 1)*((nat.sqrt c) + 1) > c := sorry

lemma sq_neg_lt :
  ∀ (a b : ℤ),
    a ≤ 0 →
    b ≤ 0 →
    a < b →
    b*b < a*a := begin
  intros a b h1 h2 h3,
  sorry
end

lemma sq_nonneg_lt :
  ∀ (a b : ℤ),
    a ≥ 0 →
    b ≥ 0 →
    a < b →
    a*a < b*b := begin
  intros a b h1 h2 h3,
  exact mul_lt_mul'' h3 h3 h1 h1,
end

lemma nat_ge_zero :
  ∀ (n : ℕ), n ≥ 0 := begin
  intros n,
  linarith,
end

lemma ge_neg_le :
  ∀ (n : ℤ),
    n ≥ 0 →
    -n ≤ 0 := begin
  intros n h,
  linarith,
end

lemma coe_nat_int_ge :
  ∀ (n : ℕ),
  n ≥ 0 →
  (↑n : ℤ) ≥ 0 := begin
  intros n h,
  simp [h],
end

lemma lt_to_le :
  ∀ (a b : ℤ),
    a < b → a ≤ b := begin
  intros a b h,
  linarith,
end

lemma neg_sq_sq :
  ∀ (a : ℤ),
    (-a)*(-a) = a*a := begin
  intros a,
  ring,
end

lemma succ_sqrt_sq_gt_orig :
  ∀ (c : ℕ),
    ((nat.sqrt c) + 1) * ((nat.sqrt c) + 1) > c := begin
  intros c,
  exact nat.lt_succ_sqrt c,
end

lemma coe_preserves_lt :
  ∀ (a b : ℕ),
    a < b →
    (↑a : ℤ) < ↑b := begin
  intros a b h,
  simp [h],
end

lemma coe_preserves_ge :
  ∀ (a b : ℕ),
    a ≥ b →
    (↑a : ℤ) ≥ ↑b := begin
  intros a b h,
  linarith,
end

lemma coe_nat_nat_nop :
  ∀ (n : ℕ),
    (↑n : ℕ) = n := begin
  intros n,
  simp,
end

lemma bounded_norm_in_hypercube:
  ∀ (ab : ℤ × ℤ) (c : ℕ),
    ∥ab∥ ≤ c →
    (ab ∈ get_hypercube ((nat.sqrt c) + 1)) := begin
  intros ab c ab_le_c,
  cases ab with a b,
  apply (range_in_hypercube a b ((nat.sqrt c) + 1)).mp,
  split,
  {
    by_cases h : -↑((nat.sqrt c) + 1) ≤ a,
    assumption,
    simp at h,
    have a_sq_le_c_and_b_sq_le_c: a*a ≤ c ∧ b*b ≤ c := begin
      apply norm_bd_on_coords,
      assumption,
    end,
    have h : a < -(↑(nat.sqrt c) + 1) := begin
      simp,
      rw [add_comm],
      exact h,
    end,
    have sq_succ_sqrt_lt_sq_a : -(↑(nat.sqrt c) + 1) * -(↑(nat.sqrt c) + 1) < a * a := begin
      apply sq_neg_lt,
      {
        have succ_sqrt_ge_zero : ↑(nat.sqrt c) + 1 ≥ 0 := begin
          apply nat_ge_zero,
        end,
        have neg_succ_sqrt_le_zero : -(↑(↑(nat.sqrt c) + 1) : ℤ) ≤ 0 := begin
          apply ge_neg_le,
          apply coe_nat_int_ge,
          assumption,
        end,
        have h_le : a ≤ -(↑(nat.sqrt c) + 1) := begin
          apply lt_to_le,
          assumption,
        end,
        apply le_trans,
        exact h_le,
        simp at *,
        exact neg_succ_sqrt_le_zero,
      },
      {
        have succ_sqrt_ge_zero : ↑(nat.sqrt c) + 1 ≥ 0 := begin
          apply nat_ge_zero,
        end,
        have neg_succ_sqrt_le_zero : -(↑(↑(nat.sqrt c) + 1) : ℤ) ≤ 0 := begin
          apply ge_neg_le,
          apply coe_nat_int_ge,
          assumption,
        end,
        simp at *,
        exact neg_succ_sqrt_le_zero,
      },
      {
        exact h,
      },
    end,
    rw [neg_sq_sq] at sq_succ_sqrt_lt_sq_a,
    have succ_sqrt_c_sq_gt_c : ((nat.sqrt c) + 1) * ((nat.sqrt c) + 1) > c := begin
      apply succ_sqrt_sq_gt_orig,
    end,
    cases a_sq_le_c_and_b_sq_le_c with a_sq_le_c b_sq_le_c,
    have c_lt_a_sq : (↑c : ℤ) < a*a := begin
      fapply lt_trans,
      exact ↑((nat.sqrt c + 1) * (nat.sqrt c + 1)),
      simp at succ_sqrt_c_sq_gt_c,
      apply coe_preserves_lt,
      assumption,
      simp,
      assumption,
    end,
    exfalso,
    apply not_le_and_gt,
    split,
    exact a_sq_le_c,
    exact c_lt_a_sq,
  },
  split,
  {
    by_cases h : a ≤ ↑(nat.sqrt c + 1),
    { assumption, },
    simp at h,
    have a_sq_le_c_and_b_sq_le_c: a*a ≤ c ∧ b*b ≤ c := begin
      apply norm_bd_on_coords,
      assumption,
    end,
    have sq_succ_sqrt_lt_sq_a : (↑(nat.sqrt c) + 1) * (↑(nat.sqrt c) + 1) < a * a := begin
      apply sq_nonneg_lt,
      {
        have succ_sqrt_ge_zero : ↑(nat.sqrt c) + 1 ≥ 0 := begin
          apply nat_ge_zero,
        end,
        apply coe_preserves_ge,
        rw [coe_nat_nat_nop] at succ_sqrt_ge_zero,
        exact succ_sqrt_ge_zero,
      },
      {
        have succ_sqrt_ge_zero : ↑(nat.sqrt c) + 1 ≥ 0 := begin
          apply nat_ge_zero,
        end,
        fapply le_trans,
        exact (↑(nat.sqrt c) + 1),
        simp only [ge] at succ_sqrt_ge_zero,
        apply coe_preserves_ge,
        rw [coe_nat_nat_nop] at succ_sqrt_ge_zero,
        exact succ_sqrt_ge_zero,
        apply lt_to_le,
        exact h,
      },
      {
        exact h,
      },
    end,
    have succ_sqrt_c_sq_gt_c : ((nat.sqrt c) + 1) * ((nat.sqrt c) + 1) > c := begin
      apply succ_sqrt_sq_gt_orig,
    end,
    cases a_sq_le_c_and_b_sq_le_c with a_sq_le_c b_sq_le_c,
    have c_lt_a_sq : (↑c : ℤ) < a*a := begin
      fapply lt_trans,
      exact ↑((nat.sqrt c + 1) * (nat.sqrt c + 1)),
      simp at succ_sqrt_c_sq_gt_c,
      apply coe_preserves_lt,
      assumption,
      simp,
      assumption,
    end,
    exfalso,
    apply not_le_and_gt,
    split,
    exact a_sq_le_c,
    exact c_lt_a_sq,
  },
  split,
  {
    by_cases h : -↑((nat.sqrt c) + 1) ≤ b,
    assumption,
    simp at h,
    have a_sq_le_c_and_b_sq_le_c: a*a ≤ c ∧ b*b ≤ c := begin
      apply norm_bd_on_coords,
      assumption,
    end,
    have h : b < -(↑(nat.sqrt c) + 1) := begin
      simp,
      rw [add_comm],
      exact h,
    end,
    have sq_succ_sqrt_lt_sq_a : -(↑(nat.sqrt c) + 1) * -(↑(nat.sqrt c) + 1) < b * b := begin
      apply sq_neg_lt,
      {
        have succ_sqrt_ge_zero : ↑(nat.sqrt c) + 1 ≥ 0 := begin
          apply nat_ge_zero,
        end,
        have neg_succ_sqrt_le_zero : -(↑(↑(nat.sqrt c) + 1) : ℤ) ≤ 0 := begin
          apply ge_neg_le,
          apply coe_nat_int_ge,
          assumption,
        end,
        have h_le : b ≤ -(↑(nat.sqrt c) + 1) := begin
          apply lt_to_le,
          assumption,
        end,
        apply le_trans,
        exact h_le,
        simp at *,
        exact neg_succ_sqrt_le_zero,
      },
      {
        have succ_sqrt_ge_zero : ↑(nat.sqrt c) + 1 ≥ 0 := begin
          apply nat_ge_zero,
        end,
        have neg_succ_sqrt_le_zero : -(↑(↑(nat.sqrt c) + 1) : ℤ) ≤ 0 := begin
          apply ge_neg_le,
          apply coe_nat_int_ge,
          assumption,
        end,
        simp at *,
        exact neg_succ_sqrt_le_zero,
      },
      {
        exact h,
      },
    end,
    rw [neg_sq_sq] at sq_succ_sqrt_lt_sq_a,
    have succ_sqrt_c_sq_gt_c : ((nat.sqrt c) + 1) * ((nat.sqrt c) + 1) > c := begin
      apply succ_sqrt_sq_gt_orig,
    end,
    cases a_sq_le_c_and_b_sq_le_c with a_sq_le_c b_sq_le_c,
    have c_lt_a_sq : (↑c : ℤ) < b*b := begin
      fapply lt_trans,
      exact ↑((nat.sqrt c + 1) * (nat.sqrt c + 1)),
      simp at succ_sqrt_c_sq_gt_c,
      apply coe_preserves_lt,
      assumption,
      simp,
      assumption,
    end,
    exfalso,
    apply not_le_and_gt,
    split,
    exact b_sq_le_c,
    exact c_lt_a_sq,
  },
  {
    by_cases h : b ≤ ↑(nat.sqrt c + 1),
    { assumption, },
    simp at h,
    have a_sq_le_c_and_b_sq_le_c: a*a ≤ c ∧ b*b ≤ c := begin
      apply norm_bd_on_coords,
      assumption,
    end,
    have sq_succ_sqrt_lt_sq_a : (↑(nat.sqrt c) + 1) * (↑(nat.sqrt c) + 1) < b*b := begin
      apply sq_nonneg_lt,
      {
        have succ_sqrt_ge_zero : ↑(nat.sqrt c) + 1 ≥ 0 := begin
          apply nat_ge_zero,
        end,
        apply coe_preserves_ge,
        rw [coe_nat_nat_nop] at succ_sqrt_ge_zero,
        exact succ_sqrt_ge_zero,
      },
      {
        have succ_sqrt_ge_zero : ↑(nat.sqrt c) + 1 ≥ 0 := begin
          apply nat_ge_zero,
        end,
        fapply le_trans,
        exact (↑(nat.sqrt c) + 1),
        simp only [ge] at succ_sqrt_ge_zero,
        apply coe_preserves_ge,
        rw [coe_nat_nat_nop] at succ_sqrt_ge_zero,
        exact succ_sqrt_ge_zero,
        apply lt_to_le,
        exact h,
      },
      {
        exact h,
      },
    end,
    have succ_sqrt_c_sq_gt_c : ((nat.sqrt c) + 1) * ((nat.sqrt c) + 1) > c := begin
      apply succ_sqrt_sq_gt_orig,
    end,
    cases a_sq_le_c_and_b_sq_le_c with a_sq_le_c b_sq_le_c,
    have c_lt_a_sq : (↑c : ℤ) < b*b := begin
      fapply lt_trans,
      exact ↑((nat.sqrt c + 1) * (nat.sqrt c + 1)),
      simp at succ_sqrt_c_sq_gt_c,
      apply coe_preserves_lt,
      assumption,
      simp,
      assumption,
    end,
    exfalso,
    apply not_le_and_gt,
    split,
    exact b_sq_le_c,
    exact c_lt_a_sq,
  }
end

lemma in_ball_exists_idx :
  ∀ (p q : point) (c : ℕ⁺) (qs : list point),
    pt_in_ball p q c qs →
    (∃ (a b : ℤ),
      (∥(a, b)∥ ≤ c) ∧ (p + (a, b) = q)) := sorry

lemma q_in_ball_means_grid_idx_in_get_idxs :
  ∀ (p q : point) (c : ℕ⁺) (qs : list point),
  pt_in_ball p q c qs →
  (get_grid_idx q) ∈ (get_idxs p c) := begin
  intros p q c qs q_in_p_ball,
  have exists_idx : (∃ (a b : ℤ), (∥(a, b)∥ ≤ c) ∧ (p + (a, b) = q)) := begin
    apply in_ball_exists_idx,
    assumption,
  end,
  cases exists_idx with a exists_idx,
  cases exists_idx with b exists_idx,
  unfold pt_in_ball at q_in_p_ball,
  cases q_in_p_ball with q_in_qs q_ne_p_and_bded_norm,
  cases q_ne_p_and_bded_norm with q_ne_p q_bded_norm,
  simp [point_norm] at q_bded_norm,
  simp [get_idxs, get_grid_idx],
  fapply exists.intro,
  exact a,
  fapply exists.intro,
  exact b,
  split,
  {
    apply bounded_norm_in_hypercube,
    exact exists_idx.left,
  },
  {
    exact exists_idx.right,
  }
end

lemma x_in_some_l_x_in_join_ls :
  ∀ (x : point) (ls : list (list point)),
    (∃ (l : list point), x ∈ l ∧ l ∈ ls) →
    x ∈ ls.join := sorry

lemma x_in_grid_idxs_x_in_find_res :
  ∀ (p x : point) (g : grid_2D),
    (get_grid_idx x ∈ get_idxs p g.c) →
    (∃ l, (in_opt_list x l) ∧ (l ∈ (get_idxs p g.c).map g.data.find)) := sorry

lemma some_l_in_ls_l_in_lift :
  ∀ {α} (l : list α) (ls : list (option (list α))),
    some l ∈ ls →
    l ∈ list.map lift_option_list ls := begin
  sorry
end

lemma get_neighbs_gets_neighbs :
  ∀ (p : point) (g : grid_2D),
    ∀ (x : point),
      (pt_in_ball p x g.c g.ps) →
      (x ∈ get_neighbs p g) := begin
  intros p g x x_in_ball,
  simp only [get_neighbs],
  have grid_idx_x_in_idxs : (get_grid_idx x) ∈ (get_idxs p g.c) := begin
    apply q_in_ball_means_grid_idx_in_get_idxs,
    assumption,
  end,
  apply (list.mem_filter.mpr),
  split,
  {
    apply x_in_some_l_x_in_join_ls,
    have x_in_opt_list : (∃ l, (in_opt_list x l) ∧ (l ∈ (get_idxs p g.c).map g.data.find)) := begin
      apply x_in_grid_idxs_x_in_find_res,
      assumption,
    end,
    cases x_in_opt_list with l x_in_opt_list,
    cases x_in_opt_list with x_in_opt_list l_in_res,
    cases l,
    { cases x_in_opt_list, },
    fapply exists.intro,
    exact l,
    split,
    unfold in_opt_list at x_in_opt_list,
    assumption,
    apply some_l_in_ls_l_in_lift,
    assumption,
  },
  {
    unfold pt_in_ball at x_in_ball,
    exact x_in_ball.right.left,
  },
end

lemma min_dist_pair_closest :
  ∀ (p : point) (ps : list point),
    ∀ (x : point),
      (x ∈ ps) →
      (min_dist_pair p ps ≤ some (p, x)) :=
begin
  sorry
end

-- lemma min_dist_pair_includes_center :
--   ∀ (p : point) (ps : list point),
--     (∃ (z w : point), min_dist_pair p ps = some (z, w)) →
--     (∃ (q : point), min_dist_pair p ps = some (p, q)) := begin
--   sorry
-- end

-- lemma pt_in_ball_mdp_is_some :
--   ∀ (p : point) (g : grid_2D),
--     (∃ (x : point), pt_in_ball p x g.c g.ps) →
--     (∃ (x : point), mdp_with p g = some (p, x)) := begin
--   intros p g exists_x_in_ball,
--   simp [mdp_with],
--   cases exists_x_in_ball with x exists_x_in_ball,
--   have x_in_neighbs : x ∈ get_neighbs p g := begin
--     apply get_neighbs_gets_neighbs,
--     assumption,
--   end,
--   have mdp_le_px : min_dist_pair p (get_neighbs p g) ≤ some (p, x) := begin
--     apply min_dist_pair_closest,
--     assumption,
--   end,
--   have mdp_is_some : ∃ (z w : point), min_dist_pair p (get_neighbs p g) = some (z, w) := begin
--     apply option_pt_le_some_eq_some,
--     exact mdp_le_px,
--   end,
--   apply min_dist_pair_includes_center,
--   assumption,
-- end

lemma get_min_dist_pair_correct :
  ∀ (p : point) (g : grid_2D),
    ∀ (x : point),
      (pt_in_ball p x g.c g.ps) →
      ((mdp_with p g) ≤ some (p, x)) := begin
  intros p g x x_in_ball,
  simp [mdp_with],
  apply min_dist_pair_closest,
  apply get_neighbs_gets_neighbs,
  assumption,
end

lemma min_dist_pair_in_ball :
  ∀ (p q : point) (g : grid_2D),
    (mdp_with p g = some (p, q)) →
    pt_in_ball p q g.c g.ps := begin
  sorry
end

-- lemma get_neighbs_contains_all_within_ball :
--   ∀ (c : ℕ⁺) (ps : list point) (p q : point) (g : grid_2D),
--     (∥ p - q ∥ ≤ c) →
--     (q ∈ get_neighbs p g) := begin
--   sorry
-- end

def aux (g : grid_2D) : list point → option (point × point)
| [] := none
| (p :: ps) :=
    let rec_res := aux ps in
    let curr_res := mdp_with p g in
    -- TODO figure out why we can't get decidable to work on `point_le`.
    if point_lt' curr_res rec_res then curr_res else rec_res

/-
We can only get `none` if `c` wasn't actually a valid hint.
-/
def find_closest_pair
  (c : ℕ⁺)
  (points : list point)
  : option (point × point) :=
  let g := grid_points c points in
  aux g points >>= (
    λ pq : point × point,
      if ∥ pq.1 - pq.2 ∥ > c
      then none
      else some pq
  )

#eval find_closest_pair ⟨3, by simp⟩ [(0, 0), (2, 0), (5, 0)]
#eval find_closest_pair ⟨4, by simp⟩ [(0, 0), (2, 0), (5, 0)]
#eval find_closest_pair ⟨7, by simp⟩ [(0, 0), (2, 2), (5, 0)]
#eval find_closest_pair ⟨8, by simp⟩ [(0, 0), (2, 2), (5, 0)]

def closest_pair (p q : point) (ps : list point) : Prop :=
  (p ∈ ps) ∧
  (q ∈ ps) ∧
  (p ≠ q) ∧
  (∀ (r s : point), r ≠ s → ∥p - q∥ ≤ ∥r - s∥)

/-
  Closest pair with help
-/
def cp_with_help (p q : point) (ps : list point) (c : ℕ⁺) : Prop :=
  (closest_pair p q ps) ∧ (1 < ∥ p - q ∥) ∧ (∥ p - q ∥ ≤ c)

inductive closest_pair_in_ball_union (c : ℕ⁺) (qs : list point) : option (point × point) → list point → Prop
| no_ball : closest_pair_in_ball_union none []
| cons_ball_no_update (xy : option (point × point)) (p : point) (ps' : list point) :
    closest_pair_in_ball_union xy ps' →
    (∀ (q : point),
      pt_in_ball p q c qs →
      (xy ≤ some (p, q))) →
    closest_pair_in_ball_union xy (p :: ps')
| cons_ball_update
    (xy : option (point × point))
    (p : point)
    (ps' : list point)
    (q : point) :
    (
      pt_in_ball p q c qs ∧
      (∀ (x : point), (pt_in_ball p x c qs) → ∥q - p∥ ≤ ∥x - p∥) ∧
      some (p, q) < xy
    ) →
    closest_pair_in_ball_union xy ps' →
    closest_pair_in_ball_union (some (p, q)) (p :: ps')

lemma point_lt_iff_point_lt'_eq_true :
  ∀ (xy zw : option (point × point)),
    xy < zw ↔ (point_lt' xy zw = true) := begin
  intros xy zw,
  constructor,
  sorry,
  sorry,
end

lemma opt_point_le_some_implies_is_some :
  ∀ (xy : option (point × point)) (z w : point),
    xy ≤ some (z, w) ↔ (∃ (x y : point), xy = some (x, y)) := begin
  sorry,
end

lemma get_mdp_includes_center_pt :
  ∀ (p : point) (g : grid_2D),
    (∃ (q : point), (mdp_with p g) = some (p, q)) ∨
    (mdp_with p g) = none := begin
  sorry
end

lemma closer_than_pt_in_ball_is_in_ball :
  ∀ (p x y : point) (c : ℕ⁺) (qs : list point),
    pt_in_ball p y c qs →
    some (p, x) ≤ some (p, y) →
    pt_in_ball p x c qs := begin
  sorry
end

lemma aux_monotonic_in_pt_list :
  ∀ (c : ℕ⁺) (g : grid_2D) (p : point) (ps' : list point),
    (aux g (p :: ps')) ≤ (aux g ps')
     := begin
  intros c qs ps' p,
  sorry,
end

lemma cp_in_ball_union_downward_closed :
  ∀ (c : ℕ⁺) (xy zw : option (point × point)) (qs ps : list point),
    closest_pair_in_ball_union c qs zw ps →
    xy ≤ zw →
    closest_pair_in_ball_union c qs xy ps
     := begin
  sorry,
end

lemma pt_in_ball_subset_to_pt_in_ball :
  ∀ (ps' ps : list point) (p q : point) (c : ℕ⁺),
    pt_in_ball p q c ps' →
    ps' ⊆ ps →
    pt_in_ball p q c ps := sorry

lemma aux_finds_closest_pair_in_ball_union:
  ∀ (g : grid_2D),
    -- `aux` finds the closest pair in union of balls of radius ≤ `c`
    -- (intersected with `qs`) around all points in `ps`.
    (∀ (ps : list point),
      ps ⊆ g.ps →
      closest_pair_in_ball_union g.c g.ps (aux g ps) ps) := begin
  intros g ps ps_subseteq_qs,
  induction ps,
  {
    apply closest_pair_in_ball_union.no_ball,
  },
  {
    rename [ps_hd → p, ps_tl → ps'],
    have ps'_subseteq_qs : ps' ⊆ g.ps :=
      (list.cons_subset.mp ps_subseteq_qs).right,
    have ih : closest_pair_in_ball_union g.c g.ps (aux g ps') ps' := ps_ih ps'_subseteq_qs,
    clear ps_ih,
    by_cases (
      ∃ (q : point),
        pt_in_ball p q g.c g.ps ∧
        (∀ (x : point), pt_in_ball p x g.c g.ps → ∥ q - p ∥ ≤ ∥ x - p ∥) ∧
        some (p, q) < (aux g ps')),
    -- Case: there is a point within a ball of `p` that is closer than the
    -- recursive result.
    {
      -- Load up the environment with useful facts.
      cases h with q hq,
      have h_min_dist_pair : ∀ (x : point), (pt_in_ball p x g.c g.ps) → ((mdp_with p g) ≤ some (p, x)) := begin
        intros x x_in_ball,
        apply get_min_dist_pair_correct,
        assumption,
      end,
      have min_dist_pair_closer_than_q : mdp_with p g ≤ some (p, q) := begin
        exact h_min_dist_pair q hq.left,
      end,
      have min_dist_pair_closer_than_rec_res : mdp_with p g < aux g ps' := begin
        apply option_pt_le_lt_trans,
        assumption,
        exact hq.right.right,
      end,
      have min_dist_pair_closer_than_rec_res_bool :
        point_lt'
          (mdp_with p g)
          (aux g ps') = true :=
        (point_lt_iff_point_lt'_eq_true (mdp_with p g) (aux g ps')).mp min_dist_pair_closer_than_rec_res,
      simp [aux, min_dist_pair_closer_than_rec_res_bool],
      have md_pair_is_some: (∃ (x y : point), mdp_with p g = some (x, y)) := begin
        exact ((opt_point_le_some_implies_is_some (mdp_with p g) p q).mp min_dist_pair_closer_than_q),
      end,
      cases md_pair_is_some with x md_pair_is_some',
      cases md_pair_is_some' with y md_pair_is_some'',
      rw [md_pair_is_some''],
      have x_eq_p : x = p := begin
        have md_pair_disj :
          (∃ (z : point), mdp_with p g = some (p, z)) ∨
          mdp_with p g = none := begin
          exact (get_mdp_includes_center_pt p g),
        end,
        cases md_pair_disj,
        {
          cases md_pair_disj with z hz,
          rw [md_pair_is_some''] at hz,
          cases hz,
          refl,
        },
        {
          rw [md_pair_is_some''] at md_pair_disj,
          cases md_pair_disj,
        },
      end,
      rw [x_eq_p] at *,

      fapply closest_pair_in_ball_union.cons_ball_update,
      exact (aux g ps'),
      {
        constructor,
        {
          rw [md_pair_is_some''] at min_dist_pair_closer_than_q,
          apply closer_than_pt_in_ball_is_in_ball,
          exact hq.left,
          assumption,
        },
        constructor,
        {
          intros z z_in_ball,
          have q_closer_than_z : ∥q - p∥ ≤ ∥z - p∥ := hq.right.left z z_in_ball,
          have y_closer_than_q : ∥y - p∥ ≤ ∥q - p∥ := begin
            rw [md_pair_is_some''] at min_dist_pair_closer_than_q,
            simp [has_le.le, point_le] at min_dist_pair_closer_than_q ⊢,
            rw point_norm_symm y p,
            rw point_norm_symm q p,
            assumption,
          end,
          exact le_trans y_closer_than_q q_closer_than_z,
        },
        {
          rw [md_pair_is_some''] at min_dist_pair_closer_than_q,
          apply option_pt_le_lt_trans,
          exact min_dist_pair_closer_than_q,
          exact hq.right.right,
        },
      },
      {
        exact ih,
      },
    },
    -- Case: there is *no* point within a ball of `p` that is closer than the
    -- recursive result.
    {
      apply closest_pair_in_ball_union.cons_ball_no_update,
      {
        apply cp_in_ball_union_downward_closed,
        exact ih,
        apply aux_monotonic_in_pt_list,
        exact g.c,
      },
      {
        intros q q_in_ball,
        have mdp_p_closest : ∀ (x : point), pt_in_ball p x g.c g.ps → (mdp_with p g) ≤ some (p, x) := begin
          apply get_min_dist_pair_correct,
        end,
        -- aux ps' ≤ mdp p
        -- intuitively, by `h`
        have aux_ps'_le_mdp_p : aux g ps' ≤ mdp_with p g := begin
          by_cases aux_ps'_le_mdp_p : aux g ps' ≤ mdp_with p g,
          { assumption, },
          {
            have mdp_p_lt_aux_ps' : mdp_with p g < aux g ps' :=
              (neg_le_iff_lt (aux g ps') (mdp_with p g)).mp aux_ps'_le_mdp_p,
            have mdp_p_eq_some_p_z_or_none : (∃ (y : point), mdp_with p g = some (p, y)) ∨ (mdp_with p g) = none := get_mdp_includes_center_pt p g,
            have mdp_p_eq_some : ∃ (z w : point), mdp_with p g = some (z, w) := begin
               apply option_pt_le_some_eq_some,
               apply get_min_dist_pair_correct,
               apply pt_in_ball_subset_to_pt_in_ball,
               exact q_in_ball,
               refl,
            end,
            have mdp_p_eq_some : (∃ (y : point), mdp_with p g = some (p, y)) := begin
              cases mdp_p_eq_some with z mdp_p_eq_some',
              cases mdp_p_eq_some' with w mdp_p_eq_some'',
              cases mdp_p_eq_some_p_z_or_none,
              { assumption, },
              {
                 rw [mdp_p_eq_some_p_z_or_none] at mdp_p_eq_some'',
                 contradiction,
              },
            end,
            cases mdp_p_eq_some with y mdp_p_eq_some',
            have h_premise :
              pt_in_ball p y g.c g.ps ∧
              (∀ (x : point), pt_in_ball p x g.c g.ps → ∥y - p∥ ≤ ∥x - p∥) ∧
              some (p, y) < aux g ps' := begin
                rw [mdp_p_eq_some'] at mdp_p_closest,
                simp only [has_le.le, point_le] at mdp_p_closest ⊢,
                rw [point_norm_sub_comm p y] at mdp_p_closest,
                have mdp_p_closest' : ∀ (x : point), (pt_in_ball p x g.c g.ps) → (∥y - p∥.le ∥x - p∥) := begin
                  intros x,
                  rw [point_norm_sub_comm x p],
                  apply mdp_p_closest,
                end,
                have mdp_p_in_ball : pt_in_ball p y g.c g.ps := begin
                  apply min_dist_pair_in_ball,
                  exact mdp_p_eq_some',
                end,
                rw [mdp_p_eq_some'] at mdp_p_lt_aux_ps',
                constructor,
                exact mdp_p_in_ball,
                constructor,
                exact mdp_p_closest',
                exact mdp_p_lt_aux_ps',
            end,
            exfalso,
            apply h,
            fapply exists.intro,
            exact y,
            exact h_premise,
          },
        end,
        -- mdp p ≤ q
        -- intuitively, by univ property of `mdp` given by `mdp_correct` lemma
        have mdp_p_le_q : mdp_with p g ≤ some (p, q) := begin
          apply mdp_p_closest,
          apply pt_in_ball_subset_to_pt_in_ball,
          exact q_in_ball,
          refl,
        end,
        -- ¬(mdp p < aux ps')
        have mdp_not_lt_aux : ¬(point_lt'
          (mdp_with p g)
          (aux g ps')) := begin
          intros mdp_p_lt_aux_ps',
          apply not_x_le_y_and_gt_y,
          exact aux_ps'_le_mdp_p,
          simp [has_lt.lt],
          exact ((point_lt_iff_point_lt' _ _).mpr mdp_p_lt_aux_ps'),
        end,
        simp [aux, mdp_not_lt_aux],
        apply option_pt_le_trans,
        exact aux_ps'_le_mdp_p,
        exact mdp_p_le_q,
      }
    }
  },
end

-- lemma cp_in_ball_union_in_ps :
--   ∀ (c : ℕ⁺) (z w : point) (ps qs : list point),
--     closest_pair_in_ball_union c qs (some (z, w)) ps →
--     z ∈ ps := sorry

lemma cp_in_ball_union_closer_than_all_pts_in_dist_c :
  ∀ (c : ℕ⁺) (r s : point) (zw : option (point × point)) (ps qs : list point),
    ps ⊆ qs →
    r ∈ ps →
    pt_in_ball r s c qs →
    closest_pair_in_ball_union c qs zw ps →
    zw ≤ some (r, s) := begin
  intros
    c r s zw ps qs
    ps_subset_qs r_in_ps s_in_r_ball zw_cp_in_balls,
  induction zw_cp_in_balls,
  {
    cases r_in_ps,
  },
  {
    rename [
      zw_cp_in_balls_xy → zw,
      zw_cp_in_balls_p → p,
      zw_cp_in_balls_ps' → ps',
      zw_cp_in_balls_ᾰ → zw_cp_in_union_ps'_balls,
      zw_cp_in_balls_ᾰ_1 → zw_closest_in_p_ball,
      zw_cp_in_balls_ih → ih
    ],
    cases r_in_ps,
    {
      rw [r_in_ps] at *,
      apply zw_closest_in_p_ball,
      assumption,
    },
    {
      have ps_decomp : p ∈ qs ∧ ps' ⊆ qs := begin
        apply list.cons_subset.mp,
        assumption,
      end,
      apply ih,
      exact ps_decomp.right,
      exact r_in_ps,
    }
  },
  {
    rename [
      zw_cp_in_balls_xy → zw',
      zw_cp_in_balls_p → p,
      zw_cp_in_balls_ps' → ps',
      zw_cp_in_balls_q → q,
      zw_cp_in_balls_ᾰ → q_closest_in_p_ball_and_pq_le_zw',
      zw_cp_in_balls_ᾰ_1 → zw_cp_in_union_ps'_balls,
      zw_cp_in_balls_ih → ih
    ],
    cases r_in_ps,
    {
      rw [r_in_ps] at *,
      simp [has_le.le, point_le],
      rw [point_norm_sub_comm p q, point_norm_sub_comm p s],
      apply q_closest_in_p_ball_and_pq_le_zw'.right.left,
      assumption,
    },
    {
      apply option_pt_lt_to_le,
      apply option_pt_lt_le_trans,
      exact q_closest_in_p_ball_and_pq_le_zw'.right.right,
      have ps_decomp : p ∈ qs ∧ ps' ⊆ qs := begin
        apply list.cons_subset.mp,
        assumption,
      end,
      apply ih,
      exact ps_decomp.right,
      exact r_in_ps,
    }
  }
end

lemma some_cp_in_balls_in_pt_list_and_neq :
  ∀ (c : ℕ⁺) (x y : point) (xy : option (point × point)) (ps : list point),
    xy = some (x, y) →
    closest_pair_in_ball_union c ps xy ps →
    x ∈ ps ∧ y ∈ ps ∧ x ≠ y := sorry

lemma cp_with_help_and_cp_in_balls_implies_closest_pair :
  ∀ (c : ℕ⁺) (ps : list point) (xy : option (point × point)),
    -- If there's a closest pair within distance `c`
    (∃ (p q : point),
      cp_with_help p q ps c) →
    -- and `xy` gives the closest pair in all balls of radius ≥ `c` around
    -- points in `ps`,
    (closest_pair_in_ball_union c ps xy ps) →
    -- then `xy` contains the closest pair in all `ps`.
    ∃ (x y : point),
      xy = some (x, y) ∧ (closest_pair x y ps) := begin
  intros c ps xy h_cp_help h_cp_in_ball_union,
  cases h_cp_help with p h_cp_help,
  cases h_cp_help with q h_cp_help,
  unfold cp_with_help closest_pair at h_cp_help,
  have xy_leq_pq : xy ≤ some (p, q) := begin
    fapply cp_in_ball_union_closer_than_all_pts_in_dist_c,
    exact c,
    exact ps,
    exact ps,
    refl,
    exact h_cp_help.left.left,
    unfold pt_in_ball,
    repeat {split},
    exact h_cp_help.left.right.left,
    apply ne.symm,
    exact h_cp_help.left.right.right.left,
    rw [point_norm_sub_comm],
    exact h_cp_help.right.right,
    assumption,
  end,
  have xy_is_some : ∃ (x y : point), xy = some (x, y) := begin
    apply option_pt_le_some_eq_some,
    exact xy_leq_pq,
  end,
  cases xy_is_some with x xy_is_some,
  cases xy_is_some with y xy_is_some,
  have x_sub_y_leq_p_sub_q : ∥x - y∥ ≤ ∥p - q∥ := begin
    rw [xy_is_some] at xy_leq_pq,
    simp [has_le.le, point_le] at xy_leq_pq ⊢,
    exact xy_leq_pq,
  end,
  have xy_closest : closest_pair x y ps := begin
    unfold closest_pair,
    have xy_in_pt_list_and_neq : x ∈ ps ∧ y ∈ ps ∧ x ≠ y := begin
      apply some_cp_in_balls_in_pt_list_and_neq,
      exact xy_is_some,
      exact h_cp_in_ball_union,
    end,
    repeat {split},
    { exact xy_in_pt_list_and_neq.left, },
    { exact xy_in_pt_list_and_neq.right.left, },
    { exact xy_in_pt_list_and_neq.right.right, },
    {
      intros r s r_neq_s,
      have pq_le_rs : ∥p - q∥ ≤ ∥r - s∥ := begin
        apply h_cp_help.left.right.right.right,
        exact r_neq_s,
      end,
      apply int_le_trans,
      exact x_sub_y_leq_p_sub_q,
      exact pq_le_rs,
    }
  end,
  fapply exists.intro,
  exact x,
  fapply exists.intro,
  exact y,
  exact ⟨xy_is_some, xy_closest⟩,
end

lemma aux_gives_closest_pair:
  ∀ (g : grid_2D),
    (∃ (p q : point),
      cp_with_help p q g.ps g.c) →
    (∃ (p q : point),
      aux g g.ps = some (p, q)
      ∧ closest_pair p q g.ps) := begin
  intros g cp_help,
  apply cp_with_help_and_cp_in_balls_implies_closest_pair,
  assumption,
  apply aux_finds_closest_pair_in_ball_union,
  simp,
end

lemma grid_pts_dot_c_with_c_eq_c :
  ∀ (c : ℕ⁺) (ps : list point),
    (grid_points c ps).c = c := sorry

lemma grid_pts_dot_ps_with_ps_eq_ps :
  ∀ (c : ℕ⁺) (ps : list point),
    (grid_points c ps).ps = ps := sorry

theorem find_closest_pair_correct :
  ∀ (c : ℕ⁺) (ps : list point),
    -- If there's a closest pair within distance `c`
    (∃ (p q : point),
      cp_with_help p q ps c) →
    -- then our algorithm finds a closest pair.
    (∃ (p q : point),
      (find_closest_pair c ps) = some (p, q) ∧
      closest_pair p q ps) := begin
  intros c ps exists_pair,
  have aux_gives_closest :
    (∃ (p q : point),
        aux (grid_points c ps) ps = some (p, q)
        ∧ closest_pair p q ps) := begin
    have expand_ps : aux (grid_points c ps) ps = aux (grid_points c ps) (grid_points c ps).ps := begin
      congr,
      symmetry,
      apply grid_pts_dot_ps_with_ps_eq_ps,
    end,
    rw [expand_ps],
    have dumb_rw :
      (∃ (p q : point), aux (grid_points c ps) (grid_points c ps).ps = some (p, q) ∧ closest_pair p q (grid_points c ps).ps) →
      (∃ (p q : point), aux (grid_points c ps) (grid_points c ps).ps = some (p, q) ∧ closest_pair p q ps) := begin
      intros h,
      cases h with p h',
      cases h' with q h'',
      fapply exists.intro,
      exact p,
      fapply exists.intro,
      exact q,
      constructor,
      exact h''.left,
      rw [grid_pts_dot_ps_with_ps_eq_ps] at h'',
      exact h''.right,
    end,
    apply dumb_rw,
    apply aux_gives_closest_pair,
    rw [grid_pts_dot_ps_with_ps_eq_ps, grid_pts_dot_c_with_c_eq_c],
    assumption,
  end,
  cases aux_gives_closest with p aux_gives_closest,
  cases aux_gives_closest with q aux_gives_closest,

  fapply exists.intro,
  exact p,
  fapply exists.intro,
  exact q,

  simp [find_closest_pair],
  apply and.intro,
  {
    fapply exists.intro,
    exact p,
    fapply exists.intro,
    exact q,
    apply and.intro,
    exact aux_gives_closest.left,

    have aux_closest_dist_leq_c : (∥p - q∥ ≤ ↑c) := begin
      cases exists_pair with p' exists_pair,
      cases exists_pair with q' exists_pair,
      have aux_closer_than_cp : ∥p - q∥ ≤ ∥p' - q'∥ := begin
        unfold closest_pair at aux_gives_closest,
        apply aux_gives_closest.right.right.right.right,
        exact exists_pair.left.right.right.left,
      end,
      apply int_le_trans,
      exact aux_closer_than_cp,
      exact exists_pair.right.right,
    end,

    by_cases (↑c < ∥p - q∥),

    rw [←coe_to_ℕ_then_ℤ_eq_coe_to_ℤ] at h,
    simp [h],
    fapply not_leq_and_gt,
    exact (p - q),
    exact c,
    apply and.intro,
    exact aux_closest_dist_leq_c,
    exact h,
    rw [←coe_to_ℕ_then_ℤ_eq_coe_to_ℤ] at h,
    simp [h],
  },
  {
    exact aux_gives_closest.right,
  }
end


/-
Copyright (c) 2020 Fox Thomson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Fox Thomson
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.set_theory.game.winner
import Mathlib.tactic.nth_rewrite.default
import Mathlib.tactic.equiv_rw
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Basic definitions about impartial (pre-)games

We will define an impartial game, one in which left and right can make exactly the same moves.
Our definition differs slightly by saying that the game is always equivalent to its negative,
no matter what moves are played. This allows for games such as poker-nim to be classifed as
impartial.
-/

namespace pgame

/-- The definition for a impartial game, defined using Conway induction -/
def impartial : pgame → Prop :=
  sorry

theorem impartial_def {G : pgame} : impartial G ↔
  equiv G (-G) ∧ (∀ (i : left_moves G), impartial (move_left G i)) ∧ ∀ (j : right_moves G), impartial (move_right G j) := sorry

namespace impartial

protected instance impartial_zero : impartial 0 := sorry

theorem neg_equiv_self (G : pgame) [h : impartial G] : equiv G (-G) :=
  and.left (iff.mp impartial_def h)

protected instance move_left_impartial {G : pgame} [h : impartial G] (i : left_moves G) : impartial (move_left G i) :=
  and.left (and.right (iff.mp impartial_def h)) i

protected instance move_right_impartial {G : pgame} [h : impartial G] (j : right_moves G) : impartial (move_right G j) :=
  and.right (and.right (iff.mp impartial_def h)) j

protected instance impartial_add (G : pgame) (H : pgame) [impartial G] [impartial H] : impartial (G + H) :=
  sorry

protected instance impartial_neg (G : pgame) [impartial G] : impartial (-G) :=
  sorry

theorem winner_cases (G : pgame) [impartial G] : first_loses G ∨ first_wins G := sorry

theorem not_first_wins (G : pgame) [impartial G] : ¬first_wins G ↔ first_loses G := sorry

theorem not_first_loses (G : pgame) [impartial G] : ¬first_loses G ↔ first_wins G :=
  iff.symm (iff.mp iff_not_comm (iff.symm (not_first_wins G)))

theorem add_self (G : pgame) [impartial G] : first_loses (G + G) :=
  iff.mpr first_loses_is_zero (equiv_trans (add_congr (neg_equiv_self G) (equiv_refl G)) add_left_neg_equiv)

theorem equiv_iff_sum_first_loses (G : pgame) (H : pgame) [impartial G] [impartial H] : equiv G H ↔ first_loses (G + H) := sorry

theorem le_zero_iff {G : pgame} [impartial G] : G ≤ 0 ↔ 0 ≤ G :=
  eq.mpr (id (Eq._oldrec (Eq.refl (G ≤ 0 ↔ 0 ≤ G)) (propext le_zero_iff_zero_le_neg)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (0 ≤ -G ↔ 0 ≤ G)) (propext (le_congr (equiv_refl 0) (neg_equiv_self G)))))
      (iff.refl (0 ≤ -G)))

theorem lt_zero_iff {G : pgame} [impartial G] : G < 0 ↔ 0 < G := sorry

theorem first_loses_symm (G : pgame) [impartial G] : first_loses G ↔ G ≤ 0 :=
  { mp := and.left, mpr := fun (h : G ≤ 0) => { left := h, right := iff.mp le_zero_iff h } }

theorem first_wins_symm (G : pgame) [impartial G] : first_wins G ↔ G < 0 :=
  { mp := and.right, mpr := fun (h : G < 0) => { left := iff.mp lt_zero_iff h, right := h } }

theorem first_loses_symm' (G : pgame) [impartial G] : first_loses G ↔ 0 ≤ G :=
  { mp := and.right, mpr := fun (h : 0 ≤ G) => { left := iff.mpr le_zero_iff h, right := h } }

theorem first_wins_symm' (G : pgame) [impartial G] : first_wins G ↔ 0 < G :=
  { mp := and.left, mpr := fun (h : 0 < G) => { left := h, right := iff.mpr lt_zero_iff h } }

theorem no_good_left_moves_iff_first_loses (G : pgame) [impartial G] : (∀ (i : left_moves G), first_wins (move_left G i)) ↔ first_loses G := sorry

theorem no_good_right_moves_iff_first_loses (G : pgame) [impartial G] : (∀ (j : right_moves G), first_wins (move_right G j)) ↔ first_loses G := sorry

theorem good_left_move_iff_first_wins (G : pgame) [impartial G] : (∃ (i : left_moves G), first_loses (move_left G i)) ↔ first_wins G := sorry

theorem good_right_move_iff_first_wins (G : pgame) [impartial G] : (∃ (j : right_moves G), first_loses (move_right G j)) ↔ first_wins G := sorry


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.concrete_category.bundled_hom
import algebra.punit_instances
import category_theory.functor.reflects_isomorphisms

/-!
# Category instances for monoid, add_monoid, comm_monoid, and add_comm_monoid.

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

We introduce the bundled categories:
* `Mon`
* `AddMon`
* `CommMon`
* `AddCommMon`
along with the relevant forgetful functors between them.
-/

universes u v

open category_theory

/-- The category of monoids and monoid morphisms. -/
@[to_additive AddMon]
def Mon : Type (u+1) := bundled monoid

/-- The category of additive monoids and monoid morphisms. -/
add_decl_doc AddMon

namespace Mon

/-- `monoid_hom` doesn't actually assume associativity. This alias is needed to make the category
theory machinery work. -/
@[to_additive "`add_monoid_hom` doesn't actually assume associativity. This alias is needed to make
the category theory machinery work."]
abbreviation assoc_monoid_hom (M N : Type*) [monoid M] [monoid N] := monoid_hom M N

@[to_additive]
instance bundled_hom : bundled_hom assoc_monoid_hom :=
⟨λ M N [monoid M] [monoid N], by exactI @monoid_hom.to_fun M N _ _,
 λ M [monoid M], by exactI @monoid_hom.id M _,
 λ M N P [monoid M] [monoid N] [monoid P], by exactI @monoid_hom.comp M N P _ _ _,
 λ M N [monoid M] [monoid N], by exactI @monoid_hom.coe_inj M N _ _⟩

attribute [derive [large_category, concrete_category]] Mon
attribute [to_additive] Mon.large_category Mon.concrete_category

@[to_additive] instance : has_coe_to_sort Mon Type* := bundled.has_coe_to_sort

/-- Construct a bundled `Mon` from the underlying type and typeclass. -/
@[to_additive]
def of (M : Type u) [monoid M] : Mon := bundled.of M

/-- Construct a bundled `Mon` from the underlying type and typeclass. -/
add_decl_doc AddMon.of

/-- Typecheck a `monoid_hom` as a morphism in `Mon`. -/
@[to_additive] def of_hom {X Y : Type u} [monoid X] [monoid Y] (f : X →* Y) :
  of X ⟶ of Y := f

/-- Typecheck a `add_monoid_hom` as a morphism in `AddMon`. -/
add_decl_doc AddMon.of_hom

@[simp] lemma of_hom_apply {X Y : Type u} [monoid X] [monoid Y] (f : X →* Y)
  (x : X) : of_hom f x = f x := rfl

@[to_additive]
instance : inhabited Mon :=
-- The default instance for `monoid punit` is derived via `punit.comm_ring`,
-- which breaks to_additive.
⟨@of punit $ @group.to_monoid _ $ @comm_group.to_group _ punit.comm_group⟩

@[to_additive]
instance (M : Mon) : monoid M := M.str

@[simp, to_additive] lemma coe_of (R : Type u) [monoid R] : (Mon.of R : Type u) = R := rfl

@[to_additive] instance {G : Type*} [group G] : group (Mon.of G) := by assumption

end Mon

/-- The category of commutative monoids and monoid morphisms. -/
@[to_additive AddCommMon]
def CommMon : Type (u+1) := bundled comm_monoid

/-- The category of additive commutative monoids and monoid morphisms. -/
add_decl_doc AddCommMon

namespace CommMon

@[to_additive]
instance : bundled_hom.parent_projection comm_monoid.to_monoid := ⟨⟩

attribute [derive [large_category, concrete_category]] CommMon
attribute [to_additive] CommMon.large_category CommMon.concrete_category

@[to_additive] instance : has_coe_to_sort CommMon Type* := bundled.has_coe_to_sort

/-- Construct a bundled `CommMon` from the underlying type and typeclass. -/
@[to_additive]
def of (M : Type u) [comm_monoid M] : CommMon := bundled.of M

/-- Construct a bundled `AddCommMon` from the underlying type and typeclass. -/
add_decl_doc AddCommMon.of

@[to_additive]
instance : inhabited CommMon :=
-- The default instance for `comm_monoid punit` is derived via `punit.comm_ring`,
-- which breaks to_additive.
⟨@of punit $ @comm_group.to_comm_monoid _ punit.comm_group⟩

@[to_additive]
instance (M : CommMon) : comm_monoid M := M.str

@[simp, to_additive] lemma coe_of (R : Type u) [comm_monoid R] : (CommMon.of R : Type u) = R := rfl

@[to_additive has_forget_to_AddMon]
instance has_forget_to_Mon : has_forget₂ CommMon Mon := bundled_hom.forget₂ _ _

@[to_additive] instance : has_coe CommMon.{u} Mon.{u} :=
{ coe := (forget₂ CommMon Mon).obj, }

end CommMon

-- We verify that the coercions of morphisms to functions work correctly:
example {R S : Mon}     (f : R ⟶ S) : (R : Type) → (S : Type) := f
example {R S : CommMon} (f : R ⟶ S) : (R : Type) → (S : Type) := f

-- We verify that when constructing a morphism in `CommMon`,
-- when we construct the `to_fun` field, the types are presented as `↥R`,
-- rather than `R.α` or (as we used to have) `↥(bundled.map comm_monoid.to_monoid R)`.
example (R : CommMon.{u}) : R ⟶ R :=
{ to_fun := λ x,
  begin
    match_target (R : Type u),
    match_hyp x : (R : Type u),
    exact x * x
  end ,
  map_one' := by simp,
  map_mul' := λ x y,
  begin rw [mul_assoc x y (x * y), ←mul_assoc y x y, mul_comm y x, mul_assoc, mul_assoc], end, }

variables {X Y : Type u}

section
variables [monoid X] [monoid Y]

/-- Build an isomorphism in the category `Mon` from a `mul_equiv` between `monoid`s. -/
@[to_additive add_equiv.to_AddMon_iso "Build an isomorphism in the category `AddMon` from
an `add_equiv` between `add_monoid`s.", simps]
def mul_equiv.to_Mon_iso (e : X ≃* Y) : Mon.of X ≅ Mon.of Y :=
{ hom := e.to_monoid_hom,
  inv := e.symm.to_monoid_hom }

end

section
variables [comm_monoid X] [comm_monoid Y]

/-- Build an isomorphism in the category `CommMon` from a `mul_equiv` between `comm_monoid`s. -/
@[to_additive add_equiv.to_AddCommMon_iso "Build an isomorphism in the category `AddCommMon`
from an `add_equiv` between `add_comm_monoid`s.", simps]
def mul_equiv.to_CommMon_iso (e : X ≃* Y) : CommMon.of X ≅ CommMon.of Y :=
{ hom := e.to_monoid_hom,
  inv := e.symm.to_monoid_hom }

end

namespace category_theory.iso

/-- Build a `mul_equiv` from an isomorphism in the category `Mon`. -/
@[to_additive AddMon_iso_to_add_equiv "Build an `add_equiv` from an isomorphism in the category
`AddMon`."]
def Mon_iso_to_mul_equiv {X Y : Mon} (i : X ≅ Y) : X ≃* Y :=
i.hom.to_mul_equiv i.inv i.hom_inv_id i.inv_hom_id

/-- Build a `mul_equiv` from an isomorphism in the category `CommMon`. -/
@[to_additive "Build an `add_equiv` from an isomorphism in the category
`AddCommMon`."]
def CommMon_iso_to_mul_equiv {X Y : CommMon} (i : X ≅ Y) : X ≃* Y :=
i.hom.to_mul_equiv i.inv i.hom_inv_id i.inv_hom_id

end category_theory.iso

/-- multiplicative equivalences between `monoid`s are the same as (isomorphic to) isomorphisms
in `Mon` -/
@[to_additive add_equiv_iso_AddMon_iso "additive equivalences between `add_monoid`s are the same
as (isomorphic to) isomorphisms in `AddMon`"]
def mul_equiv_iso_Mon_iso {X Y : Type u} [monoid X] [monoid Y] :
  (X ≃* Y) ≅ (Mon.of X ≅ Mon.of Y) :=
{ hom := λ e, e.to_Mon_iso,
  inv := λ i, i.Mon_iso_to_mul_equiv, }

/-- multiplicative equivalences between `comm_monoid`s are the same as (isomorphic to) isomorphisms
in `CommMon` -/
@[to_additive add_equiv_iso_AddCommMon_iso "additive equivalences between `add_comm_monoid`s are
the same as (isomorphic to) isomorphisms in `AddCommMon`"]
def mul_equiv_iso_CommMon_iso {X Y : Type u} [comm_monoid X] [comm_monoid Y] :
  (X ≃* Y) ≅ (CommMon.of X ≅ CommMon.of Y) :=
{ hom := λ e, e.to_CommMon_iso,
  inv := λ i, i.CommMon_iso_to_mul_equiv, }

@[to_additive]
instance Mon.forget_reflects_isos : reflects_isomorphisms (forget Mon.{u}) :=
{ reflects := λ X Y f _,
  begin
    resetI,
    let i := as_iso ((forget Mon).map f),
    let e : X ≃* Y := { ..f, ..i.to_equiv },
    exact ⟨(is_iso.of_iso e.to_Mon_iso).1⟩,
  end }

@[to_additive]
instance CommMon.forget_reflects_isos : reflects_isomorphisms (forget CommMon.{u}) :=
{ reflects := λ X Y f _,
  begin
    resetI,
    let i := as_iso ((forget CommMon).map f),
    let e : X ≃* Y := { ..f, ..i.to_equiv },
    exact ⟨(is_iso.of_iso e.to_CommMon_iso).1⟩,
  end }

/-!
Once we've shown that the forgetful functors to type reflect isomorphisms,
we automatically obtain that the `forget₂` functors between our concrete categories
reflect isomorphisms.
-/
example : reflects_isomorphisms (forget₂ CommMon Mon) := by apply_instance


/-
Copyright (c) 2018 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton, Scott Morrison
-/
import category_theory.opposites

/-!
# Morphisms from equations between objects.

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

When working categorically, sometimes one encounters an equation `h : X = Y` between objects.

Your initial aversion to this is natural and appropriate:
you're in for some trouble, and if there is another way to approach the problem that won't
rely on this equality, it may be worth pursuing.

You have two options:
1. Use the equality `h` as one normally would in Lean (e.g. using `rw` and `subst`).
   This may immediately cause difficulties, because in category theory everything is dependently
   typed, and equations between objects quickly lead to nasty goals with `eq.rec`.
2. Promote `h` to a morphism using `eq_to_hom h : X ⟶ Y`, or `eq_to_iso h : X ≅ Y`.

This file introduces various `simp` lemmas which in favourable circumstances
result in the various `eq_to_hom` morphisms to drop out at the appropriate moment!
-/

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

namespace category_theory
open opposite

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

/--
An equality `X = Y` gives us a morphism `X ⟶ Y`.

It is typically better to use this, rather than rewriting by the equality then using `𝟙 _`
which usually leads to dependent type theory hell.
-/
def eq_to_hom {X Y : C} (p : X = Y) : X ⟶ Y := by rw p; exact 𝟙 _

@[simp] lemma eq_to_hom_refl (X : C) (p : X = X) : eq_to_hom p = 𝟙 X := rfl
@[simp, reassoc] lemma eq_to_hom_trans {X Y Z : C} (p : X = Y) (q : Y = Z) :
  eq_to_hom p ≫ eq_to_hom q = eq_to_hom (p.trans q) :=
by { cases p, cases q, simp, }

lemma comp_eq_to_hom_iff {X Y Y' : C} (p : Y = Y') (f : X ⟶ Y) (g : X ⟶ Y') :
  f ≫ eq_to_hom p = g ↔ f = g ≫ eq_to_hom p.symm :=
{ mp := λ h, h ▸ by simp,
  mpr := λ h, by simp [eq_whisker h (eq_to_hom p)] }

lemma eq_to_hom_comp_iff {X X' Y : C} (p : X = X') (f : X ⟶ Y) (g : X' ⟶ Y) :
  eq_to_hom p ≫ g = f ↔ g = eq_to_hom p.symm ≫ f :=
{ mp := λ h, h ▸ by simp,
  mpr := λ h, h ▸ by simp [whisker_eq _ h] }

/--
If we (perhaps unintentionally) perform equational rewriting on
the source object of a morphism,
we can replace the resulting `_.mpr f` term by a composition with an `eq_to_hom`.

It may be advisable to introduce any necessary `eq_to_hom` morphisms manually,
rather than relying on this lemma firing.
-/
@[simp]
lemma congr_arg_mpr_hom_left {X Y Z : C} (p : X = Y) (q : Y ⟶ Z) :
  (congr_arg (λ W : C, W ⟶ Z) p).mpr q = eq_to_hom p ≫ q :=
by { cases p, simp, }

/--
If we (perhaps unintentionally) perform equational rewriting on
the target object of a morphism,
we can replace the resulting `_.mpr f` term by a composition with an `eq_to_hom`.

It may be advisable to introduce any necessary `eq_to_hom` morphisms manually,
rather than relying on this lemma firing.
-/
@[simp]
lemma congr_arg_mpr_hom_right {X Y Z : C} (p : X ⟶ Y) (q : Z = Y) :
  (congr_arg (λ W : C, X ⟶ W) q).mpr p = p ≫ eq_to_hom q.symm :=
by { cases q, simp, }

/--
An equality `X = Y` gives us an isomorphism `X ≅ Y`.

It is typically better to use this, rather than rewriting by the equality then using `iso.refl _`
which usually leads to dependent type theory hell.
-/
def eq_to_iso {X Y : C} (p : X = Y) : X ≅ Y :=
⟨eq_to_hom p, eq_to_hom p.symm, by simp, by simp⟩

@[simp] lemma eq_to_iso.hom {X Y : C} (p : X = Y) : (eq_to_iso p).hom = eq_to_hom p :=
rfl
@[simp] lemma eq_to_iso.inv {X Y : C} (p : X = Y) : (eq_to_iso p).inv = eq_to_hom p.symm :=
rfl

@[simp]

@[simp] lemma eq_to_hom_op {X Y : C} (h : X = Y) :
  (eq_to_hom h).op = eq_to_hom (congr_arg op h.symm) :=
by { cases h, refl, }

@[simp] lemma eq_to_hom_unop {X Y : Cᵒᵖ} (h : X = Y) :
  (eq_to_hom h).unop = eq_to_hom (congr_arg unop h.symm) :=
by { cases h, refl, }

instance {X Y : C} (h : X = Y) : is_iso (eq_to_hom h) := is_iso.of_iso (eq_to_iso h)

@[simp] lemma inv_eq_to_hom {X Y : C} (h : X = Y) : inv (eq_to_hom h) = eq_to_hom h.symm :=
by { ext, simp, }

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

namespace functor

/-- Proving equality between functors. This isn't an extensionality lemma,
  because usually you don't really want to do this. -/
lemma ext {F G : C ⥤ D} (h_obj : ∀ X, F.obj X = G.obj X)
  (h_map : ∀ X Y f, F.map f = eq_to_hom (h_obj X) ≫ G.map f ≫ eq_to_hom (h_obj Y).symm) :
  F = G :=
begin
  cases F with F_obj _ _ _, cases G with G_obj _ _ _,
  obtain rfl : F_obj = G_obj, by { ext X, apply h_obj },
  congr,
  funext X Y f,
  simpa using h_map X Y f
end

/-- Two morphisms are conjugate via eq_to_hom if and only if they are heterogeneously equal. -/
lemma conj_eq_to_hom_iff_heq {W X Y Z : C} (f : W ⟶ X) (g : Y ⟶ Z) (h : W = Y) (h' : X = Z) :
  f = eq_to_hom h ≫ g ≫ eq_to_hom h'.symm ↔ f == g :=
by { cases h, cases h', simp }

/-- Proving equality between functors using heterogeneous equality. -/
lemma hext {F G : C ⥤ D} (h_obj : ∀ X, F.obj X = G.obj X)
  (h_map : ∀ X Y (f : X ⟶ Y), F.map f == G.map f) : F = G :=
functor.ext h_obj (λ _ _ f,
  (conj_eq_to_hom_iff_heq _ _ (h_obj _) (h_obj _)).2 $ h_map _ _ f)

-- Using equalities between functors.

lemma congr_obj {F G : C ⥤ D} (h : F = G) (X) : F.obj X = G.obj X :=
by subst h

lemma congr_hom {F G : C ⥤ D} (h : F = G) {X Y} (f : X ⟶ Y) :
  F.map f = eq_to_hom (congr_obj h X) ≫ G.map f ≫ eq_to_hom (congr_obj h Y).symm :=
by subst h; simp

lemma congr_inv_of_congr_hom (F G : C ⥤ D) {X Y : C} (e : X ≅ Y)
  (hX : F.obj X = G.obj X) (hY : F.obj Y = G.obj Y)
  (h₂ : F.map e.hom = eq_to_hom (by rw hX) ≫ G.map e.hom ≫ eq_to_hom (by rw hY)) :
F.map e.inv = eq_to_hom (by rw hY) ≫ G.map e.inv ≫ eq_to_hom (by rw hX) :=
by simp only [← is_iso.iso.inv_hom e, functor.map_inv, h₂, is_iso.inv_comp,
  inv_eq_to_hom, category.assoc]

lemma congr_map (F : C ⥤ D) {X Y : C} {f g : X ⟶ Y} (h : f = g) :
  F.map f = F.map g := by rw h

section heq

/- Composition of functors and maps w.r.t. heq -/

variables {E : Type u₃} [category.{v₃} E] {F G : C ⥤ D} {X Y Z : C} {f : X ⟶ Y} {g : Y ⟶ Z}

lemma map_comp_heq (hx : F.obj X = G.obj X) (hy : F.obj Y = G.obj Y) (hz : F.obj Z = G.obj Z)
  (hf : F.map f == G.map f) (hg : F.map g == G.map g) : F.map (f ≫ g) == G.map (f ≫ g) :=
by { rw [F.map_comp, G.map_comp], congr' }

lemma map_comp_heq' (hobj : ∀ X : C, F.obj X = G.obj X)
  (hmap : ∀ {X Y} (f : X ⟶ Y), F.map f == G.map f) :
  F.map (f ≫ g) == G.map (f ≫ g) :=
by rw functor.hext hobj (λ _ _, hmap)

lemma precomp_map_heq (H : E ⥤ C)
  (hmap : ∀ {X Y} (f : X ⟶ Y), F.map f == G.map f) {X Y : E} (f : X ⟶ Y) :
  (H ⋙ F).map f == (H ⋙ G).map f := hmap _

lemma postcomp_map_heq (H : D ⥤ E) (hx : F.obj X = G.obj X) (hy : F.obj Y = G.obj Y)
  (hmap : F.map f == G.map f) : (F ⋙ H).map f == (G ⋙ H).map f :=
by { dsimp, congr' }

lemma postcomp_map_heq' (H : D ⥤ E) (hobj : ∀ X : C, F.obj X = G.obj X)
  (hmap : ∀ {X Y} (f : X ⟶ Y), F.map f == G.map f) :
  (F ⋙ H).map f == (G ⋙ H).map f :=
by rw functor.hext hobj (λ _ _, hmap)

lemma hcongr_hom {F G : C ⥤ D} (h : F = G) {X Y} (f : X ⟶ Y) : F.map f == G.map f :=
by subst h

end heq

end functor

/--
This is not always a good idea as a `@[simp]` lemma,
as we lose the ability to use results that interact with `F`,
e.g. the naturality of a natural transformation.

In some files it may be appropriate to use `local attribute [simp] eq_to_hom_map`, however.
-/
lemma eq_to_hom_map (F : C ⥤ D) {X Y : C} (p : X = Y) :
  F.map (eq_to_hom p) = eq_to_hom (congr_arg F.obj p) :=
by cases p; simp

/--
See the note on `eq_to_hom_map` regarding using this as a `simp` lemma.
-/
lemma eq_to_iso_map (F : C ⥤ D) {X Y : C} (p : X = Y) :
  F.map_iso (eq_to_iso p) = eq_to_iso (congr_arg F.obj p) :=
by ext; cases p; simp

@[simp] lemma eq_to_hom_app {F G : C ⥤ D} (h : F = G) (X : C) :
  (eq_to_hom h : F ⟶ G).app X = eq_to_hom (functor.congr_obj h X) :=
by subst h; refl

lemma nat_trans.congr {F G : C ⥤ D} (α : F ⟶ G) {X Y : C} (h : X = Y) :
  α.app X = F.map (eq_to_hom h) ≫ α.app Y ≫ G.map (eq_to_hom h.symm) :=
by { rw [α.naturality_assoc], simp [eq_to_hom_map], }

lemma eq_conj_eq_to_hom {X Y : C} (f : X ⟶ Y) :
  f = eq_to_hom rfl ≫ f ≫ eq_to_hom rfl :=
by simp only [category.id_comp, eq_to_hom_refl, category.comp_id]

lemma dcongr_arg {ι : Type*} {F G : ι → C} (α : ∀ i, F i ⟶ G i) {i j : ι} (h : i = j) :
  α i = eq_to_hom (congr_arg F h) ≫ α j ≫ eq_to_hom (congr_arg G h.symm) :=
by { subst h, simp }

end category_theory