open nat

example (P : ℕ → Prop) (h₀ : P 0) (h₁ : ∀ n, P (succ n)) (m : ℕ) :
  P m :=
begin
  cases m with m',
  exact h₀,
  exact h₁ m'
end


import acomplete_binary_tree
import data.nat.log

set_option trace.simplify.rewrite true
set_option trace.simp_lemmas true
set_option eqn_compiler.zeta true

open tree

variable {α : Type}
variables {n: ℕ}
variables xs zs: list α
variable a: α
variables t: tree α

/-
# Converting a List into an Almost Complete Tree
Section 4.3.1 from __Functional Algorithms, Verified!__.
This section is not included in the Isabelle file.

## Definitions
-/

def bal [inhabited α]: ℕ → list α → tree α × list α
| n xs :=
  if h: n ≠ 0 then let
    m := n /2,
    (l, ys) :=
    have m < n, begin
      have h1: 0 < n, from nat.pos_of_ne_zero h,
      have h2: 1 < 2, by simp,
      exact nat.div_lt_self h1 h2,
    end,
    bal m xs,
    (r, zs) :=
    have n - 1 - m < n, begin
      have h1: 0 < (1 + m), by simp [nat.add_one_ne_zero m, nat.add_comm, nat.pos_of_ne_zero],
      have: m < n, by simp [nat.div_lt_self, nat.pos_of_ne_zero, *],
      have h2: 1 + m <= n, by linarith,
      rw nat.sub_sub n 1 m,
      exact nat.sub_lt_of_pos_le (1 + m) n h1 h2,
    end,
    bal (n - 1 - m) (ys.tail) in
    ((node ys.head l r), zs)
  else (nil, xs)

/-
Including nested let expressions in the definition of bal does not seem to work when using the definition in proofs.
Therefore, an alternative, but similar definition bal' without let expression,
is made and used in the proofs.
-/
def bal' [inhabited α]: ℕ → list α → tree α × list α
| n xs := begin
  apply if h: n ≠ 0 then
  have n - 1 - n /2 < n, begin
    have h1: 0 < (1 + n /2), by simp [nat.add_one_ne_zero (n/2), nat.add_comm, nat.pos_of_ne_zero],
    have: n / 2 < n, by simp [nat.div_lt_self, nat.pos_of_ne_zero, *],
    have h2: 1 + n /2 <= n, by linarith,
    rw nat.sub_sub n 1 (n/2),
    exact nat.sub_lt_of_pos_le (1 + n /2) n h1 h2,
  end,
  have n/2 < n, begin
    have h1: 0 < n, from nat.pos_of_ne_zero h,
    have h2: 1 < 2, by simp,
    exact nat.div_lt_self h1 h2,
  end,
  ((node (bal' (n/2) xs).snd.head (bal' (n/2) xs).fst (bal' (n - 1 - n/2) ((bal' (n/2) xs).snd.tail)).fst), (bal' (n - 1 - n/2) ((bal' (n/2) xs).snd.tail)).snd)
  else (nil, xs)
end

def bal_list [inhabited α]: ℕ → list α → tree α
| n xs := (bal' n xs).fst

def balance_list [inhabited α]: list α → tree α
| xs := bal_list xs.length xs

def bal_tree [inhabited α]: ℕ → tree α → tree α
| n t := bal_list n (inorder t)

def balance_tree [inhabited α]: tree α → tree α
| t := bal_tree (size t) t

/-
## Correctness

Lemma 4.9 from __Functional Algorithms, Verified!__
-/
lemma bal_prefix_suffix [inhabited α]:
  n <= xs.length ∧ bal' n xs = (t, zs) → xs = inorder t ++ zs ∧ size t = n :=
begin
  induction n using nat.strong_induction_on with n ih generalizing t zs xs,
  intro h,
  cases h,
  by_cases n=0,
  { have h2: bal' 0 xs = (t, zs), from eq.subst h h_right,
    have h3: bal' 0 xs = (nil, xs) := begin
      rw [bal', if_neg],
      simp,
    end,
    apply and.intro,
    { have: t = nil, by cc,
      simp [inorder, *],
      cc },
    simp *,
    cc },
  let l := (bal' (n/2) xs).fst,
  let ys := (bal' (n/2) xs).snd,
  let r := (bal' (n - 1 - n/2) ys.tail).fst,
  let as := (bal' (n - 1 - n/2) ys.tail).snd,
  have h1: 0 < n, from nat.pos_of_ne_zero h,
  have h1': 1 <= n, by linarith,
  have h1'': 1 < 2, by simp,
  have h2: n/2 < n, begin
    exact nat.div_lt_self h1 h1'',
  end,
  have h3': n/2 <= n, from le_of_lt h2,
  have h4': n/2 <= n - 1, by linarith,
  have h2' : 1 <= n - n/2, by by simp [add_le_of_le_tsub_right_of_le, le_tsub_of_add_le_left, *],
  have h3: n - 1 - n/2 < n, begin
    have h1: 0 < (1 + n/2), by simp [nat.add_one_ne_zero (n/2), nat.add_comm, nat.pos_of_ne_zero],
    have h2: 1 + n/2 <= n, from iff.elim_left (le_tsub_iff_right h3') h2',
    rw nat.sub_sub n 1 (n/2),
    exact nat.sub_lt_of_pos_le (1 + n/2) n h1 h2,
  end,
  have : bal' n xs = ((node ys.head l r), as) := by rw [bal', if_pos h],
  have h14: t = (node ys.head l r), by cc,
  have h13: zs = as, by cc,
  simp at ih,
  have h4: n/2 <= xs.length, from trans h3' h_left,
  have h5: bal' (n/2) xs = (l, ys), by simp,
  have ih': xs = inorder l ++ ys ∧ size l = n/2, from ih (n/2) h2 l ys xs h4 h5,
  cases ih',
  have h8: n <= ys.length + n/2, from calc
    n <= (xs).length : h_left
    ... = (inorder l ++ ys).length : by cc
    ... = n/2 + ys.length: by simp [list.length, ih'_right]
    ...= ys.length + n/2 : by ring,
  have h5': n - n/2 <= ys.length, by simp [h8],
  have h6: ys.length - 1 = ys.tail.length, by simp,
  have h7: 1 <= ys.length, from trans h2' h5',
  have h15: 0 < ys.length, by simp [nat.lt_of_succ_le, h7],
  have : ys.length = ys.tail.length + 1, from iff.elim_left (nat.sub_eq_iff_eq_add h7) h6,
  have h10: n - n/2 <= ys.tail.length + 1, by calc
    n - n/2 <= ys.length: by simp only [tsub_le_iff_right, h8]
    ... = ys.tail.length + 1: by cc,
  have h11: n - n/2 -1 <= ys.tail.length, by simp only [tsub_le_iff_right, h10],
  rw nat.sub.right_comm n (n/2) 1 at h11,
  have h12: bal' (n - 1 - n / 2) ys.tail = (r, zs), by simp [h13],
  have ih'':  ys.tail = inorder r ++ zs ∧ size r = n - 1 - n/2, from ih (n - 1 - n/2) h3 r zs ys.tail h11 h12,
  cases ih'',
  apply and.intro,
  { simp [h14, inorder],
    rw ← ih''_left,
    rw list.cons_head_tail,
    { exact ih'_left },
    exact list.ne_nil_of_length_pos h15 },
  simp  [h14, size, ih'_right, ih''_right],
  calc
    n / 2 + (n - 1 - n / 2) + 1 = n - 1 + 1: by rw add_tsub_cancel_of_le h4'
    ... = n : by rw tsub_add_cancel_of_le h1'
end

lemma inorder_bal_list_eq_take [inhabited α ] :
  n <= xs.length → inorder (bal_list n xs) = list.take n xs :=
begin
  intro h,
  rw [bal_list, bal'],
  split_ifs,
  { let l := (bal' (n/2) xs).fst,
    let ys := (bal' (n/2) xs).snd,
    let r := (bal' (n - 1 - n/2) ys.tail).fst,
    let zs := (bal' (n - 1 - n/2) ys.tail).snd,
    have h1: bal' n xs = ((node ys.head l r), zs) :=
    begin
      rw [bal', if_pos h_1],
    end,
    have h2:  n <= xs.length ∧ bal' n xs = (node ys.head l r,
 zs) → xs = inorder (node ys.head l r) ++ zs ∧ size (node ys.head l r) = n, from bal_prefix_suffix _ _ _ ,
    simp [h, h1] at h2,
    cases h2,
    have h3: (inorder (node ys.head l r)).length = n, by simp only [length_inorder, h2_right],
    have h4: list.take n xs = list.take n (inorder (node ys.head l r) ++ zs), from congr_arg (list.take n) h2_left,
    rw h4,
    rw list.take_left' h3 },
  simp at h_1,
  rw h_1,
  simp [list.take_zero]
end

lemma inorder_balance_list_eq_list [inhabited α] : inorder (balance_list xs) = xs :=
begin
  rw balance_list,
  simp [*, inorder_bal_list_eq_take],
end

lemma inorder_bal_tree_eq_take_inorder [inhabited α]:
  n <= size t → inorder (bal_tree n t) = list.take n (inorder t) :=
begin
  intro h,
  rw [bal_tree],
  simp [*, inorder_bal_list_eq_take],
end

lemma inorder_balance_tree_eq_inorder [inhabited α]: inorder (balance_tree t) = inorder t:=
begin
  rw balance_tree,
  simp [*, inorder_bal_tree_eq_take_inorder, ← length_inorder],
end

/-
This lemma is used in lemma 4.10 and 4.11
-/
lemma bal_length [inhabited α]:
  n <= xs.length ∧ bal' n xs = (t, zs) → xs.length = zs.length + n :=
begin
  intro h,
  have : xs = inorder t ++ zs ∧ size t = n, by simp [bal_prefix_suffix xs zs t h],
  simp [*, add_comm],
end

/-
Lemma 4.10 from __Functional Algorithms, Verified!__
-/
lemma bal_height [inhabited α] :
  n <= xs.length ∧ bal' n xs = (t, zs) → height t = nat.clog 2 (n + 1):=
begin
  induction n using nat.strong_induction_on with n ih generalizing t zs xs,
  intro h,
  cases h,
  by_cases n=0,
  { simp *,
    have : bal' 0 xs = (nil, xs) := begin
      rw [bal', if_neg],
      simp,
    end,
    cc },
  have h1: 0 < n, from nat.pos_of_ne_zero h,
  have h2 : 1 <= n, by simp [nat.add_one_le_iff, h1],
  have h3: n/2 < n, by simp [nat.div_lt_self h1],
  have h5: 1 + n/2 <= n, by simp [nat.one_add_le_iff, h3],
  have h6: n - 1 - n/2 < n, begin
    have h7: 0 < (1 + n/2), by simp [nat.add_one_ne_zero (n/2), nat.add_comm, nat.pos_of_ne_zero],
    rw nat.sub_sub n 1 (n/2),
    exact nat.sub_lt_of_pos_le (1 + n/2) n h7 h5,
  end,
  let l := (bal' (n/2) xs).fst,
  let ys := (bal' (n/2) xs).snd,
  let r := (bal' (n - 1 - n/2) ys.tail).fst,
  let as := (bal' (n - 1 - n/2) ys.tail).snd,
  have : bal' n xs = ((node ys.head l r), as), by rw [bal', if_pos h],
  have h8: t = (node ys.head l r), by cc,
  have h9: zs = as, by cc,
  simp at ih,
  have h10: n/2 <= xs.length, from le_of_lt (lt_of_lt_of_le h3 h_left),
  have h11: bal' (n/2) xs = (l, ys), by simp,
  have ih': height l = nat.clog 2 (n/2 + 1), from ih (n/2) h3 l ys xs h10 h11,
  have h12: xs.length = ys.length + n/2, from bal_length xs ys l ⟨ h10, h11⟩ ,
  have h13: n - 1 - n/2 <= ys.tail.length, from calc
    n - 1 - n/2 = n - (1 + n/2): by rw nat.sub_sub n 1 (n/2)
    ... <= xs.length - (1 + n/2) : nat.sub_le_sub_right h_left (1 + n/2)
    ... = ys.length + n/2 - (1 + n/2): by rw h12
    ...= ys.length + n/2 - 1 - n/2: by rw ← nat.sub_sub (ys.length + n/2) 1 (n/2)
    ... = ys.length + n/2 - n/2 - 1: by rw nat.sub.right_comm (ys.length + n/2) 1 (n/2)
    ... = ys.length - 1: by simp
    ... = ys.tail.length: by simp,
  have h14: bal' (n - 1 - n / 2) ys.tail = (r, as), by simp [-tsub_le_iff_right],
  have ih'': height r = nat.clog 2 ((n - 1 - n/2) + 1), from ih (n - 1 - n/2) h6 r as ys.tail h13 h14,
  have h15: nat.clog 2 (n - 1 - n / 2 + 1) <= nat.clog 2 (n/2 + 1), begin
    apply nat.clog_le_clog_of_le,
    simp,
    ring,
    have h16: n < ( n / 2) * 2 + 2, by simp [nat.lt_div_mul_add],
    rw mul_comm,
    rw nat.lt_add_one_iff at h16,
    exact h16
  end,
  rw [← ih', ← ih''] at h15,
  have h17: 2 <= n + 1, by simp [nat.add_le_add_right h2 1],
  have h18: nat.clog 2 (n + 1) = nat.clog 2 ((n+1 + 2 - 1)/2) + 1, by simp [nat.clog_of_two_le _ h17],
  have h19: (n + 1 + 2 - 1)/2 = n / 2 + 1 := begin
    calc
    (n + 1 + 2 - 1)/2 = ( n + 2) /2 : by ring
    ... = n/2 + 1: by simp
  end,
  rw h19 at h18,
  calc
    height t = max (height l) (height r) + 1: by simp [h8, height]
    ... = height l + 1: by {simp, exact h15}
    ... = nat.clog 2 (n/2 + 1) + 1 : by rw ih'
    ... = nat.clog 2 (n + 1): by rw ← h18
end

lemma eq_div2_add_div2 {n:ℕ }: (n + 1) / 2 + n /2 = n :=
begin
  induction n with n ih,
  { ring},
  simp [nat.succ_eq_add_one],
  ring,
  simp [nat.succ_eq_add_one],
  rw add_comm (n/2 + 1),
  rw ← add_assoc,
  simp [nat.add_one] at *,
  exact ih,
end

/-
Lemma 4.11 from __Functional Algorithms, Verified!__
-/
lemma bal_min_height [inhabited α] :
  n <= xs.length ∧ bal' n xs = (t, zs) → min_height t = nat.log 2 (n + 1):=
begin
  induction n using nat.strong_induction_on with n ih generalizing t zs xs,
  intro h,
  cases h,
  by_cases n=0,
  { simp *,
    have : bal' 0 xs = (nil, xs) := begin
      rw [bal', if_neg],
      simp,
    end,
    rw h at h_right,
    have h1: t = nil, by cc,
    simp [min_height, *] },
  have h1: 0 < n, from nat.pos_of_ne_zero h,
  have h2 : 1 <= n, by simp [nat.add_one_le_iff, h1],
  have h3: n/2 < n, by simp [nat.div_lt_self h1],
  have h5: 1 + n/2 <= n, by simp [nat.one_add_le_iff, h3],
  have h6: n - 1 - n/2 < n, begin
    have h7: 0 < (1 + n/2), by simp [nat.add_one_ne_zero (n/2), nat.add_comm, nat.pos_of_ne_zero],
    rw nat.sub_sub n 1 (n/2),
    exact nat.sub_lt_of_pos_le (1 + n/2) n h7 h5,
  end,
  let l := (bal' (n/2) xs).fst,
  let ys := (bal' (n/2) xs).snd,
  let r := (bal' (n - 1 - n/2) ys.tail).fst,
  let as := (bal' (n - 1 - n/2) ys.tail).snd,
  have : bal' n xs = ((node ys.head l r), as), by rw [bal', if_pos h],
  have h8: t = (node ys.head l r), by cc,
  have h9: zs = as, by cc,
  simp at ih,
  have h10: n/2 <= xs.length, from le_of_lt (lt_of_lt_of_le h3 h_left),
  have h11: bal' (n/2) xs = (l, ys), by simp,
  have ih': min_height l = nat.log 2 (n/2 + 1), from ih (n/2) h3 l ys xs h10 h11,
  have h12: xs.length = ys.length + n/2, from bal_length xs ys l ⟨ h10, h11⟩ ,
  have h13: n - 1 - n/2 <= ys.tail.length, from calc
    n - 1 - n/2 = n - (1 + n/2): by rw nat.sub_sub n 1 (n/2)
    ... <= xs.length - (1 + n/2) : nat.sub_le_sub_right h_left (1 + n/2)
    ... = ys.length + n/2 - (1 + n/2): by rw h12
    ...= ys.length + n/2 - 1 - n/2: by rw ← nat.sub_sub (ys.length + n/2) 1 (n/2)
    ... = ys.length + n/2 - n/2 - 1: by rw nat.sub.right_comm (ys.length + n/2) 1 (n/2)
    ... = ys.length - 1: by simp
    ... = ys.tail.length: by simp,
  have h14: bal' (n - 1 - n / 2) ys.tail = (r, as), by simp [-tsub_le_iff_right],
  have ih'': min_height r = nat.log 2 ((n - 1 - n/2) + 1), from ih (n - 1 - n/2) h6 r as ys.tail h13 h14,
  have h15: nat.log 2 (n - 1 - n / 2 + 1) <= nat.log 2 (n/2 + 1), begin
    apply nat.log_le_log_of_le,
    simp,
    ring,
    have h16: n < ( n / 2) * 2 + 2, by simp [nat.lt_div_mul_add],
    rw mul_comm,
    rw nat.lt_add_one_iff at h16,
    exact h16
  end,
  rw [← ih', ← ih''] at h15,
  have h17: 2 <= n + 1, by simp [nat.add_le_add_right h2 1],
  have h17': 1 < 2, by simp,
  have h18: nat.log 2 (n + 1) = nat.log 2 ((n+1)/2) + 1, by simp [nat.log_of_one_lt_of_le h17' h17],
  have h19: (n + 1) / 2 = n - 1 - n/2 + 1 := begin
    have h21: n / 2 <= n, from le_of_lt h3,
    have h22: 1 <= n - n / 2, by {rw le_tsub_iff_right h21, exact h5},
    rw [nat.sub.right_comm n 1 (n/2), tsub_add_cancel_of_le h22 ],
    apply symm,
    rw nat.sub_eq_iff_eq_add h21,
    exact eq_div2_add_div2.symm,
  end,
  rw h19 at h18,
  calc
    min_height t = min (min_height l) (min_height r) + 1: by simp [h8, min_height]
    ... = min_height r + 1: by {simp, exact h15}
    ... = nat.log 2 (n - 1 - n / 2 + 1) + 1 : by rw ih''
    ... = nat.log 2 (n + 1): by rw ← h18
end

/-
This lemma is not proofed in  __Functional Algorithms, Verified!__,
but is needed for corollary 4.12
-/
lemma clog_sub_log_le_one {n: ℕ } : nat.clog 2 n - nat.log 2 n <= 1 :=
begin
  have h: 1 < 2, by simp,
  cases n,
  { simp },
  have h1: 0 < n.succ, by simp,
  have h2: 2 ^ nat.log 2 n.succ ≤ n.succ, from (nat.pow_log_le_self h ( nat.succ_pos n)),
  have h3: n.succ ≤ 2 ^ nat.clog 2 n.succ , from nat.le_pow_clog h n.succ,
  have h4: n.succ < 2 ^ (nat.log 2 n.succ).succ, from nat.lt_pow_succ_log_self h h1,
  have h5: 1 <= n.succ, by linarith,
  cases h5.lt_or_eq,
  { have h6: 2 ^ (nat.clog 2 n.succ).pred < n.succ, from nat.pow_pred_clog_lt_self h h_1,
    have h7: 2 ^ (nat.clog 2 n.succ).pred <  2 ^ (nat.log 2 n.succ).succ, from h6.trans h4,
    rw nat.pow_lt_iff_lt_right _ at h7,
    simp [tsub_le_iff_right, add_comm 1, nat.le_of_pred_lt h7] },
  rw ← h_1,
  simp,
end

/-
Corollary 4.12 from __Functional Algorithms, Verified!__
-/
lemma bal_acomplete [inhabited α ]: n <= xs.length ∧ bal' n xs = (t, zs) → acomplete t:=
begin
  intro h,
  rw acomplete,
  have h1: height t = nat.clog 2 (n + 1), from bal_height xs zs t h,
  have h2: min_height t = nat.log 2 (n + 1), from bal_min_height xs zs t h,
  rw [h1, h2],
  exact clog_sub_log_le_one,
end


import Mathlib.Tactic.LibrarySearch
import Mathlib.Util.AssertNoSorry
import Mathlib.Algebra.Order.Ring.Canonical

noncomputable section

set_option maxHeartbeats 400000 in
example (x : Nat) : x ≠ x.succ := ne_of_lt (by library_search)
example : 0 ≠ 1 + 1 := ne_of_lt (by library_search)
example (x y : Nat) : x + y = y + x := by library_search
example (n m k : Nat) : n ≤ m → n + k ≤ m + k := by library_search
example (ha : a > 0) (w : b ∣ c) : a * b ∣ a * c := by library_search

example : Int := by library_search

example : x < x + 1 := library_search%

example (P : Prop) (p : P) : P := by library_search
example (P : Prop) (p : P) (np : ¬P) : false := by library_search
example (X : Type) (P : Prop) (x : X) (h : ∀ x : X, x = x → P) : P := by library_search

example (α : Prop) : α → α := by library_search -- says: `exact id`

-- Note: these examples no longer work after we turned off lemmas with discrimination key `#[*]`.
-- example (p : Prop) : (¬¬p) → p := by library_search -- says: `exact not_not.mp`
-- example (a b : Prop) (h : a ∧ b) : a := by library_search -- says: `exact h.left`
-- example (P Q : Prop) : (¬ Q → ¬ P) → (P → Q) := by library_search -- say: `exact Function.mtr`

example (a b : ℕ) : a + b = b + a :=
by library_search -- says: `exact add_comm a b`

example (n m k : ℕ) : n * (m - k) = n * m - n * k :=
by library_search -- says: `exact Nat.mul_sub_left_distrib n m k`

example (n m k : ℕ) : n * m - n * k = n * (m - k) :=
by library_search -- says: `exact Eq.symm (mul_tsub n m k)`

example {α : Type} (x y : α) : x = y ↔ y = x := by library_search -- says: `exact eq_comm`

example (a b : ℕ) (ha : 0 < a) (_hb : 0 < b) : 0 < a + b := by library_search

section synonym

example (a b : ℕ) (ha : a > 0) (_hb : 0 < b) : 0 < a + b := by library_search

example (a b : ℕ) (h : a ∣ b) (w : b > 0) : a ≤ b :=
by library_search -- says: `exact Nat.le_of_dvd w h`

example (a b : ℕ) (h : a ∣ b) (w : b > 0) : b ≥ a := by library_search -- says: `exact Nat.le_of_dvd w h`

-- TODO: A lemma with head symbol `¬` can be used to prove `¬ p` or `⊥`
example (a : ℕ) : ¬ (a < 0) := by library_search -- says `exact not_lt_bot`
example (a : ℕ) (h : a < 0) : False := by library_search -- says `exact Nat.not_succ_le_zero a h`

-- An inductive type hides the constructor's arguments enough
-- so that `library_search` doesn't accidentally close the goal.
inductive P : ℕ → Prop
| gt_in_head {n : ℕ} : n < 0 → P n

-- This lemma with `>` as its head symbol should also be found for goals with head symbol `<`.
theorem lemma_with_gt_in_head (a : ℕ) (h : P a) : 0 > a := by cases h; assumption

-- This lemma with `false` as its head symbols should also be found for goals with head symbol `¬`.
theorem lemma_with_false_in_head (a b : ℕ) (_h1 : a < b) (h2 : P a) : False :=
by apply Nat.not_lt_zero; cases h2; assumption

example (a : ℕ) (h : P a) : 0 > a := by library_search -- says `exact lemma_with_gt_in_head a h`
example (a : ℕ) (h : P a) : a < 0 := by library_search -- says `exact lemma_with_gt_in_head a h`

example (a b : ℕ) (h1 : a < b) (h2 : P a) : False := by library_search -- says `exact lemma_with_false_in_head a b h1 h2`

-- TODO example (a b : ℕ) (h1 : a < b) : ¬ (P a) := by library_search -- says `exact lemma_with_false_in_head a b h1`

end synonym

example : ∀ P : Prop, ¬(P ↔ ¬P) := by library_search

-- We even find `iff` results:
example {a b c : ℕ} (h₁ : a ∣ c) (h₂ : a ∣ b + c) : a ∣ b := by library_search -- says `exact (Nat.dvd_add_iff_left h₁).mpr h₂`

-- Note: these examples no longer work after we turned off lemmas with discrimination key `#[*]`.
-- example {α : Sort u} (h : Empty) : α := by library_search -- says `exact Empty.elim h`
-- example (f : A → C) (g : B → C) : (A ⊕ B) → C := by library_search -- says `exact Sum.elim f g`
-- example (n : ℕ) (r : ℚ) : ℚ := by library_search using n, r -- exact nsmulRec n r

opaque f : ℕ → ℕ
axiom F (a b : ℕ) : f a ≤ f b ↔ a ≤ b
example (a b : ℕ) (h : a ≤ b) : f a ≤ f b := by library_search

example (L _M : List (List ℕ)) : List ℕ := by library_search using L

example (P _Q : List ℕ) (h : ℕ) : List ℕ := by library_search using h, P

example (l : List α) (f : α → β ⊕ γ) : List β × List γ := by
  library_search using f -- partitionMap f l

example (n m : ℕ) : ℕ := by library_search using n, m -- exact rightAdd n m

example (P Q : List ℕ) (_h : ℕ) : List ℕ :=
by library_search using P, Q -- exact P ∩ Q

-- Check that we don't use sorryAx:
-- (see https://github.com/leanprover-community/mathlib4/issues/226)

theorem Bool_eq_iff {A B: Bool} : (A = B) = (A ↔ B) :=
  by (cases A <;> cases B <;> simp)

theorem Bool_eq_iff2 {A B: Bool} : (A = B) = (A ↔ B) :=
  by library_search -- exact Bool_eq_iff

assert_no_sorry Bool_eq_iff2


/-
Copyright (c) 2018 Kevin Buzzard and Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Buzzard, Patrick Massot.

This file is to a certain extent based on `quotient_module.lean` by Johannes Hölzl.
-/
import group_theory.coset

universes u v

variables {G : Type u} [group G] (N : set G) [normal_subgroup N] {H : Type v} [group H]

namespace quotient_group

instance : group (quotient N) :=
{ one := (1 : G),
  mul := λ a b, quotient.lift_on₂' a b
    (λ a b, ((a * b : G) : quotient N))
  (λ a₁ a₂ b₁ b₂ hab₁ hab₂,
      quot.sound
    ((is_subgroup.mul_mem_cancel_left N (is_subgroup.inv_mem hab₂)).1
        (by rw [mul_inv_rev, mul_inv_rev, ← mul_assoc (a₂⁻¹ * a₁⁻¹),
          mul_assoc _ b₂, ← mul_assoc b₂, mul_inv_self, one_mul, mul_assoc (a₂⁻¹)];
          exact normal_subgroup.normal _ hab₁ _))),
  mul_assoc := λ a b c, quotient.induction_on₃' a b c
    (λ a b c, congr_arg mk (mul_assoc a b c)),
  one_mul := λ a, quotient.induction_on' a
    (λ a, congr_arg mk (one_mul a)),
  mul_one := λ a, quotient.induction_on' a
    (λ a, congr_arg mk (mul_one a)),
  inv := λ a, quotient.lift_on' a (λ a, ((a⁻¹ : G) : quotient N))
    (λ a b hab, quotient.sound' begin
      show a⁻¹⁻¹ * b⁻¹ ∈ N,
      rw ← mul_inv_rev,
      exact is_subgroup.inv_mem (is_subgroup.mem_norm_comm hab)
    end),
  mul_left_inv := λ a, quotient.induction_on' a
    (λ a, congr_arg mk (mul_left_inv a)) }
attribute [to_additive quotient_add_group.add_group._proof_6] quotient_group.group._proof_6
attribute [to_additive quotient_add_group.add_group._proof_5] quotient_group.group._proof_5
attribute [to_additive quotient_add_group.add_group._proof_4] quotient_group.group._proof_4
attribute [to_additive quotient_add_group.add_group._proof_3] quotient_group.group._proof_3
attribute [to_additive quotient_add_group.add_group._proof_2] quotient_group.group._proof_2
attribute [to_additive quotient_add_group.add_group._proof_1] quotient_group.group._proof_1
attribute [to_additive quotient_add_group.add_group] quotient_group.group
attribute [to_additive quotient_add_group.add_group.equations._eqn_1] quotient_group.group.equations._eqn_1

instance : is_group_hom (mk : G → quotient N) := ⟨λ _ _, rfl⟩
attribute [to_additive quotient_add_group.is_add_group_hom] quotient_group.is_group_hom
attribute [to_additive quotient_add_group.is_add_group_hom.equations._eqn_1] quotient_group.is_group_hom.equations._eqn_1

instance {G : Type*} [comm_group G] (s : set G) [is_subgroup s] : comm_group (quotient s) :=
{ mul_comm := λ a b, quotient.induction_on₂' a b
    (λ a b, congr_arg mk (mul_comm a b)),
  ..@quotient_group.group _ _ s (normal_subgroup_of_comm_group s) }
attribute [to_additive quotient_add_group.add_comm_group._proof_6] quotient_group.comm_group._proof_6
attribute [to_additive quotient_add_group.add_comm_group._proof_5] quotient_group.comm_group._proof_5
attribute [to_additive quotient_add_group.add_comm_group._proof_4] quotient_group.comm_group._proof_4
attribute [to_additive quotient_add_group.add_comm_group._proof_3] quotient_group.comm_group._proof_3
attribute [to_additive quotient_add_group.add_comm_group._proof_2] quotient_group.comm_group._proof_2
attribute [to_additive quotient_add_group.add_comm_group._proof_1] quotient_group.comm_group._proof_1
attribute [to_additive quotient_add_group.add_comm_group] quotient_group.comm_group
attribute [to_additive quotient_add_group.add_comm_group.equations._eqn_1] quotient_group.comm_group.equations._eqn_1

@[simp] lemma coe_one : ((1 : G) : quotient N) = 1 := rfl
@[simp] lemma coe_mul (a b : G) : ((a * b : G) : quotient N) = a * b := rfl
@[simp] lemma coe_inv (a : G) : ((a⁻¹ : G) : quotient N) = a⁻¹ := rfl
@[simp] lemma coe_pow (a : G) (n : ℕ) : ((a ^ n : G) : quotient N) = a ^ n :=
@is_group_hom.pow _ _ _ _ mk _ a n

attribute [to_additive quotient_add_group.coe_zero] coe_one
attribute [to_additive quotient_add_group.coe_add] coe_mul
attribute [to_additive quotient_add_group.coe_neg] coe_inv

@[simp] lemma coe_gpow (a : G) (n : ℤ) : ((a ^ n : G) : quotient N) = a ^ n :=
@is_group_hom.gpow _ _ _ _ mk _ a n

local notation ` Q ` := quotient N

instance is_group_hom_quotient_group_mk : is_group_hom (mk : G → Q) :=
by refine {..}; intros; refl
attribute [to_additive quotient_add_group.is_add_group_hom_quotient_add_group_mk] quotient_group.is_group_hom_quotient_group_mk
attribute [to_additive quotient_add_group.is_add_group_hom_quotient_add_group_mk.equations._eqn_1] quotient_group.is_group_hom_quotient_group_mk.equations._eqn_1

def lift (φ : G → H) [is_group_hom φ] (HN : ∀x∈N, φ x = 1) (q : Q) : H :=
q.lift_on' φ $ assume a b (hab : a⁻¹ * b ∈ N),
(calc φ a = φ a * 1           : by simp
...       = φ a * φ (a⁻¹ * b) : by rw HN (a⁻¹ * b) hab
...       = φ (a * (a⁻¹ * b)) : by rw is_group_hom.mul φ a (a⁻¹ * b)
...       = φ b               : by simp)
attribute [to_additive quotient_add_group.lift._proof_1] lift._proof_1
attribute [to_additive quotient_add_group.lift] lift
attribute [to_additive quotient_add_group.lift.equations._eqn_1] lift.equations._eqn_1

@[simp] lemma lift_mk {φ : G → H} [is_group_hom φ] (HN : ∀x∈N, φ x = 1) (g : G) :
  lift N φ HN (g : Q) = φ g := rfl
attribute [to_additive quotient_add_group.lift_mk] lift_mk

@[simp] lemma lift_mk' {φ : G → H} [is_group_hom φ] (HN : ∀x∈N, φ x = 1) (g : G) :
  lift N φ HN (mk g : Q) = φ g := rfl
attribute [to_additive quotient_add_group.lift_mk'] lift_mk'

variables (φ : G → H) [is_group_hom φ] (HN : ∀x∈N, φ x = 1)

instance is_group_hom_quotient_lift  :
  is_group_hom (lift N φ HN) :=
⟨λ q r, quotient.induction_on₂' q r $ λ a b,
  show φ (a * b) = φ a * φ b, from is_group_hom.mul φ a b⟩
attribute [to_additive quotient_add_group.is_add_group_hom_quotient_lift] quotient_group.is_group_hom_quotient_lift
attribute [to_additive quotient_add_group.is_add_group_hom_quotient_lift.equations._eqn_1] quotient_group.is_group_hom_quotient_lift.equations._eqn_1

open function is_group_hom

@[to_additive quotient_add_group.injective_ker_lift]
lemma injective_ker_lift : injective (lift (ker φ) φ $ λ x h, (mem_ker φ).1 h) :=
assume a b, quotient.induction_on₂' a b $ assume a b (h : φ a = φ b), quotient.sound' $
show a⁻¹ * b ∈ ker φ, by rw [mem_ker φ,
  is_group_hom.mul φ, ← h, is_group_hom.inv φ, inv_mul_self]

end quotient_group


/-
Copyright (c) 2021 Ashwin Iyengar. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Buzzard, Johan Commelin, Ashwin Iyengar, Patrick Massot
-/
import group_theory.subgroup.basic
import topology.algebra.open_subgroup
import topology.algebra.ring.basic

/-!
# Nonarchimedean Topology

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

In this file we set up the theory of nonarchimedean topological groups and rings.

A nonarchimedean group is a topological group whose topology admits a basis of
open neighborhoods of the identity element in the group consisting of open subgroups.
A nonarchimedean ring is a topological ring whose underlying topological (additive)
group is nonarchimedean.

## Definitions

- `nonarchimedean_add_group`: nonarchimedean additive group.
- `nonarchimedean_group`: nonarchimedean multiplicative group.
- `nonarchimedean_ring`: nonarchimedean ring.

-/

open_locale pointwise

/-- An topological additive group is nonarchimedean if every neighborhood of 0
  contains an open subgroup. -/
class nonarchimedean_add_group (G : Type*)
  [add_group G] [topological_space G] extends topological_add_group G : Prop :=
(is_nonarchimedean : ∀ U ∈ nhds (0 : G), ∃ V : open_add_subgroup G, (V : set G) ⊆ U)

/-- A topological group is nonarchimedean if every neighborhood of 1 contains an open subgroup. -/
@[to_additive]
class nonarchimedean_group (G : Type*)
  [group G] [topological_space G] extends topological_group G : Prop :=
(is_nonarchimedean : ∀ U ∈ nhds (1 : G), ∃ V : open_subgroup G, (V : set G) ⊆ U)

/-- An topological ring is nonarchimedean if its underlying topological additive
  group is nonarchimedean. -/
class nonarchimedean_ring (R : Type*)
  [ring R] [topological_space R] extends topological_ring R : Prop :=
(is_nonarchimedean : ∀ U ∈ nhds (0 : R), ∃ V : open_add_subgroup R, (V : set R) ⊆ U)

/-- Every nonarchimedean ring is naturally a nonarchimedean additive group. -/
@[priority 100] -- see Note [lower instance priority]
instance nonarchimedean_ring.to_nonarchimedean_add_group
  (R : Type*) [ring R] [topological_space R] [t: nonarchimedean_ring R] :
nonarchimedean_add_group R := {..t}

namespace nonarchimedean_group

variables {G : Type*} [group G] [topological_space G] [nonarchimedean_group G]
variables {H : Type*} [group H] [topological_space H] [topological_group H]
variables {K : Type*} [group K] [topological_space K] [nonarchimedean_group K]

/-- If a topological group embeds into a nonarchimedean group, then it is nonarchimedean. -/
@[to_additive nonarchimedean_add_group.nonarchimedean_of_emb "If a topological group embeds into a
nonarchimedean group, then it is nonarchimedean."]
lemma nonarchimedean_of_emb (f : G →* H) (emb : open_embedding f) : nonarchimedean_group H :=
{ is_nonarchimedean := λ U hU, have h₁ : (f ⁻¹' U) ∈ nhds (1 : G), from
    by {apply emb.continuous.tendsto, rwa f.map_one},
  let ⟨V, hV⟩ := is_nonarchimedean (f ⁻¹' U) h₁ in
    ⟨{is_open' := emb.is_open_map _ V.is_open, ..subgroup.map f V},
      set.image_subset_iff.2 hV⟩ }

/-- An open neighborhood of the identity in the cartesian product of two nonarchimedean groups
contains the cartesian product of an open neighborhood in each group. -/
@[to_additive nonarchimedean_add_group.prod_subset "An open neighborhood of the identity in the
cartesian product of two nonarchimedean groups contains the cartesian product of an open
neighborhood in each group."]
lemma prod_subset {U} (hU : U ∈ nhds (1 : G × K)) :
  ∃ (V : open_subgroup G) (W : open_subgroup K), (V : set G) ×ˢ (W : set K) ⊆ U :=
begin
  erw [nhds_prod_eq, filter.mem_prod_iff] at hU,
  rcases hU with ⟨U₁, hU₁, U₂, hU₂, h⟩,
  cases is_nonarchimedean _ hU₁ with V hV,
  cases is_nonarchimedean _ hU₂ with W hW,
  use V, use W,
  rw set.prod_subset_iff,
  intros x hX y hY,
  exact set.subset.trans (set.prod_mono hV hW) h (set.mem_sep hX hY),
end

/-- An open neighborhood of the identity in the cartesian square of a nonarchimedean group
contains the cartesian square of an open neighborhood in the group. -/
@[to_additive nonarchimedean_add_group.prod_self_subset "An open neighborhood of the identity in the
cartesian square of a nonarchimedean group contains the cartesian square of an open neighborhood in
the group."]
lemma prod_self_subset {U} (hU : U ∈ nhds (1 : G × G)) :
  ∃ (V : open_subgroup G), (V : set G) ×ˢ (V : set G) ⊆ U :=
let ⟨V, W, h⟩ := prod_subset hU in
  ⟨V ⊓ W, by {refine set.subset.trans (set.prod_mono _ _) ‹_›; simp}⟩

/-- The cartesian product of two nonarchimedean groups is nonarchimedean. -/
@[to_additive "The cartesian product of two nonarchimedean groups is nonarchimedean."]
instance : nonarchimedean_group (G × K) :=
{ is_nonarchimedean := λ U hU, let ⟨V, W, h⟩ := prod_subset hU in ⟨V.prod W, ‹_›⟩ }

end nonarchimedean_group

namespace nonarchimedean_ring

open nonarchimedean_ring
open nonarchimedean_add_group

variables {R S : Type*}
variables [ring R] [topological_space R] [nonarchimedean_ring R]
variables [ring S] [topological_space S] [nonarchimedean_ring S]

/-- The cartesian product of two nonarchimedean rings is nonarchimedean. -/
instance : nonarchimedean_ring (R × S) :=
{ is_nonarchimedean := nonarchimedean_add_group.is_nonarchimedean }

/-- Given an open subgroup `U` and an element `r` of a nonarchimedean ring, there is an open
  subgroup `V` such that `r • V` is contained in `U`. -/
lemma left_mul_subset (U : open_add_subgroup R) (r : R) :
  ∃ V : open_add_subgroup R, r • (V : set R) ⊆ U :=
⟨U.comap (add_monoid_hom.mul_left r) (continuous_mul_left r),
  (U : set R).image_preimage_subset _⟩

/-- An open subgroup of a nonarchimedean ring contains the square of another one. -/
lemma mul_subset (U : open_add_subgroup R) :
  ∃ V : open_add_subgroup R, (V : set R) * V ⊆ U :=
let ⟨V, H⟩ := prod_self_subset (is_open.mem_nhds (is_open.preimage continuous_mul U.is_open)
  begin
    simpa only [set.mem_preimage, set_like.mem_coe, prod.snd_zero, mul_zero] using U.zero_mem,
  end) in
begin
  use V,
  rintros v ⟨a, b, ha, hb, hv⟩,
  have hy := H (set.mk_mem_prod ha hb),
  simp only [set.mem_preimage, set_like.mem_coe] at hy,
  rwa hv at hy
end

end nonarchimedean_ring


/-
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 combinatorics.set_family.intersecting
! leanprover-community/mathlib commit d90e4e186f1d18e375dcd4e5b5f6364b01cb3e46
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Fintype.Card
import Mathlib.Order.UpperLower.Basic

/-!
# Intersecting families

This file defines intersecting families and proves their basic properties.

## Main declarations

* `Set.Intersecting`: Predicate for a set of elements in a generalized boolean algebra to be an
  intersecting family.
* `Set.Intersecting.card_le`: An intersecting family can only take up to half the elements, because
  `a` and `aᶜ` cannot simultaneously be in it.
* `Set.Intersecting.is_max_iff_card_eq`: Any maximal intersecting family takes up half the elements.

## References

* [D. J. Kleitman, *Families of non-disjoint subsets*][kleitman1966]
-/

open Finset

variable {α : Type _}

namespace Set

section SemilatticeInf

variable [SemilatticeInf α] [OrderBot α] {s t : Set α} {a b c : α}

/-- A set family is intersecting if every pair of elements is non-disjoint. -/
def Intersecting (s : Set α) : Prop :=
  ∀ ⦃a⦄, a ∈ s → ∀ ⦃b⦄, b ∈ s → ¬Disjoint a b
#align set.intersecting Set.Intersecting

@[mono]
theorem Intersecting.mono (h : t ⊆ s) (hs : s.Intersecting) : t.Intersecting := fun _a ha _b hb =>
  hs (h ha) (h hb)
#align set.intersecting.mono Set.Intersecting.mono

theorem Intersecting.not_bot_mem (hs : s.Intersecting) : ⊥ ∉ s := fun h => hs h h disjoint_bot_left
#align set.intersecting.not_bot_mem Set.Intersecting.not_bot_mem

theorem Intersecting.ne_bot (hs : s.Intersecting) (ha : a ∈ s) : a ≠ ⊥ :=
  ne_of_mem_of_not_mem ha hs.not_bot_mem
#align set.intersecting.ne_bot Set.Intersecting.ne_bot

theorem intersecting_empty : (∅ : Set α).Intersecting := fun _ => False.elim
#align set.intersecting_empty Set.intersecting_empty

@[simp]
theorem intersecting_singleton : ({a} : Set α).Intersecting ↔ a ≠ ⊥ := by simp [Intersecting]
#align set.intersecting_singleton Set.intersecting_singleton

theorem Intersecting.insert (hs : s.Intersecting) (ha : a ≠ ⊥) (h : ∀ b ∈ s, ¬Disjoint a b) :
    (insert a s).Intersecting := by
  rintro b (rfl | hb) c (rfl | hc)
  · rwa [disjoint_self]
  · exact h _ hc
  · exact fun H => h _ hb H.symm
  · exact hs hb hc
#align set.intersecting.insert Set.Intersecting.insert

theorem intersecting_insert :
    (insert a s).Intersecting ↔ s.Intersecting ∧ a ≠ ⊥ ∧ ∀ b ∈ s, ¬Disjoint a b :=
  ⟨fun h =>
    ⟨h.mono <| subset_insert _ _, h.ne_bot <| mem_insert _ _, fun _b hb =>
      h (mem_insert _ _) <| mem_insert_of_mem _ hb⟩,
    fun h => h.1.insert h.2.1 h.2.2⟩
#align set.intersecting_insert Set.intersecting_insert

theorem intersecting_iff_pairwise_not_disjoint :
    s.Intersecting ↔ (s.Pairwise fun a b => ¬Disjoint a b) ∧ s ≠ {⊥} := by
  refine' ⟨fun h => ⟨fun a ha b hb _ => h ha hb, _⟩, fun h a ha b hb hab => _⟩
  · rintro rfl
    exact intersecting_singleton.1 h rfl
  have := h.1.eq ha hb (Classical.not_not.2 hab)
  rw [this, disjoint_self] at hab
  rw [hab] at hb
  exact
    h.2
      (eq_singleton_iff_unique_mem.2
        ⟨hb, fun c hc => not_ne_iff.1 fun H => h.1 hb hc H.symm disjoint_bot_left⟩)
#align set.intersecting_iff_pairwise_not_disjoint Set.intersecting_iff_pairwise_not_disjoint

protected theorem Subsingleton.intersecting (hs : s.Subsingleton) : s.Intersecting ↔ s ≠ {⊥} :=
  intersecting_iff_pairwise_not_disjoint.trans <| and_iff_right <| hs.pairwise _
#align set.subsingleton.intersecting Set.Subsingleton.intersecting

theorem intersecting_iff_eq_empty_of_subsingleton [Subsingleton α] (s : Set α) :
    s.Intersecting ↔ s = ∅ := by
  refine'
    subsingleton_of_subsingleton.intersecting.trans
      ⟨not_imp_comm.2 fun h => subsingleton_of_subsingleton.eq_singleton_of_mem _, _⟩
  · obtain ⟨a, ha⟩ := nonempty_iff_ne_empty.2 h
    rwa [Subsingleton.elim ⊥ a]
  · rintro rfl
    exact (Set.singleton_nonempty _).ne_empty.symm
#align set.intersecting_iff_eq_empty_of_subsingleton Set.intersecting_iff_eq_empty_of_subsingleton

/-- Maximal intersecting families are upper sets. -/
protected theorem Intersecting.isUpperSet (hs : s.Intersecting)
    (h : ∀ t : Set α, t.Intersecting → s ⊆ t → s = t) : IsUpperSet s := by
  classical
    rintro a b hab ha
    rw [h (Insert.insert b s) _ (subset_insert _ _)]
    · exact mem_insert _ _
    exact
      hs.insert (mt (eq_bot_mono hab) <| hs.ne_bot ha) fun c hc hbc => hs ha hc <| hbc.mono_left hab
#align set.intersecting.is_upper_set Set.Intersecting.isUpperSet

/-- Maximal intersecting families are upper sets. Finset version. -/
theorem Intersecting.isUpperSet' {s : Finset α} (hs : (s : Set α).Intersecting)
    (h : ∀ t : Finset α, (t : Set α).Intersecting → s ⊆ t → s = t) : IsUpperSet (s : Set α) := by
  classical
    rintro a b hab ha
    rw [h (Insert.insert b s) _ (Finset.subset_insert _ _)]
    · exact mem_insert_self _ _
    rw [coe_insert]
    exact
      hs.insert (mt (eq_bot_mono hab) <| hs.ne_bot ha) fun c hc hbc => hs ha hc <| hbc.mono_left hab
#align set.intersecting.is_upper_set' Set.Intersecting.isUpperSet'

end SemilatticeInf

theorem Intersecting.exists_mem_set {𝒜 : Set (Set α)} (h𝒜 : 𝒜.Intersecting) {s t : Set α}
    (hs : s ∈ 𝒜) (ht : t ∈ 𝒜) : ∃ a, a ∈ s ∧ a ∈ t :=
  not_disjoint_iff.1 <| h𝒜 hs ht
#align set.intersecting.exists_mem_set Set.Intersecting.exists_mem_set

theorem Intersecting.exists_mem_finset [DecidableEq α] {𝒜 : Set (Finset α)} (h𝒜 : 𝒜.Intersecting)
    {s t : Finset α} (hs : s ∈ 𝒜) (ht : t ∈ 𝒜) : ∃ a, a ∈ s ∧ a ∈ t :=
  not_disjoint_iff.1 <| disjoint_coe.not.2 <| h𝒜 hs ht
#align set.intersecting.exists_mem_finset Set.Intersecting.exists_mem_finset

variable [BooleanAlgebra α]

theorem Intersecting.not_mem {s : Set α} (hs : s.Intersecting) {a : α} (ha : aᶜ ∈ s) : a ∉ s :=
  fun h => hs ha h disjoint_compl_left
#align set.intersecting.not_mem Set.Intersecting.not_mem

theorem Intersecting.disjoint_map_compl {s : Finset α} (hs : (s : Set α).Intersecting) :
    Disjoint s (s.map ⟨compl, compl_injective⟩) := by
  rw [Finset.disjoint_left]
  rintro x hx hxc
  obtain ⟨x, hx', rfl⟩ := mem_map.mp hxc
  exact hs.not_compl_mem hx' hx
#align set.intersecting.disjoint_map_compl Set.Intersecting.disjoint_map_compl

theorem Intersecting.card_le [Fintype α] {s : Finset α} (hs : (s : Set α).Intersecting) :
    2 * s.card ≤ Fintype.card α := by
  classical
    refine' (s.disjUnion _ hs.disjoint_map_compl).card_le_univ.trans_eq' _
    rw [two_mul, card_disjUnion, card_map]
#align set.intersecting.card_le Set.Intersecting.card_le

variable [Nontrivial α] [Fintype α] {s : Finset α}

-- Note, this lemma is false when `α` has exactly one element and boring when `α` is empty.
theorem Intersecting.is_max_iff_card_eq (hs : (s : Set α).Intersecting) :
    (∀ t : Finset α, (t : Set α).Intersecting → s ⊆ t → s = t) ↔ 2 * s.card = Fintype.card α := by
  classical
    refine'
      ⟨fun h => _, fun h t ht hst =>
        Finset.eq_of_subset_of_card_le hst <|
          le_of_mul_le_mul_left (ht.card_le.trans_eq h.symm) two_pos⟩
    suffices s.disjUnion (s.map ⟨compl, compl_injective⟩) hs.disjoint_map_compl = Finset.univ by
      rw [Fintype.card, ← this, two_mul, card_disjUnion, card_map]
    rw [← coe_eq_univ, disjUnion_eq_union, coe_union, coe_map, Function.Embedding.coeFn_mk,
      image_eq_preimage_of_inverse compl_compl compl_compl]
    refine' eq_univ_of_forall fun a => _
    simp_rw [mem_union, mem_preimage]
    by_contra' ha
    refine' s.ne_insert_of_not_mem _ ha.1 (h _ _ <| s.subset_insert _)
    rw [coe_insert]
    refine' hs.insert _ fun b hb hab => ha.2 <| (hs.isUpperSet' h) hab.le_compl_left hb
    rintro rfl
    have := h {⊤} (by rw [coe_singleton]; exact intersecting_singleton.2 top_ne_bot)
    rw [compl_bot] at ha
    rw [coe_eq_empty.1 ((hs.isUpperSet' h).not_top_mem.1 ha.2)] at this
    exact Finset.singleton_ne_empty _ (this <| Finset.empty_subset _).symm
#align set.intersecting.is_max_iff_card_eq Set.Intersecting.is_max_iff_card_eq

theorem Intersecting.exists_card_eq (hs : (s : Set α).Intersecting) :
    ∃ t, s ⊆ t ∧ 2 * t.card = Fintype.card α ∧ (t : Set α).Intersecting := by
  have := hs.card_le
  rw [mul_comm, ← Nat.le_div_iff_mul_le' two_pos] at this
  revert hs
  refine' s.strongDownwardInductionOn _ this
  rintro s ih _hcard hs
  by_cases h : ∀ t : Finset α, (t : Set α).Intersecting → s ⊆ t → s = t
  · exact ⟨s, Subset.rfl, hs.is_max_iff_card_eq.1 h, hs⟩
  push_neg  at h
  obtain ⟨t, ht, hst⟩ := h
  refine' (ih _ (_root_.ssubset_iff_subset_ne.2 hst) ht).imp fun u => And.imp_left hst.1.trans
  rw [Nat.le_div_iff_mul_le' two_pos, mul_comm]
  exact ht.card_le
#align set.intersecting.exists_card_eq Set.Intersecting.exists_card_eq

end Set


/-
Copyright (c) 2020 Kyle Miller All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Kyle Miller.
-/
import tactic.linarith
import data.sym

open function
open sym

/-!
# The symmetric square
This file defines the symmetric square, which is `α × α` modulo
swapping.  This is also known as the type of unordered pairs.
More generally, the symmetric square is the second symmetric power
(see `data.sym`). The equivalence is `sym2.equiv_sym`.
From the point of view that an unordered pair is equivalent to a
multiset of cardinality two (see `sym2.equiv_multiset`), there is a
`has_mem` instance `sym2.mem`, which is a `Prop`-valued membership
test.  Given `a ∈ z` for `z : sym2 α`, it does not appear to be
possible, in general, to *computably* give the other element in the
pair.  For this, `sym2.vmem a z` is a `Type`-valued membership test
that gives a way to obtain the other element with `sym2.vmem.other`.
Recall that an undirected graph (allowing self loops, but no multiple
edges) is equivalent to a symmetric relation on the vertex type `α`.
Given a symmetric relation on `α`, the corresponding edge set is
constructed by `sym2.from_rel`.
## Notation
The symmetric square has a setoid instance, so `⟦(a, b)⟧` denotes a
term of the symmetric square.
## Tags
symmetric square, unordered pairs, symmetric powers
-/

universe u
variables {α : Type u}
namespace sym2

/--
This is the relation capturing the notion of pairs equivalent up to permutations.
-/
inductive rel (α : Type u) : (α × α) → (α × α) → Prop
| refl (x y : α) : rel (x, y) (x, y)
| swap (x y : α) : rel (x, y) (y, x)

attribute [refl] rel.refl

@[symm] lemma rel.symm {x y : α × α} : rel α x y → rel α y x :=
by { rintro ⟨_,_⟩, exact a, apply rel.swap }

@[trans] lemma rel.trans {x y z : α × α} : rel α x y → rel α y z → rel α x z :=
by { intros a b, cases_matching* rel _ _ _; apply rel.refl <|> apply rel.swap }

lemma rel.is_equivalence : equivalence (rel α) := by tidy; apply rel.trans; assumption

instance rel.setoid (α : Type u) : setoid (α × α) := ⟨rel α, rel.is_equivalence⟩

end sym2

/--
`sym2 α` is the symmetric square of `α`, which, in other words, is the
type of unordered pairs.
It is equivalent in a natural way to multisets of cardinality 2 (see
`sym2.equiv_multiset`).
-/
@[reducible]
def sym2 (α : Type u) := quotient (sym2.rel.setoid α)

namespace sym2

def mk (a b : α) : sym2 α := ⟦(a, b)⟧

lemma eq_swap {a b : α} : ⟦(a, b)⟧ = ⟦(b, a)⟧ :=
by { rw quotient.eq, apply rel.swap }

lemma congr_right (a b c : α) : ⟦(a, b)⟧ = ⟦(a, c)⟧ ↔ b = c :=
by { split; intro h, { rw quotient.eq at h, cases h; refl }, rw h }

/--
The functor `sym2` is functorial, and this function constructs the induced maps.
-/
def map {α β : Type*} (f : α → β) : sym2 α → sym2 β :=
quotient.map (prod.map f f)
  (by { rintros _ _ h, cases h, { refl }, apply rel.swap })

@[simp]
lemma map_id : sym2.map (@id α) = id := by tidy

lemma map_comp {α β γ : Type*} {g : β → γ} {f : α → β} :
  sym2.map (g ∘ f) = sym2.map g ∘ sym2.map f := by tidy

section membership

/-! ### Declarations about membership -/

/--
This is a predicate that determines whether a given term is a member of a term of the
symmetric square.  From this point of view, the symmetric square is the subtype of
cardinality-two multisets on `α`.
-/
def mem (x : α) (z : sym2 α) : Prop :=
∃ (y : α), z = ⟦(x, y)⟧

instance : has_mem α (sym2 α) := ⟨mem⟩

lemma mk_has_mem (x y : α) : x ∈ ⟦(x, y)⟧ := ⟨y, rfl⟩
lemma mk_has_mem_right (x y : α) : y ∈ ⟦(x, y)⟧ := by { rw eq_swap, apply mk_has_mem }

/--
This is a type-valued version of the membership predicate `mem` that contains the other
element `y` of `z` such that `z = ⟦(x, y)⟧`.  It is a subsingleton already,
so there is no need to apply `trunc` to the type.
-/
@[nolint has_inhabited_instance]
def vmem (x : α) (z : sym2 α) : Type u :=
{y : α // z = ⟦(x, y)⟧}

instance (x : α) (z : sym2 α) : subsingleton {y : α // z = ⟦(x, y)⟧} :=
⟨by { rintros ⟨a, ha⟩ ⟨b, hb⟩, rw [ha, congr_right] at hb, tidy }⟩

/--
The `vmem` version of `mk_has_mem`.
-/
def mk_has_vmem (x y : α) : vmem x ⟦(x, y)⟧ :=
⟨y, rfl⟩

instance {a : α} {z : sym2 α} : has_lift (vmem a z) (mem a z) := ⟨λ h, ⟨h.val, h.property⟩⟩

/--
Given an element of a term of the symmetric square (using `vmem`), retrieve the other element.
-/
def vmem.other {a : α} {p : sym2 α} (h : vmem a p) : α := h.val

/--
The defining property of the other element is that it can be used to
reconstruct the term of the symmetric square.
-/
lemma vmem_other_spec {a : α} {z : sym2 α} (h : vmem a z) :
  z = ⟦(a, h.other)⟧ := by { delta vmem.other, tidy }

/--
This is the `mem`-based version of `other`.
-/
noncomputable def mem.other {a : α} {z : sym2 α} (h : a ∈ z) : α :=
classical.some h

lemma mem_other_spec {a : α} {z : sym2 α} (h : a ∈ z) :
  ⟦(a, h.other)⟧ = z := by erw ← classical.some_spec h

lemma other_is_mem_other {a : α} {z : sym2 α} (h : vmem a z) (h' : a ∈ z) :
  h.other = mem.other h' := by rw [← congr_right a, ← vmem_other_spec h, mem_other_spec]

lemma eq_iff {x y z w : α} :
  ⟦(x, y)⟧ = ⟦(z, w)⟧ ↔ (x = z ∧ y = w) ∨ (x = w ∧ y = z) :=
begin
  split; intro h,
  { rw quotient.eq at h, cases h; tidy },
  { cases h; rw [h.1, h.2], rw eq_swap }
end

@[simp] lemma mem_iff {a b c : α} : a ∈ ⟦(b, c)⟧ ↔ a = b ∨ a = c :=
{ mp  := by { rintro ⟨_, h⟩, rw eq_iff at h, tidy },
  mpr := by { rintro ⟨_⟩; subst a, { apply mk_has_mem }, rw eq_swap, apply mk_has_mem } }

end membership

/--
A type `α` is naturally included in the diagonal of `α × α`, and this function gives the image
of this diagonal in `sym2 α`.
-/
def diag (x : α) : sym2 α := ⟦(x, x)⟧

/--
A predicate for testing whether an element of `sym2 α` is on the diagonal.
-/
def is_diag (z : sym2 α) : Prop := z ∈ set.range (@diag α)

lemma is_diag_iff_proj_eq (z : α × α) : is_diag ⟦z⟧ ↔ z.1 = z.2 :=
begin
  cases z with a, split,
  { rintro ⟨_, h⟩, erw eq_iff at h, cc },
  { rintro ⟨⟩, use a, refl },
end

instance is_diag.decidable_pred (α : Type u) [decidable_eq α] : decidable_pred (@is_diag α) :=
by { intro z, induction z, { erw is_diag_iff_proj_eq, apply_instance }, apply subsingleton.elim }

section relations

/-! ### Declarations about symmetric relations -/

variables {r : α → α → Prop}

/--
Symmetric relations define a set on `sym2 α` by taking all those pairs
of elements that are related.
-/
def from_rel (sym : symmetric r) : set (sym2 α) :=
(quotient.mk : α × α → sym2 α) '' (uncurry r)
--λ z, quotient.rec_on z (λ z, r z.1 z.2) (by { rintros _ _ ⟨_,_⟩, tidy })

@[simp]
lemma from_rel_proj_prop {sym : symmetric r} {z : α × α} :
  ⟦z⟧ ∈ from_rel sym ↔ r z.1 z.2 :=
begin
  cases z,
  dsimp,
  split,
  { intro h,
    rcases h with ⟨⟨a,b⟩,h,h1⟩,
    replace h1 := quotient.exact h1,
    cases h1, exact h,
    apply sym, exact h,
  },
  { intro h,
    use (z_fst, z_snd),
    use h }
end

@[simp]
lemma from_rel_prop {sym : symmetric r} {a b : α} :
  ⟦(a, b)⟧ ∈ from_rel sym ↔ r a b := by simp only [from_rel_proj_prop]

lemma from_rel_irreflexive {sym : symmetric r} :
  irreflexive r ↔ ∀ {z}, z ∈ from_rel sym → ¬is_diag z :=
{ mp  := by { intros h z hr hd, induction z,
              erw is_diag_iff_proj_eq at hd, erw from_rel_proj_prop at hr, tidy },
  mpr := by { intros h x hr, rw ← @from_rel_prop _ _ sym at hr, exact h hr ⟨x, rfl⟩ }}

instance from_rel.decidable_as_set (sym : symmetric r) [h : decidable_rel r] :
  decidable_pred (λ x, x ∈ sym2.from_rel sym) :=
λ (x : sym2 α), quotient.rec_on x
  (λ x', by { simp_rw from_rel_proj_prop, apply_instance })
  (by tidy)

instance from_rel.decidable_pred (sym : symmetric r) [h : decidable_rel r] :
  decidable_pred (sym2.from_rel sym) :=
by { change decidable_pred (λ x, x ∈ sym2.from_rel sym), apply_instance }

end relations

section sym_equiv

/-! ### Equivalence to the second symmetric power -/

local attribute [instance] vector.perm.is_setoid

private def from_vector {α : Type*} : vector α 2 → α × α
| ⟨[a, b], h⟩ := (a, b)

private lemma perm_card_two_iff {α : Type*} {a₁ b₁ a₂ b₂ : α} :
  [a₁, b₁].perm [a₂, b₂] ↔ (a₁ = a₂ ∧ b₁ = b₂) ∨ (a₁ = b₂ ∧ b₁ = a₂) :=
{ mp  := by { simp [← multiset.coe_eq_coe, ← multiset.cons_coe, multiset.cons_eq_cons]; tidy },
  mpr := by { intro h, cases h; rw [h.1, h.2], apply list.perm.swap', refl } }

/--
The symmetric square is equivalent to length-2 vectors up to permutations.
-/
def sym2_equiv_sym' {α : Type*} : equiv (sym2 α) (sym' α 2) :=
{ to_fun := quotient.map
    (λ (x : α × α), ⟨[x.1, x.2], rfl⟩)
    (by { rintros _ _ ⟨_⟩, { refl }, apply list.perm.swap', refl }),
  inv_fun := quotient.map from_vector (begin
    rintros ⟨x, hx⟩ ⟨y, hy⟩ h,
    cases x with _ x, { simp at hx; tauto },
    cases x with _ x, { simp at hx; norm_num at hx },
    cases x with _ x, swap, { exfalso, simp at hx; linarith [hx] },
    cases y with _ y, { simp at hy; tauto },
    cases y with _ y, { simp at hy; norm_num at hy },
    cases y with _ y, swap, { exfalso, simp at hy; linarith [hy] },
    rcases perm_card_two_iff.mp h with ⟨rfl,rfl⟩|⟨rfl,rfl⟩, { refl },
    apply sym2.rel.swap,
  end),
  left_inv := by tidy,
  right_inv := λ x, begin
    induction x,
    { cases x with x hx,
      cases x with _ x, { simp at hx; tauto },
      cases x with _ x, { simp at hx; norm_num at hx },
      cases x with _ x, swap, { exfalso, simp at hx; linarith [hx] },
      refl },
    refl,
  end }

/--
The symmetric square is equivalent to the second symmetric power.
-/
def equiv_sym (α : Type*) : sym2 α ≃ sym α 2 :=
equiv.trans sym2_equiv_sym' (sym_equiv_sym' α 2).symm

/--
The symmetric square is equivalent to multisets of cardinality
two. (This is currently a synonym for `equiv_sym`, but it's provided
in case the definition for `sym` changes.)
-/
def equiv_multiset (α : Type*) : sym2 α ≃ {s : multiset α // s.card = 2} :=
equiv_sym α

end sym_equiv

section finite

/--
An algorithm for computing `sym2.rel`.
-/
def rel_bool [decidable_eq α] (x y : α × α) : bool :=
if x.1 = y.1 then x.2 = y.2 else
  if x.1 = y.2 then x.2 = y.1 else ff

lemma rel_bool_spec [decidable_eq α] (x y : α × α) :
  ↥(rel_bool x y) ↔ rel α x y :=
begin
  cases x with x₁ x₂, cases y with y₁ y₂,
  dsimp [rel_bool], split_ifs;
  simp only [false_iff, bool.coe_sort_ff, bool.of_to_bool_iff],
  rotate 2, { contrapose! h, cases h; cc },
  all_goals { subst x₁, split; intro h1,
    { subst h1; apply sym2.rel.swap },
    { cases h1; cc }}
end

/--
Given `[decidable_eq α]` and `[fintype α]`, the following instance gives `fintype (sym2 α)`.
-/
instance (α : Type*) [decidable_eq α] : decidable_rel (sym2.rel α) :=
λ x y, decidable_of_bool (rel_bool x y) (rel_bool_spec x y)

end finite

end sym2


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.limits.shapes.split_coequalizer
import category_theory.limits.preserves.basic

/-!
# Preserving (co)equalizers

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

Constructions to relate the notions of preserving (co)equalizers and reflecting (co)equalizers
to concrete (co)forks.

In particular, we show that `equalizer_comparison f g G` is an isomorphism iff `G` preserves
the limit of the parallel pair `f,g`, as well as the dual result.
-/

noncomputable theory

universes w v₁ v₂ u₁ u₂

open category_theory category_theory.category category_theory.limits

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

namespace category_theory.limits

section equalizers
variables {X Y Z : C} {f g : X ⟶ Y} {h : Z ⟶ X} (w : h ≫ f = h ≫ g)

/--
The map of a fork is a limit iff the fork consisting of the mapped morphisms is a limit. This
essentially lets us commute `fork.of_ι` with `functor.map_cone`.
-/
def is_limit_map_cone_fork_equiv :
  is_limit (G.map_cone (fork.of_ι h w)) ≃
  is_limit (fork.of_ι (G.map h) (by simp only [←G.map_comp, w]) : fork (G.map f) (G.map g)) :=
(is_limit.postcompose_hom_equiv (diagram_iso_parallel_pair _) _).symm.trans
  (is_limit.equiv_iso_limit (fork.ext (iso.refl _) (by { simp [fork.ι] })))

/-- The property of preserving equalizers expressed in terms of forks. -/
def is_limit_fork_map_of_is_limit [preserves_limit (parallel_pair f g) G]
  (l : is_limit (fork.of_ι h w)) :
  is_limit (fork.of_ι (G.map h) (by simp only [←G.map_comp, w]) : fork (G.map f) (G.map g)) :=
is_limit_map_cone_fork_equiv G w (preserves_limit.preserves l)

/-- The property of reflecting equalizers expressed in terms of forks. -/
def is_limit_of_is_limit_fork_map [reflects_limit (parallel_pair f g) G]
  (l : is_limit (fork.of_ι (G.map h) (by simp only [←G.map_comp, w]) : fork (G.map f) (G.map g))) :
  is_limit (fork.of_ι h w) :=
reflects_limit.reflects ((is_limit_map_cone_fork_equiv G w).symm l)

variables (f g) [has_equalizer f g]

/--
If `G` preserves equalizers and `C` has them, then the fork constructed of the mapped morphisms of
a fork is a limit.
-/
def is_limit_of_has_equalizer_of_preserves_limit
  [preserves_limit (parallel_pair f g) G] :
  is_limit (fork.of_ι (G.map (equalizer.ι f g))
                      (by simp only [←G.map_comp, equalizer.condition])) :=
is_limit_fork_map_of_is_limit G _ (equalizer_is_equalizer f g)

variables [has_equalizer (G.map f) (G.map g)]

/--
If the equalizer comparison map for `G` at `(f,g)` is an isomorphism, then `G` preserves the
equalizer of `(f,g)`.
-/
def preserves_equalizer.of_iso_comparison [i : is_iso (equalizer_comparison f g G)] :
  preserves_limit (parallel_pair f g) G :=
begin
  apply preserves_limit_of_preserves_limit_cone (equalizer_is_equalizer f g),
  apply (is_limit_map_cone_fork_equiv _ _).symm _,
  apply is_limit.of_point_iso (limit.is_limit (parallel_pair (G.map f) (G.map g))),
  apply i,
end

variables [preserves_limit (parallel_pair f g) G]
/--
If `G` preserves the equalizer of `(f,g)`, then the equalizer comparison map for `G` at `(f,g)` is
an isomorphism.
-/
def preserves_equalizer.iso :
  G.obj (equalizer f g) ≅ equalizer (G.map f) (G.map g) :=
is_limit.cone_point_unique_up_to_iso
  (is_limit_of_has_equalizer_of_preserves_limit G f g)
  (limit.is_limit _)

@[simp]
lemma preserves_equalizer.iso_hom :
  (preserves_equalizer.iso G f g).hom = equalizer_comparison f g G :=
rfl

instance : is_iso (equalizer_comparison f g G) :=
begin
  rw ← preserves_equalizer.iso_hom,
  apply_instance
end

end equalizers

section coequalizers

variables {X Y Z : C} {f g : X ⟶ Y} {h : Y ⟶ Z} (w : f ≫ h = g ≫ h)

/--
The map of a cofork is a colimit iff the cofork consisting of the mapped morphisms is a colimit.
This essentially lets us commute `cofork.of_π` with `functor.map_cocone`.
-/
def is_colimit_map_cocone_cofork_equiv :
  is_colimit (G.map_cocone (cofork.of_π h w)) ≃
  is_colimit (cofork.of_π (G.map h) (by simp only [←G.map_comp, w]) : cofork (G.map f) (G.map g)) :=
(is_colimit.precompose_inv_equiv (diagram_iso_parallel_pair _) _).symm.trans $
is_colimit.equiv_iso_colimit $ cofork.ext (iso.refl _) $
begin
  dsimp only [cofork.π, cofork.of_π_ι_app],
  dsimp, rw [category.comp_id, category.id_comp]
end

/-- The property of preserving coequalizers expressed in terms of coforks. -/
def is_colimit_cofork_map_of_is_colimit [preserves_colimit (parallel_pair f g) G]
  (l : is_colimit (cofork.of_π h w)) :
  is_colimit (cofork.of_π (G.map h) (by simp only [←G.map_comp, w]) : cofork (G.map f) (G.map g)) :=
is_colimit_map_cocone_cofork_equiv G w (preserves_colimit.preserves l)

/-- The property of reflecting coequalizers expressed in terms of coforks. -/
def is_colimit_of_is_colimit_cofork_map [reflects_colimit (parallel_pair f g) G]
  (l : is_colimit (cofork.of_π (G.map h) (by simp only [←G.map_comp, w])
                  : cofork (G.map f) (G.map g))) :
  is_colimit (cofork.of_π h w) :=
reflects_colimit.reflects ((is_colimit_map_cocone_cofork_equiv G w).symm l)

variables (f g) [has_coequalizer f g]

/--
If `G` preserves coequalizers and `C` has them, then the cofork constructed of the mapped morphisms
of a cofork is a colimit.
-/
def is_colimit_of_has_coequalizer_of_preserves_colimit
  [preserves_colimit (parallel_pair f g) G] :
  is_colimit (cofork.of_π (G.map (coequalizer.π f g)) _) :=
is_colimit_cofork_map_of_is_colimit G _ (coequalizer_is_coequalizer f g)

variables [has_coequalizer (G.map f) (G.map g)]

/--
If the coequalizer comparison map for `G` at `(f,g)` is an isomorphism, then `G` preserves the
coequalizer of `(f,g)`.
-/
def of_iso_comparison [i : is_iso (coequalizer_comparison f g G)] :
  preserves_colimit (parallel_pair f g) G :=
begin
  apply preserves_colimit_of_preserves_colimit_cocone (coequalizer_is_coequalizer f g),
  apply (is_colimit_map_cocone_cofork_equiv _ _).symm _,
  apply is_colimit.of_point_iso (colimit.is_colimit (parallel_pair (G.map f) (G.map g))),
  apply i,
end

variables [preserves_colimit (parallel_pair f g) G]
/--
If `G` preserves the coequalizer of `(f,g)`, then the coequalizer comparison map for `G` at `(f,g)`
is an isomorphism.
-/
def preserves_coequalizer.iso :
  coequalizer (G.map f) (G.map g) ≅ G.obj (coequalizer f g) :=
is_colimit.cocone_point_unique_up_to_iso
  (colimit.is_colimit _)
  (is_colimit_of_has_coequalizer_of_preserves_colimit G f g)

@[simp]
lemma preserves_coequalizer.iso_hom :
  (preserves_coequalizer.iso G f g).hom = coequalizer_comparison f g G :=
rfl

instance : is_iso (coequalizer_comparison f g G) :=
begin
  rw ← preserves_coequalizer.iso_hom,
  apply_instance
end

instance map_π_epi : epi (G.map (coequalizer.π f g)) :=
⟨λ W h k, by { rw ←ι_comp_coequalizer_comparison, apply (cancel_epi _).1, apply epi_comp }⟩

@[reassoc]
lemma map_π_preserves_coequalizer_inv :
  G.map (coequalizer.π f g) ≫ (preserves_coequalizer.iso G f g).inv =
  coequalizer.π (G.map f) (G.map g) :=
begin
  rw [←ι_comp_coequalizer_comparison_assoc, ←preserves_coequalizer.iso_hom,
      iso.hom_inv_id, comp_id],
end

@[reassoc]
lemma map_π_preserves_coequalizer_inv_desc
  {W : D} (k : G.obj Y ⟶ W) (wk : G.map f ≫ k = G.map g ≫ k) :
  G.map (coequalizer.π f g) ≫ (preserves_coequalizer.iso G f g).inv ≫ coequalizer.desc k wk = k :=
by rw [←category.assoc, map_π_preserves_coequalizer_inv, coequalizer.π_desc]

@[reassoc]
lemma map_π_preserves_coequalizer_inv_colim_map
  {X' Y' : D} (f' g' : X' ⟶ Y') [has_coequalizer f' g'] (p : G.obj X ⟶ X') (q : G.obj Y ⟶ Y')
  (wf : (G.map f) ≫ q = p ≫ f') (wg : (G.map g) ≫ q = p ≫ g') :
  G.map (coequalizer.π f g) ≫ (preserves_coequalizer.iso G f g).inv ≫
  colim_map (parallel_pair_hom (G.map f) (G.map g) f' g' p q wf wg) =
  q ≫ coequalizer.π f' g' :=
by rw [←category.assoc, map_π_preserves_coequalizer_inv, ι_colim_map, parallel_pair_hom_app_one]

@[reassoc]
lemma map_π_preserves_coequalizer_inv_colim_map_desc
  {X' Y' : D} (f' g' : X' ⟶ Y') [has_coequalizer f' g'] (p : G.obj X ⟶ X') (q : G.obj Y ⟶ Y')
  (wf : (G.map f) ≫ q = p ≫ f') (wg : (G.map g) ≫ q = p ≫ g')
  {Z' : D} (h : Y' ⟶ Z') (wh : f' ≫ h = g' ≫ h) :
  G.map (coequalizer.π f g) ≫ (preserves_coequalizer.iso G f g).inv ≫
  colim_map (parallel_pair_hom (G.map f) (G.map g) f' g' p q wf wg) ≫
  coequalizer.desc h wh =
  q ≫ h :=
begin
  slice_lhs 1 3 { rw map_π_preserves_coequalizer_inv_colim_map },
  slice_lhs 2 3 { rw coequalizer.π_desc },
end

/-- Any functor preserves coequalizers of split pairs. -/
@[priority 1]
instance preserves_split_coequalizers (f g : X ⟶ Y) [has_split_coequalizer f g] :
  preserves_colimit (parallel_pair f g) G :=
begin
  apply preserves_colimit_of_preserves_colimit_cocone
            ((has_split_coequalizer.is_split_coequalizer f g).is_coequalizer),
  apply (is_colimit_map_cocone_cofork_equiv G _).symm
            ((has_split_coequalizer.is_split_coequalizer f g).map G).is_coequalizer,
end
end coequalizers

end category_theory.limits


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.monoidal.natural_transformation
import Mathlib.category_theory.discrete_category
import Mathlib.algebra.group.hom
import Mathlib.PostPort

universes u

namespace Mathlib

/-!
# Monoids as discrete monoidal categories

The discrete category on a monoid is a monoidal category.
Multiplicative morphisms induced monoidal functors.
-/

namespace category_theory

protected instance monoid_discrete (M : Type u) [monoid M] : monoid (discrete M) :=
  id _inst_1

protected instance discrete.monoidal_category (M : Type u) [monoid M] : monoidal_category (discrete M) :=
  monoidal_category.mk (fun (X Y : discrete M) => X * Y)
    (fun (W X Y Z : discrete M) (f : W ⟶ X) (g : Y ⟶ Z) => eq_to_hom sorry) 1
    (fun (X Y Z : discrete M) => eq_to_iso sorry) (fun (X : discrete M) => eq_to_iso sorry)
    fun (X : discrete M) => eq_to_iso sorry

/--
A multiplicative morphism between monoids gives a monoidal functor between the corresponding
discrete monoidal categories.
-/
@[simp] theorem discrete.monoidal_functor_μ_is_iso {M : Type u} [monoid M] {N : Type u} [monoid N] (F : M →* N) (X : discrete M) (Y : discrete M) : monoidal_functor.μ_is_iso (discrete.monoidal_functor F) X Y =
  discrete.category_theory.is_iso
    (lax_monoidal_functor.μ
      (lax_monoidal_functor.mk
        (functor.mk ⇑F fun (X Y : discrete M) (f : X ⟶ Y) => eq_to_hom (discrete.monoidal_functor._proof_1 F X Y f))
        (eq_to_hom (discrete.monoidal_functor._proof_4 F))
        fun (X Y : discrete M) => eq_to_hom (discrete.monoidal_functor._proof_5 F X Y))
      X Y) :=
  Eq.refl (monoidal_functor.μ_is_iso (discrete.monoidal_functor F) X Y)

/--
The monoidal natural isomorphism corresponding to composing two multiplicative morphisms.
-/
def discrete.monoidal_functor_comp {M : Type u} [monoid M] {N : Type u} [monoid N] {K : Type u} [monoid K] (F : M →* N) (G : N →* K) : discrete.monoidal_functor F ⊗⋙ discrete.monoidal_functor G ≅ discrete.monoidal_functor (monoid_hom.comp G F) :=
  iso.mk (monoidal_nat_trans.mk (nat_trans.mk fun (X : discrete M) => 𝟙))
    (monoidal_nat_trans.mk (nat_trans.mk fun (X : discrete M) => 𝟙))


/-
Copyright (c) 2021 OpenAI. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kunhao Zheng, Stanislas Polu, David Renshaw, OpenAI GPT-f
-/
import mathzoo.imports.miniF2F

open_locale nat rat real big_operators topological_space

theorem amc12a_2021_p9 :
  ∏ k in finset.range 7, (2^(2^k) + 3^(2^k)) = 3^128 - 2^128 :=
begin
  simp only [finset.prod_range_succ],
  norm_num,
end

-- Sum a sequence by grouping adjacent terms.
lemma sum_pairs (n : ℕ) (f : ℕ → ℚ) :
  ∑ k in (finset.range (2 * n)), f k = ∑ k in (finset.range n), (f (2 * k) + f (2 * k + 1)) :=
begin
  induction n with pn hpn,
  { simp only [finset.sum_empty, finset.range_zero, mul_zero] },
  { have hs: (2 * pn.succ) = (2 * pn).succ.succ := rfl,
    rw [finset.sum_range_succ, ←hpn, hs, finset.sum_range_succ, finset.sum_range_succ],
    ring },
end


/-
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, Devon Tuma

! This file was ported from Lean 3 source module probability.probability_mass_function.basic
! leanprover-community/mathlib commit 4ac69b290818724c159de091daa3acd31da0ee6d
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Topology.Instances.Ennreal
import Mathbin.MeasureTheory.Measure.MeasureSpace

/-!
# Probability mass functions

This file is about probability mass functions or discrete probability measures:
a function `α → ℝ≥0∞` such that the values have (infinite) sum `1`.

Construction of monadic `pure` and `bind` is found in `probability_mass_function/monad.lean`,
other constructions of `pmf`s are found in `probability_mass_function/constructions.lean`.

Given `p : pmf α`, `pmf.to_outer_measure` constructs an `outer_measure` on `α`,
by assigning each set the sum of the probabilities of each of its elements.
Under this outer measure, every set is Carathéodory-measurable,
so we can further extend this to a `measure` on `α`, see `pmf.to_measure`.
`pmf.to_measure.is_probability_measure` shows this associated measure is a probability measure.
Conversely, given a probability measure `μ` on a measurable space `α` with all singleton sets
measurable, `μ.to_pmf` constructs a `pmf` on `α`, setting the probability mass of a point `x`
to be the measure of the singleton set `{x}`.

## Tags

probability mass function, discrete probability measure
-/

noncomputable section

variable {α β γ : Type _}

open Classical BigOperators NNReal ENNReal MeasureTheory

/-- A probability mass function, or discrete probability measures is a function `α → ℝ≥0∞` such
  that the values have (infinite) sum `1`. -/
def Pmf.{u} (α : Type u) : Type u :=
  { f : α → ℝ≥0∞ // HasSum f 1 }
#align pmf Pmf

namespace Pmf

instance funLike : FunLike (Pmf α) α fun p => ℝ≥0∞
    where
  coe p a := p.1 a
  coe_injective' p q h := Subtype.eq h
#align pmf.fun_like Pmf.funLike

@[ext]
protected theorem ext {p q : Pmf α} (h : ∀ x, p x = q x) : p = q :=
  FunLike.ext p q h
#align pmf.ext Pmf.ext

theorem ext_iff {p q : Pmf α} : p = q ↔ ∀ x, p x = q x :=
  FunLike.ext_iff
#align pmf.ext_iff Pmf.ext_iff

theorem hasSum_coe_one (p : Pmf α) : HasSum p 1 :=
  p.2
#align pmf.has_sum_coe_one Pmf.hasSum_coe_one

@[simp]
theorem tsum_coe (p : Pmf α) : (∑' a, p a) = 1 :=
  p.hasSum_coe_one.tsum_eq
#align pmf.tsum_coe Pmf.tsum_coe

theorem tsum_coe_ne_top (p : Pmf α) : (∑' a, p a) ≠ ∞ :=
  p.tsum_coe.symm ▸ ENNReal.one_ne_top
#align pmf.tsum_coe_ne_top Pmf.tsum_coe_ne_top

theorem tsum_coe_indicator_ne_top (p : Pmf α) (s : Set α) : (∑' a, s.indicator p a) ≠ ∞ :=
  ne_of_lt
    (lt_of_le_of_lt
      (tsum_le_tsum (fun a => Set.indicator_apply_le fun _ => le_rfl) ENNReal.summable
        ENNReal.summable)
      (lt_of_le_of_ne le_top p.tsum_coe_ne_top))
#align pmf.tsum_coe_indicator_ne_top Pmf.tsum_coe_indicator_ne_top

@[simp]
theorem coe_ne_zero (p : Pmf α) : ⇑p ≠ 0 := fun hp =>
  zero_ne_one ((tsum_zero.symm.trans (tsum_congr fun x => symm (congr_fun hp x))).trans p.tsum_coe)
#align pmf.coe_ne_zero Pmf.coe_ne_zero

/-- The support of a `pmf` is the set where it is nonzero. -/
def support (p : Pmf α) : Set α :=
  Function.support p
#align pmf.support Pmf.support

@[simp]
theorem mem_support_iff (p : Pmf α) (a : α) : a ∈ p.support ↔ p a ≠ 0 :=
  Iff.rfl
#align pmf.mem_support_iff Pmf.mem_support_iff

@[simp]
theorem support_nonempty (p : Pmf α) : p.support.Nonempty :=
  Function.support_nonempty_iff.2 p.coe_ne_zero
#align pmf.support_nonempty Pmf.support_nonempty

theorem apply_eq_zero_iff (p : Pmf α) (a : α) : p a = 0 ↔ a ∉ p.support := by
  rw [mem_support_iff, Classical.not_not]
#align pmf.apply_eq_zero_iff Pmf.apply_eq_zero_iff

theorem apply_pos_iff (p : Pmf α) (a : α) : 0 < p a ↔ a ∈ p.support :=
  pos_iff_ne_zero.trans (p.mem_support_iff a).symm
#align pmf.apply_pos_iff Pmf.apply_pos_iff

theorem apply_eq_one_iff (p : Pmf α) (a : α) : p a = 1 ↔ p.support = {a} :=
  by
  refine'
    ⟨fun h =>
      Set.Subset.antisymm (fun a' ha' => by_contra fun ha => _) fun a' ha' =>
        ha'.symm ▸ (p.mem_support_iff a).2 fun ha => zero_ne_one <| ha.symm.trans h,
      fun h =>
      trans (symm <| tsum_eq_single a fun a' ha' => (p.apply_eq_zero_iff a').2 (h.symm ▸ ha'))
        p.tsum_coe⟩
  suffices : 1 < ∑' a, p a
  exact ne_of_lt this p.tsum_coe.symm
  have : 0 < ∑' b, ite (b = a) 0 (p b) :=
    lt_of_le_of_ne' zero_le'
      ((tsum_ne_zero_iff ENNReal.summable).2
        ⟨a', ite_ne_left_iff.2 ⟨ha, Ne.symm <| (p.mem_support_iff a').2 ha'⟩⟩)
  calc
    1 = 1 + 0 := (add_zero 1).symm
    _ < p a + ∑' b, ite (b = a) 0 (p b) :=
      (ENNReal.add_lt_add_of_le_of_lt ENNReal.one_ne_top (le_of_eq h.symm) this)
    _ = ite (a = a) (p a) 0 + ∑' b, ite (b = a) 0 (p b) := by rw [eq_self_iff_true, if_true]
    _ = (∑' b, ite (b = a) (p b) 0) + ∑' b, ite (b = a) 0 (p b) :=
      by
      congr
      exact symm (tsum_eq_single a fun b hb => if_neg hb)
    _ = ∑' b, ite (b = a) (p b) 0 + ite (b = a) 0 (p b) := ennreal.tsum_add.symm
    _ = ∑' b, p b := tsum_congr fun b => by split_ifs <;> simp only [zero_add, add_zero, le_rfl]

#align pmf.apply_eq_one_iff Pmf.apply_eq_one_iff

theorem coe_le_one (p : Pmf α) (a : α) : p a ≤ 1 :=
  hasSum_le
    (by
      intro b
      split_ifs <;> simp only [h, zero_le', le_rfl])
    (hasSum_ite_eq a (p a)) (hasSum_coe_one p)
#align pmf.coe_le_one Pmf.coe_le_one

theorem apply_ne_top (p : Pmf α) (a : α) : p a ≠ ∞ :=
  ne_of_lt (lt_of_le_of_lt (p.coe_le_one a) ENNReal.one_lt_top)
#align pmf.apply_ne_top Pmf.apply_ne_top

theorem apply_lt_top (p : Pmf α) (a : α) : p a < ∞ :=
  lt_of_le_of_ne le_top (p.apply_ne_top a)
#align pmf.apply_lt_top Pmf.apply_lt_top

section OuterMeasure

open MeasureTheory MeasureTheory.OuterMeasure

/-- Construct an `outer_measure` from a `pmf`, by assigning measure to each set `s : set α` equal
  to the sum of `p x` for for each `x ∈ α` -/
def toOuterMeasure (p : Pmf α) : OuterMeasure α :=
  OuterMeasure.sum fun x : α => p x • dirac x
#align pmf.to_outer_measure Pmf.toOuterMeasure

variable (p : Pmf α) (s t : Set α)

theorem toOuterMeasure_apply : p.toOuterMeasure s = ∑' x, s.indicator p x :=
  tsum_congr fun x => smul_dirac_apply (p x) x s
#align pmf.to_outer_measure_apply Pmf.toOuterMeasure_apply

@[simp]
theorem toOuterMeasure_caratheodory : p.toOuterMeasure.caratheodory = ⊤ :=
  by
  refine' eq_top_iff.2 <| le_trans (le_infₛ fun x hx => _) (le_sum_caratheodory _)
  exact
    let ⟨y, hy⟩ := hx
    ((le_of_eq (dirac_caratheodory y).symm).trans (le_smul_caratheodory _ _)).trans (le_of_eq hy)
#align pmf.to_outer_measure_caratheodory Pmf.toOuterMeasure_caratheodory

@[simp]
theorem toOuterMeasure_apply_finset (s : Finset α) : p.toOuterMeasure s = ∑ x in s, p x :=
  by
  refine' (to_outer_measure_apply p s).trans ((@tsum_eq_sum _ _ _ _ _ _ s _).trans _)
  · exact fun x hx => Set.indicator_of_not_mem hx _
  · exact Finset.sum_congr rfl fun x hx => Set.indicator_of_mem hx _
#align pmf.to_outer_measure_apply_finset Pmf.toOuterMeasure_apply_finset

theorem toOuterMeasure_apply_singleton (a : α) : p.toOuterMeasure {a} = p a :=
  by
  refine' (p.to_outer_measure_apply {a}).trans ((tsum_eq_single a fun b hb => _).trans _)
  · exact ite_eq_right_iff.2 fun hb' => False.elim <| hb hb'
  · exact ite_eq_left_iff.2 fun ha' => False.elim <| ha' rfl
#align pmf.to_outer_measure_apply_singleton Pmf.toOuterMeasure_apply_singleton

theorem toOuterMeasure_injective : (toOuterMeasure : Pmf α → OuterMeasure α).Injective :=
  fun p q h =>
  Pmf.ext fun x =>
    (p.toOuterMeasure_apply_singleton x).symm.trans
      ((congr_fun (congr_arg _ h) _).trans <| q.toOuterMeasure_apply_singleton x)
#align pmf.to_outer_measure_injective Pmf.toOuterMeasure_injective

@[simp]
theorem toOuterMeasure_inj {p q : Pmf α} : p.toOuterMeasure = q.toOuterMeasure ↔ p = q :=
  toOuterMeasure_injective.eq_iff
#align pmf.to_outer_measure_inj Pmf.toOuterMeasure_inj

theorem toOuterMeasure_apply_eq_zero_iff : p.toOuterMeasure s = 0 ↔ Disjoint p.support s :=
  by
  rw [to_outer_measure_apply, ENNReal.tsum_eq_zero]
  exact function.funext_iff.symm.trans Set.indicator_eq_zero'
#align pmf.to_outer_measure_apply_eq_zero_iff Pmf.toOuterMeasure_apply_eq_zero_iff

/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (x «expr ∉ » s) -/
theorem toOuterMeasure_apply_eq_one_iff : p.toOuterMeasure s = 1 ↔ p.support ⊆ s :=
  by
  refine' (p.to_outer_measure_apply s).symm ▸ ⟨fun h a hap => _, fun h => _⟩
  · refine' by_contra fun hs => ne_of_lt _ (h.trans p.tsum_coe.symm)
    have hs' : s.indicator p a = 0 := Set.indicator_apply_eq_zero.2 fun hs' => False.elim <| hs hs'
    have hsa : s.indicator p a < p a := hs'.symm ▸ (p.apply_pos_iff a).2 hap
    exact
      ENNReal.tsum_lt_tsum (p.tsum_coe_indicator_ne_top s)
        (fun x => Set.indicator_apply_le fun _ => le_rfl) hsa
  · suffices : ∀ (x) (_ : x ∉ s), p x = 0
    exact
      trans
        (tsum_congr fun a => (Set.indicator_apply s p a).trans (ite_eq_left_iff.2 <| symm ∘ this a))
        p.tsum_coe
    exact fun a ha => (p.apply_eq_zero_iff a).2 <| Set.not_mem_subset h ha
#align pmf.to_outer_measure_apply_eq_one_iff Pmf.toOuterMeasure_apply_eq_one_iff

@[simp]
theorem toOuterMeasure_apply_inter_support :
    p.toOuterMeasure (s ∩ p.support) = p.toOuterMeasure s := by
  simp only [to_outer_measure_apply, Pmf.support, Set.indicator_inter_support]
#align pmf.to_outer_measure_apply_inter_support Pmf.toOuterMeasure_apply_inter_support

/-- Slightly stronger than `outer_measure.mono` having an intersection with `p.support` -/
theorem toOuterMeasure_mono {s t : Set α} (h : s ∩ p.support ⊆ t) :
    p.toOuterMeasure s ≤ p.toOuterMeasure t :=
  le_trans (le_of_eq (toOuterMeasure_apply_inter_support p s).symm) (p.toOuterMeasure.mono h)
#align pmf.to_outer_measure_mono Pmf.toOuterMeasure_mono

theorem toOuterMeasure_apply_eq_of_inter_support_eq {s t : Set α}
    (h : s ∩ p.support = t ∩ p.support) : p.toOuterMeasure s = p.toOuterMeasure t :=
  le_antisymm (p.toOuterMeasure_mono (h.symm ▸ Set.inter_subset_left t p.support))
    (p.toOuterMeasure_mono (h ▸ Set.inter_subset_left s p.support))
#align pmf.to_outer_measure_apply_eq_of_inter_support_eq Pmf.toOuterMeasure_apply_eq_of_inter_support_eq

@[simp]
theorem toOuterMeasure_apply_fintype [Fintype α] : p.toOuterMeasure s = ∑ x, s.indicator p x :=
  (p.toOuterMeasure_apply s).trans (tsum_eq_sum fun x h => absurd (Finset.mem_univ x) h)
#align pmf.to_outer_measure_apply_fintype Pmf.toOuterMeasure_apply_fintype

end OuterMeasure

section Measure

open MeasureTheory

/-- Since every set is Carathéodory-measurable under `pmf.to_outer_measure`,
  we can further extend this `outer_measure` to a `measure` on `α` -/
def toMeasure [MeasurableSpace α] (p : Pmf α) : Measure α :=
  p.toOuterMeasure.toMeasure ((toOuterMeasure_caratheodory p).symm ▸ le_top)
#align pmf.to_measure Pmf.toMeasure

variable [MeasurableSpace α] (p : Pmf α) (s t : Set α)

theorem toOuterMeasure_apply_le_toMeasure_apply : p.toOuterMeasure s ≤ p.toMeasure s :=
  le_toMeasure_apply p.toOuterMeasure _ s
#align pmf.to_outer_measure_apply_le_to_measure_apply Pmf.toOuterMeasure_apply_le_toMeasure_apply

theorem toMeasure_apply_eq_toOuterMeasure_apply (hs : MeasurableSet s) :
    p.toMeasure s = p.toOuterMeasure s :=
  toMeasure_apply p.toOuterMeasure _ hs
#align pmf.to_measure_apply_eq_to_outer_measure_apply Pmf.toMeasure_apply_eq_toOuterMeasure_apply

theorem toMeasure_apply (hs : MeasurableSet s) : p.toMeasure s = ∑' x, s.indicator p x :=
  (p.toMeasure_apply_eq_toOuterMeasure_apply s hs).trans (p.toOuterMeasure_apply s)
#align pmf.to_measure_apply Pmf.toMeasure_apply

theorem toMeasure_apply_singleton (a : α) (h : MeasurableSet ({a} : Set α)) :
    p.toMeasure {a} = p a := by
  simp [to_measure_apply_eq_to_outer_measure_apply _ _ h, to_outer_measure_apply_singleton]
#align pmf.to_measure_apply_singleton Pmf.toMeasure_apply_singleton

theorem toMeasure_apply_eq_zero_iff (hs : MeasurableSet s) :
    p.toMeasure s = 0 ↔ Disjoint p.support s := by
  rw [to_measure_apply_eq_to_outer_measure_apply p s hs, to_outer_measure_apply_eq_zero_iff]
#align pmf.to_measure_apply_eq_zero_iff Pmf.toMeasure_apply_eq_zero_iff

theorem toMeasure_apply_eq_one_iff (hs : MeasurableSet s) : p.toMeasure s = 1 ↔ p.support ⊆ s :=
  (p.toMeasure_apply_eq_toOuterMeasure_apply s hs : p.toMeasure s = p.toOuterMeasure s).symm ▸
    p.toOuterMeasure_apply_eq_one_iff s
#align pmf.to_measure_apply_eq_one_iff Pmf.toMeasure_apply_eq_one_iff

@[simp]
theorem toMeasure_apply_inter_support (hs : MeasurableSet s) (hp : MeasurableSet p.support) :
    p.toMeasure (s ∩ p.support) = p.toMeasure s := by
  simp [p.to_measure_apply_eq_to_outer_measure_apply s hs,
    p.to_measure_apply_eq_to_outer_measure_apply _ (hs.inter hp)]
#align pmf.to_measure_apply_inter_support Pmf.toMeasure_apply_inter_support

theorem toMeasure_mono {s t : Set α} (hs : MeasurableSet s) (ht : MeasurableSet t)
    (h : s ∩ p.support ⊆ t) : p.toMeasure s ≤ p.toMeasure t := by
  simpa only [p.to_measure_apply_eq_to_outer_measure_apply, hs, ht] using to_outer_measure_mono p h
#align pmf.to_measure_mono Pmf.toMeasure_mono

theorem toMeasure_apply_eq_of_inter_support_eq {s t : Set α} (hs : MeasurableSet s)
    (ht : MeasurableSet t) (h : s ∩ p.support = t ∩ p.support) : p.toMeasure s = p.toMeasure t := by
  simpa only [p.to_measure_apply_eq_to_outer_measure_apply, hs, ht] using
    to_outer_measure_apply_eq_of_inter_support_eq p h
#align pmf.to_measure_apply_eq_of_inter_support_eq Pmf.toMeasure_apply_eq_of_inter_support_eq

section MeasurableSingletonClass

variable [MeasurableSingletonClass α]

theorem toMeasure_injective : (toMeasure : Pmf α → Measure α).Injective := fun p q h =>
  Pmf.ext fun x =>
    (p.toMeasure_apply_singleton x <| measurableSet_singleton x).symm.trans
      ((congr_fun (congr_arg _ h) _).trans <|
        q.toMeasure_apply_singleton x <| measurableSet_singleton x)
#align pmf.to_measure_injective Pmf.toMeasure_injective

@[simp]
theorem toMeasure_inj {p q : Pmf α} : p.toMeasure = q.toMeasure ↔ p = q :=
  toMeasure_injective.eq_iff
#align pmf.to_measure_inj Pmf.toMeasure_inj

@[simp]
theorem toMeasure_apply_finset (s : Finset α) : p.toMeasure s = ∑ x in s, p x :=
  (p.toMeasure_apply_eq_toOuterMeasure_apply s s.MeasurableSet).trans
    (p.toOuterMeasure_apply_finset s)
#align pmf.to_measure_apply_finset Pmf.toMeasure_apply_finset

theorem toMeasure_apply_of_finite (hs : s.Finite) : p.toMeasure s = ∑' x, s.indicator p x :=
  (p.toMeasure_apply_eq_toOuterMeasure_apply s hs.MeasurableSet).trans (p.toOuterMeasure_apply s)
#align pmf.to_measure_apply_of_finite Pmf.toMeasure_apply_of_finite

@[simp]
theorem toMeasure_apply_fintype [Fintype α] : p.toMeasure s = ∑ x, s.indicator p x :=
  (p.toMeasure_apply_eq_toOuterMeasure_apply s s.toFinite.MeasurableSet).trans
    (p.toOuterMeasure_apply_fintype s)
#align pmf.to_measure_apply_fintype Pmf.toMeasure_apply_fintype

end MeasurableSingletonClass

end Measure

end Pmf

namespace MeasureTheory

open Pmf

namespace Measure

/-- Given that `α` is a countable, measurable space with all singleton sets measurable,
we can convert any probability measure into a `pmf`, where the mass of a point
is the measure of the singleton set under the original measure. -/
def toPmf [Countable α] [MeasurableSpace α] [MeasurableSingletonClass α] (μ : Measure α)
    [h : IsProbabilityMeasure μ] : Pmf α :=
  ⟨fun x => μ ({x} : Set α),
    ENNReal.summable.hasSum_iff.2
      (trans
        (symm <|
          (tsum_indicator_apply_singleton μ Set.univ MeasurableSet.univ).symm.trans
            (tsum_congr fun x => congr_fun (Set.indicator_univ _) x))
        h.measure_univ)⟩
#align measure_theory.measure.to_pmf MeasureTheory.Measure.toPmf

variable [Countable α] [MeasurableSpace α] [MeasurableSingletonClass α] (μ : Measure α)
  [IsProbabilityMeasure μ]

theorem toPmf_apply (x : α) : μ.toPmf x = μ {x} :=
  rfl
#align measure_theory.measure.to_pmf_apply MeasureTheory.Measure.toPmf_apply

@[simp]
theorem toPmf_toMeasure : μ.toPmf.toMeasure = μ :=
  Measure.ext fun s hs => by
    simpa only [μ.to_pmf.to_measure_apply s hs, ← μ.tsum_indicator_apply_singleton s hs]
#align measure_theory.measure.to_pmf_to_measure MeasureTheory.Measure.toPmf_toMeasure

end Measure

end MeasureTheory

namespace Pmf

open MeasureTheory

/-- The measure associated to a `pmf` by `to_measure` is a probability measure -/
instance toMeasure.isProbabilityMeasure [MeasurableSpace α] (p : Pmf α) :
    IsProbabilityMeasure p.toMeasure :=
  ⟨by
    simpa only [MeasurableSet.univ, to_measure_apply_eq_to_outer_measure_apply, Set.indicator_univ,
      to_outer_measure_apply, ENNReal.coe_eq_one] using tsum_coe p⟩
#align pmf.to_measure.is_probability_measure Pmf.toMeasure.isProbabilityMeasure

variable [Countable α] [MeasurableSpace α] [MeasurableSingletonClass α] (p : Pmf α) (μ : Measure α)
  [IsProbabilityMeasure μ]

@[simp]
theorem toMeasure_toPmf : p.toMeasure.toPmf = p :=
  Pmf.ext fun x => by
    rw [← p.to_measure_apply_singleton x (measurable_set_singleton x), p.to_measure.to_pmf_apply]
#align pmf.to_measure_to_pmf Pmf.toMeasure_toPmf

theorem toMeasure_eq_iff_eq_toPmf (μ : Measure α) [IsProbabilityMeasure μ] :
    p.toMeasure = μ ↔ p = μ.toPmf := by rw [← to_measure_inj, measure.to_pmf_to_measure]
#align pmf.to_measure_eq_iff_eq_to_pmf Pmf.toMeasure_eq_iff_eq_toPmf

theorem toPmf_eq_iff_toMeasure_eq (μ : Measure α) [IsProbabilityMeasure μ] :
    μ.toPmf = p ↔ μ = p.toMeasure := by rw [← to_measure_inj, measure.to_pmf_to_measure]
#align pmf.to_pmf_eq_iff_to_measure_eq Pmf.toPmf_eq_iff_toMeasure_eq

end Pmf


/-
Copyright (c) 2021 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import algebra.char_zero.lemmas
import order.locally_finite
import data.finset.locally_finite

/-!
# Finite intervals of integers

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

This file proves that `ℤ` is a `locally_finite_order` and calculates the cardinality of its
intervals as finsets and fintypes.
-/

open finset int

instance : locally_finite_order ℤ :=
{ finset_Icc := λ a b, (finset.range (b + 1 - a).to_nat).map $
    nat.cast_embedding.trans $ add_left_embedding a,
  finset_Ico := λ a b, (finset.range (b - a).to_nat).map $
    nat.cast_embedding.trans $ add_left_embedding a,
  finset_Ioc := λ a b, (finset.range (b - a).to_nat).map $
    nat.cast_embedding.trans $ add_left_embedding (a + 1),
  finset_Ioo := λ a b, (finset.range (b - a - 1).to_nat).map $
    nat.cast_embedding.trans $ add_left_embedding (a + 1),
  finset_mem_Icc := λ a b x, begin
    simp_rw [mem_map, exists_prop, mem_range, int.lt_to_nat, function.embedding.trans_apply,
      nat.cast_embedding_apply, add_left_embedding_apply],
    split,
    { rintro ⟨a, h, rfl⟩,
      rw [lt_sub_iff_add_lt, int.lt_add_one_iff, add_comm] at h,
      exact ⟨int.le.intro rfl, h⟩ },
    { rintro ⟨ha, hb⟩,
      use (x - a).to_nat,
      rw ←lt_add_one_iff at hb,
      rw to_nat_sub_of_le ha,
      exact ⟨sub_lt_sub_right hb _, add_sub_cancel'_right _ _⟩ }
  end,
  finset_mem_Ico := λ a b x, begin
    simp_rw [mem_map, exists_prop, mem_range, int.lt_to_nat, function.embedding.trans_apply,
      nat.cast_embedding_apply, add_left_embedding_apply],
    split,
    { rintro ⟨a, h, rfl⟩,
      exact ⟨int.le.intro rfl, lt_sub_iff_add_lt'.mp h⟩ },
    { rintro ⟨ha, hb⟩,
      use (x - a).to_nat,
      rw to_nat_sub_of_le ha,
      exact ⟨sub_lt_sub_right hb _, add_sub_cancel'_right _ _⟩ }
  end,
  finset_mem_Ioc := λ a b x, begin
    simp_rw [mem_map, exists_prop, mem_range, int.lt_to_nat, function.embedding.trans_apply,
      nat.cast_embedding_apply, add_left_embedding_apply],
    split,
    { rintro ⟨a, h, rfl⟩,
      rw [←add_one_le_iff, le_sub_iff_add_le', add_comm _ (1 : ℤ), ←add_assoc] at h,
      exact ⟨int.le.intro rfl, h⟩ },
    { rintro ⟨ha, hb⟩,
      use (x - (a + 1)).to_nat,
      rw [to_nat_sub_of_le ha, ←add_one_le_iff, sub_add, add_sub_cancel],
      exact ⟨sub_le_sub_right hb _, add_sub_cancel'_right _ _⟩ }
  end,
  finset_mem_Ioo := λ a b x, begin
    simp_rw [mem_map, exists_prop, mem_range, int.lt_to_nat, function.embedding.trans_apply,
      nat.cast_embedding_apply, add_left_embedding_apply],
    split,
    { rintro ⟨a, h, rfl⟩,
      rw [sub_sub, lt_sub_iff_add_lt'] at h,
      exact ⟨int.le.intro rfl, h⟩ },
    { rintro ⟨ha, hb⟩,
      use (x - (a + 1)).to_nat,
      rw [to_nat_sub_of_le ha, sub_sub],
      exact ⟨sub_lt_sub_right hb _, add_sub_cancel'_right _ _⟩ }
  end }

namespace int
variables (a b : ℤ)

lemma Icc_eq_finset_map :
  Icc a b = (finset.range (b + 1 - a).to_nat).map
    (nat.cast_embedding.trans $ add_left_embedding a) := rfl
lemma Ico_eq_finset_map :
  Ico a b = (finset.range (b - a).to_nat).map
    (nat.cast_embedding.trans $ add_left_embedding a) := rfl
lemma Ioc_eq_finset_map :
  Ioc a b = (finset.range (b - a).to_nat).map
    (nat.cast_embedding.trans $ add_left_embedding (a + 1)) := rfl
lemma Ioo_eq_finset_map :
  Ioo a b = (finset.range (b - a - 1).to_nat).map
    (nat.cast_embedding.trans $ add_left_embedding (a + 1)) := rfl

@[simp] lemma card_Icc : (Icc a b).card = (b + 1 - a).to_nat :=
by { change (finset.map _ _).card = _, rw [finset.card_map, finset.card_range] }

@[simp] lemma card_Ico : (Ico a b).card = (b - a).to_nat :=
by { change (finset.map _ _).card = _, rw [finset.card_map, finset.card_range] }

@[simp] lemma card_Ioc : (Ioc a b).card = (b - a).to_nat :=
by { change (finset.map _ _).card = _, rw [finset.card_map, finset.card_range] }

@[simp] lemma card_Ioo : (Ioo a b).card = (b - a - 1).to_nat :=
by { change (finset.map _ _).card = _, rw [finset.card_map, finset.card_range] }

lemma card_Icc_of_le (h : a ≤ b + 1) : ((Icc a b).card : ℤ) = b + 1 - a :=
by rw [card_Icc, to_nat_sub_of_le h]

lemma card_Ico_of_le (h : a ≤ b) : ((Ico a b).card : ℤ) = b - a :=
by rw [card_Ico, to_nat_sub_of_le h]

lemma card_Ioc_of_le (h : a ≤ b) : ((Ioc a b).card : ℤ) = b - a :=
by rw [card_Ioc, to_nat_sub_of_le h]

lemma card_Ioo_of_lt (h : a < b) : ((Ioo a b).card : ℤ) = b - a - 1 :=
by rw [card_Ioo, sub_sub, to_nat_sub_of_le h]

@[simp] lemma card_fintype_Icc : fintype.card (set.Icc a b) = (b + 1 - a).to_nat :=
by rw [←card_Icc, fintype.card_of_finset]

@[simp] lemma card_fintype_Ico : fintype.card (set.Ico a b) = (b - a).to_nat :=
by rw [←card_Ico, fintype.card_of_finset]

@[simp] lemma card_fintype_Ioc : fintype.card (set.Ioc a b) = (b - a).to_nat :=
by rw [←card_Ioc, fintype.card_of_finset]

@[simp] lemma card_fintype_Ioo : fintype.card (set.Ioo a b) = (b - a - 1).to_nat :=
by rw [←card_Ioo, fintype.card_of_finset]

lemma card_fintype_Icc_of_le (h : a ≤ b + 1) : (fintype.card (set.Icc a b) : ℤ) = b + 1 - a :=
by rw [card_fintype_Icc, to_nat_sub_of_le h]

lemma card_fintype_Ico_of_le (h : a ≤ b) : (fintype.card (set.Ico a b) : ℤ) = b - a :=
by rw [card_fintype_Ico, to_nat_sub_of_le h]

lemma card_fintype_Ioc_of_le (h : a ≤ b) : (fintype.card (set.Ioc a b) : ℤ) = b - a :=
by rw [card_fintype_Ioc, to_nat_sub_of_le h]

lemma card_fintype_Ioo_of_lt (h : a < b) : (fintype.card (set.Ioo a b) : ℤ) = b - a - 1 :=
by rw [card_fintype_Ioo, sub_sub, to_nat_sub_of_le h]

lemma image_Ico_mod (n a : ℤ) (h : 0 ≤ a) :
  (Ico n (n+a)).image (% a) = Ico 0 a :=
begin
  obtain rfl | ha := eq_or_lt_of_le h,
  { simp, },
  ext i,
  simp only [mem_image, exists_prop, mem_range, mem_Ico],
  split,
  { rintro ⟨i, h, rfl⟩, exact ⟨mod_nonneg i (ne_of_gt ha), mod_lt_of_pos i ha⟩, },
  intro hia,
  have hn := int.mod_add_div n a,
  obtain hi | hi := lt_or_le i (n % a),
  { refine ⟨i + a * (n/a + 1), ⟨_, _⟩, _⟩,
    { rw [add_comm (n/a), mul_add, mul_one, ← add_assoc],
      refine hn.symm.le.trans (add_le_add_right _ _),
      simpa only [zero_add] using add_le_add (hia.left) (int.mod_lt_of_pos n ha).le, },
    { refine lt_of_lt_of_le (add_lt_add_right hi (a * (n/a + 1))) _,
      rw [mul_add, mul_one, ← add_assoc, hn], },
    { rw [int.add_mul_mod_self_left, int.mod_eq_of_lt hia.left hia.right], } },
  { refine ⟨i + a * (n/a), ⟨_, _⟩, _⟩,
    { exact hn.symm.le.trans (add_le_add_right hi _), },
    { rw [add_comm n a],
      refine add_lt_add_of_lt_of_le hia.right (le_trans _ hn.le),
      simp only [zero_le, le_add_iff_nonneg_left],
      exact int.mod_nonneg n (ne_of_gt ha), },
    { rw [int.add_mul_mod_self_left, int.mod_eq_of_lt hia.left hia.right], } },
end

end int


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Callum Sutton, Yury Kudryashov

! This file was ported from Lean 3 source module algebra.big_operators.ring_equiv
! leanprover-community/mathlib commit 008205aa645b3f194c1da47025c5f110c8406eab
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.BigOperators.Basic
import Mathlib.Algebra.Ring.Equiv

/-!
# Results about mapping big operators across ring equivalences
-/

namespace RingEquiv

open BigOperators

variable {α R S : Type _}

protected theorem map_list_prod [Semiring R] [Semiring S] (f : R ≃+* S) (l : List R) :
    f l.prod = (l.map f).prod := map_list_prod f l
#align ring_equiv.map_list_prod RingEquiv.map_list_prod

protected theorem map_list_sum [NonAssocSemiring R] [NonAssocSemiring S] (f : R ≃+* S)
    (l : List R) : f l.sum = (l.map f).sum := map_list_sum f l
#align ring_equiv.map_list_sum RingEquiv.map_list_sum

/-- An isomorphism into the opposite ring acts on the product by acting on the reversed elements -/
protected theorem unop_map_list_prod [Semiring R] [Semiring S] (f : R ≃+* Sᵐᵒᵖ) (l : List R) :
    MulOpposite.unop (f l.prod) = (l.map (MulOpposite.unop ∘ f)).reverse.prod :=
  unop_map_list_prod f l
#align ring_equiv.unop_map_list_prod RingEquiv.unop_map_list_prod

protected theorem map_multiset_prod [CommSemiring R] [CommSemiring S] (f : R ≃+* S)
    (s : Multiset R) : f s.prod = (s.map f).prod :=
  map_multiset_prod f s
#align ring_equiv.map_multiset_prod RingEquiv.map_multiset_prod

protected theorem map_multiset_sum [NonAssocSemiring R] [NonAssocSemiring S] (f : R ≃+* S)
    (s : Multiset R) : f s.sum = (s.map f).sum :=
  map_multiset_sum f s
#align ring_equiv.map_multiset_sum RingEquiv.map_multiset_sum

protected theorem map_prod [CommSemiring R] [CommSemiring S] (g : R ≃+* S) (f : α → R)
    (s : Finset α) : g (∏ x in s, f x) = ∏ x in s, g (f x) :=
  map_prod g f s
#align ring_equiv.map_prod RingEquiv.map_prod

protected theorem map_sum [NonAssocSemiring R] [NonAssocSemiring S] (g : R ≃+* S) (f : α → R)
    (s : Finset α) : g (∑ x in s, f x) = ∑ x in s, g (f x) :=
  map_sum g f s
#align ring_equiv.map_sum RingEquiv.map_sum

end RingEquiv