/-
5. Use the Pigeonhole Principle to prove the following statements involv-
ing a positive integer n:
(a) In any set of 6 integers, there must be two whose difference is divisible by 5.
(b) In any set of n + 1 integers, there must be two whose difference is
divisible by n.
(c) Given any n integers a₁, a₂,..., aₙ, there is a non-empty subset of
these whose sum is divisible by n. (Hint: Consider the integers 0,a₁ ,
a₁ + a₂ ,..., a₁ +...+aₙ and use (b).)
(d) Given any set S consisting of ten distinct integers between 1 and 50,
there are two different 5-element subsets of S with the same sum.
(e) Given any set T consisting of nine distinct integers between 1 and
50, there are two disjoint subsets of T with the same sum.
(f) In any set of 101 integers chosen from the set {1, 2, . . . , 200}, there
must be two integers such that one divides the other.
-/
import tactic
import combinatorics.pigeonhole
import algebra.big_operators.fin
import data.int.succ_pred
import data.int.parity
import data.nat.factorization.basic

open function

lemma parta (S : finset ℤ) (hS : S.card = 6) : ∃ a b ∈ S, a ≠ b ∧ (5 : ℤ) ∣ a - b :=
begin
  let f : ℤ → ℤ := λ z, z % 5,
  let T : finset ℤ := finset.Ico 0 5,
  have hfT : ∀ z : ℤ, z ∈ S → (f z) ∈ T,
  { intros z hz,
    simp only [f, finset.mem_Ico],
    split,
    apply int.mod_nonneg,
    norm_num,
    apply int.mod_lt,
    norm_num, },
  have hST : T.card * 1 < S.card,
  { simp only [hS, int.card_Ico, tsub_zero, mul_one],
    norm_num, },
  have := finset.exists_lt_card_fiber_of_mul_lt_card_of_maps_to hfT hST,
  dsimp at this,
  rcases this with ⟨y, Hy, H⟩,
  rw finset.one_lt_card at H,
  rcases H with ⟨a, ha, b, hb, H⟩,
  simp only [finset.mem_filter] at ha hb,
  use [a, ha.1, b, hb.1, H],
  apply int.modeq.dvd,
  change f b = f a,
  rw [hb.2, ha.2],
end

lemma partb (n : ℕ) (hn : 0 < n) (S : finset ℤ) (hS : S.card = n + 1) : ∃ a b ∈ S, a ≠ b ∧ (n : ℤ) ∣ a - b :=
begin
  let f : ℤ → ℤ := λ z, z % n,
  let T : finset ℤ := finset.Ico 0 n,
  have hfT : ∀ z : ℤ, z ∈ S → (f z) ∈ T,
  { intros z hz,
    simp only [f, finset.mem_Ico],
    split,
    apply int.mod_nonneg,
    linarith,
    convert int.mod_lt _ _,
    simp only [nat.abs_cast],
    linarith, },
  have hST : T.card * 1 < S.card,
  { simp only [hS, int.card_Ico, tsub_zero, int.to_nat_coe_nat, mul_one, lt_add_iff_pos_right, nat.lt_one_iff], },
  have := finset.exists_lt_card_fiber_of_mul_lt_card_of_maps_to hfT hST,
  dsimp at this,
  rcases this with ⟨y, Hy, H⟩,
  rw finset.one_lt_card at H,
  rcases H with ⟨a, ha, b, hb, H⟩,
  simp at ha hb,
  use [a, ha.1, b, hb.1, H],
  apply int.modeq.dvd,
  change f b = f a,
  rw [hb.2, ha.2],
end

-- A stronger of part b which should be easier to use
-- (the point is that f might not be injective on s)
lemma partb' {ι : Type*} {s : finset ι} (f : ι → ℤ) (hs : s.nonempty) {n : ℕ} (hn : 0 < n)
  (hs' : n < s.card): ∃ a b ∈ s, a ≠ b ∧ (n : ℤ) ∣ f a - f b :=
begin
  let f' : ι → ℤ := λ z, (f z) % n,
  let T : finset ℤ := finset.Ico 0 n,
  have hfT : ∀ z : ι, z ∈ s → (f' z) ∈ T,
  { intros z hz,
    simp only [f', finset.mem_Ico],
    have hn' : (n : ℤ) ≠ 0,
    { norm_cast, exact hn.ne', },
    split,
    { exact int.mod_nonneg _ hn', },
    { convert int.mod_lt _ hn',
      simp only [nat.abs_cast], }, },
  have hST : T.card * 1 < s.card,
  { simp [hs'], },
  obtain ⟨y, hyT, hcard⟩ :=
    finset.exists_lt_card_fiber_of_mul_lt_card_of_maps_to hfT hST,
  rw finset.one_lt_card_iff at hcard,
  rcases hcard with ⟨a, b, ha, hb, hab⟩,
  rw finset.mem_filter at ha hb,
  refine ⟨a, ha.1, b, hb.1, hab, _⟩,
  dsimp at ha hb,
  apply int.modeq.dvd,
  change f' b = f' a,
  rw [hb.2, ha.2],
end

open_locale big_operators

lemma finset.sum_Ico {M : Type*} [add_comm_group M]
  {a b : ℕ} (h : a ≤ b) (f : ℕ → M) :
  ∑ i in finset.Ico a b, f i = ∑ j in finset.range b, f j - ∑ j in finset.range a, f j :=
begin
  rw eq_sub_iff_add_eq,
  rw ← finset.sum_union,
  { apply finset.sum_congr _ (λ x _, rfl),
    rw [finset.range_eq_Ico, finset.union_comm, finset.Ico_union_Ico_eq_Ico (nat.zero_le a) h], },
  { rintros x (hx : x ∈ _ ∩ _),
    rw [finset.mem_inter, finset.mem_Ico, finset.mem_range] at hx,
    rcases hx with ⟨⟨h1, _⟩, h2⟩,
    exact false.elim (h1.not_lt h2), },
end

lemma partc (n : ℕ) (hn : 0 < n) (f : ℕ → ℤ) : ∃ S : finset ℕ,
  S ⊆ finset.range n ∧ S.nonempty ∧ (n : ℤ) ∣ ∑ i in S, f i :=
begin
  --  {ι : Type*} {s : finset ι} (f : ι → ℤ) (hs : s.nonempty) {n : ℕ} (hn : 0 < n)
  -- (hs' : n < s.card): ∃ a b ∈ s, a ≠ b ∧ (n : ℤ) ∣ f a - f b := sorry
  rcases partb' (λ t, ∑ i in finset.range t, f i)
    (@finset.nonempty_range_succ n) hn (by simp) with ⟨a, ha, b, hb, hab, hn⟩,
  rw finset.mem_range_succ_iff at ha hb,
  rw ne_iff_lt_or_gt at hab,
  rcases hab with hab | (hab : b < a),
  { use finset.Ico a b,
    refine ⟨_, _, _⟩,
    { rw [finset.range_eq_Ico, finset.Ico_subset_Ico_iff hab],
      exact ⟨zero_le a, hb⟩, },
    { rwa finset.nonempty_Ico, },
    { rwa [finset.sum_Ico hab.le, ← dvd_neg, neg_sub], }, },
  { -- b < a case
    use finset.Ico b a,
    refine ⟨_, _, _⟩,
    { rw [finset.range_eq_Ico, finset.Ico_subset_Ico_iff hab],
      exact ⟨zero_le b, ha⟩, },
    { rwa finset.nonempty_Ico, },
    { rwa finset.sum_Ico hab.le, }, },
end

-- should be in mathlib maybe? (thanks Eric Rodriguez)
def sum_le_max (S : finset ℤ) (x : ℤ) (hS' : ∀ s ∈ S, s ≤ x) :
  ∑ i in S, i ≤ ∑ i in finset.Ioc (x - finset.card S) x, i :=
begin
  induction h : finset.card S with k ih generalizing S x,
  { obtain rfl := finset.card_eq_zero.mp h, simp},
  have hSn : 0 < S.card := h.symm ▸ k.succ_pos,
  replace hSn : S.nonempty := finset.card_pos.mp hSn,
  specialize ih (S.erase (S.max' hSn)) (x - 1) (λ s hs, _) _,
  { rw [←int.pred, ←int.pred_eq_pred, order.le_pred_iff],
    obtain ⟨hs₁, hs₂⟩ := finset.mem_erase.1 hs,
    exact (S.lt_max'_of_mem_erase_max' hSn hs).trans_le (hS' _ $ S.max'_mem hSn) },
  { simpa [h] using finset.card_erase_of_mem (S.max'_mem hSn) },
  have : x - 1 - k = x - k.succ,
  { rw [sub_sub, sub_right_inj],
    simp only [add_comm, nat.cast_succ]},
  rw this at ih,
  have hSm : S.max' hSn ≤ x := hS' _ (S.max'_mem hSn),
  replace ih := add_le_add ih hSm,
  suffices : finset.Ioc (x - k.succ) (x - 1) = (finset.Ioc (x - k.succ) x).erase x,
  { rwa [finset.sum_erase_add _ _ $ S.max'_mem hSn, this, finset.sum_erase_add] at ih,
    simp only [finset.right_mem_Ioc, sub_lt_self_iff],
    exact nat.cast_pos.mpr (k.succ_pos) },
  ext,
  simp only [nat.cast_succ, finset.mem_Ioc, finset.Ioc_erase_right, finset.mem_Ioo,
             and.congr_right_iff],
  rintro -,
  rw [←int.pred, ←int.pred_eq_pred, order.le_pred_iff]
end

-- should also be in mathlib maybe?
def min_le_sum (S : finset ℤ) (x : ℤ) (hS' : ∀ s ∈ S, x ≤ s) :
 ∑ i in finset.Ico x (x + finset.card S), i ≤ ∑ i in S, i :=
begin
  have := sum_le_max (finset.image (λ i, -i) S) (-x) _, swap,
  { intros s hs,
    rw finset.mem_image at hs,
    rcases hs with ⟨t, ht, rfl⟩,
    exact neg_le_neg (hS' t ht), },
  rw ← neg_le_neg_iff,
  have Scard : (finset.image has_neg.neg S).card = S.card,
  { rw finset.card_image_iff,
    intros x hx y hy,
    exact neg_inj.1, },
  convert this,
  { rw finset.sum_image,
    symmetry,
    apply finset.sum_neg_distrib,
    intros x hx y hy h,
    rwa neg_inj at h, },
  { rw ← finset.sum_neg_distrib,
    apply finset.sum_bij (λ (a : ℤ) ha, -a),
    { intros a ha,
      simp only [finset.mem_Ioc, neg_le_neg_iff],
      rw finset.mem_Ico at ha,
      rw Scard,
      cases ha,
      split; linarith, },
    { simp only [eq_self_iff_true, implies_true_iff], },
    { simp only [neg_inj, imp_self, implies_true_iff, forall_const], },
    { rw Scard,
      intros b hb,
      refine ⟨-b, _, _⟩,
      { simp only [finset.mem_Ico, finset.mem_Ioc] at hb ⊢,
        cases hb, split; linarith, },
      { simp only [neg_neg], }, }, },
end

lemma partd (S : finset ℤ) (hS : ∀ s ∈ S, (1 : ℤ) ≤ s ∧ s ≤ 50) (hScard : S.card = 10) : ∃ A B : finset ℤ,
  A.card = 5 ∧ B.card = 5 ∧ A ≠ B ∧ A ≤ S ∧ B ≤ S ∧ ∑ i in A, i = ∑ j in B, j :=
begin
  -- consider possibilities for subset of S with card 5
  let P := finset.powerset_len 5 S,
  -- consider possibilities for sum
  let F := finset.Icc (15 : ℤ) 240,
  have hFP : F.card * 1 < P.card,
  { simp only [finset.card_powerset_len 5 S, hScard, int.card_Icc, mul_one],
    have h : (10 : ℕ).choose 5 = 252,
    {refl},
    simp only [h],
    norm_num, },
  let g : finset ℤ → ℤ := λ x, ∑ i in x, i,
  have hg : ∀ p : finset ℤ, p ∈ P → (g p) ∈ F,
  { intros p hp,
    simp only [g, finset.mem_Icc],
    rw finset.mem_powerset_len at hp,
    split,
    { convert min_le_sum p 1 (λ s hs, (hS s (hp.1 hs)).1),
      rw hp.2,
      refl, },
    { convert sum_le_max p 50 (λ s hs, (hS s (hp.1 hs)).2),
      rw hp.2,
      refl, }, },
  have := finset.exists_lt_card_fiber_of_mul_lt_card_of_maps_to hg hFP,
  dsimp at this,
  rcases this with ⟨y, hy1, hy2⟩,
  rw finset.one_lt_card at hy2,
  rcases hy2 with ⟨A, hA, B, hB, hAB⟩,
  rw finset.mem_filter at hA hB,
  refine ⟨A, B, _⟩,
  rw [finset.mem_powerset_len] at hA hB,
  simp [hAB, hA.1, hB.1],
  change g A = g B,
  rw [hA.2, hB.2],
end

lemma parte (T : finset ℤ) (hT : ∀ t ∈ T, (1 : ℤ) ≤ t ∧ t ≤ 50) (hTcard : T.card = 9) : ∃ A B : finset ℤ,
  A ≤ T ∧ B ≤ T ∧ disjoint A B ∧ ∑ i in A, i = ∑ j in B, j :=
begin
  -- as long as we can find two non-empty sets A, B of the same sum, we can find two disjoint set by A\B and B\A
  suffices h : ∃ C D : finset ℤ, C ≤ T ∧ D ≤ T ∧ C ≠ D ∧ ∑ i in C, i = ∑ j in D, j,
  { -- let A = C - (C ∩ D), B = D - (C ∩ D),
    rcases h with ⟨C, D, hC, hD, hCD, h⟩,
    let A : finset ℤ := C \ D,
    let B : finset ℤ := D \ C,
    refine ⟨A, B, _⟩,
    have hAC : A ≤ C, apply finset.sdiff_subset,
    have hBD : B ≤ D, apply finset.sdiff_subset,
    have hA : A ≤ T := le_trans hAC hC,
    have hB : B ≤ T := le_trans hBD hD,
    refine ⟨hA, hB, disjoint_sdiff_sdiff, _⟩,
    let X := C ∩ D,
    suffices : ∑ (i : ℤ) in A, i + ∑ (x : ℤ) in X, x = ∑ (j : ℤ) in B, j + ∑ (x : ℤ) in X, x,
    exact (add_left_inj (∑ (x : ℤ) in X, x)).mp this,
    convert h,
    { suffices : C = A ∪ X,
      { rw [this, ← finset.sum_union],
        exact finset.disjoint_sdiff_inter C D, },
      ext x,
      simp only [finset.mem_union, finset.mem_sdiff, finset.mem_inter, ← and_or_distrib_left],
      tauto, },
    { suffices : D = B ∪ X,
      { rw [this, ← finset.sum_union],
        change disjoint B (C ∩ D),
        rw finset.inter_comm C D,
        exact finset.disjoint_sdiff_inter D C, },
      { ext x,
        simp only [finset.mem_union, finset.mem_sdiff, finset.mem_inter, ← and_or_distrib_left],
        tauto, }, }, },
  { -- consider powerset of T
    let P := finset.powerset T,
    let F := finset.Icc (0:ℤ) 414,
    have hPF : F.card * 1 < P.card,
    { simp [nat.card_Icc, finset.card_powerset, hTcard],
      norm_num, },
    -- find a map from P to F by summing elements in P
    let g : finset ℤ → ℤ := λ x, ∑ i in x, i,
    have hg : ∀ p : finset ℤ, p ∈ P → (g p) ∈ F,
    { intros p hp,
      simp [g],
      rw finset.mem_powerset at hp,
      split,
      { apply finset.sum_nonneg,
        intros i hi,
        exact le_trans zero_le_one (hT i (hp hi)).1, },
      { transitivity (∑ i in T, i),
        { apply finset.sum_le_sum_of_subset_of_nonneg hp,
          intros i hi _,
          exact le_trans zero_le_one (hT i hi).1, },
        { convert sum_le_max T 50 _,
          { rw hTcard, refl, },
          { intros i hi, exact (hT i hi).2, }, } }, },
    have := finset.exists_lt_card_fiber_of_mul_lt_card_of_maps_to hg hPF,
    dsimp at this,
    rcases this with ⟨y, hy1, hy2⟩,
    rw finset.one_lt_card at hy2,
    rcases hy2 with ⟨C, hC, D, hD, hCD⟩,
    rw [finset.mem_filter, finset.mem_powerset] at hC hD,
    refine ⟨C, D, hC.1, hD.1, hCD, _⟩,
    change g C = g D,
    rw [hC.2, hD.2], },
end

lemma nat.ord_compl_eq_dvd (a b : ℕ) (h : ord_compl[2] a = ord_compl[2] b) (ha : 0 < a) (hab : a < b) :
  a ∣ b :=
begin
  -- if a = 2^k1 * p, b = 2^k2 * p
  set k1 : ℕ := a.factorization 2,
  set k2 : ℕ := b.factorization 2,
  rw dvd_iff_exists_eq_mul_left,
  -- c = 2^ (k2 - k1)
  use (2 ^ (k2 - k1)),
  have h02 : 0 < 2 := by norm_num,
  -- because of natural division is involved, we need divisibility
  have had := nat.ord_proj_dvd a 2,
  have hbd := nat.ord_proj_dvd b 2,
  have haf := pow_pos h02 k1,
  have hbf := pow_pos h02 k2,
  have hab : k1 ≤ k2,
  { by_contra hc,
    push_neg at hc,
    have hc' : 2 ^ k2 < 2 ^ k1,
    { rw pow_lt_pow_iff,
      exact hc,
      norm_num, },
    have hak : 0 < a / 2 ^ k1,
    { apply nat.div_pos,
      apply nat.ord_proj_le,
      exact ne_of_gt ha,
      exact haf, },
    suffices : b < a,
    { linarith, },
    { have hc'' :  2 ^ k2 * (b / 2 ^ k2) < 2 ^ k1 * (a / 2 ^ k1),
      { rw ← h, apply mul_lt_mul_of_pos_right hc' hak, },
    rw [mul_comm (2 ^ k2) (b / 2 ^ k2), nat.div_mul_cancel] at hc'',
    swap, exact hbd,
    rw [mul_comm (2 ^ k1) (a / 2 ^ k1), nat.div_mul_cancel] at hc'',
    exact hc'',
    exact had, }, },
  have := nat.pow_div hab h02,
  rw ← this,
  -- again we need divisibility to proceed
  have hkd := pow_dvd_pow 2 hab,
  rw [mul_comm, ← nat.mul_div_assoc _ hkd, mul_comm a (2^k2), nat.mul_div_assoc],
  swap, exact had,
  rw [h, mul_comm, nat.div_mul_cancel hbd],
end

lemma partf (T : finset ℕ) (hT : ∀ t ∈ T, (1 : ℤ) ≤ t ∧ t ≤ 200) (hTcard : T.card = 101) : ∃ a b : ℕ,
  a ∈ T ∧ b ∈ T ∧ a ≠ b ∧ a ∣ b :=
begin
  -- claim : every t can be written as 2^k * q for which q is odd, using ord_compl[2] t
  let Q : finset ℕ := (finset.Icc 1 200).filter odd,
  have hQcard : Q.card = 100,
  { -- Show that it equals (finset.Iio 100).map \<\la n, 2 * n + 1, proof_of_injectivity_here\>
    have hQ : Q = (finset.Iio 100).map ⟨λ n, 2 * n + 1 ,
                                        begin intros a b hab,
                                        simpa [add_left_inj, mul_eq_mul_left_iff, bit0_eq_zero, nat.one_ne_zero, or_false] using hab,
                                        end ⟩,
    { dsimp [Q],
      rw le_antisymm_iff,
      split,
      { intros x hx,
        simp only [finset.mem_map, finset.mem_Iio, function.embedding.coe_fn_mk, exists_prop, nat.one_le_cast, finset.mem_filter,
          finset.mem_Icc, nat.odd_iff_not_even] at hx ⊢,
        refine ⟨((x-1)/2), _, _⟩,
        { rcases hx with ⟨⟨h1, h2⟩, h3⟩,
          zify at h2 ⊢,
          rw int.div_lt_iff_lt_mul,
          linarith,
          norm_num, },
        { rcases hx with ⟨⟨h1, h2⟩, h3⟩,
          rw ← nat.odd_iff_not_even at h3,
          unfold odd at h3,
          cases h3 with k h3,
          rw h3,
          simp only [nat.add_succ_sub_one, add_zero, nat.mul_div_right, nat.succ_pos'], }, },
      { intros x hx,
        simp only [finset.mem_map, finset.mem_Iio, function.embedding.coe_fn_mk, exists_prop, nat.one_le_cast, finset.mem_filter,
          finset.mem_Icc, nat.odd_iff_not_even] at hx ⊢,
        rcases hx with ⟨a, ⟨h1, h2⟩⟩,
        refine ⟨⟨_, _⟩, _⟩,
        { rw ← h2,
          linarith, },
        { rw ← h2,
          linarith, },
        { intro h,
          rw [nat.even_iff, ← h2, nat.mul_comm, nat.mul_add_mod a 2 1] at h,
          simpa [nat.one_mod, nat.one_ne_zero] using h, }, }, },
    rw hQ,
    simp only [nat.card_Iio, finset.card_map], },
  have hTO : Q.card * 1 < T.card,
  { rw [hQcard, hTcard], norm_num, },
  -- find a map from T to Q, by considering corresponding 'q'
  let f : ℕ → ℕ := λ z, ord_compl[2] z,
  have hf : ∀ t ∈ T, (f t) ∈ Q,
  { intros t ht,
    simp only [f, finset.mem_filter, finset.mem_Icc, nat.odd_iff_not_even],
    have ht0 : t ≠ 0,
    { specialize hT t ht,
    cases hT with hT1 hT2,
    linarith, },
    refine ⟨⟨_,_⟩,_⟩,
    { rw nat.one_le_div_iff,
      {apply nat.ord_proj_le 2 ht0, },
      {exact nat.ord_proj_pos t 2, }, },
    { apply nat.div_le_of_le_mul,
      have h1 := nat.ord_proj_pos t 2,
      rw ← nat.succ_le_iff at h1,
      exact le_mul_of_one_le_of_le h1 (hT t ht).2, },
    { simp only [even_iff_two_dvd, nat.not_dvd_ord_compl nat.prime_two ht0, not_false_iff], }, },
  have := finset.exists_lt_card_fiber_of_mul_lt_card_of_maps_to hf hTO,
  dsimp at this,
  rcases this with ⟨y, hy1, hy2⟩,
  rw finset.one_lt_card at hy2,
  rcases hy2 with ⟨a, ha, b, hb, hab⟩,
  by_cases a < b,
  { refine ⟨a, b, _⟩,
    simp only [hab, ne.def, not_false_iff, true_and],
    rw finset.mem_filter at ha hb,
    simp only [ha.1, hb.1, true_and],
    have ha0 : 0 < a,
    { specialize hT a ha.1,
      cases hT with h1 h2,
      linarith, },
    suffices : f a = f b,
    { apply nat.ord_compl_eq_dvd,
      exact this,
      exact ha0,
      exact h, },
    { rw [ha.2, hb.2], }, },
  { have h : b < a,
    { omega, },
    refine ⟨b, a, _⟩,
    simp only [ne.symm hab, ne.def, not_false_iff, true_and],
    rw finset.mem_filter at ha hb,
    simp only [ha.1, hb.1, true_and],
    have hb0 : 0 < b,
    { specialize hT b hb.1,
      cases hT with h1 h2,
      linarith, },
    suffices : f b = f a,
    { apply nat.ord_compl_eq_dvd,
      exact this,
      exact hb0,
      exact h, },
    { rw [ha.2, hb.2], }, },
end


import algebra.field data.set

universe u

class is_subring {R : Type u} [ring R] (s : set R) : Prop :=
(one_mem : (1 : R) ∈ s)
(sub_mem : ∀ {x y : R}, x ∈ s → y ∈ s → x - y ∈ s)
(mul_mem : ∀ {x y : R}, x ∈ s → y ∈ s → x * y ∈ s)

open is_subring set

namespace is_subring

lemma zero_mem {R : Type u} [ring R] {s : set R} [is_subring s] :
(0 : R) ∈ s := eq.subst (sub_self (1 : R)) (sub_mem (one_mem s) (one_mem s))

lemma neg_mem {R : Type u} [ring R] {s : set R} [is_subring s] {x : R}:
x ∈ s → -x ∈ s :=
begin
intros hx,
have H : 0 - x ∈ s,
    exact sub_mem zero_mem hx,
rw zero_sub at H,
exact H,
end

lemma add_mem  {R : Type u} [ring R] {s : set R} [is_subring s] {x y : R} :
x ∈ s → y ∈ s → x + y ∈ s := λ hx hy, eq.subst (sub_neg_eq_add x y) (sub_mem hx (neg_mem hy))

instance subring_to_ring {R : Type u} [ring R] (s : set R) [is_subring s] : ring s :=
{
add := λ (a b : s), ⟨a.val + b.val, add_mem a.property b.property⟩,
add_assoc := assume ⟨a, _⟩ ⟨b, _⟩ ⟨c, _⟩, subtype.eq (add_assoc a b c),
zero := ⟨0, zero_mem⟩,
zero_add := assume ⟨a, _⟩, subtype.eq (zero_add a),
add_zero := assume ⟨a, _⟩, subtype.eq (add_zero a),
neg := λ (a : s), ⟨ -a.val, neg_mem a.property⟩ ,
add_left_neg := assume ⟨a, _⟩, subtype.eq (add_left_neg a),
add_comm := assume ⟨a, _⟩ ⟨b, _⟩, subtype.eq (add_comm a b),
mul := λ (a b : s), ⟨a.val * b.val, mul_mem a.property b.property⟩,
mul_assoc := assume ⟨a, _⟩ ⟨b, _⟩ ⟨c, _⟩, subtype.eq (mul_assoc a b c),
one := ⟨1, one_mem s⟩,
one_mul := assume ⟨a, _⟩, subtype.eq (one_mul a),
mul_one := assume ⟨a, _⟩, subtype.eq (mul_one a),
left_distrib := assume ⟨a, _⟩ ⟨b, _⟩ ⟨c, _⟩, subtype.eq (left_distrib a b c),
right_distrib := assume ⟨a, _⟩ ⟨b, _⟩ ⟨c, _⟩, subtype.eq (right_distrib a b c),
}

end is_subring

class is_subfield {F : Type u} [field F] (s : set F) : Prop :=
(one_mem : (1 : F) ∈ s)
(sub_mem : ∀ {x y : F}, x ∈ s → y ∈ s → x - y ∈ s)
(mul_mem : ∀ {x y : F}, x ∈ s → y ∈ s → x * y ∈ s)
(inv_mem : ∀ {x : F}, x ∈ s → x⁻¹ ∈ s)

open is_subfield

namespace is_subfield

lemma zero_mem {F : Type u} [field F] {s : set F} [is_subfield s] :
(0 : F) ∈ s := eq.subst (sub_self (1 : F)) (sub_mem (one_mem s) (one_mem s))

lemma neg_mem {R : Type u} [field R] {s : set R} [is_subfield s] {x : R}:
x ∈ s → -x ∈ s :=
begin
intros hx,
have H : 0 - x ∈ s,
    exact sub_mem zero_mem hx,
rw zero_sub at H,
exact H,
end

lemma add_mem {F : Type u} [field F] {s : set F} [is_subfield s] {x y : F} :
x ∈ s → y ∈ s → x + y ∈ s := λ hx hy, eq.subst (sub_neg_eq_add x y) (sub_mem hx (neg_mem hy))

instance subfield_to_field {F : Type u} [field F] (s : set F) [is_subfield s] : field s :=
{
add := λ (a b : s), ⟨a.val + b.val, add_mem a.property b.property⟩,
add_assoc := assume ⟨a, _⟩ ⟨b, _⟩ ⟨c, _⟩, subtype.eq (add_assoc a b c),
zero := ⟨0, zero_mem⟩,
zero_add := assume ⟨a, _⟩, subtype.eq (zero_add a),
add_zero := assume ⟨a, _⟩, subtype.eq (add_zero a),
neg := λ (a : s), ⟨ -a.val, neg_mem a.property⟩ ,
add_left_neg := assume ⟨a, _⟩, subtype.eq (add_left_neg a),
add_comm := assume ⟨a, _⟩ ⟨b, _⟩, subtype.eq (add_comm a b),
mul := λ (a b : s), ⟨a.val * b.val, mul_mem a.property b.property⟩,
mul_assoc := assume ⟨a, _⟩ ⟨b, _⟩ ⟨c, _⟩, subtype.eq (mul_assoc a b c),
one := ⟨1, one_mem s⟩,
one_mul := assume ⟨a, _⟩, subtype.eq (one_mul a),
mul_one := assume ⟨a, _⟩, subtype.eq (mul_one a),
left_distrib := assume ⟨a, _⟩ ⟨b, _⟩ ⟨c, _⟩, subtype.eq (left_distrib a b c),
right_distrib := assume ⟨a, _⟩ ⟨b, _⟩ ⟨c, _⟩, subtype.eq (right_distrib a b c),
inv := λ (a : s), ⟨a.val⁻¹, inv_mem a.property⟩,
zero_ne_one := begin apply (iff_false_left zero_ne_one).mp, simp, exact F, apply_instance, end,
mul_inv_cancel := assume ⟨a, _⟩, λ h, subtype.eq (mul_inv_cancel ((iff_false_left (not_not_intro h)).mp (begin dunfold ne, rw auto.not_not_eq, apply subtype.ext, end))),
inv_mul_cancel := assume ⟨a, _⟩, λ h, subtype.eq (inv_mul_cancel ((iff_false_left (not_not_intro h)).mp (begin dunfold ne, rw auto.not_not_eq, apply subtype.ext, end))),
mul_comm := assume ⟨a, _⟩ ⟨b, _⟩, subtype.eq (mul_comm a b),
}

end is_subfield


import tuto_lib
import data.int.parity
/-
Negations, proof by contradiction and contraposition.

This file introduces the logical rules and tactics related to negation:
exfalso, by_contradiction, contrapose, by_cases and push_neg.

There is a special statement denoted by `false` which, by definition,
has no proof.

So `false` implies everything. Indeed `false → P` means any proof of
`false` could be turned into a proof of P.
This fact is known by its latin name
"ex falso quod libet" (from false follows whatever you want).
Hence Lean's tactic to invoke this is called `exfalso`.
-/

example : false → 0 = 1 :=
begin
  intro h,
  exfalso,
  exact h,
end

/-
The preceding example suggests that this definition of `false` isn't very useful.
But actually it allows us to define the negation of a statement P as
"P implies false" that we can read as "if P were true, we would get
a contradiction". Lean denotes this by `¬ P`.

One can prove that (¬ P) ↔ (P ↔ false). But in practice we directly
use the definition of `¬ P`.
-/

example {x : ℝ} : ¬ x < x :=
by { rw lt_iff_le_and_ne, cc }

example {x : ℝ} : ¬ x < x :=
begin
  intro hyp,
  rw lt_iff_le_and_ne at hyp,
  cases hyp with hyp_inf hyp_non,
  clear hyp_inf, -- we won't use that one, so let's discard it
  change x = x → false at hyp_non, -- Lean doesn't need this psychological line
  apply hyp_non,
  refl,
end

open int

-- 0045
example (n : ℤ) (h_pair : even n) (h_non_pair : ¬ even n) : 0 = 1 := by cc

-- 0046
example (P Q : Prop) (h₁ : P ∨ Q) (h₂ : ¬ (P ∧ Q)) : ¬ P ↔ Q :=
begin
  split,
  { intro h₃,
    cases h₁ with p q,
    { exfalso,
      apply h₃,
      assumption },
    { assumption } },
  { intro h₃,
    cases h₁ with p q,
    { exfalso,
      apply h₂,
      split; assumption },
    { intro q,
      apply h₂,
      split; assumption } }
end

/-
The definition of negation easily implies that, for every statement P,
P → ¬ ¬ P

The excluded middle axiom, which asserts P ∨ ¬ P allows us to
prove the converse implication.

Together those two implications form the principle of double negation elimination.
  not_not {P : Prop} : (¬ ¬ P) ↔ P

The implication `¬ ¬ P → P` is the basis for proofs by contradiction:
in order to prove P, it suffices to prove ¬¬ P, ie `¬ P → false`.

Of course there is no need to keep explaining all this. The tactic
`by_contradiction Hyp` will transform any goal P into `false` and
add Hyp : ¬ P to the local context.

Let's return to a proof from the 5th file: uniqueness of limits for a sequence.
This cannot be proved without using some version of the excluded middle
axiom. We used it secretely in

eq_of_abs_sub_le_all (x y : ℝ) : (∀ ε > 0, |x - y| ≤ ε) → x = y

(we'll prove a variation on this lemma below).
-/
example (u : ℕ → ℝ) (l l' : ℝ) : seq_limit u l → seq_limit u l' → l = l' :=
begin
  intros hl hl',
  by_contra h,
  change l ≠ l' at h,
  have h₁ : |l - l'| > 0,
  { apply abs_pos_of_ne_zero,
    apply sub_ne_zero_of_ne,
    assumption },
  set ε := |l - l'| / 4 with hε,
  cases hl ε (by linarith) with N hN,
  cases hl' ε (by linarith) with N' hN',
  let N := max N N',
  specialize hN N le_sup_left,
  specialize hN' N le_sup_right,
  have h₂ : |l - l'| < |l - l'|,
  calc |l - l'| = |(l - u N) + (u N - l')| : by ring
  ...           ≤ |l - u N| + |u N - l'|   : by apply abs_add
  ...           ≤ |u N - l| + |u N - l'|   : by rw abs_sub
  ...           < |l - l'|                 : by linarith,
  linarith
end

example (u : ℕ → ℝ) (l l' : ℝ) : seq_limit u l → seq_limit u l' → l = l' :=
begin
  intros hl hl',
  by_contradiction H,
  change l ≠ l' at H, -- Lean does not need this line
  have ineg : |l-l'| > 0,
    exact abs_pos_of_ne_zero (sub_ne_zero_of_ne H),
  cases hl ( |l-l'|/4 ) (by linarith) with N hN,
  cases hl' ( |l-l'|/4 ) (by linarith) with N' hN',
  let N₀ := max N N', -- this is a new tactic, whose effect should be clear
  specialize hN N₀ (le_max_left _ _),
  specialize hN' N₀ (le_max_right _ _),
  have clef : |l-l'| < |l-l'|,
    calc
    |l - l'| = |(l-u N₀) + (u N₀ -l')|   : by ring
         ... ≤ |l - u N₀| + |u N₀ - l'|  : by apply abs_add
         ... = |u N₀ - l| + |u N₀ - l'|  : by rw abs_sub
         ... < |l-l'|                    : by linarith,
  linarith, -- linarith can also find simple numerical contradictions
end

/-
Another incarnation of the excluded middle axiom is the principle of
contraposition: in order to prove P ⇒ Q, it suffices to prove
non Q ⇒ non P.
-/

-- Using a proof by contradiction, let's prove the contraposition principle
-- 0047
example (P Q : Prop) (h : ¬ Q → ¬ P) : P → Q :=
begin
  intro p,
  by_contra hq,
  apply h; assumption
end

/-
Again Lean doesn't need to be explain this principle. We can use the
`contrapose` tactic.
-/

example (P Q : Prop) (h : ¬ Q → ¬ P) : P → Q :=
begin
  contrapose,
  exact h,
end

/-
In the next exercise, we'll use
 odd n : ∃ k, n = 2*k + 1
 not_even_iff_odd : ¬ even n ↔ odd n,
-/
-- 0048
example (n : ℤ) : even (n^2) ↔ even n :=
begin
  rw pow_two,
  split,
  { contrapose,
    repeat { rw not_even_iff_odd },
    rintros ⟨k, rfl⟩,
    set a := 2 * k with ha,
    use k * (a + 2),
    rw ha,
    ring },
  { rintros ⟨k, rfl⟩,
    use 2 * k * k,
    ring }
end
/-
As a last step on our law of the excluded middle tour, let's notice that, especially
in pure logic exercises, it can sometimes be useful to use the
excluded middle axiom in its original form:
  classical.em : ∀ P, P ∨ ¬ P

Instead of applying this lemma and then using the `cases` tactic, we
have the shortcut
 by_cases h : P,

combining both steps to create two proof branches: one assuming
h : P, and the other assuming h : ¬ P

For instance, let's prove a reformulation of this implication relation,
which is sometimes used as a definition in other logical foundations,
especially those based on truth tables (hence very strongly using
excluded middle from the very beginning).
-/

variables (P Q : Prop)

example : (P → Q) ↔ (¬ P ∨ Q) :=
begin
  split; intros h,
  { by_cases hq : Q,
    { right, assumption },
    { left, exact λ p, hq (h p) } },
  { intro p,
    cases h with hp q,
    { exfalso, apply hp, assumption },
    { assumption } }
end

example : (P → Q) ↔ (¬ P ∨ Q) :=
begin
  split,
  { intro h,
    by_cases hP : P,
    { right,
      exact h hP },
    { left,
      exact hP } },
  { intros h hP,
    cases h with hnP hQ,
    { exfalso,
      exact hnP hP },
    { exact hQ } },
end

-- 0049
example : ¬ (P ∧ Q) ↔ ¬ P ∨ ¬ Q :=
begin
  split,
  { intro h,
    by_cases hp : P,
    { right,
      intro q,
      apply h,
      split; assumption },
    { left; assumption } },
  { rintros h ⟨p, q⟩,
    cases h; cc }
end

/-
It is crucial to understand negation of quantifiers.
Let's do it by hand for a little while.
In the first exercise, only the definition of negation is needed.
-/

-- 0050
example (n : ℤ) : ¬ (∃ k, n = 2*k) ↔ ∀ k, n ≠ 2*k :=
begin
  split; intro h,
  { intros k hk,
    exact h ⟨k, hk⟩ },
  { rintro ⟨k, hk⟩,
    exact h k hk }
end

/-
Contrary to negation of the existential quantifier, negation of the
universal quantifier requires excluded middle for the first implication.
In order to prove this, we can use either
* a double proof by contradiction
* a contraposition, not_not : (¬ ¬ P) ↔ P) and a proof by contradiction.
-/

def even_fun (f : ℝ → ℝ) := ∀ x, f (-x) = f x

-- 0051
example (f : ℝ → ℝ) : ¬ even_fun f ↔ ∃ x, f (-x) ≠ f x :=
begin
  split,
  { intro h₁,
    by_contra h₂,
    apply h₁,
    intro x,
    by_contra h₃,
    apply h₂,
    use x; assumption },
  { rintros ⟨x, hx⟩ hf,
    apply hx,
    apply hf }
end

example (f : ℝ → ℝ) : ¬ even_fun f ↔ ∃ x, f (-x) ≠ f x :=
begin
  split,
  { contrapose,
    intro h,
    rw not_not,
    intro x,
    by_contra,
    apply h,
    use x; assumption },
  { contrapose,
    rw not_not,
    intro h,
    -- It sucks that the anonymous contructor syntax isn't "builtin enough" in
    -- Lean, so I can't write `by_contra ⟨x, hx⟩`.
    by_contra this,
    cases this with x hx,
    apply hx,
    apply h }
end

/-
Of course we can't keep repeating the above proofs, especially the second one.
So we use the `push_neg` tactic.
-/

example : ¬ even_fun (λ x, 2*x) :=
begin
  unfold even_fun, -- Here unfolding is important because push_neg won't do it.
  push_neg,
  use 42,
  linarith,
end

-- 0052
example (f : ℝ → ℝ) : ¬ even_fun f ↔ ∃ x, f (-x) ≠ f x :=
begin
  unfold even_fun,
  push_neg
end

def bounded_above (f : ℝ → ℝ) := ∃ M, ∀ x, f x ≤ M

example : ¬ bounded_above (λ x, x) :=
begin
  unfold bounded_above,
  push_neg,
  intro M,
  use M + 1,
  linarith,
end

-- Let's contrapose
-- 0053
example (x : ℝ) : (∀ ε > 0, x ≤ ε) → x ≤ 0 :=
begin
  contrapose,
  push_neg,
  intro h,
  use x/2,
  split; linarith
end

/-
The "contrapose, push_neg" combo is so common that we can abreviate it to
`contrapose!`

Let's use this trick, together with:
  eq_or_lt_of_le : a ≤ b → a = b ∨ a < b
-/

-- 0054
example (f : ℝ → ℝ) : (∀ x y, x < y → f x < f y) ↔ (∀ x y, (x ≤ y ↔ f x ≤ f y)) :=
begin
  split,
  { intros hf x y,
    split,
    { intro h,
      cases eq_or_lt_of_le h with h h,
      { rw h },
      { linarith [hf x y h] } },
    { contrapose!,
      apply hf } },
  { intros hf x y,
    contrapose!,
    intro h,
    rwa hf }
end


/-
Copyright (c) 2019 Neil Strickland. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Neil Strickland, Yury Kudryashov
-/
import algebra.group.semiconj

/-!
# Commuting pairs of elements in monoids

We define the predicate `commute a b := a * b = b * a` and provide some operations on terms `(h :
commute a b)`. E.g., if `a`, `b`, and c are elements of a semiring, and that `hb : commute a b` and
`hc : commute a c`.  Then `hb.pow_left 5` proves `commute (a ^ 5) b` and `(hb.pow_right 2).add_right
(hb.mul_right hc)` proves `commute a (b ^ 2 + b * c)`.

Lean does not immediately recognise these terms as equations, so for rewriting we need syntax like
`rw [(hb.pow_left 5).eq]` rather than just `rw [hb.pow_left 5]`.

This file defines only a few operations (`mul_left`, `inv_right`, etc).  Other operations
(`pow_right`, field inverse etc) are in the files that define corresponding notions.

## Implementation details

Most of the proofs come from the properties of `semiconj_by`.
-/

/-- Two elements commute if `a * b = b * a`. -/
@[to_additive add_commute "Two elements additively commute if `a + b = b + a`"]
def commute {S : Type*} [has_mul S] (a b : S) : Prop := semiconj_by a b b

namespace commute

section has_mul

variables {S : Type*} [has_mul S]

/-- Equality behind `commute a b`; useful for rewriting. -/
@[to_additive] protected theorem eq {a b : S} (h : commute a b) : a * b = b * a := h

/-- Any element commutes with itself. -/
@[refl, simp, to_additive] protected theorem refl (a : S) : commute a a := eq.refl (a * a)

/-- If `a` commutes with `b`, then `b` commutes with `a`. -/
@[symm, to_additive] protected theorem symm {a b : S} (h : commute a b) : commute b a :=
eq.symm h

@[to_additive]
protected theorem symm_iff {a b : S} : commute a b ↔ commute b a :=
⟨commute.symm, commute.symm⟩

end has_mul

section semigroup

variables {S : Type*} [semigroup S] {a b c : S}

/-- If `a` commutes with both `b` and `c`, then it commutes with their product. -/
@[simp, to_additive] theorem mul_right (hab : commute a b) (hac : commute a c) :
  commute a (b * c) :=
hab.mul_right hac

/-- If both `a` and `b` commute with `c`, then their product commutes with `c`. -/
@[simp, to_additive] theorem mul_left (hac : commute a c) (hbc : commute b c) :
  commute (a * b) c :=
hac.mul_left hbc

@[to_additive] protected lemma right_comm (h : commute b c) (a : S) :
  a * b * c = a * c * b :=
by simp only [mul_assoc, h.eq]

@[to_additive] protected lemma left_comm (h : commute a b) (c) :
  a * (b * c) = b * (a * c) :=
by simp only [← mul_assoc, h.eq]

end semigroup

@[to_additive]
protected

section mul_one_class

variables {M : Type*} [mul_one_class M]

@[simp, to_additive] theorem one_right (a : M) : commute a 1 := semiconj_by.one_right a
@[simp, to_additive] theorem one_left (a : M) : commute 1 a := semiconj_by.one_left a

end mul_one_class

section monoid

variables {M : Type*} [monoid M]

@[to_additive] theorem units_inv_right {a : M} {u : units M} : commute a u → commute a ↑u⁻¹ :=
semiconj_by.units_inv_right

@[simp, to_additive] theorem units_inv_right_iff {a : M} {u : units M} :
  commute a ↑u⁻¹ ↔ commute a u :=
semiconj_by.units_inv_right_iff

@[to_additive] theorem units_inv_left {u : units M} {a : M} : commute ↑u a → commute ↑u⁻¹ a :=
semiconj_by.units_inv_symm_left

@[simp, to_additive]
theorem units_inv_left_iff {u : units M} {a : M}: commute ↑u⁻¹ a ↔ commute ↑u a :=
semiconj_by.units_inv_symm_left_iff

variables {u₁ u₂ : units M}

@[to_additive]
theorem units_coe : commute u₁ u₂ → commute (u₁ : M) u₂ := semiconj_by.units_coe
@[to_additive]
theorem units_of_coe : commute (u₁ : M) u₂ → commute u₁ u₂ := semiconj_by.units_of_coe
@[simp, to_additive]
theorem units_coe_iff : commute (u₁ : M) u₂ ↔ commute u₁ u₂ := semiconj_by.units_coe_iff

end monoid

section group

variables {G : Type*} [group G] {a b : G}

@[to_additive]
theorem inv_right : commute a b → commute a b⁻¹ := semiconj_by.inv_right
@[simp, to_additive]
theorem inv_right_iff : commute a b⁻¹ ↔ commute a b := semiconj_by.inv_right_iff

@[to_additive] theorem inv_left :  commute a b → commute a⁻¹ b := semiconj_by.inv_symm_left
@[simp, to_additive]
theorem inv_left_iff : commute a⁻¹ b ↔ commute a b := semiconj_by.inv_symm_left_iff

@[to_additive]
theorem inv_inv : commute a b → commute a⁻¹ b⁻¹ := semiconj_by.inv_inv_symm
@[simp, to_additive]
theorem inv_inv_iff : commute a⁻¹ b⁻¹ ↔ commute a b := semiconj_by.inv_inv_symm_iff

@[to_additive]
protected theorem inv_mul_cancel (h : commute a b) : a⁻¹ * b * a = b :=
by rw [h.inv_left.eq, inv_mul_cancel_right]

@[to_additive]
theorem inv_mul_cancel_assoc (h : commute a b) : a⁻¹ * (b * a) = b :=
by rw [← mul_assoc, h.inv_mul_cancel]

@[to_additive]
protected theorem mul_inv_cancel (h : commute a b) : a * b * a⁻¹ = b :=
by rw [h.eq, mul_inv_cancel_right]

@[to_additive]
theorem mul_inv_cancel_assoc (h : commute a b) : a * (b * a⁻¹) = b :=
by rw [← mul_assoc, h.mul_inv_cancel]

end group

end commute

section comm_group

variables {G : Type*} [comm_group G] (a b : G)

@[simp, to_additive] lemma mul_inv_cancel_comm : a * b * a⁻¹ = b :=
(commute.all a b).mul_inv_cancel

@[simp, to_additive] lemma mul_inv_cancel_comm_assoc : a * (b * a⁻¹) = b :=
(commute.all a b).mul_inv_cancel_assoc

@[simp, to_additive] lemma inv_mul_cancel_comm : a⁻¹ * b * a = b :=
(commute.all a b).inv_mul_cancel

@[simp, to_additive] lemma inv_mul_cancel_comm_assoc : a⁻¹ * (b * a) = b :=
(commute.all a b).inv_mul_cancel_assoc

end comm_group


import Mathlib.Init.Set
import Mathlib.Data.List.Basic

namespace List

/-- `Perm l₁ l₂` or `l₁ ~ l₂` asserts that `l₁` and `l₂` are Permutations
  of each other. This is defined by induction using pairwise swaps. -/
inductive Perm {α} : List α → List α → Prop
| nil   : Perm [] []
| cons  : ∀ (x : α) {l₁ l₂ : List α}, Perm l₁ l₂ → Perm (x::l₁) (x::l₂)
| swap  : ∀ (x y : α) (l : List α), Perm (y::x::l) (x::y::l)
| trans : ∀ {l₁ l₂ l₃ : List α}, Perm l₁ l₂ → Perm l₂ l₃ → Perm l₁ l₃

open Perm

infixl:50 " ~ " => Perm

protected theorem Perm.refl : ∀ (l : List α), l ~ l
| []      => Perm.nil
| (x::xs) => (Perm.refl xs).cons x

protected theorem Perm.symm {l₁ l₂ : List α} (p : l₁ ~ l₂) : l₂ ~ l₁ := by
induction p with
| nil => exact Perm.nil
| cons x _ ih => exact Perm.cons x ih
| swap x y l => exact Perm.swap y x l
| trans _ _ ih₁ ih₂ => exact Perm.trans ih₂ ih₁

theorem Perm_comm {l₁ l₂ : List α} : l₁ ~ l₂ ↔ l₂ ~ l₁ := ⟨Perm.symm, Perm.symm⟩

theorem Perm.swap'
  (x y : α)
  {l₁ l₂ : List α}
  (p : l₁ ~ l₂) :
  y::x::l₁ ~ x::y::l₂ :=
  have h1 : y :: l₁ ~ y :: l₂ := Perm.cons y p
  have h2 : x :: y :: l₁ ~ x :: y :: l₂ := Perm.cons x h1
  have h3 : y :: x :: l₁ ~ x :: y :: l₁ := Perm.swap x y l₁
  Perm.trans h3 h2

theorem Perm.Equivalence : Equivalence (@Perm α) := ⟨Perm.refl, Perm.symm, Perm.trans⟩

instance (α : Type u) : Setoid (List α) := ⟨Perm, Perm.Equivalence⟩

theorem Perm.subset {α : Type u} {l₁ l₂ : List α} (p : l₁ ~ l₂) : l₁ ⊆ l₂ := by
induction p with
| nil => exact nil_subset _
| cons _ _ ih => exact cons_subset_cons _ ih
| swap x y l =>
  intro a
  rw [mem_cons]
  exact fun
  | Or.inl rfl => Mem.tail _ (Mem.head ..)
  | Or.inr (Mem.head ..) => Mem.head ..
  | Or.inr (Mem.tail _ a_mem_l) => Mem.tail _ (Mem.tail _ a_mem_l)
| trans h1 h2 ih₁ ih₂ => exact subset.trans ih₁ ih₂

theorem perm_middle {a : α} : ∀ {l₁ l₂ : List α}, l₁++a::l₂ ~ a::(l₁++l₂)
| [], l₂ => Perm.refl _
| (b::l₁), l₂ =>
  let h2 := @perm_middle α a l₁ l₂
  (h2.cons _).trans (swap a b _)