import data.nat.prime

open nat

-- local attribute [trans] dvd_trans

-- Definition
def exactly_divides (p : ℕ) (r : ℕ) (n : ℕ) := p^r ∣ n ∧ ¬(p^(succ r) ∣ n)

notation p`^`r `∣∣`:50 n:50 := exactly_divides p r n

section
variable {p : ℕ}

-- Equivalent definitions
lemma exactly_divides' {r : ℕ} {n : ℕ} : p^r ∣∣ n ↔ (∀ i, p^i ∣ n ↔ i ≤ r) :=
begin
  apply iff.intro,
  { intros prn i, apply iff.intro,
    { intro pin,
      apply (le_or_gt _ _).resolve_right, intro i_gt_r,
      exact absurd (dvd_trans (pow_dvd_pow p i_gt_r) pin) prn.right },
    { intro i_le_r,
      exact dvd.trans (pow_dvd_pow p i_le_r) (and.left prn) }
    },
  { intro h, split,
    { exact (h r).mpr (refl r) },
    { exact mt (h (succ r)).mp (not_succ_le_self r) }
  }
end

lemma exactly_divides'' {r : ℕ} {n : ℕ} (p_pos : p > 0) :
  p^r ∣∣ n ↔ ∃ k, n = p^r * k ∧ ¬(p ∣ k) :=
begin
  apply iff.intro,
  { intro prn,
    existsi n / (p^r), split,
    { exact (nat.mul_div_cancel' prn.left).symm },
    { intro d,
      have :=
      calc p^(succ r) = p^r * p            : rfl
           ...        ∣ p^r * (n / (p^r))  : mul_dvd_mul_left (p^r) d
           ...        = n                  : nat.mul_div_cancel' prn.left,
      have := prn.right, contradiction
    }
  },
  { intro h, rcases h with ⟨k, h1, h2⟩, split,
    { exact ⟨k,h1⟩ },
    { intro d,
      rw h1 at d,
      have : p ∣ k := dvd_of_mul_dvd_mul_left (pos_pow_of_pos r p_pos) d,
      contradiction
    }
  }
end

-- Uniqueness
lemma exactly_divides_unique {r s : ℕ} {n : ℕ} : p^r ∣∣ n → p^s ∣∣ n → r = s :=
λ prn psn,
have ri : ∀ i, p^i ∣ n ↔ i ≤ r := exactly_divides'.mp prn,
have si : ∀ i, p^i ∣ n ↔ i ≤ s := exactly_divides'.mp psn,
have this : ∀ i, i ≤ r ↔ i ≤ s := λ i, (ri i).symm.trans (si i),
le_antisymm ((this r).mp (le_refl r)) ((this s).mpr (le_refl s))

-- Recursion relations
lemma exactly_divides_zero {n : ℕ} (p_pos : p > 0) : ¬(p ∣ n) ↔ p^0 ∣∣ n :=
begin
  rw exactly_divides'' p_pos,
  apply iff.intro,
  { intro h, exact ⟨n, by simp, h⟩ },
  { intro h, rcases h with ⟨k, e, nd⟩, simp [e, nd] }
end

lemma exactly_divides_succ {r n : ℕ} (p_pos : p > 0) : p^r ∣∣ n ↔ p^(succ r) ∣∣ (p * n) :=
begin
  rw [exactly_divides'' p_pos, exactly_divides'' p_pos],
  apply iff.intro,
  {
    intro prn,
    rcases prn with ⟨k, h1, h2⟩,
    have h1' : p * n = p^(succ r) * k :=
    calc p * n = p * (p^r * k)  : by rw h1
         ...   = (p^r * p) * k  : by ac_refl,
    exact ⟨k, h1', h2⟩,
  },
  {
    intro psrpn,
    rcases psrpn with ⟨k, h1, h2⟩,
    have h1' : p * n = p * (p^r * k) :=
    calc p * n = p^(succ r) * k  : h1
         ...   = p * (p^r * k)   : by unfold nat.pow; ac_refl,
    exact ⟨k, eq_of_mul_eq_mul_left p_pos h1', h2⟩
  }
end

-- Multiplicative
lemma exactly_divides_one (hp : prime p) : p^0 ∣∣ 1 :=
(exactly_divides_zero (hp.gt_one.trans dec_trivial)).mp (prime.not_dvd_one hp)

lemma exactly_divides_mul {r s a b : ℕ} (hp : prime p) : p^r ∣∣ a → p^s ∣∣ b → p^(r+s) ∣∣ a*b :=
begin
  intros pra psb,
  rw exactly_divides'' (hp.gt_one.trans dec_trivial) at ⊢ pra psb,
  rcases pra with ⟨ka, ha1, ha2⟩,
  rcases psb with ⟨kb, hb1, hb2⟩,
  existsi ka * kb, split,
  { exact calc a * b = (p^r * ka) * (p^s * kb)  : by rw [ha1, hb1]
               ...   = (p^r * p^s) * (ka * kb)  : by ac_refl
               ...   = p^(r+s) * (ka * kb)      : by rw pow_add },
  { exact prime.not_dvd_mul hp ha2 hb2 }
end

lemma exactly_divides_pow {r k a : ℕ} (hp : prime p) : p^r ∣∣ a → p^(k * r) ∣∣ a^k :=
mul_comm r k ▸
  λ pra, nat.rec_on k
           (exactly_divides_one hp)
           (λ k' ih, (exactly_divides_mul hp ih pra))

-- Gcd
lemma dvd_gcd_iff {a b k : ℕ} : k ∣ gcd a b ↔ k ∣ a ∧ k ∣ b :=
iff.intro (λ d, ⟨dvd_trans d (gcd_dvd a b).left,
                 dvd_trans d (gcd_dvd a b).right⟩)
          (λ p, and.elim p dvd_gcd)

lemma exactly_divides_gcd {r s a b : ℕ} : p^r ∣∣ a → p^s ∣∣ b → p^(min r s) ∣∣ gcd a b :=
begin
  intros pra psb,
  rw exactly_divides' at ⊢ pra psb,
  intro i,
  exact calc p^i ∣ gcd a b ↔ p^i ∣ a ∧ p^i ∣ b  : dvd_gcd_iff
             ...           ↔ i ≤ r ∧ i ≤ s      : and_congr (pra i) (psb i)
             ...           ↔ i ≤ min r s        : le_min_iff.symm
end

end


import data.set.basic -- hide
open set -- hide

/-
The following lemma can be proved using `ext`, `split`, `cases`, `left`, `right` tactics.

If you are lazy, the `finish` tactic will take the fun out of this exercise. So try to not use it.
-/

/- Hint : Click here for a hint, in case you get stuck.
Remember that `x ∈ A ∩ B` is "the same as" `x ∈ A ∧ x ∈ B`. Therefore if you have a hypothesis
of the form `h : x ∈ A ∩ B` and your goal is `⊢ x ∈ B`, you win by `exact h.2`.
-/

variables {X Y : Type} -- hide

/- Lemma : no-side-bar
The distributive property of ∩ with respect to ∪.
-/
lemma inter_union (A B C : set X) : A ∩ (B ∪ C) = (A ∩ B) ∪ (A ∩ C) :=
begin
  ext,
  split,
  {
    intro h,
    cases h,
    cases h_right,
    {
      left,
      split;
      assumption,
    },
    {
      right,
      split;
      assumption,
    }
  },
  {
    intro h,
    cases h,
    {
      split,
      {
        exact h.1,
      },
      {
        left,
        exact h.2,
      },
    },
    {
      split,
      {
        exact h.1,
      },
      {
        right,
        exact h.2,
      }
    }
  }
end


-- Reduction of Hamiltonian path to SAT problem

-- My graph is G = {(1, 2), (1, 3), (1, 4), (2, 3)}

-- x_ij means the ith position of Hamiltonian path is occupied by node j
variables   x11 x12 x13 x14
            x21 x22 x23 x24
            x31 x32 x33 x34
            x41 x42 x43 x44 : Prop

-- Any path:
variables path: ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ x14 ∧
                x21 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
                ¬ x31 ∧ x32 ∧ ¬ x33 ∧ ¬ x34 ∧
                ¬ x41 ∧ ¬ x42 ∧ x43 ∧ ¬ x44

-- Now I have to show that this path satisfies (or not) the conditions of a Hamiltonian path.

-- Every node needs to appear in the path:

theorem node_1_in_the_path (path : ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ x14 ∧ x21 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
¬ x31 ∧ x32 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ x43 ∧ ¬ x44) : x11 ∨ x21 ∨ x31 ∨ x41 :=
    or.inr (or.inl path.right.right.right.right.left)

theorem node_2_in_the_path (path : ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ x14 ∧ x21 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
¬ x31 ∧ x32 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ x43 ∧ ¬ x44) : x12 ∨ x22 ∨ x32 ∨ x42 :=
    or.inr (or.inr (or.inl path.right.right.right.right.right.right.right.right.right.left))

theorem node_3_in_the_path (path : ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ x14 ∧ x21 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
¬ x31 ∧ x32 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ x43 ∧ ¬ x44) : x13 ∨ x23 ∨ x33 ∨ x43 :=
    or.inr (or.inr (or.inr path.right.right.right.right.right.right.right.right.right.right.right.right.right.right.left))

theorem node_4_in_the_path (path : ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ x14 ∧ x21 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
¬ x31 ∧ x32 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ x43 ∧ ¬ x44) : x14 ∨ x24 ∨ x34 ∨ x44 :=
    or.inl path.right.right.right.left

-- No node appears twice in the path:

theorem node_1_not_twice (path : ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ x14 ∧ x21 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
¬ x31 ∧ x32 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ x43 ∧ ¬ x44) :
(¬ x11 ∨ ¬ x21) ∧ (¬ x11 ∨ ¬ x31) ∧ (¬ x11 ∨ ¬ x41) ∧
(¬ x21 ∨ ¬ x31) ∧ (¬ x21 ∨ ¬ x41) ∧ (¬ x31 ∨ ¬ x41) :=
    have h₁ : ¬ x11, from path.left,
    have h₂ : ¬ x31, from path.right.right.right.right.right.right.right.right.left,
    have h₃ : ¬ x41, from path.right.right.right.right.right.right.right.right.right.right.right.right.left,
    and.intro (or.inl h₁) (and.intro (or.inl h₁) (and.intro (or.inl h₁)
    (and.intro (or.inr h₂) (and.intro (or.inr h₃) (or.inr h₃)))))

theorem node_2_not_twice (path : ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ x14 ∧ x21 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
¬ x31 ∧ x32 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ x43 ∧ ¬ x44) :
(¬ x12 ∨ ¬ x22) ∧ (¬ x12 ∨ ¬ x32) ∧ (¬ x12 ∨ ¬ x42) ∧
(¬ x22 ∨ ¬ x32) ∧ (¬ x22 ∨ ¬ x42) ∧ (¬ x32 ∨ ¬ x42) :=
    have h₁ : ¬ x12, from path.right.left,
    have h₂ : ¬ x22, from path.right.right.right.right.right.left,
    have h₃ : ¬ x42, from path.right.right.right.right.right.right.right.right.right.right.right.right.right.left,
    and.intro (or.inl h₁) (and.intro (or.inl h₁) (and.intro (or.inl h₁)
    (and.intro (or.inl h₂) (and.intro (or.inr h₃) (or.inr h₃)))))

theorem node_3_not_twice (path : ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ x14 ∧ x21 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
¬ x31 ∧ x32 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ x43 ∧ ¬ x44) :
(¬ x13 ∨ ¬ x23) ∧ (¬ x13 ∨ ¬ x33) ∧ (¬ x13 ∨ ¬ x43) ∧
(¬ x23 ∨ ¬ x33) ∧ (¬ x23 ∨ ¬ x43) ∧ (¬ x33 ∨ ¬ x43) :=
    have h₁ : ¬ x13, from path.right.right.left,
    have h₂ : ¬ x23, from path.right.right.right.right.right.right.left,
    have h₃ : ¬ x33, from path.right.right.right.right.right.right.right.right.right.right.left,
    and.intro (or.inl h₁) (and.intro (or.inl h₁) (and.intro (or.inl h₁)
    (and.intro (or.inl h₂) (and.intro (or.inl h₂) (or.inl h₃)))))

theorem node_4_not_twice (path : ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ x14 ∧ x21 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
¬ x31 ∧ x32 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ x43 ∧ ¬ x44) :
(¬ x14 ∨ ¬ x24) ∧ (¬ x14 ∨ ¬ x34) ∧ (¬ x14 ∨ ¬ x44) ∧
(¬ x24 ∨ ¬ x34) ∧ (¬ x24 ∨ ¬ x44) ∧ (¬ x34 ∨ ¬ x44) :=
    have h₁ : ¬ x24, from path.right.right.right.right.right.right.right.left,
    have h₂ : ¬ x34, from path.right.right.right.right.right.right.right.right.right.right.right.left,
    have h₃ : ¬ x44, from path.right.right.right.right.right.right.right.right.right.right.right.right.right.right.right,
    and.intro (or.inr h₁) (and.intro (or.inr h₂) (and.intro (or.inr h₃)
    (and.intro (or.inr h₂) (and.intro (or.inr h₃) (or.inr h₃)))))

-- Every position must be occupied:

theorem position_1_occupied (path : ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ x14 ∧ x21 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
¬ x31 ∧ x32 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ x43 ∧ ¬ x44) : x11 ∨ x12 ∨ x13 ∨ x14 :=
    or.inr (or.inr (or.inr path.right.right.right.left))

theorem position_2_occupied (path : ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ x14 ∧ x21 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
¬ x31 ∧ x32 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ x43 ∧ ¬ x44) : x21 ∨ x22 ∨ x23 ∨ x24 :=
    or.inl path.right.right.right.right.left

theorem position_3_occupied (path : ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ x14 ∧ x21 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
¬ x31 ∧ x32 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ x43 ∧ ¬ x44) : x31 ∨ x32 ∨ x33 ∨ x34 :=
    or.inr (or.inl path.right.right.right.right.right.right.right.right.right.left)

theorem position_4_occupied (path : ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ x14 ∧ x21 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
¬ x31 ∧ x32 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ x43 ∧ ¬ x44) : x41 ∨ x42 ∨ x43 ∨ x44 :=
    or.inr (or.inr (or.inl path.right.right.right.right.right.right.right.right.right.right.right.right.right.right.left))

-- No two nodes can occupy the same position

theorem position_1_not_twice (path : ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ x14 ∧ x21 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
¬ x31 ∧ x32 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ x43 ∧ ¬ x44) :
(¬ x11 ∨ ¬ x12) ∧ (¬ x11 ∨ ¬ x13) ∧ (¬ x11 ∨ ¬ x14) ∧
(¬ x12 ∨ ¬ x13) ∧ (¬ x12 ∨ ¬ x14) ∧ (¬ x13 ∨ ¬ x14) :=
    have h₁ : ¬ x11, from path.left,
    have h₂ : ¬ x12, from path.right.left,
    have h₃ : ¬ x13, from path.right.right.left,
    and.intro (or.inr h₂) (and.intro (or.inr h₃) (and.intro (or.inl h₁)
    (and.intro (or.inr h₃) (and.intro (or.inl h₂) (or.inl h₃)))))

theorem position_2_not_twice (path : ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ x14 ∧ x21 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
¬ x31 ∧ x32 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ x43 ∧ ¬ x44) :
(¬ x21 ∨ ¬ x22) ∧ (¬ x21 ∨ ¬ x23) ∧ (¬ x21 ∨ ¬ x24) ∧
(¬ x22 ∨ ¬ x23) ∧ (¬ x22 ∨ ¬ x24) ∧ (¬ x23 ∨ ¬ x24) :=
    have h₁ : ¬ x22, from path.right.right.right.right.right.left,
    have h₂ : ¬ x23, from path.right.right.right.right.right.right.left,
    have h₃ : ¬ x24, from path.right.right.right.right.right.right.right.left,
    and.intro (or.inr h₁) (and.intro (or.inr h₂) (and.intro (or.inr h₃)
    (and.intro (or.inr h₂) (and.intro (or.inr h₃) (or.inr h₃)))))

theorem position_3_not_twice (path : ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ x14 ∧ x21 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
¬ x31 ∧ x32 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ x43 ∧ ¬ x44) :
(¬ x31 ∨ ¬ x32) ∧ (¬ x31 ∨ ¬ x33) ∧ (¬ x31 ∨ ¬ x34) ∧
(¬ x32 ∨ ¬ x33) ∧ (¬ x32 ∨ ¬ x34) ∧ (¬ x33 ∨ ¬ x34) :=
    have h₁ : ¬ x31, from path.right.right.right.right.right.right.right.right.left,
    have h₂ : ¬ x33, from path.right.right.right.right.right.right.right.right.right.right.left,
    have h₃ : ¬ x34, from path.right.right.right.right.right.right.right.right.right.right.right.left,
    and.intro (or.inl h₁) (and.intro (or.inr h₂) (and.intro (or.inr h₃)
    (and.intro (or.inr h₂) (and.intro (or.inr h₃) (or.inr h₃)))))

theorem position_4_not_twice (path : ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ x14 ∧ x21 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
¬ x31 ∧ x32 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ x43 ∧ ¬ x44) :
(¬ x41 ∨ ¬ x42) ∧ (¬ x41 ∨ ¬ x43) ∧ (¬ x41 ∨ ¬ x44) ∧
(¬ x42 ∨ ¬ x43) ∧ (¬ x42 ∨ ¬ x44) ∧ (¬ x43 ∨ ¬ x44) :=
    have h₁ : ¬ x41, from path.right.right.right.right.right.right.right.right.right.right.right.right.left,
    have h₂ : ¬ x42, from path.right.right.right.right.right.right.right.right.right.right.right.right.right.left,
    have h₃ : ¬ x44, from path.right.right.right.right.right.right.right.right.right.right.right.right.right.right.right,
    and.intro (or.inr h₂) (and.intro (or.inl h₁) (and.intro (or.inr h₃)
    (and.intro (or.inl h₂) (and.intro (or.inr h₃) (or.inr h₃)))))

-- Non adjacent nodes cannot be adjacent in the path.
-- My graph is G = {(1, 2), (1, 3), (1, 4), (2, 3)}, so (2, 4) and (3, 4) don't belong to G.
-- If (2, 4) doesn't belong to G, nodes 2 and 4 aren't adjacent, so they can't be adjacent in the path:

theorem first_non_adjacent (path : ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ x14 ∧ x21 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
¬ x31 ∧ x32 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ x43 ∧ ¬ x44) :
(¬ x12 ∨ ¬ x24) ∧ (¬ x22 ∨ ¬ x34) ∧ (¬ x32 ∨ ¬ x44) :=
    have h₁ : ¬ x12, from path.right.left,
    have h₂ : ¬ x22, from path.right.right.right.right.right.left,
    have h₃ : ¬ x44, from path.right.right.right.right.right.right.right.right.right.right.right.right.right.right.right,
    and.intro (or.inl h₁) (and.intro (or.inl h₂) (or.inr h₃))

-- The same for (3, 4):

theorem second_non_adjacent (path : ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ x14 ∧ x21 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
¬ x31 ∧ x32 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ x43 ∧ ¬ x44) :
(¬ x13 ∨ ¬ x24) ∧ (¬ x23 ∨ ¬ x34) ∧ (¬ x33 ∨ ¬ x44) :=
    have h₁ : ¬ x13, from path.right.right.left,
    have h₂ : ¬ x23, from path.right.right.right.right.right.right.left,
    have h₃ : ¬ x44, from path.right.right.right.right.right.right.right.right.right.right.right.right.right.right.right,
    and.intro (or.inl h₁) (and.intro (or.inl h₂) (or.inr h₃))

-- We can conclude that my path for graph G is Hamiltonian.


/-
Copyright (c) 2022 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov, Sébastien Gouëzel

! This file was ported from Lean 3 source module order.monotone.union
! leanprover-community/mathlib commit d012cd09a9b256d870751284dd6a29882b0be105
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Order.Bounds.Basic

/-!
# Monotonicity on intervals

In this file we prove that a function is (strictly) monotone (or antitone) on a linear order `α`
provided that it is (strictly) monotone on `(-∞, a]` and on `[a, +∞)`. This is a special case
of a more general statement where one deduces monotonicity on a union from monotonicity on each
set.
-/

open Set

variable {α β : Type _} [LinearOrder α] [Preorder β] {a : α} {f : α → β}

/-- If `f` is strictly monotone both on `s` and `t`, with `s` to the left of `t` and the center
point belonging to both `s` and `t`, then `f` is strictly monotone on `s ∪ t` -/
protected theorem StrictMonoOn.union {s t : Set α} {c : α} (h₁ : StrictMonoOn f s)
    (h₂ : StrictMonoOn f t) (hs : IsGreatest s c) (ht : IsLeast t c) : StrictMonoOn f (s ∪ t) := by
  have A : ∀ x, x ∈ s ∪ t → x ≤ c → x ∈ s := by
    intro x hx hxc
    cases hx
    · assumption
    rcases eq_or_lt_of_le hxc with (rfl | h'x)
    · exact hs.1
    exact (lt_irrefl _ (h'x.trans_le (ht.2 (by assumption)))).elim
  have B : ∀ x, x ∈ s ∪ t → c ≤ x → x ∈ t := by
    intro x hx hxc
    match hx with
    | Or.inr hx => exact hx
    | Or.inl hx =>
      rcases eq_or_lt_of_le hxc with (rfl | h'x)
      · exact ht.1
      exact (lt_irrefl _ (h'x.trans_le (hs.2 hx))).elim
  intro x hx y hy hxy
  rcases lt_or_le x c with (hxc | hcx)
  · have xs : x ∈ s := A _ hx hxc.le
    rcases lt_or_le y c with (hyc | hcy)
    · exact h₁ xs (A _ hy hyc.le) hxy
    · exact (h₁ xs hs.1 hxc).trans_le (h₂.monotoneOn ht.1 (B _ hy hcy) hcy)
  · have xt : x ∈ t := B _ hx hcx
    have yt : y ∈ t := B _ hy (hcx.trans hxy.le)
    exact h₂ xt yt hxy
#align strict_mono_on.union StrictMonoOn.union

/-- If `f` is strictly monotone both on `(-∞, a]` and `[a, ∞)`, then it is strictly monotone on the
whole line. -/
protected theorem StrictMonoOn.Iic_union_Ici (h₁ : StrictMonoOn f (Iic a))
    (h₂ : StrictMonoOn f (Ici a)) : StrictMono f := by
  rw [← strictMonoOn_univ, ← @Iic_union_Ici _ _ a]
  exact StrictMonoOn.union h₁ h₂ isGreatest_Iic isLeast_Ici
#align strict_mono_on.Iic_union_Ici StrictMonoOn.Iic_union_Ici

/-- If `f` is strictly antitone both on `s` and `t`, with `s` to the left of `t` and the center
point belonging to both `s` and `t`, then `f` is strictly antitone on `s ∪ t` -/
protected theorem StrictAntiOn.union {s t : Set α} {c : α} (h₁ : StrictAntiOn f s)
    (h₂ : StrictAntiOn f t) (hs : IsGreatest s c) (ht : IsLeast t c) : StrictAntiOn f (s ∪ t) :=
  (h₁.dual_right.union h₂.dual_right hs ht).dual_right
#align strict_anti_on.union StrictAntiOn.union

/-- If `f` is strictly antitone both on `(-∞, a]` and `[a, ∞)`, then it is strictly antitone on the
whole line. -/
protected theorem StrictAntiOn.Iic_union_Ici (h₁ : StrictAntiOn f (Iic a))
    (h₂ : StrictAntiOn f (Ici a)) : StrictAnti f :=
  (h₁.dual_right.Iic_union_Ici h₂.dual_right).dual_right
#align strict_anti_on.Iic_union_Ici StrictAntiOn.Iic_union_Ici

/-- If `f` is monotone both on `s` and `t`, with `s` to the left of `t` and the center
point belonging to both `s` and `t`, then `f` is monotone on `s ∪ t` -/
protected theorem MonotoneOn.union_right {s t : Set α} {c : α} (h₁ : MonotoneOn f s)
    (h₂ : MonotoneOn f t) (hs : IsGreatest s c) (ht : IsLeast t c) : MonotoneOn f (s ∪ t) := by
  have A : ∀ x, x ∈ s ∪ t → x ≤ c → x ∈ s := by
    intro x hx hxc
    cases hx
    · assumption
    rcases eq_or_lt_of_le hxc with (rfl | h'x)
    · exact hs.1
    exact (lt_irrefl _ (h'x.trans_le (ht.2 (by assumption)))).elim
  have B : ∀ x, x ∈ s ∪ t → c ≤ x → x ∈ t := by
    intro x hx hxc
    match hx with
    | Or.inr hx => exact hx
    | Or.inl hx =>
      rcases eq_or_lt_of_le hxc with (rfl | h'x)
      · exact ht.1
      exact (lt_irrefl _ (h'x.trans_le (hs.2 hx))).elim
  intro x hx y hy hxy
  rcases lt_or_le x c with (hxc | hcx)
  · have xs : x ∈ s := A _ hx hxc.le
    rcases lt_or_le y c with (hyc | hcy)
    · exact h₁ xs (A _ hy hyc.le) hxy
    · exact (h₁ xs hs.1 hxc.le).trans (h₂ ht.1 (B _ hy hcy) hcy)
  · have xt : x ∈ t := B _ hx hcx
    have yt : y ∈ t := B _ hy (hcx.trans hxy)
    exact h₂ xt yt hxy
#align monotone_on.union_right MonotoneOn.union_right

/-- If `f` is monotone both on `(-∞, a]` and `[a, ∞)`, then it is monotone on the whole line. -/
protected theorem MonotoneOn.Iic_union_Ici (h₁ : MonotoneOn f (Iic a)) (h₂ : MonotoneOn f (Ici a)) :
    Monotone f := by
  rw [← monotoneOn_univ, ← @Iic_union_Ici _ _ a]
  exact MonotoneOn.union_right h₁ h₂ isGreatest_Iic isLeast_Ici
#align monotone_on.Iic_union_Ici MonotoneOn.Iic_union_Ici

/-- If `f` is antitone both on `s` and `t`, with `s` to the left of `t` and the center
point belonging to both `s` and `t`, then `f` is antitone on `s ∪ t` -/
protected theorem AntitoneOn.union_right {s t : Set α} {c : α} (h₁ : AntitoneOn f s)
    (h₂ : AntitoneOn f t) (hs : IsGreatest s c) (ht : IsLeast t c) : AntitoneOn f (s ∪ t) :=
  (h₁.dual_right.union_right h₂.dual_right hs ht).dual_right
#align antitone_on.union_right AntitoneOn.union_right

/-- If `f` is antitone both on `(-∞, a]` and `[a, ∞)`, then it is antitone on the whole line. -/
protected theorem AntitoneOn.Iic_union_Ici (h₁ : AntitoneOn f (Iic a)) (h₂ : AntitoneOn f (Ici a)) :
    Antitone f :=
  (h₁.dual_right.Iic_union_Ici h₂.dual_right).dual_right
#align antitone_on.Iic_union_Ici AntitoneOn.Iic_union_Ici


import analysis.inner_product_space.adjoint
import analysis.inner_product_space.pi_L2
import analysis.inner_product_space.spectrum

variables {𝕜 E : Type*} [is_R_or_C 𝕜] [inner_product_space 𝕜 E] [finite_dimensional 𝕜 E]
  [decidable_eq 𝕜]

local notation `⟪`x`, `y`⟫` := @inner 𝕜 E _ x y

namespace inner_product_space

variables {T : E →ₗ[𝕜] E} (hT : is_self_adjoint T)
variables {n : ℕ} (hn : finite_dimensional.finrank 𝕜 E = n)

noncomputable def is_self_adjoint.sqrt : E →ₗ[𝕜] E :=
  @basis.constr (fin n) 𝕜 E E _ _ _ _ _ (hT.eigenvector_basis hn) 𝕜 _ _ _
    (λ (i : (fin n)), (real.sqrt(hT.eigenvalues hn i) : 𝕜) • (hT.eigenvector_basis hn i))

local notation `evec` := hT.eigenvector_basis hn
local notation `eval` := hT.eigenvalues hn

lemma is_self_adjoint.sqrt_apply {i : (fin n)} :
  (hT.sqrt hn) (evec i) = (real.sqrt (eval i) : 𝕜) • (evec i) :=
    by simp only [is_self_adjoint.sqrt, (evec).constr_basis]

lemma is_self_adjoint.sqrt_mul_self_eq (hnn : ∀ (i : (fin n)), eval i ≥ 0) :
  (hT.sqrt hn) * (hT.sqrt hn) = T :=
begin
  apply basis.ext (hT.eigenvector_basis hn),
  intro i,
  simp only [linear_map.mul_apply, inner_product_space.is_self_adjoint.apply_eigenvector_basis,
    is_self_adjoint.sqrt_apply, ring_hom.id_apply, linear_map.map_smulₛₗ, smul_smul],
  norm_cast,
  rw real.mul_self_sqrt (hnn i),
end

lemma is_self_adjoint.sqrt_self_adjoint : is_self_adjoint (hT.sqrt hn) :=
begin
  rw [linear_map.is_self_adjoint_iff_eq_adjoint, linear_map.eq_adjoint_iff_basis (evec) (evec)],
  intros i j,
  simp only [is_self_adjoint.sqrt_apply, inner_smul_left, inner_smul_right, is_R_or_C.conj_of_real,
    is_R_or_C.of_real_inj, mul_eq_mul_right_iff],
  by_cases hij : i = j,
  simp only [hij, true_or, eq_self_iff_true, inner_self_eq_zero],
  have orthonormal_evec : orthonormal 𝕜 evec := is_self_adjoint.eigenvector_basis_orthonormal hT hn,
  rw orthonormal_iff_ite at orthonormal_evec,
  specialize orthonormal_evec i j,
  simp only [orthonormal_evec, ite_eq_right_iff],
  tauto,
end

end inner_product_space


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Simon Hudon
-/
import data.pfunctor.multivariate.basic

/-!
# Multivariate quotients of polynomial functors.

Basic definition of multivariate QPF. QPFs form a compositional framework
for defining inductive and coinductive types, their quotients and nesting.

The idea is based on building ever larger functors. For instance, we can define
a list using a shape functor:

```lean
inductive list_shape (a b : Type)
| nil : list_shape
| cons : a -> b -> list_shape
```

This shape can itself be decomposed as a sum of product which are themselves
QPFs. It follows that the shape is a QPF and we can take its fixed point
and create the list itself:

```lean
def list (a : Type) := fix list_shape a -- not the actual notation
```

We can continue and define the quotient on permutation of lists and create
the multiset type:

```lean
def multiset (a : Type) := qpf.quot list.perm list a -- not the actual notion
```

And `multiset` is also a QPF. We can then create a novel data type (for Lean):

```lean
inductive tree (a : Type)
| node : a -> multiset tree -> tree
```

An unordered tree. This is currently not supported by Lean because it nests
an inductive type inside of a quotient. We can go further and define
unordered, possibly infinite trees:

```lean
coinductive tree' (a : Type)
| node : a -> multiset tree' -> tree'
```

by using the `cofix` construct. Those options can all be mixed and
matched because they preserve the properties of QPF. The latter example,
`tree'`, combines fixed point, co-fixed point and quotients.

## Related modules

 * constructions
   * fix
   * cofix
   * quot
   * comp
   * sigma / pi
   * prj
   * const

each proves that some operations on functors preserves the QPF structure

## Reference

 * [Jeremy Avigad, Mario M. Carneiro and Simon Hudon, *Data Types as Quotients of Polynomial Functors*][avigad-carneiro-hudon2019]
-/

universe u

open_locale mvfunctor

/--
Multivariate quotients of polynomial functors.
-/
class mvqpf {n : ℕ} (F : typevec.{u} n → Type*) [mvfunctor F] :=
(P         : mvpfunctor.{u} n)
(abs       : Π {α}, P.obj α → F α)
(repr      : Π {α}, F α → P.obj α)
(abs_repr  : ∀ {α} (x : F α), abs (repr x) = x)
(abs_map   : ∀ {α β} (f : α ⟹ β) (p : P.obj α), abs (f <$$> p) = f <$$> abs p)

namespace mvqpf
variables {n : ℕ} {F : typevec.{u} n → Type*} [mvfunctor F] [q : mvqpf F]
include q
open mvfunctor (liftp liftr)

/-!
### Show that every mvqpf is a lawful mvfunctor.
-/

protected theorem id_map {α : typevec n} (x : F α) : typevec.id <$$> x = x :=
by { rw ←abs_repr x, cases repr x with a f, rw [←abs_map], reflexivity }

@[simp] theorem comp_map {α β γ : typevec n} (f : α ⟹ β) (g : β ⟹ γ) (x : F α) :
  (g ⊚ f) <$$> x = g <$$> f <$$> x :=
by { rw ←abs_repr x, cases repr x with a f, rw [←abs_map, ←abs_map, ←abs_map], reflexivity }

@[priority 100]
instance is_lawful_mvfunctor : is_lawful_mvfunctor F :=
{ id_map := @mvqpf.id_map n F _ _,
  comp_map := @comp_map n F _ _ }

/- Lifting predicates and relations -/

theorem liftp_iff {α : typevec n} (p : Π ⦃i⦄, α i → Prop) (x : F α) :
  liftp p x ↔ ∃ a f, x = abs ⟨a, f⟩ ∧ ∀ i j, p (f i j) :=
begin
  split,
  { rintros ⟨y, hy⟩, cases h : repr y with a f,
    use [a, λ i j, (f i j).val], split,
    { rw [←hy, ←abs_repr y, h, ←abs_map], reflexivity },
    intros i j, apply (f i j).property },
  rintros ⟨a, f, h₀, h₁⟩, dsimp at *,
  use abs (⟨a, λ i j, ⟨f i j, h₁ i j⟩⟩),
  rw [←abs_map, h₀], reflexivity
end

theorem liftr_iff {α : typevec n} (r : Π ⦃i⦄, α i → α i → Prop) (x y : F α) :
  liftr r x y ↔ ∃ a f₀ f₁, x = abs ⟨a, f₀⟩ ∧ y = abs ⟨a, f₁⟩ ∧ ∀ i j, r (f₀ i j) (f₁ i j) :=
begin
  split,
  { rintros ⟨u, xeq, yeq⟩, cases h : repr u with a f,
    use [a, λ i j, (f i j).val.fst, λ i j, (f i j).val.snd],
    split, { rw [←xeq, ←abs_repr u, h, ←abs_map], refl },
    split, { rw [←yeq, ←abs_repr u, h, ←abs_map], refl },
    intros i j, exact (f i j).property },
  rintros ⟨a, f₀, f₁, xeq, yeq, h⟩,
  use abs ⟨a, λ i j, ⟨(f₀ i j, f₁ i j), h i j⟩⟩,
  dsimp, split,
  { rw [xeq, ←abs_map], refl },
  rw [yeq, ←abs_map], refl
end

open set
open mvfunctor

theorem mem_supp {α : typevec n} (x : F α) (i) (u : α i) :
  u ∈ supp x i ↔ ∀ a f, abs ⟨a, f⟩ = x → u ∈ f i '' univ :=
begin
  rw [supp], dsimp, split,
  { intros h a f haf,
    have : liftp (λ i u, u ∈ f i '' univ) x,
    { rw liftp_iff, refine ⟨a, f, haf.symm, _⟩,
      intros i u, exact mem_image_of_mem _ (mem_univ _) },
    exact h this },
  intros h p, rw liftp_iff,
  rintros ⟨a, f, xeq, h'⟩,
  rcases h a f xeq.symm with ⟨i, _, hi⟩,
  rw ←hi, apply h'
end

theorem supp_eq {α : typevec n} {i} (x : F α) :
  supp x i = { u | ∀ a f, abs ⟨a, f⟩ = x → u ∈ f i '' univ } :=
by ext; apply mem_supp

theorem has_good_supp_iff {α : typevec n} (x : F α) :
  (∀ p, liftp p x ↔ ∀ i (u ∈ supp x i), p i u) ↔
    ∃ a f, abs ⟨a, f⟩ = x ∧ ∀ i a' f', abs ⟨a', f'⟩ = x → f i '' univ ⊆ f' i '' univ :=
begin
  split,
  { intros h,
    have : liftp (supp x) x, by { rw h, introv, exact id, },
    rw liftp_iff at this, rcases this with ⟨a, f, xeq, h'⟩,
    refine ⟨a, f, xeq.symm, _⟩,
    intros a' f' h'',
    rintros hu u ⟨j, h₂, hfi⟩,
    have hh : u ∈ supp x a', by rw ←hfi; apply h',
    refine (mem_supp x _ u).mp hh _ _ hu, },
  rintros ⟨a, f, xeq, h⟩ p, rw liftp_iff, split,
  { rintros ⟨a', f', xeq', h'⟩ i u usuppx,
    rcases (mem_supp x _ u).mp @usuppx a' f' xeq'.symm with ⟨i, _, f'ieq⟩,
    rw ←f'ieq, apply h' },
  intro h',
  refine ⟨a, f, xeq.symm, _⟩, intros j y,
  apply h', rw mem_supp,
  intros a' f' xeq',
  apply h _ a' f' xeq',
  apply mem_image_of_mem _ (mem_univ _)
end

variable (q)

/-- A qpf is said to be uniform if every polynomial functor
representing a single value all have the same range. -/
def is_uniform : Prop := ∀ ⦃α : typevec n⦄ (a a' : q.P.A)
    (f : q.P.B a ⟹ α) (f' : q.P.B a' ⟹ α),
  abs ⟨a, f⟩ = abs ⟨a', f'⟩ → ∀ i, f i '' univ = f' i '' univ

/-- does `abs` preserve `liftp`? -/
def liftp_preservation : Prop :=
∀ ⦃α : typevec n⦄ (p : Π ⦃i⦄, α i → Prop) (x : q.P.obj α), liftp p (abs x) ↔ liftp p x

/-- does `abs` preserve `supp`? -/
def supp_preservation : Prop :=
∀ ⦃α⦄ (x : q.P.obj α), supp (abs x) = supp x

variable [q]

theorem supp_eq_of_is_uniform (h : q.is_uniform) {α : typevec n} (a : q.P.A) (f : q.P.B a ⟹ α) :
  ∀ i, supp (abs ⟨a, f⟩) i = f i '' univ :=
begin
  intro, ext u, rw [mem_supp], split,
  { intro h', apply h' _ _ rfl },
  intros h' a' f' e,
  rw [←h _ _ _ _ e.symm], apply h'
end

theorem liftp_iff_of_is_uniform (h : q.is_uniform) {α : typevec n} (x : F α) (p : Π i, α i → Prop) :
  liftp p x ↔ ∀ i (u ∈ supp x i), p i u :=
begin
  rw [liftp_iff, ←abs_repr x],
  cases repr x with a f,  split,
  { rintros ⟨a', f', abseq, hf⟩ u,
    rw [supp_eq_of_is_uniform h, h _ _ _ _ abseq],
    rintros b ⟨i, _, hi⟩, rw ←hi, apply hf },
  intro h',
  refine ⟨a, f, rfl, λ _ i, h' _ _ _⟩,
  rw supp_eq_of_is_uniform h,
  exact ⟨i, mem_univ i, rfl⟩
end

theorem supp_map (h : q.is_uniform) {α β : typevec n} (g : α ⟹ β) (x : F α) (i) :
  supp (g <$$> x) i = g i '' supp x i :=
begin
  rw ←abs_repr x, cases repr x with a f, rw [←abs_map, mvpfunctor.map_eq],
  rw [supp_eq_of_is_uniform h, supp_eq_of_is_uniform h, ← image_comp],
  refl,
end

theorem supp_preservation_iff_uniform :
  q.supp_preservation ↔ q.is_uniform :=
begin
  split,
  { intros h α a a' f f' h' i,
    rw [← mvpfunctor.supp_eq,← mvpfunctor.supp_eq,← h,h',h] },
  { rintros h α ⟨a,f⟩, ext, rwa [supp_eq_of_is_uniform,mvpfunctor.supp_eq], }
end

theorem liftp_preservation_iff_uniform :
  q.liftp_preservation ↔ q.is_uniform :=
by rw [← supp_preservation_iff_liftp_preservation, supp_preservation_iff_uniform]

end mvqpf


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

! This file was ported from Lean 3 source module number_theory.well_approximable
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Dynamics.Ergodic.AddCircle
import Mathbin.MeasureTheory.Covering.LiminfLimsup
import Mathbin.Data.Nat.Totient

/-!
# Well-approximable numbers and Gallagher's ergodic theorem

Gallagher's ergodic theorem is a result in metric number theory. It thus belongs to that branch of
mathematics concerning arithmetic properties of real numbers which hold almost eveywhere with
respect to the Lebesgue measure.

Gallagher's theorem concerns the approximation of real numbers by rational numbers. The input is a
sequence of distances `δ₁, δ₂, ...`, and the theorem concerns the set of real numbers `x` for which
there is an infinity of solutions to:
$$
  |x - m/n| < δₙ,
$$
where the rational number `m/n` is in lowest terms. The result is that for any `δ`, this set is
either almost all `x` or almost no `x`.

This result was proved by Gallagher in 1959
[P. Gallagher, *Approximation by reduced fractions*](Gallagher1961). It is formalised here as
`add_circle.add_well_approximable_ae_empty_or_univ` except with `x` belonging to the circle `ℝ ⧸ ℤ`
since this turns out to be more natural.

Given a particular `δ`, the Duffin-Schaeffer conjecture (now a theorem) gives a criterion for
deciding which of the two cases in the conclusion of Gallagher's theorem actually occurs. It was
proved by Koukoulopoulos and Maynard in 2019
[D. Koukoulopoulos, J. Maynard, *On the Duffin-Schaeffer conjecture*](KoukoulopoulosMaynard2020).
We do *not* include a formalisation of the Koukoulopoulos-Maynard result here.

## Main definitions and results:

 * `approx_order_of`: in a seminormed group `A`, given `n : ℕ` and `δ : ℝ`, `approx_order_of A n δ`
   is the set of elements within a distance `δ` of a point of order `n`.
 * `well_approximable`: in a seminormed group `A`, given a sequence of distances `δ₁, δ₂, ...`,
   `well_approximable A δ` is the limsup as `n → ∞` of the sets `approx_order_of A n δₙ`. Thus, it
   is the set of points that lie in infinitely many of the sets `approx_order_of A n δₙ`.
 * `add_circle.add_well_approximable_ae_empty_or_univ`: *Gallagher's ergodic theorem* says that for
   for the (additive) circle `𝕊`, for any sequence of distances `δ`, the set
   `add_well_approximable 𝕊 δ` is almost empty or almost full.

## TODO:

The hypothesis `hδ` in `add_circle.add_well_approximable_ae_empty_or_univ` can be dropped.
An elementary (non-measure-theoretic) argument shows that if `¬ hδ` holds then
`add_well_approximable 𝕊 δ = univ` (provided `δ` is non-negative).
-/

open Set Filter Function Metric MeasureTheory

open MeasureTheory Topology Pointwise

/-- In a seminormed group `A`, given `n : ℕ` and `δ : ℝ`, `approx_order_of A n δ` is the set of
elements within a distance `δ` of a point of order `n`. -/
@[to_additive approxAddOrderOf
      "In a seminormed additive group `A`, given `n : ℕ` and `δ : ℝ`,\n`approx_add_order_of A n δ` is the set of elements within a distance `δ` of a point of order `n`."]
def approxOrderOf (A : Type _) [SeminormedGroup A] (n : ℕ) (δ : ℝ) : Set A :=
  thickening δ { y | orderOf y = n }
#align approx_order_of approxOrderOf
#align approx_add_order_of approxAddOrderOf

@[to_additive mem_approx_add_orderOf_iff]
theorem mem_approxOrderOf_iff {A : Type _} [SeminormedGroup A] {n : ℕ} {δ : ℝ} {a : A} :
    a ∈ approxOrderOf A n δ ↔ ∃ b : A, orderOf b = n ∧ a ∈ ball b δ := by
  simp only [approxOrderOf, thickening_eq_bUnion_ball, mem_Union₂, mem_set_of_eq, exists_prop]
#align mem_approx_order_of_iff mem_approxOrderOf_iff
#align mem_approx_add_order_of_iff mem_approx_add_orderOf_iff

/-- In a seminormed group `A`, given a sequence of distances `δ₁, δ₂, ...`, `well_approximable A δ`
is the limsup as `n → ∞` of the sets `approx_order_of A n δₙ`. Thus, it is the set of points that
lie in infinitely many of the sets `approx_order_of A n δₙ`. -/
@[to_additive addWellApproximable
      "In a seminormed additive group `A`, given a sequence of\ndistances `δ₁, δ₂, ...`, `add_well_approximable A δ` is the limsup as `n → ∞` of the sets\n`approx_add_order_of A n δₙ`. Thus, it is the set of points that lie in infinitely many of the sets\n`approx_add_order_of A n δₙ`."]
def wellApproximable (A : Type _) [SeminormedGroup A] (δ : ℕ → ℝ) : Set A :=
  blimsup (fun n => approxOrderOf A n (δ n)) atTop fun n => 0 < n
#align well_approximable wellApproximable
#align add_well_approximable addWellApproximable

@[to_additive mem_add_wellApproximable_iff]
theorem mem_wellApproximable_iff {A : Type _} [SeminormedGroup A] {δ : ℕ → ℝ} {a : A} :
    a ∈ wellApproximable A δ ↔
      a ∈ blimsup (fun n => approxOrderOf A n (δ n)) atTop fun n => 0 < n :=
  Iff.rfl
#align mem_well_approximable_iff mem_wellApproximable_iff
#align mem_add_well_approximable_iff mem_add_wellApproximable_iff

namespace approxOrderOf

variable {A : Type _} [SeminormedCommGroup A] {a : A} {m n : ℕ} (δ : ℝ)

@[to_additive]
theorem image_pow_subset_of_coprime (hm : 0 < m) (hmn : n.coprime m) :
    (fun y => y ^ m) '' approxOrderOf A n δ ⊆ approxOrderOf A n (m * δ) :=
  by
  rintro - ⟨a, ha, rfl⟩
  obtain ⟨b, hb, hab⟩ := mem_approx_order_of_iff.mp ha
  replace hb : b ^ m ∈ { u : A | orderOf u = n };
  · rw [← hb] at hmn⊢
    exact orderOf_pow_coprime hmn
  apply ball_subset_thickening hb ((m : ℝ) • δ)
  convert pow_mem_ball hm hab using 1
  simp only [nsmul_eq_mul, Algebra.id.smul_eq_mul]
#align approx_order_of.image_pow_subset_of_coprime approxOrderOf.image_pow_subset_of_coprime
#align approx_add_order_of.image_nsmul_subset_of_coprime approxAddOrderOf.image_nsmul_subset_of_coprime

@[to_additive]
theorem image_pow_subset (n : ℕ) (hm : 0 < m) :
    (fun y => y ^ m) '' approxOrderOf A (n * m) δ ⊆ approxOrderOf A n (m * δ) :=
  by
  rintro - ⟨a, ha, rfl⟩
  obtain ⟨b, hb : orderOf b = n * m, hab : a ∈ ball b δ⟩ := mem_approx_order_of_iff.mp ha
  replace hb : b ^ m ∈ { y : A | orderOf y = n }
  · rw [mem_set_of_eq, orderOf_pow' b hm.ne', hb, Nat.gcd_mul_left_left, n.mul_div_cancel hm]
  apply ball_subset_thickening hb (m * δ)
  convert pow_mem_ball hm hab
  simp only [nsmul_eq_mul]
#align approx_order_of.image_pow_subset approxOrderOf.image_pow_subset
#align approx_add_order_of.image_nsmul_subset approxAddOrderOf.image_nsmul_subset

@[to_additive]
theorem smul_subset_of_coprime (han : (orderOf a).coprime n) :
    a • approxOrderOf A n δ ⊆ approxOrderOf A (orderOf a * n) δ :=
  by
  simp_rw [approxOrderOf, thickening_eq_bUnion_ball, ← image_smul, image_Union₂, image_smul,
    smul_ball'', smul_eq_mul, mem_set_of_eq]
  refine' Union₂_subset_iff.mpr fun b hb c hc => _
  simp only [mem_Union, exists_prop]
  refine' ⟨a * b, _, hc⟩
  rw [← hb] at han⊢
  exact (Commute.all a b).orderOf_mul_eq_mul_orderOf_of_coprime han
#align approx_order_of.smul_subset_of_coprime approxOrderOf.smul_subset_of_coprime
#align approx_add_order_of.vadd_subset_of_coprime approxAddOrderOf.vadd_subset_of_coprime

@[to_additive vadd_eq_of_mul_dvd]
theorem smul_eq_of_mul_dvd (hn : 0 < n) (han : orderOf a ^ 2 ∣ n) :
    a • approxOrderOf A n δ = approxOrderOf A n δ :=
  by
  simp_rw [approxOrderOf, thickening_eq_bUnion_ball, ← image_smul, image_Union₂, image_smul,
    smul_ball'', smul_eq_mul, mem_set_of_eq]
  replace han : ∀ {b : A}, orderOf b = n → orderOf (a * b) = n
  · intro b hb
    rw [← hb] at han hn
    rw [sq] at han
    rwa [(Commute.all a b).orderOf_mul_eq_right_of_forall_prime_mul_dvd (order_of_pos_iff.mp hn)
        fun p hp hp' => dvd_trans (mul_dvd_mul_right hp' <| orderOf a) han]
  let f : { b : A | orderOf b = n } → { b : A | orderOf b = n } := fun b => ⟨a * b, han b.property⟩
  have hf : surjective f := by
    rintro ⟨b, hb⟩
    refine' ⟨⟨a⁻¹ * b, _⟩, _⟩
    · rw [mem_set_of_eq, ← orderOf_inv, mul_inv_rev, inv_inv, mul_comm]
      apply han
      simpa
    · simp only [Subtype.mk_eq_mk, Subtype.coe_mk, mul_inv_cancel_left]
  simpa only [f, mem_set_of_eq, Subtype.coe_mk, Union_coe_set] using
    hf.Union_comp fun b => ball (b : A) δ
#align approx_order_of.smul_eq_of_mul_dvd approxOrderOf.smul_eq_of_mul_dvd
#align approx_add_order_of.vadd_eq_of_mul_dvd approxAddOrderOf.vadd_eq_of_mul_dvd

end approxOrderOf

namespace UnitAddCircle

theorem mem_approxAddOrderOf_iff {δ : ℝ} {x : UnitAddCircle} {n : ℕ} (hn : 0 < n) :
    x ∈ approxAddOrderOf UnitAddCircle n δ ↔ ∃ m < n, gcd m n = 1 ∧ ‖x - ↑((m : ℝ) / n)‖ < δ :=
  by
  haveI := Real.fact_zero_lt_one
  simp only [mem_approx_add_orderOf_iff, mem_set_of_eq, ball, exists_prop, dist_eq_norm,
    AddCircle.addOrderOf_eq_pos_iff hn, mul_one]
  constructor
  · rintro ⟨y, ⟨m, hm₁, hm₂, rfl⟩, hx⟩
    exact ⟨m, hm₁, hm₂, hx⟩
  · rintro ⟨m, hm₁, hm₂, hx⟩
    exact ⟨↑((m : ℝ) / n), ⟨m, hm₁, hm₂, rfl⟩, hx⟩
#align unit_add_circle.mem_approx_add_order_of_iff UnitAddCircle.mem_approxAddOrderOf_iff

theorem mem_addWellApproximable_iff (δ : ℕ → ℝ) (x : UnitAddCircle) :
    x ∈ addWellApproximable UnitAddCircle δ ↔
      { n : ℕ | ∃ m < n, gcd m n = 1 ∧ ‖x - ↑((m : ℝ) / n)‖ < δ n }.Infinite :=
  by
  simp only [mem_add_wellApproximable_iff, ← Nat.cofinite_eq_atTop, cofinite.blimsup_set_eq,
    mem_set_of_eq]
  refine' iff_of_eq (congr_arg Set.Infinite <| ext fun n => ⟨fun hn => _, fun hn => _⟩)
  · exact (mem_approx_add_orderOf_iff hn.1).mp hn.2
  · have h : 0 < n := by
      obtain ⟨m, hm₁, hm₂, hm₃⟩ := hn
      exact pos_of_gt hm₁
    exact ⟨h, (mem_approx_add_orderOf_iff h).mpr hn⟩
#align unit_add_circle.mem_add_well_approximable_iff UnitAddCircle.mem_addWellApproximable_iff

end UnitAddCircle

namespace AddCircle

variable {T : ℝ} [hT : Fact (0 < T)]

include hT

-- mathport name: «expr ∤ »
local notation a "∤" b => ¬a ∣ b

-- mathport name: «expr ∣∣ »
local notation a "∣∣" b => a ∣ b ∧ (a * a)∤b

-- mathport name: expr𝕊
local notation "𝕊" => AddCircle T

/-- *Gallagher's ergodic theorem* on Diophantine approximation. -/
theorem addWellApproximable_ae_empty_or_univ (δ : ℕ → ℝ) (hδ : Tendsto δ atTop (𝓝 0)) :
    (∀ᵐ x, ¬addWellApproximable 𝕊 δ x) ∨ ∀ᵐ x, addWellApproximable 𝕊 δ x :=
  by
  /- Sketch of proof:

    Let `E := add_well_approximable 𝕊 δ`. For each prime `p : ℕ`, we can partition `E` into three
    pieces `E = (A p) ∪ (B p) ∪ (C p)` where:
      `A p = blimsup (approx_add_order_of 𝕊 n (δ n)) at_top (λ n, 0 < n ∧ (p ∤ n))`
      `B p = blimsup (approx_add_order_of 𝕊 n (δ n)) at_top (λ n, 0 < n ∧ (p ∣∣ n))`
      `C p = blimsup (approx_add_order_of 𝕊 n (δ n)) at_top (λ n, 0 < n ∧ (p*p ∣ n))`.
    (In other words, `A p` is the set of points `x` for which there exist infinitely-many `n` such
    that `x` is within a distance `δ n` of a point of order `n` and `p ∤ n`. Similarly for `B`, `C`.)

    These sets have the following key properties:
      1. `A p` is almost invariant under the ergodic map `y ↦ p • y`
      2. `B p` is almost invariant under the ergodic map `y ↦ p • y + 1/p`
      3. `C p` is invariant under the map `y ↦ y + 1/p`
    To prove 1 and 2 we need the key result `blimsup_thickening_mul_ae_eq` but 3 is elementary.

    It follows from `add_circle.ergodic_nsmul_add` and `ergodic.ae_empty_or_univ_of_image_ae_le` that
    if either `A p` or `B p` is not almost empty for any `p`, then it is almost full and thus so is
    `E`. We may therefore assume that both `A p` and `B p` are almost empty for all `p`. We thus have
    `E` is almost equal to `C p` for every prime. Combining this with 3 we find that `E` is almost
    invariant under the map `y ↦ y + 1/p` for every prime `p`. The required result then follows from
    `add_circle.ae_empty_or_univ_of_forall_vadd_ae_eq_self`. -/
  letI : SemilatticeSup Nat.Primes := Nat.Subtype.semilatticeSup _
  set μ : Measure 𝕊 := volume
  set u : Nat.Primes → 𝕊 := fun p => ↑((↑(1 : ℕ) : ℝ) / p * T)
  have hu₀ : ∀ p : Nat.Primes, addOrderOf (u p) = (p : ℕ) :=
    by
    rintro ⟨p, hp⟩
    exact add_order_of_div_of_gcd_eq_one hp.pos (gcd_one_left p)
  have hu : tendsto (addOrderOf ∘ u) at_top at_top :=
    by
    rw [(funext hu₀ : addOrderOf ∘ u = coe)]
    have h_mono : Monotone (coe : Nat.Primes → ℕ) := fun p q hpq => hpq
    refine' h_mono.tendsto_at_top_at_top fun n => _
    obtain ⟨p, hp, hp'⟩ := n.exists_infinite_primes
    exact ⟨⟨p, hp'⟩, hp⟩
  set E := addWellApproximable 𝕊 δ
  set X : ℕ → Set 𝕊 := fun n => approxAddOrderOf 𝕊 n (δ n)
  set A : ℕ → Set 𝕊 := fun p => blimsup X at_top fun n => 0 < n ∧ p∤n
  set B : ℕ → Set 𝕊 := fun p => blimsup X at_top fun n => 0 < n ∧ p∣∣n
  set C : ℕ → Set 𝕊 := fun p => blimsup X at_top fun n => 0 < n ∧ p ^ 2 ∣ n
  have hA₀ : ∀ p, MeasurableSet (A p) := fun p =>
    MeasurableSet.measurableSet_blimsup fun n hn => is_open_thickening.measurable_set
  have hB₀ : ∀ p, MeasurableSet (B p) := fun p =>
    MeasurableSet.measurableSet_blimsup fun n hn => is_open_thickening.measurable_set
  have hE₀ : null_measurable_set E μ :=
    by
    refine'
      (MeasurableSet.measurableSet_blimsup fun n hn => IsOpen.measurableSet _).NullMeasurableSet
    exact is_open_thickening
  have hE₁ : ∀ p, E = A p ∪ B p ∪ C p := by
    intro p
    simp only [E, addWellApproximable, ← blimsup_or_eq_sup, ← and_or_left, ← sup_eq_union, sq]
    congr
    refine' funext fun n => propext <| iff_self_and.mpr fun hn => _
    -- `tauto` can finish from here but unfortunately it's very slow.
    simp only [(em (p ∣ n)).symm, (em (p * p ∣ n)).symm, or_and_left, or_true_iff, true_and_iff,
      or_assoc']
  have hE₂ : ∀ p : Nat.Primes, A p =ᵐ[μ] (∅ : Set 𝕊) ∧ B p =ᵐ[μ] (∅ : Set 𝕊) → E =ᵐ[μ] C p :=
    by
    rintro p ⟨hA, hB⟩
    rw [hE₁ p]
    exact union_ae_eq_right_of_ae_eq_empty ((union_ae_eq_right_of_ae_eq_empty hA).trans hB)
  have hA : ∀ p : Nat.Primes, A p =ᵐ[μ] (∅ : Set 𝕊) ∨ A p =ᵐ[μ] univ :=
    by
    rintro ⟨p, hp⟩
    let f : 𝕊 → 𝕊 := fun y => (p : ℕ) • y
    suffices
      f '' A p ⊆ blimsup (fun n => approxAddOrderOf 𝕊 n (p * δ n)) at_top fun n => 0 < n ∧ p∤n
      by
      apply (ergodic_nsmul hp.one_lt).ae_empty_or_univ_of_image_ae_le (hA₀ p)
      apply (HasSubset.Subset.eventuallyLE this).congr eventually_eq.rfl
      exact
        blimsup_thickening_mul_ae_eq μ (fun n => 0 < n ∧ p∤n) (fun n => { y | addOrderOf y = n })
          (nat.cast_pos.mpr hp.pos) _ hδ
    refine' (SupₛHom.setImage f).apply_blimsup_le.trans (mono_blimsup fun n hn => _)
    replace hn := nat.coprime_comm.mp (hp.coprime_iff_not_dvd.2 hn.2)
    exact approxAddOrderOf.image_nsmul_subset_of_coprime (δ n) hp.pos hn
  have hB : ∀ p : Nat.Primes, B p =ᵐ[μ] (∅ : Set 𝕊) ∨ B p =ᵐ[μ] univ :=
    by
    rintro ⟨p, hp⟩
    let x := u ⟨p, hp⟩
    let f : 𝕊 → 𝕊 := fun y => p • y + x
    suffices
      f '' B p ⊆ blimsup (fun n => approxAddOrderOf 𝕊 n (p * δ n)) at_top fun n => 0 < n ∧ p∣∣n
      by
      apply (ergodic_nsmul_add x hp.one_lt).ae_empty_or_univ_of_image_ae_le (hB₀ p)
      apply (HasSubset.Subset.eventuallyLE this).congr eventually_eq.rfl
      exact
        blimsup_thickening_mul_ae_eq μ (fun n => 0 < n ∧ p∣∣n) (fun n => { y | addOrderOf y = n })
          (nat.cast_pos.mpr hp.pos) _ hδ
    refine' (SupₛHom.setImage f).apply_blimsup_le.trans (mono_blimsup _)
    rintro n ⟨hn, h_div, h_ndiv⟩
    have h_cop : (addOrderOf x).coprime (n / p) :=
      by
      obtain ⟨q, rfl⟩ := h_div
      rw [hu₀, Subtype.coe_mk, hp.coprime_iff_not_dvd, q.mul_div_cancel_left hp.pos]
      exact fun contra => h_ndiv (mul_dvd_mul_left p contra)
    replace h_div : n / p * p = n := Nat.div_mul_cancel h_div
    have hf : f = (fun y => x + y) ∘ fun y => p • y :=
      by
      ext
      simp [add_comm x]
    simp_rw [comp_app]
    rw [le_eq_subset, SupₛHom.setImage_to_fun, hf, image_comp]
    have := @monotone_image 𝕊 𝕊 fun y => x + y
    specialize this (approxAddOrderOf.image_nsmul_subset (δ n) (n / p) hp.pos)
    simp only [h_div] at this⊢
    refine' this.trans _
    convert approxAddOrderOf.vadd_subset_of_coprime (p * δ n) h_cop
    simp only [hu₀, Subtype.coe_mk, h_div, mul_comm p]
  change (∀ᵐ x, x ∉ E) ∨ E ∈ volume.ae
  rw [← eventually_eq_empty, ← eventually_eq_univ]
  have hC : ∀ p : Nat.Primes, u p +ᵥ C p = C p :=
    by
    intro p
    let e := (AddAction.toPerm (u p) : Equiv.Perm 𝕊).toOrderIsoSet
    change e (C p) = C p
    rw [e.apply_blimsup, ← hu₀ p]
    exact
      blimsup_congr
        (eventually_of_forall fun n hn => approxAddOrderOf.vadd_eq_of_mul_dvd (δ n) hn.1 hn.2)
  by_cases h : ∀ p : Nat.Primes, A p =ᵐ[μ] (∅ : Set 𝕊) ∧ B p =ᵐ[μ] (∅ : Set 𝕊)
  · replace h : ∀ p : Nat.Primes, (u p +ᵥ E : Set _) =ᵐ[μ] E
    · intro p
      replace hE₂ : E =ᵐ[μ] C p := hE₂ p (h p)
      have h_qmp : MeasureTheory.Measure.QuasiMeasurePreserving ((· +ᵥ ·) (-u p)) μ μ :=
        (measure_preserving_vadd _ μ).QuasiMeasurePreserving
      refine' (h_qmp.vadd_ae_eq_of_ae_eq (u p) hE₂).trans (ae_eq_trans _ hE₂.symm)
      rw [hC]
    exact ae_empty_or_univ_of_forall_vadd_ae_eq_self hE₀ h hu
  · right
    simp only [not_forall, not_and_or] at h
    obtain ⟨p, hp⟩ := h
    rw [hE₁ p]
    cases hp
    · cases hA p
      · contradiction
      simp only [h, union_ae_eq_univ_of_ae_eq_univ_left]
    · cases hB p
      · contradiction
      simp only [h, union_ae_eq_univ_of_ae_eq_univ_left, union_ae_eq_univ_of_ae_eq_univ_right]
#align add_circle.add_well_approximable_ae_empty_or_univ AddCircle.addWellApproximable_ae_empty_or_univ

end AddCircle


/-
Copyright (c) 2020 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz

! This file was ported from Lean 3 source module data.set.constructions
! leanprover-community/mathlib commit 9003f28797c0664a49e4179487267c494477d853
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Finset.Basic

/-!
# Constructions involving sets of sets.

## Finite Intersections

We define a structure `FiniteInter` which asserts that a set `S` of subsets of `α` is
closed under finite intersections.

We define `finiteInterClosure` which, given a set `S` of subsets of `α`, is the smallest
set of subsets of `α` which is closed under finite intersections.

`finiteInterClosure S` is endowed with a term of type `FiniteInter` using
`finiteInterClosure_finiteInter`.

-/

variable {α : Type _} (S : Set (Set α))

/-- A structure encapsulating the fact that a set of sets is closed under finite intersection. -/
structure FiniteInter : Prop where
  /-- `univ_mem` states that `Set.univ` is in `S`. -/
  univ_mem : Set.univ ∈ S
  /-- `inter_mem` states that any two intersections of sets in `S` is also in `S`. -/
  inter_mem : ∀ ⦃s⦄, s ∈ S → ∀ ⦃t⦄, t ∈ S → s ∩ t ∈ S
#align has_finite_inter FiniteInter

namespace FiniteInter

/-- The smallest set of sets containing `S` which is closed under finite intersections. -/
inductive finiteInterClosure : Set (Set α)
  | basic {s} : s ∈ S → finiteInterClosure s
  | univ : finiteInterClosure Set.univ
  | inter {s t} : finiteInterClosure s → finiteInterClosure t → finiteInterClosure (s ∩ t)
#align has_finite_inter.finite_inter_closure FiniteInter.finiteInterClosure

theorem finiteInterClosure_finiteInter : FiniteInter (finiteInterClosure S) :=
  { univ_mem := finiteInterClosure.univ
    inter_mem := fun _ h _ => finiteInterClosure.inter h }
#align has_finite_inter.finite_inter_closure_has_finite_inter FiniteInter.finiteInterClosure_finiteInter

variable {S}

theorem finiteInter_mem (cond : FiniteInter S) (F : Finset (Set α)) :
    ↑F ⊆ S → ⋂₀ (↑F : Set (Set α)) ∈ S := by
  classical
    refine' Finset.induction_on F (fun _ => _) _
    · simp [cond.univ_mem]
    · intro a s _ h1 h2
      suffices a ∩ ⋂₀ ↑s ∈ S by simpa
      exact
        cond.inter_mem (h2 (Finset.mem_insert_self a s))
          (h1 fun x hx => h2 <| Finset.mem_insert_of_mem hx)
#align has_finite_inter.finite_inter_mem FiniteInter.finiteInter_mem

theorem finiteInterClosure_insert {A : Set α} (cond : FiniteInter S) (P)
    (H : P ∈ finiteInterClosure (insert A S)) : P ∈ S ∨ ∃ Q ∈ S, P = A ∩ Q := by
  induction' H with S h T1 T2 _ _ h1 h2
  · cases h
    · exact Or.inr ⟨Set.univ, cond.univ_mem, by simpa⟩
    · exact Or.inl (by assumption)
  · exact Or.inl cond.univ_mem
  · rcases h1 with (h | ⟨Q, hQ, rfl⟩) <;> rcases h2 with (i | ⟨R, hR, rfl⟩)
    · exact Or.inl (cond.inter_mem h i)
    · exact
        Or.inr ⟨T1 ∩ R, cond.inter_mem h hR, by simp only [← Set.inter_assoc, Set.inter_comm _ A]⟩
    · exact Or.inr ⟨Q ∩ T2, cond.inter_mem hQ i, by simp only [Set.inter_assoc]⟩
    · exact
        Or.inr
          ⟨Q ∩ R, cond.inter_mem hQ hR, by
            ext x
            constructor <;> simp (config := { contextual := true })⟩
#align has_finite_inter.finite_inter_closure_insert FiniteInter.finiteInterClosure_insert

end FiniteInter


-- Las_clases_de_equivalencia_contienen_a_las_clases_de_equivalencia_de_sus_elementos.lean
-- Las clases de equivalencia contienen a las clases de equivalencia de sus elementos
-- José A. Alonso Jiménez
-- Sevilla, 3 de octubre de 2021
-- ---------------------------------------------------------------------

-- ---------------------------------------------------------------------
-- Este ejercicio es el 4º de una serie, que comenzó con el [ejercicio
-- del 30 de septiembre](https://bit.ly/2YfsvBZ), cuyo objetivo es
-- demostrar que el tipo de las particiones de un conjunto `X` es
-- isomorfo al tipo de las relaciones de equivalencia sobre `X`.
--
-- El ejercicio consiste en demostrar que si C es una clase de
-- equivalencia y a ∈ C, entonces la clase de equivalencia de a está
-- contenida en C.
-- ---------------------------------------------------------------------

import tactic

variable {A : Type}
variable (R : A → A → Prop)

def clase (a : A) :=
  {b : A | R b a}

-- Se usará el siguiente lema auxiliar
lemma pertenece_clase_syss
  {a b : A}
  : b ∈ clase R a ↔ R b a :=
by refl

-- 1ª demostración
example
  {hR: equivalence R}
  {a b : A}
  : a ∈ clase R b → clase R a ⊆ clase R b :=
begin
  intro hab,
  intros z hza,
  rw pertenece_clase_syss at hab hza ⊢,
  obtain ⟨-, -, htrans⟩ := hR,
  exact htrans hza hab,
end

-- 2ª demostración
example
  {hR: equivalence R}
  {a b : A}
  : a ∈ clase R b → clase R a ⊆ clase R b :=
begin
  intros hab z hza,
  exact hR.2.2 hza hab,
end

-- 3ª demostración
lemma subclase_si_pertenece
  {hR: equivalence R}
  {a b : A}
  : a ∈ clase R b → clase R a ⊆ clase R b :=
λ hab z hza, hR.2.2 hza hab


/-
Copyright (c) 2020 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import logic.function.conjugate
import tactic.alias

/-!
# Iterations of a function

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

In this file we prove simple properties of `nat.iterate f n` a.k.a. `f^[n]`:

* `iterate_zero`, `iterate_succ`, `iterate_succ'`, `iterate_add`, `iterate_mul`:
  formulas for `f^[0]`, `f^[n+1]` (two versions), `f^[n+m]`, and `f^[n*m]`;

* `iterate_id` : `id^[n]=id`;

* `injective.iterate`, `surjective.iterate`, `bijective.iterate` :
  iterates of an injective/surjective/bijective function belong to the same class;

* `left_inverse.iterate`, `right_inverse.iterate`, `commute.iterate_left`, `commute.iterate_right`,
  `commute.iterate_iterate`:
  some properties of pairs of functions survive under iterations

* `iterate_fixed`, `semiconj.iterate_*`, `semiconj₂.iterate`:
  if `f` fixes a point (resp., semiconjugates unary/binary operarations), then so does `f^[n]`.

-/

universes u v

variables {α : Type u} {β : Type v}
namespace function

variable (f : α → α)

@[simp] theorem iterate_zero : f^[0] = id := rfl

theorem iterate_zero_apply (x : α) : f^[0] x = x := rfl

@[simp] theorem iterate_succ (n : ℕ) : f^[n.succ] = (f^[n]) ∘ f := rfl

theorem iterate_succ_apply (n : ℕ) (x : α) : f^[n.succ] x = (f^[n]) (f x) := rfl

@[simp] theorem iterate_id (n : ℕ) : (id : α → α)^[n] = id :=
nat.rec_on n rfl $ λ n ihn, by rw [iterate_succ, ihn, comp.left_id]

theorem iterate_add : ∀ (m n : ℕ), f^[m + n] = (f^[m]) ∘ (f^[n])
| m 0 := rfl
| m (nat.succ n) := by rw [nat.add_succ, iterate_succ, iterate_succ, iterate_add]

theorem iterate_add_apply (m n : ℕ) (x : α) : f^[m + n] x = (f^[m] (f^[n] x)) :=
by rw iterate_add

@[simp] theorem iterate_one : f^[1] = f := funext $ λ a, rfl

lemma iterate_mul (m : ℕ) : ∀ n, f^[m * n] = (f^[m]^[n])
| 0 := by simp only [nat.mul_zero, iterate_zero]
| (n + 1) := by simp only [nat.mul_succ, nat.mul_one, iterate_one, iterate_add, iterate_mul n]

variable {f}

theorem iterate_fixed {x} (h : f x = x) (n : ℕ) : f^[n] x = x :=
nat.rec_on n rfl $ λ n ihn, by rw [iterate_succ_apply, h, ihn]

theorem injective.iterate (Hinj : injective f) (n : ℕ) : injective (f^[n]) :=
nat.rec_on n injective_id $ λ n ihn, ihn.comp Hinj

theorem surjective.iterate (Hsurj : surjective f) (n : ℕ) : surjective (f^[n]) :=
nat.rec_on n surjective_id $ λ n ihn, ihn.comp Hsurj

theorem bijective.iterate (Hbij : bijective f) (n : ℕ) : bijective (f^[n]) :=
⟨Hbij.1.iterate n, Hbij.2.iterate n⟩

namespace semiconj

lemma iterate_right {f : α → β} {ga : α → α} {gb : β → β} (h : semiconj f ga gb) (n : ℕ) :
  semiconj f (ga^[n]) (gb^[n]) :=
nat.rec_on n id_right $ λ n ihn, ihn.comp_right h

lemma iterate_left {g : ℕ → α → α} (H : ∀ n, semiconj f (g n) (g $ n + 1)) (n k : ℕ) :
  semiconj (f^[n]) (g k) (g $ n + k) :=
begin
  induction n with n ihn generalizing k,
  { rw [nat.zero_add], exact id_left },
  { rw [nat.succ_eq_add_one, nat.add_right_comm, nat.add_assoc],
    exact (H k).comp_left (ihn (k + 1)) }
end

end semiconj

namespace commute

variable {g : α → α}

lemma iterate_right (h : commute f g) (n : ℕ) : commute f (g^[n]) := h.iterate_right n

lemma iterate_left (h : commute f g) (n : ℕ) : commute (f^[n]) g := (h.symm.iterate_right n).symm

lemma iterate_iterate (h : commute f g) (m n : ℕ) : commute (f^[m]) (g^[n]) :=
(h.iterate_left m).iterate_right n

lemma iterate_eq_of_map_eq (h : commute f g) (n : ℕ) {x} (hx : f x = g x) : f^[n] x = (g^[n]) x :=
nat.rec_on n rfl $ λ n ihn,
by simp only [iterate_succ_apply, hx, (h.iterate_left n).eq, ihn, ((refl g).iterate_right n).eq]

lemma comp_iterate (h : commute f g) (n : ℕ) : (f ∘ g)^[n] = (f^[n]) ∘ (g^[n]) :=
begin
  induction n with n ihn, { refl },
  funext x,
  simp only [ihn, (h.iterate_right n).eq, iterate_succ, comp_app]
end

variable (f)

lemma iterate_self (n : ℕ) : commute (f^[n]) f := (refl f).iterate_left n

lemma self_iterate (n : ℕ) : commute f (f^[n]) := (refl f).iterate_right n

lemma iterate_iterate_self (m n : ℕ) : commute (f^[m]) (f^[n]) := (refl f).iterate_iterate m n

end commute

lemma semiconj₂.iterate {f : α → α} {op : α → α → α} (hf : semiconj₂ f op op) (n : ℕ) :
  semiconj₂ (f^[n]) op op :=
nat.rec_on n (semiconj₂.id_left op) (λ n ihn, ihn.comp hf)

variable (f)

theorem iterate_succ' (n : ℕ) : f^[n.succ] = f ∘ (f^[n]) :=
by rw [iterate_succ, (commute.self_iterate f n).comp_eq]

theorem iterate_succ_apply' (n : ℕ) (x : α) : f^[n.succ] x = f (f^[n] x) :=
by rw [iterate_succ']

theorem iterate_pred_comp_of_pos {n : ℕ} (hn : 0 < n) : f^[n.pred] ∘ f = (f^[n]) :=
by rw [← iterate_succ, nat.succ_pred_eq_of_pos hn]

theorem comp_iterate_pred_of_pos {n : ℕ} (hn : 0 < n) : f ∘ (f^[n.pred]) = (f^[n]) :=
by rw [← iterate_succ', nat.succ_pred_eq_of_pos hn]

/-- A recursor for the iterate of a function. -/
def iterate.rec (p : α → Sort*) {f : α → α} (h : ∀ a, p a → p (f a)) {a : α} (ha : p a) (n : ℕ) :
  p (f^[n] a) :=
nat.rec ha (λ m, by { rw iterate_succ', exact h _ }) n

lemma iterate.rec_zero (p : α → Sort*) {f : α → α} (h : ∀ a, p a → p (f a)) {a : α} (ha : p a) :
  iterate.rec p h ha 0 = ha :=
rfl

variables {f} {m n : ℕ} {a : α}

theorem left_inverse.iterate {g : α → α} (hg : left_inverse g f) (n : ℕ) :
  left_inverse (g^[n]) (f^[n]) :=
nat.rec_on n (λ _, rfl) $ λ n ihn, by { rw [iterate_succ', iterate_succ], exact ihn.comp hg }

theorem right_inverse.iterate {g : α → α} (hg : right_inverse g f) (n : ℕ) :
  right_inverse (g^[n]) (f^[n]) :=
hg.iterate n

lemma iterate_comm (f : α → α) (m n : ℕ) : f^[n]^[m] = (f^[m]^[n]) :=
(iterate_mul _ _ _).symm.trans (eq.trans (by rw nat.mul_comm) (iterate_mul _ _ _))

lemma iterate_commute (m n : ℕ) : commute (λ f : α → α, f^[m]) (λ f, f^[n]) :=
λ f, iterate_comm f m n

alias iterate_add_eq_iterate ↔ iterate_cancel_of_add _

lemma iterate_cancel (hf : injective f) (ha : f^[m] a = (f^[n] a)) : f^[m - n] a = a :=
begin
  cases le_total m n,
  { simp [nat.sub_eq_zero_of_le h] },
  { exact iterate_cancel_of_add hf (by rwa nat.sub_add_cancel h) }
end

end function

namespace list
open function

theorem foldl_const (f : α → α) (a : α) (l : list β) : l.foldl (λ b _, f b) a = (f^[l.length]) a :=
begin
  induction l with b l H generalizing a,
  { refl },
  { rw [length_cons, foldl, iterate_succ_apply, H] }
end

theorem foldr_const (f : β → β) (b : β) : Π l : list α, l.foldr (λ _, f) b = (f^[l.length]) b
| []     := rfl
| (a::l) := by rw [length_cons, foldr, foldr_const l, iterate_succ_apply']

end list


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Jeremy Avigad, Mario Carneiro

List permutations.
-/
import data.list.basic

namespace list
universe variables uu vv
variables {α : Type uu} {β : Type vv}

/-- `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 [] []
| skip  : Π (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

infix ~ := perm

@[refl] protected theorem perm.refl : ∀ (l : list α), l ~ l
| []      := perm.nil
| (x::xs) := skip x (perm.refl xs)

@[symm] protected theorem perm.symm {l₁ l₂ : list α} (p : l₁ ~ l₂) : l₂ ~ l₁ :=
perm.rec_on p
  perm.nil
  (λ x l₁ l₂ p₁ r₁, skip x r₁)
  (λ x y l, swap y x l)
  (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, trans r₂ r₁)

theorem perm.swap'
  (x y : α) {l₁ l₂ : list α} (p : l₁ ~ l₂) : y::x::l₁ ~ x::y::l₂ :=
trans (swap _ _ _) (skip _ $ skip _ p)

attribute [trans] perm.trans

theorem perm.eqv (α : Type) : equivalence (@perm α) :=
mk_equivalence (@perm α) (@perm.refl α) (@perm.symm α) (@perm.trans α)

instance is_setoid (α : Type) : setoid (list α) :=
setoid.mk (@perm α) (perm.eqv α)

theorem perm_subset {l₁ l₂ : list α} (p : l₁ ~ l₂) : l₁ ⊆ l₂ :=
λ a, perm.rec_on p
  (λ h, h)
  (λ x l₁ l₂ p₁ r₁ i, or.elim i
    (λ ax, by simp [ax])
    (λ al₁, or.inr (r₁ al₁)))
  (λ x y l ayxl, or.elim ayxl
    (λ ay, by simp [ay])
    (λ axl, or.elim axl
      (λ ax, by simp [ax])
      (λ al, or.inr (or.inr al))))
  (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂ ainl₁, r₂ (r₁ ainl₁))

theorem mem_of_perm {a : α} {l₁ l₂ : list α} (h : l₁ ~ l₂) : a ∈ l₁ ↔ a ∈ l₂ :=
iff.intro (λ m, perm_subset h m) (λ m, perm_subset h.symm m)

theorem perm_app_left {l₁ l₂ : list α} (t₁ : list α) (p : l₁ ~ l₂) : l₁++t₁ ~ l₂++t₁ :=
perm.rec_on p
  (perm.refl ([] ++ t₁))
  (λ x l₁ l₂ p₁ r₁, skip x r₁)
  (λ x y l, swap x y _)
  (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, trans r₁ r₂)

theorem perm_app_right {t₁ t₂ : list α} : ∀ (l : list α), t₁ ~ t₂ → l++t₁ ~ l++t₂
| []      p := p
| (x::xs) p := skip x (perm_app_right xs p)

theorem perm_app {l₁ l₂ t₁ t₂ : list α} (p₁ : l₁ ~ l₂) (p₂ : t₁ ~ t₂) : l₁++t₁ ~ l₂++t₂ :=
trans (perm_app_left t₁ p₁) (perm_app_right l₂ p₂)

theorem perm_app_cons (a : α) {h₁ h₂ t₁ t₂ : list α}
  (p₁ : h₁ ~ h₂) (p₂ : t₁ ~ t₂) : h₁ ++ a::t₁ ~ h₂ ++ a::t₂ :=
perm_app p₁ (skip a p₂)

@[simp] theorem perm_middle {a : α} : ∀ {l₁ l₂ : list α}, l₁++a::l₂ ~ a::(l₁++l₂)
| []      l₂ := perm.refl _
| (b::l₁) l₂ := (skip b (@perm_middle l₁ l₂)).trans (swap a b _)

@[simp] theorem perm_cons_app (a : α) (l : list α) : l ++ [a] ~ a::l :=
by simpa using @perm_middle _ a l []

@[simp] theorem perm_app_comm : ∀ {l₁ l₂ : list α}, (l₁++l₂) ~ (l₂++l₁)
| []     l₂ := by simp
| (a::t) l₂ := (skip a perm_app_comm).trans perm_middle.symm

theorem concat_perm (l : list α) (a : α) : concat l a ~ a :: l :=
by simp

theorem perm_length {l₁ l₂ : list α} (p : l₁ ~ l₂) : length l₁ = length l₂ :=
perm.rec_on p
  rfl
  (λ x l₁ l₂ p r, by simp[r])
  (λ x y l, by simp)
  (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, eq.trans r₁ r₂)

theorem eq_nil_of_perm_nil {l₁ : list α} (p : [] ~ l₁) : l₁ = [] :=
eq_nil_of_length_eq_zero (perm_length p).symm

theorem perm_nil {l₁ : list α} : l₁ ~ [] ↔ l₁ = [] :=
⟨λ p, eq_nil_of_perm_nil p.symm, λ e, e ▸ perm.refl _⟩

theorem not_perm_nil_cons (x : α) (l : list α) : ¬ [] ~ x::l
| p := by injection eq_nil_of_perm_nil p

theorem eq_singleton_of_perm {a b : α} (p : [a] ~ [b]) : a = b :=
by simpa using perm_subset p (by simp)

theorem eq_singleton_of_perm_inv {a : α} {l : list α} (p : [a] ~ l) : l = [a] :=
match l, show 1 = _, from perm_length p, p with
| [a'], rfl, p := by rw [eq_singleton_of_perm p]
end

@[simp] theorem reverse_perm : ∀ (l : list α), reverse l ~ l
| []     := perm.nil
| (a::l) := by rw reverse_cons; exact
  (perm_cons_app _ _).trans (skip a $ reverse_perm l)

theorem perm_cons_app_cons {l l₁ l₂ : list α} (a : α) (p : l ~ l₁++l₂) : a::l ~ l₁++(a::l₂) :=
trans (skip a p) perm_middle.symm

@[simp] theorem perm_repeat {a : α} {n : ℕ} {l : list α} : repeat a n ~ l ↔ repeat a n = l :=
⟨λ p, (eq_repeat.2 $ by exact
  ⟨by simpa using (perm_length p).symm,
   λ b m, eq_of_mem_repeat $ perm_subset p.symm m⟩).symm,
 λ h, h ▸ perm.refl _⟩

theorem perm_erase [decidable_eq α] {a : α} {l : list α} (h : a ∈ l) : l ~ a :: l.erase a :=
let ⟨l₁, l₂, _, e₁, e₂⟩ := exists_erase_eq h in
e₂.symm ▸ e₁.symm ▸ perm_middle

@[elab_as_eliminator] theorem perm_induction_on
    {P : list α → list α → Prop} {l₁ l₂ : list α} (p : l₁ ~ l₂)
    (h₁ : P [] [])
    (h₂ : ∀ x l₁ l₂, l₁ ~ l₂ → P l₁ l₂ → P (x::l₁) (x::l₂))
    (h₃ : ∀ x y l₁ l₂, l₁ ~ l₂ → P l₁ l₂ → P (y::x::l₁) (x::y::l₂))
    (h₄ : ∀ l₁ l₂ l₃, l₁ ~ l₂ → l₂ ~ l₃ → P l₁ l₂ → P l₂ l₃ → P l₁ l₃) :
  P l₁ l₂ :=
have P_refl : ∀ l, P l l, from
  assume l,
  list.rec_on l h₁ (λ x xs ih, h₂ x xs xs (perm.refl xs) ih),
perm.rec_on p h₁ h₂ (λ x y l, h₃ x y l l (perm.refl l) (P_refl l)) h₄

@[congr] theorem perm_filter_map (f : α → option β) {l₁ l₂ : list α} (p : l₁ ~ l₂) :
  filter_map f l₁ ~ filter_map f l₂ :=
begin
  induction p with x l₂ l₂' p IH  x y l₂  l₂ m₂ r₂ p₁ p₂ IH₁ IH₂,
  { simp },
  { simp [filter_map], cases f x with a; simp [filter_map, IH, skip] },
  { simp [filter_map], cases f x with a; cases f y with b; simp [filter_map, swap] },
  { exact IH₁.trans IH₂ }
end

@[congr] theorem perm_map (f : α → β) {l₁ l₂ : list α} (p : l₁ ~ l₂) :
  map f l₁ ~ map f l₂ :=
by rw ← filter_map_eq_map; apply perm_filter_map _ p

theorem perm_pmap {p : α → Prop} (f : Π a, p a → β)
  {l₁ l₂ : list α} (p : l₁ ~ l₂) {H₁ H₂} : pmap f l₁ H₁ ~ pmap f l₂ H₂ :=
begin
  induction p with x l₂ l₂' p IH  x y l₂  l₂ m₂ r₂ p₁ p₂ IH₁ IH₂,
  { simp },
  { simp [IH, skip] },
  { simp [swap] },
  { refine IH₁.trans IH₂,
    exact λ a m, H₂ a (perm_subset p₂ m) }
end

theorem perm_filter (p : α → Prop) [decidable_pred p]
  {l₁ l₂ : list α} (s : l₁ ~ l₂) : filter p l₁ ~ filter p l₂ :=
by rw ← filter_map_eq_filter; apply perm_filter_map _ s

theorem exists_perm_sublist {l₁ l₂ l₂' : list α}
  (s : l₁ <+ l₂) (p : l₂ ~ l₂') : ∃ l₁' ~ l₁, l₁' <+ l₂' :=
begin
  induction p with x l₂ l₂' p IH  x y l₂  l₂ m₂ r₂ p₁ p₂ IH₁ IH₂ generalizing l₁ s,
  { exact ⟨[], eq_nil_of_sublist_nil s ▸ perm.refl _, nil_sublist _⟩ },
  { cases s with _ _ _ s l₁ _ _ s,
    { exact let ⟨l₁', p', s'⟩ := IH s in ⟨l₁', p', s'.cons _ _ _⟩ },
    { exact let ⟨l₁', p', s'⟩ := IH s in ⟨x::l₁', skip x p', s'.cons2 _ _ _⟩ } },
  { cases s with _ _ _ s l₁ _ _ s; cases s with _ _ _ s l₁ _ _ s,
    { exact ⟨l₁, perm.refl _, (s.cons _ _ _).cons _ _ _⟩ },
    { exact ⟨x::l₁, perm.refl _, (s.cons _ _ _).cons2 _ _ _⟩ },
    { exact ⟨y::l₁, perm.refl _, (s.cons2 _ _ _).cons _ _ _⟩ },
    { exact ⟨x::y::l₁, perm.swap _ _ _, (s.cons2 _ _ _).cons2 _ _ _⟩ } },
  { exact let ⟨m₁, pm, sm⟩ := IH₁ s, ⟨r₁, pr, sr⟩ := IH₂ sm in
          ⟨r₁, pr.trans pm, sr⟩ }
end

section rel
open relator
variables {γ : Type*} {δ : Type*} {r : α → β → Prop} {p : γ → δ → Prop}

local infixr ` ∘r ` : 80 := relation.comp

lemma perm_comp_perm : (perm ∘r perm : list α → list α → Prop) = perm :=
begin
  funext a c, apply propext,
  split,
  { exact assume ⟨b, hab, hba⟩, perm.trans hab hba },
  { exact assume h, ⟨a, perm.refl a, h⟩ }
end

lemma perm_comp_forall₂ {l u v} (hlu : perm l u) (huv : forall₂ r u v) : (forall₂ r ∘r perm) l v :=
begin
  induction hlu generalizing v,
  case perm.nil { cases huv, exact ⟨[], forall₂.nil, perm.nil⟩ },
  case perm.skip : a l u hlu ih {
    cases huv with _ b _ v hab huv',
    rcases ih huv' with ⟨l₂, h₁₂, h₂₃⟩,
    exact ⟨b::l₂, forall₂.cons hab h₁₂, perm.skip _ h₂₃⟩
  },
  case perm.swap : a₁ a₂ l₁ l₂ h₂₃ {
    cases h₂₃ with _ b₁ _ l₂ h₁ hr_₂₃,
    cases hr_₂₃ with _ b₂ _ l₂ h₂ h₁₂,
    exact ⟨b₂::b₁::l₂, forall₂.cons h₂ (forall₂.cons h₁ h₁₂), perm.swap _ _ _⟩
  },
  case perm.trans : la₁ la₂ la₃ _ _ ih₁ ih₂ {
    rcases ih₂ huv with ⟨lb₂, hab₂, h₂₃⟩,
    rcases ih₁ hab₂ with ⟨lb₁, hab₁, h₁₂⟩,
    exact ⟨lb₁, hab₁, perm.trans h₁₂ h₂₃⟩
  }
end

lemma forall₂_comp_perm_eq_perm_comp_forall₂ : forall₂ r ∘r perm = perm ∘r forall₂ r :=
begin
  funext l₁ l₃, apply propext,
  split,
  { assume h, rcases h with ⟨l₂, h₁₂, h₂₃⟩,
    have : forall₂ (flip r) l₂ l₁, from h₁₂.flip ,
    rcases perm_comp_forall₂ h₂₃.symm this with ⟨l', h₁, h₂⟩,
    exact ⟨l', h₂.symm, h₁.flip⟩ },
  { exact assume ⟨l₂, h₁₂, h₂₃⟩, perm_comp_forall₂ h₁₂ h₂₃ }
end

lemma rel_perm_imp (hr : right_unique r) : (forall₂ r ⇒ forall₂ r ⇒ implies) perm perm :=
assume a b h₁ c d h₂ h,
have (flip (forall₂ r) ∘r (perm ∘r forall₂ r)) b d, from ⟨a, h₁, c, h, h₂⟩,
have ((flip (forall₂ r) ∘r forall₂ r) ∘r perm) b d,
  by rwa [← forall₂_comp_perm_eq_perm_comp_forall₂, ← relation.comp_assoc] at this,
let ⟨b', ⟨c', hbc, hcb⟩, hbd⟩ := this in
have b' = b, from right_unique_forall₂ @hr hcb hbc,
this ▸ hbd

lemma rel_perm (hr : bi_unique r) : (forall₂ r ⇒ forall₂ r ⇒ (↔)) perm perm :=
assume a b hab c d hcd, iff.intro
  (rel_perm_imp hr.2 hab hcd)
  (rel_perm_imp (assume a b c, left_unique_flip hr.1) hab.flip hcd.flip)

end rel

section subperm

/-- `subperm l₁ l₂`, denoted `l₁ <+~ l₂`, means that `l₁` is a sublist of
  a permutation of `l₂`. This is an analogue of `l₁ ⊆ l₂` which respects
  multiplicities of elements, and is used for the `≤` relation on multisets. -/
def subperm (l₁ l₂ : list α) : Prop := ∃ l ~ l₁, l <+ l₂

infix ` <+~ `:50 := subperm

theorem perm.subperm_left {l l₁ l₂ : list α} (p : l₁ ~ l₂) : l <+~ l₁ ↔ l <+~ l₂ :=
suffices ∀ {l₁ l₂ : list α}, l₁ ~ l₂ → l <+~ l₁ → l <+~ l₂,
from ⟨this p, this p.symm⟩,
λ l₁ l₂ p ⟨u, pu, su⟩,
  let ⟨v, pv, sv⟩ := exists_perm_sublist su p in
  ⟨v, pv.trans pu, sv⟩

theorem perm.subperm_right {l₁ l₂ l : list α} (p : l₁ ~ l₂) : l₁ <+~ l ↔ l₂ <+~ l :=
⟨λ ⟨u, pu, su⟩, ⟨u, pu.trans p, su⟩,
 λ ⟨u, pu, su⟩, ⟨u, pu.trans p.symm, su⟩⟩

theorem subperm_of_sublist {l₁ l₂ : list α} (s : l₁ <+ l₂) : l₁ <+~ l₂ :=
⟨l₁, perm.refl _, s⟩

theorem subperm_of_perm {l₁ l₂ : list α} (p : l₁ ~ l₂) : l₁ <+~ l₂ :=
⟨l₂, p.symm, sublist.refl _⟩

theorem subperm.refl (l : list α) : l <+~ l := subperm_of_perm (perm.refl _)

theorem subperm.trans {l₁ l₂ l₃ : list α} : l₁ <+~ l₂ → l₂ <+~ l₃ → l₁ <+~ l₃
| s ⟨l₂', p₂, s₂⟩ :=
  let ⟨l₁', p₁, s₁⟩ := p₂.subperm_left.2 s in ⟨l₁', p₁, s₁.trans s₂⟩

theorem length_le_of_subperm {l₁ l₂ : list α} : l₁ <+~ l₂ → length l₁ ≤ length l₂
| ⟨l, p, s⟩ := perm_length p ▸ length_le_of_sublist s

theorem subperm.perm_of_length_le {l₁ l₂ : list α} : l₁ <+~ l₂ → length l₂ ≤ length l₁ → l₁ ~ l₂
| ⟨l, p, s⟩ h :=
  suffices l = l₂, from this ▸ p.symm,
  eq_of_sublist_of_length_le s $ perm_length p.symm ▸ h

theorem subperm.antisymm {l₁ l₂ : list α} (h₁ : l₁ <+~ l₂) (h₂ : l₂ <+~ l₁) : l₁ ~ l₂ :=
h₁.perm_of_length_le (length_le_of_subperm h₂)

theorem subset_of_subperm {l₁ l₂ : list α} : l₁ <+~ l₂ → l₁ ⊆ l₂
| ⟨l, p, s⟩ := subset.trans (perm_subset p.symm) (subset_of_sublist s)

end subperm

theorem exists_perm_append_of_sublist : ∀ {l₁ l₂ : list α}, l₁ <+ l₂ → ∃ l, l₂ ~ l₁ ++ l
| ._ ._ sublist.slnil            := ⟨nil, perm.refl _⟩
| ._ ._ (sublist.cons l₁ l₂ a s) :=
  let ⟨l, p⟩ := exists_perm_append_of_sublist s in
  ⟨a::l, (skip a p).trans perm_middle.symm⟩
| ._ ._ (sublist.cons2 l₁ l₂ a s) :=
  let ⟨l, p⟩ := exists_perm_append_of_sublist s in
  ⟨l, skip a p⟩

theorem perm_countp (p : α → Prop) [decidable_pred p]
  {l₁ l₂ : list α} (s : l₁ ~ l₂) : countp p l₁ = countp p l₂ :=
by rw [countp_eq_length_filter, countp_eq_length_filter];
   exact perm_length (perm_filter _ s)

theorem countp_le_of_subperm (p : α → Prop) [decidable_pred p]
  {l₁ l₂ : list α} : l₁ <+~ l₂ → countp p l₁ ≤ countp p l₂
| ⟨l, p', s⟩ := perm_countp p p' ▸ countp_le_of_sublist s

theorem perm_count [decidable_eq α] {l₁ l₂ : list α}
  (p : l₁ ~ l₂) (a) : count a l₁ = count a l₂ :=
perm_countp _ p

theorem count_le_of_subperm [decidable_eq α] {l₁ l₂ : list α}
  (s : l₁ <+~ l₂) (a) : count a l₁ ≤ count a l₂ :=
countp_le_of_subperm _ s

theorem foldl_eq_of_perm {f : β → α → β} {l₁ l₂ : list α} (rcomm : right_commutative f) (p : l₁ ~ l₂) :
  ∀ b, foldl f b l₁ = foldl f b l₂ :=
perm_induction_on p
  (λ b, rfl)
  (λ x t₁ t₂ p r b, r (f b x))
  (λ x y t₁ t₂ p r b, by simp; rw rcomm; exact r (f (f b x) y))
  (λ t₁ t₂ t₃ p₁ p₂ r₁ r₂ b, eq.trans (r₁ b) (r₂ b))

theorem foldr_eq_of_perm {f : α → β → β} {l₁ l₂ : list α} (lcomm : left_commutative f) (p : l₁ ~ l₂) :
  ∀ b, foldr f b l₁ = foldr f b l₂ :=
perm_induction_on p
  (λ b, rfl)
  (λ x t₁ t₂ p r b, by simp; rw [r b])
  (λ x y t₁ t₂ p r b, by simp; rw [lcomm, r b])
  (λ t₁ t₂ t₃ p₁ p₂ r₁ r₂ a, eq.trans (r₁ a) (r₂ a))

lemma rec_heq_of_perm {β : list α → Sort*} {f : Πa l, β l → β (a::l)} {b : β []} {l l' : list α}
  (hl : perm l l')
  (f_congr : ∀{a l l' b b'}, perm l l' → b == b' → f a l b == f a l' b')
  (f_swap : ∀{a a' l b}, f a (a'::l) (f a' l b) == f a' (a::l) (f a l b)) :
  @list.rec α β b f l == @list.rec α β b f l' :=
begin
  induction hl,
  case list.perm.nil { refl },
  case list.perm.skip : a l l' h ih { exact f_congr h ih },
  case list.perm.swap : a a' l { exact f_swap },
  case list.perm.trans : l₁ l₂ l₃ h₁ h₂ ih₁ ih₂ { exact heq.trans ih₁ ih₂ }
end

section
variables {op : α → α → α} [is_associative α op] [is_commutative α op]
local notation a * b := op a b
local notation l <*> a := foldl op a l

lemma fold_op_eq_of_perm {l₁ l₂ : list α} {a : α} (h : l₁ ~ l₂) : l₁ <*> a = l₂ <*> a :=
foldl_eq_of_perm (right_comm _ (is_commutative.comm _) (is_associative.assoc _)) h _
end

section comm_monoid
open list
variable [comm_monoid α]

@[to_additive list.sum_eq_of_perm]
lemma prod_eq_of_perm {l₁ l₂ : list α} (h : perm l₁ l₂) : prod l₁ = prod l₂ :=
by induction h; simp [*, mul_left_comm]

@[to_additive list.sum_reverse]
lemma prod_reverse (l : list α) : prod l.reverse = prod l :=
prod_eq_of_perm $ reverse_perm l

end comm_monoid

theorem perm_inv_core {a : α} {l₁ l₂ r₁ r₂ : list α} : l₁++a::r₁ ~ l₂++a::r₂ → l₁++r₁ ~ l₂++r₂ :=
begin
  generalize e₁ : l₁++a::r₁ = s₁, generalize e₂ : l₂++a::r₂ = s₂,
  intro p, revert l₁ l₂ r₁ r₂ e₁ e₂,
  refine perm_induction_on p _ (λ x t₁ t₂ p IH, _) (λ x y t₁ t₂ p IH, _) (λ t₁ t₂ t₃ p₁ p₂ IH₁ IH₂, _);
    intros l₁ l₂ r₁ r₂ e₁ e₂,
  { apply (not_mem_nil a).elim, rw ← e₁, simp },
  { cases l₁ with y l₁; cases l₂ with z l₂;
      dsimp at e₁ e₂; injections; subst x,
    { substs t₁ t₂,     exact p },
    { substs z t₁ t₂,   exact p.trans perm_middle },
    { substs y t₁ t₂,   exact perm_middle.symm.trans p },
    { substs z t₁ t₂,   exact skip y (IH rfl rfl) } },
  { rcases l₁ with _|⟨y, _|⟨z, l₁⟩⟩; rcases l₂ with _|⟨u, _|⟨v, l₂⟩⟩;
      dsimp at e₁ e₂; injections; substs x y,
    { substs r₁ r₂,     exact skip a p },
    { substs r₁ r₂,     exact skip u p },
    { substs r₁ v t₂,   exact skip u (p.trans perm_middle) },
    { substs r₁ r₂,     exact skip y p },
    { substs r₁ r₂ y u, exact skip a p },
    { substs r₁ u v t₂, exact (skip y $ p.trans perm_middle).trans (swap _ _ _) },
    { substs r₂ z t₁,   exact skip y (perm_middle.symm.trans p) },
    { substs r₂ y z t₁, exact (swap _ _ _).trans (skip u $ perm_middle.symm.trans p) },
    { substs u v t₁ t₂, exact (IH rfl rfl).swap' _ _ } },
  { substs t₁ t₃,
    have : a ∈ t₂ := perm_subset p₁ (by simp),
    rcases mem_split this with ⟨l₂, r₂, e₂⟩,
    subst t₂, exact (IH₁ rfl rfl).trans (IH₂ rfl rfl) }
end

theorem perm_cons_inv {a : α} {l₁ l₂ : list α} : a::l₁ ~ a::l₂ → l₁ ~ l₂ :=
@perm_inv_core _ _ [] [] _ _

theorem perm_cons (a : α) {l₁ l₂ : list α} : a::l₁ ~ a::l₂ ↔ l₁ ~ l₂ :=
⟨perm_cons_inv, skip a⟩

theorem perm_app_left_iff {l₁ l₂ : list α} : ∀ l, l++l₁ ~ l++l₂ ↔ l₁ ~ l₂
| []     := iff.rfl
| (a::l) := (perm_cons a).trans (perm_app_left_iff l)

theorem perm_app_right_iff {l₁ l₂ : list α} (l) : l₁++l ~ l₂++l ↔ l₁ ~ l₂ :=
⟨λ p, (perm_app_left_iff _).1 $ trans perm_app_comm $ trans p perm_app_comm,
 perm_app_left _⟩

theorem perm_option_to_list {o₁ o₂ : option α} : o₁.to_list ~ o₂.to_list ↔ o₁ = o₂ :=
begin
  refine ⟨λ p, _, λ e, e ▸ perm.refl _⟩,
  cases o₁ with a; cases o₂ with b, {refl},
  { cases (perm_length p) },
  { cases (perm_length p) },
  { exact option.mem_to_list.1 ((mem_of_perm p).2 $ by simp) }
end

theorem subperm_cons (a : α) {l₁ l₂ : list α} : a::l₁ <+~ a::l₂ ↔ l₁ <+~ l₂ :=
⟨λ ⟨l, p, s⟩, begin
  cases s with _ _ _ s' u _ _ s',
  { exact (p.subperm_left.2 $ subperm_of_sublist $ sublist_cons _ _).trans
     (subperm_of_sublist s') },
  { exact ⟨u, perm_cons_inv p, s'⟩ }
end, λ ⟨l, p, s⟩, ⟨a::l, skip a p, s.cons2 _ _ _⟩⟩

theorem cons_subperm_of_mem {a : α} {l₁ l₂ : list α} (d₁ : nodup l₁) (h₁ : a ∉ l₁) (h₂ : a ∈ l₂)
 (s : l₁ <+~ l₂) : a :: l₁ <+~ l₂ :=
begin
  rcases s with ⟨l, p, s⟩,
  induction s generalizing l₁,
  case list.sublist.slnil { cases h₂ },
  case list.sublist.cons : r₁ r₂ b s' ih {
    simp at h₂,
    cases h₂ with e m,
    { subst b, exact ⟨a::r₁, skip a p, s'.cons2 _ _ _⟩ },
    { rcases ih m d₁ h₁ p with ⟨t, p', s'⟩, exact ⟨t, p', s'.cons _ _ _⟩ } },
  case list.sublist.cons2 : r₁ r₂ b s' ih {
    have bm : b ∈ l₁ := (perm_subset p $ mem_cons_self _ _),
    have am : a ∈ r₂ := h₂.resolve_left (λ e, h₁ $ e.symm ▸ bm),
    rcases mem_split bm with ⟨t₁, t₂, rfl⟩,
    have st : t₁ ++ t₂ <+ t₁ ++ b :: t₂ := by simp,
    rcases ih am (nodup_of_sublist st d₁)
      (mt (λ x, subset_of_sublist st x) h₁)
      (perm_cons_inv $ p.trans perm_middle) with ⟨t, p', s'⟩,
    exact ⟨b::t, (skip b p').trans $ (swap _ _ _).trans (skip a perm_middle.symm), s'.cons2 _ _ _⟩ }
end

theorem subperm_app_left {l₁ l₂ : list α} : ∀ l, l++l₁ <+~ l++l₂ ↔ l₁ <+~ l₂
| []     := iff.rfl
| (a::l) := (subperm_cons a).trans (subperm_app_left l)

theorem subperm_app_right {l₁ l₂ : list α} (l) : l₁++l <+~ l₂++l ↔ l₁ <+~ l₂ :=
(perm_app_comm.subperm_left.trans perm_app_comm.subperm_right).trans (subperm_app_left l)

theorem subperm.exists_of_length_lt {l₁ l₂ : list α} :
  l₁ <+~ l₂ → length l₁ < length l₂ → ∃ a, a :: l₁ <+~ l₂
| ⟨l, p, s⟩ h :=
  suffices length l < length l₂ → ∃ (a : α), a :: l <+~ l₂, from
  (this $ perm_length p.symm ▸ h).imp (λ a, (skip a p).subperm_right.1),
  begin
    clear subperm.exists_of_length_lt p h l₁, rename l₂ u,
    induction s with l₁ l₂ a s IH _ _ b s IH; intro h,
    { cases h },
    { cases lt_or_eq_of_le (nat.le_of_lt_succ h : length l₁ ≤ length l₂) with h h,
      { exact (IH h).imp (λ a s, s.trans (subperm_of_sublist $ sublist_cons _ _)) },
      { exact ⟨a, eq_of_sublist_of_length_eq s h ▸ subperm.refl _⟩ } },
    { exact (IH $ nat.lt_of_succ_lt_succ h).imp
        (λ a s, (swap _ _ _).subperm_right.1 $ (subperm_cons _).2 s) }
  end

theorem subperm_of_subset_nodup
  {l₁ l₂ : list α} (d : nodup l₁) (H : l₁ ⊆ l₂) : l₁ <+~ l₂ :=
begin
  induction d with a l₁' h d IH,
  { exact ⟨nil, perm.nil, nil_sublist _⟩ },
  { cases forall_mem_cons.1 H with H₁ H₂,
    simp at h,
    exact cons_subperm_of_mem d h H₁ (IH H₂) }
end

theorem perm_ext {l₁ l₂ : list α} (d₁ : nodup l₁) (d₂ : nodup l₂) : l₁ ~ l₂ ↔ ∀a, a ∈ l₁ ↔ a ∈ l₂ :=
⟨λ p a, mem_of_perm p, λ H, subperm.antisymm
  (subperm_of_subset_nodup d₁ (λ a, (H a).1))
  (subperm_of_subset_nodup d₂ (λ a, (H a).2))⟩

theorem perm_ext_sublist_nodup {l₁ l₂ l : list α} (d : nodup l)
  (s₁ : l₁ <+ l) (s₂ : l₂ <+ l) : l₁ ~ l₂ ↔ l₁ = l₂ :=
⟨λ h, begin
  induction s₂ with l₂ l a s₂ IH l₂ l a s₂ IH generalizing l₁,
  { exact eq_nil_of_perm_nil h.symm },
  { simp at d,
    cases s₁ with _ _ _ s₁ l₁ _ _ s₁,
    { exact IH d.2 s₁ h },
    { apply d.1.elim,
      exact subset_of_subperm ⟨_, h.symm, s₂⟩ (mem_cons_self _ _) } },
  { simp at d,
    cases s₁ with _ _ _ s₁ l₁ _ _ s₁,
    { apply d.1.elim,
      exact subset_of_subperm ⟨_, h, s₁⟩ (mem_cons_self _ _) },
    { rw IH d.2 s₁ (perm_cons_inv h) } }
end, λ h, by rw h⟩

section
variable [decidable_eq α]

-- attribute [congr]
theorem erase_perm_erase (a : α) {l₁ l₂ : list α} (p : l₁ ~ l₂) :
  l₁.erase a ~ l₂.erase a :=
if h₁ : a ∈ l₁ then
have h₂ : a ∈ l₂, from perm_subset p h₁,
perm_cons_inv $ trans (perm_erase h₁).symm $ trans p (perm_erase h₂)
else
have h₂ : a ∉ l₂, from mt (mem_of_perm p).2 h₁,
by rw [erase_of_not_mem h₁, erase_of_not_mem h₂]; exact p

theorem erase_subperm (a : α) (l : list α) : l.erase a <+~ l :=
⟨l.erase a, perm.refl _, erase_sublist _ _⟩

theorem erase_subperm_erase {l₁ l₂ : list α} (a : α) (h : l₁ <+~ l₂) : l₁.erase a <+~ l₂.erase a :=
let ⟨l, hp, hs⟩ := h in ⟨l.erase a, erase_perm_erase _ hp, erase_sublist_erase _ hs⟩

theorem perm_diff_left {l₁ l₂ : list α} (t : list α) (h : l₁ ~ l₂) : l₁.diff t ~ l₂.diff t :=
by induction t generalizing l₁ l₂ h; simp [*, erase_perm_erase]

theorem perm_diff_right (l : list α) {t₁ t₂ : list α} (h : t₁ ~ t₂) : l.diff t₁ = l.diff t₂ :=
by induction h generalizing l; simp [*, erase_perm_erase, erase_comm]
  <|> exact (ih_1 _).trans (ih_2 _)

theorem subperm_cons_diff {a : α} : ∀ {l₁ l₂ : list α}, (a :: l₁).diff l₂ <+~ a :: l₁.diff l₂
| l₁ []      := ⟨a::l₁, by simp⟩
| l₁ (b::l₂) :=
begin
  repeat {rw diff_cons},
  by_cases heq : a = b,
  { by_cases b ∈ l₁,
    { rw perm.subperm_right, apply subperm_cons_diff,
      simp [perm_diff_left, heq, perm_erase h] },
    { simp [subperm_of_sublist, sublist.cons, h, heq] } },
  { simp [heq, subperm_cons_diff] }
end

theorem subset_cons_diff {a : α} {l₁ l₂ : list α} : (a :: l₁).diff l₂ ⊆ a :: l₁.diff l₂ :=
subset_of_subperm subperm_cons_diff

theorem perm_bag_inter_left {l₁ l₂ : list α} (t : list α) (h : l₁ ~ l₂) : l₁.bag_inter t ~ l₂.bag_inter t :=
begin
  induction h with x _ _ _ _ x y _ _ _ _ _ _ ih_1 ih_2 generalizing t, {simp},
  { by_cases x ∈ t; simp [*, skip] },
  { by_cases x = y, {simp [h]},
    by_cases xt : x ∈ t; by_cases yt : y ∈ t,
    { simp [xt, yt, mem_erase_of_ne h, mem_erase_of_ne (ne.symm h), erase_comm, swap] },
    { simp [xt, yt, mt mem_of_mem_erase, skip] },
    { simp [xt, yt, mt mem_of_mem_erase, skip] },
    { simp [xt, yt] } },
  { exact (ih_1 _).trans (ih_2 _) }
end

theorem perm_bag_inter_right (l : list α) {t₁ t₂ : list α} (p : t₁ ~ t₂) : l.bag_inter t₁ = l.bag_inter t₂ :=
begin
  induction l with a l IH generalizing t₁ t₂ p, {simp},
  by_cases a ∈ t₁,
  { simp [h, (mem_of_perm p).1 h, IH (erase_perm_erase _ p)] },
  { simp [h, mt (mem_of_perm p).2 h, IH p] }
end

theorem cons_perm_iff_perm_erase {a : α} {l₁ l₂ : list α} : a::l₁ ~ l₂ ↔ a ∈ l₂ ∧ l₁ ~ l₂.erase a :=
⟨λ h, have a ∈ l₂, from perm_subset h (mem_cons_self a l₁),
      ⟨this, perm_cons_inv $ h.trans $ perm_erase this⟩,
 λ ⟨m, h⟩, trans (skip a h) (perm_erase m).symm⟩

theorem perm_iff_count {l₁ l₂ : list α} : l₁ ~ l₂ ↔ ∀ a, count a l₁ = count a l₂ :=
⟨perm_count, λ H, begin
  induction l₁ with a l₁ IH generalizing l₂,
  { cases l₂ with b l₂, {refl},
    specialize H b, simp at H, contradiction },
  { have : a ∈ l₂ := count_pos.1 (by rw ← H; simp; apply nat.succ_pos),
    refine trans (skip a $ IH $ λ b, _) (perm_erase this).symm,
    specialize H b,
    rw perm_count (perm_erase this) at H,
    by_cases b = a; simp [h] at H ⊢; assumption }
end⟩

instance decidable_perm : ∀ (l₁ l₂ : list α), decidable (l₁ ~ l₂)
| []      []      := is_true $ perm.refl _
| []      (b::l₂) := is_false $ λ h, by have := eq_nil_of_perm_nil h; contradiction
| (a::l₁) l₂      := by haveI := decidable_perm l₁ (l₂.erase a);
                        exact decidable_of_iff' _ cons_perm_iff_perm_erase

-- @[congr]
theorem perm_erase_dup_of_perm {l₁ l₂ : list α} (p : l₁ ~ l₂) :
  erase_dup l₁ ~ erase_dup l₂ :=
perm_iff_count.2 $ λ a,
if h : a ∈ l₁
then by simp [nodup_erase_dup, h, perm_subset p h]
else by simp [h, mt (mem_of_perm p).2 h]

-- attribute [congr]
theorem perm_insert (a : α)
  {l₁ l₂ : list α} (p : l₁ ~ l₂) : insert a l₁ ~ insert a l₂ :=
if h : a ∈ l₁
then by simpa [h, perm_subset p h] using p
else by simpa [h, mt (mem_of_perm p).2 h] using skip a p

theorem perm_insert_swap (x y : α) (l : list α) :
  insert x (insert y l) ~ insert y (insert x l) :=
begin
  by_cases xl : x ∈ l; by_cases yl : y ∈ l; simp [xl, yl],
  by_cases xy : x = y, { simp [xy] },
  simp [not_mem_cons_of_ne_of_not_mem xy xl,
        not_mem_cons_of_ne_of_not_mem (ne.symm xy) yl],
  constructor
end

theorem perm_union_left {l₁ l₂ : list α} (t₁ : list α) (h : l₁ ~ l₂) : l₁ ∪ t₁ ~ l₂ ∪ t₁ :=
begin
  induction h with a _ _ _ ih _ _ _ _ _ _ _ _ ih_1 ih_2; try {simp},
  { exact perm_insert a ih },
  { apply perm_insert_swap },
  { exact ih_1.trans ih_2 }
end

theorem perm_union_right (l : list α) {t₁ t₂ : list α} (h : t₁ ~ t₂) : l ∪ t₁ ~ l ∪ t₂ :=
by induction l; simp [*, perm_insert]

-- @[congr]
theorem perm_union {l₁ l₂ t₁ t₂ : list α} (p₁ : l₁ ~ l₂) (p₂ : t₁ ~ t₂) : l₁ ∪ t₁ ~ l₂ ∪ t₂ :=
trans (perm_union_left t₁ p₁) (perm_union_right l₂ p₂)

theorem perm_inter_left {l₁ l₂ : list α} (t₁ : list α) : l₁ ~ l₂ → l₁ ∩ t₁ ~ l₂ ∩ t₁ :=
perm_filter _

theorem perm_inter_right (l : list α) {t₁ t₂ : list α} (p : t₁ ~ t₂) : l ∩ t₁ = l ∩ t₂ :=
by dsimp [(∩), list.inter]; congr; funext a; rw [mem_of_perm p]

-- @[congr]
theorem perm_inter {l₁ l₂ t₁ t₂ : list α} (p₁ : l₁ ~ l₂) (p₂ : t₁ ~ t₂) : l₁ ∩ t₁ ~ l₂ ∩ t₂ :=
perm_inter_right l₂ p₂ ▸ perm_inter_left t₁ p₁
end

theorem perm_pairwise {R : α → α → Prop} (S : symmetric R) :
  ∀ {l₁ l₂ : list α} (p : l₁ ~ l₂), pairwise R l₁ ↔ pairwise R l₂ :=
suffices ∀ {l₁ l₂}, l₁ ~ l₂ → pairwise R l₁ → pairwise R l₂, from λ l₁ l₂ p, ⟨this p, this p.symm⟩,
λ l₁ l₂ p d, begin
  induction d with a l₁ h d IH generalizing l₂,
  { rw eq_nil_of_perm_nil p, constructor },
  { have : a ∈ l₂ := perm_subset p (mem_cons_self _ _),
    rcases mem_split this with ⟨s₂, t₂, rfl⟩,
    have p' := perm_cons_inv (p.trans perm_middle),
    refine (pairwise_middle S).2 (pairwise_cons.2 ⟨λ b m, _, IH _ p'⟩),
    exact h _ (perm_subset p'.symm m) }
end

theorem perm_nodup {l₁ l₂ : list α} : l₁ ~ l₂ → (nodup l₁ ↔ nodup l₂) :=
perm_pairwise $ @ne.symm α

theorem perm_bind_left {l₁ l₂ : list α} (f : α → list β) (p : l₁ ~ l₂) :
  l₁.bind f ~ l₂.bind f :=
begin
  induction p with a l₁ l₂ p IH a b l l₁ l₂ l₃ p₁ p₂ IH₁ IH₂, {simp},
  { simp, exact perm_app_right _ IH },
  { simp, rw [← append_assoc, ← append_assoc], exact perm_app_left _ perm_app_comm },
  { exact trans IH₁ IH₂ }
end

theorem perm_bind_right (l : list α) {f g : α → list β} (h : ∀ a, f a ~ g a) :
  l.bind f ~ l.bind g :=
by induction l with a l IH; simp; exact perm_app (h a) IH

theorem perm_product_left {l₁ l₂ : list α} (t₁ : list β) (p : l₁ ~ l₂) : product l₁ t₁ ~ product l₂ t₁ :=
perm_bind_left _ p

theorem perm_product_right (l : list α) {t₁ t₂ : list β} (p : t₁ ~ t₂) : product l t₁ ~ product l t₂ :=
perm_bind_right _ $ λ a, perm_map _ p

@[congr] theorem perm_product {l₁ l₂ : list α} {t₁ t₂ : list β}
  (p₁ : l₁ ~ l₂) (p₂ : t₁ ~ t₂) : product l₁ t₁ ~ product l₂ t₂ :=
trans (perm_product_left t₁ p₁) (perm_product_right l₂ p₂)

theorem sublists_cons_perm_append (a : α) (l : list α) :
  sublists (a :: l) ~ sublists l ++ map (cons a) (sublists l) :=
begin
  simp [sublists, sublists_aux_cons_cons],
  refine skip _ ((skip _ _).trans perm_middle.symm),
  induction sublists_aux l cons with b l IH; simp,
  exact skip b ((skip _ IH).trans perm_middle.symm)
end

theorem sublists_perm_sublists' : ∀ l : list α, sublists l ~ sublists' l
| []     := perm.refl _
| (a::l) := let IH := sublists_perm_sublists' l in
  by rw sublists'_cons; exact
  (sublists_cons_perm_append _ _).trans (perm_app IH (perm_map _ IH))

theorem revzip_sublists (l : list α) :
  ∀ l₁ l₂, (l₁, l₂) ∈ revzip l.sublists → l₁ ++ l₂ ~ l :=
begin
  rw revzip,
  apply list.reverse_rec_on l,
  { intros l₁ l₂ h, simp at h, simp [h] },
  { intros l a IH l₁ l₂ h,
    rw [sublists_concat, reverse_append, zip_append, ← map_reverse,
        zip_map_right, zip_map_left] at h; [simp at h, simp],
    rcases h with ⟨l₁, l₂', h, rfl, rfl⟩ | ⟨l₁', l₂, h, rfl, rfl⟩,
    { rw ← append_assoc,
      exact perm_app_left _ (IH _ _ h) },
    { rw append_assoc,
      apply (perm_app_right _ perm_app_comm).trans,
      rw ← append_assoc,
      exact perm_app_left _ (IH _ _ h) } }
end

theorem revzip_sublists' (l : list α) :
  ∀ l₁ l₂, (l₁, l₂) ∈ revzip l.sublists' → l₁ ++ l₂ ~ l :=
begin
  rw revzip,
  induction l with a l IH; intros l₁ l₂ h,
  { simp at h, simp [h] },
  { rw [sublists'_cons, reverse_append, zip_append, ← map_reverse,
        zip_map_right, zip_map_left] at h; [simp at h, simp],
    rcases h with ⟨l₁, l₂', h, rfl, rfl⟩ | ⟨l₁', l₂, h, rfl, rfl⟩,
    { exact perm_middle.trans (skip _ (IH _ _ h)) },
    { exact skip _ (IH _ _ h) } }
end

theorem perm_lookmap (f : α → option α) {l₁ l₂ : list α}
  (H : pairwise (λ a b, ∀ (c ∈ f a) (d ∈ f b), a = b ∧ c = d) l₁)
  (p : l₁ ~ l₂) : lookmap f l₁ ~ lookmap f l₂ :=
begin
  let F := λ a b, ∀ (c ∈ f a) (d ∈ f b), a = b ∧ c = d,
  change pairwise F l₁ at H,
  induction p with a l₁ l₂ p IH a b l l₁ l₂ l₃ p₁ p₂ IH₁ IH₂, {simp},
  { cases h : f a,
    { simp [h], exact (IH (pairwise_cons.1 H).2).skip _ },
    { simp [lookmap_cons_some _ _ h], exact p.skip _ } },
  { cases h₁ : f a with c; cases h₂ : f b with d,
    { simp [h₁, h₂], apply swap },
    { simp [h₁, lookmap_cons_some _ _ h₂], apply swap },
    { simp [lookmap_cons_some _ _ h₁, h₂], apply swap },
    { simp [lookmap_cons_some _ _ h₁, lookmap_cons_some _ _ h₂],
      rcases (pairwise_cons.1 H).1 _ (or.inl rfl) _ h₂ _ h₁ with ⟨rfl, rfl⟩,
      refl } },
  { refine (IH₁ H).trans (IH₂ ((perm_pairwise _ p₁).1 H)),
    exact λ a b h c h₁ d h₂, (h d h₂ c h₁).imp eq.symm eq.symm }
end

theorem perm_erasep (f : α → Prop) [decidable_pred f] {l₁ l₂ : list α}
  (H : pairwise (λ a b, f a → f b → false) l₁)
  (p : l₁ ~ l₂) : erasep f l₁ ~ erasep f l₂ :=
begin
  let F := λ a b, f a → f b → false,
  change pairwise F l₁ at H,
  induction p with a l₁ l₂ p IH a b l l₁ l₂ l₃ p₁ p₂ IH₁ IH₂, {simp},
  { by_cases h : f a,
    { simp [h, p] },
    { simp [h], exact (IH (pairwise_cons.1 H).2).skip _ } },
  { by_cases h₁ : f a; by_cases h₂ : f b; simp [h₁, h₂],
    { cases (pairwise_cons.1 H).1 _ (or.inl rfl) h₂ h₁ },
    { apply swap } },
  { refine (IH₁ H).trans (IH₂ ((perm_pairwise _ p₁).1 H)),
    exact λ a b h h₁ h₂, h h₂ h₁ }
end

/- enumerating permutations -/

section permutations

theorem permutations_aux2_fst (t : α) (ts : list α) (r : list β) : ∀ (ys : list α) (f : list α → β),
  (permutations_aux2 t ts r ys f).1 = ys ++ ts
| []      f := rfl
| (y::ys) f := match _, permutations_aux2_fst ys _ : ∀ o : list α × list β, o.1 = ys ++ ts →
      (permutations_aux2._match_1 t y f o).1 = y :: ys ++ ts with
  | ⟨_, zs⟩, rfl := rfl
  end

@[simp] theorem permutations_aux2_snd_nil (t : α) (ts : list α) (r : list β) (f : list α → β) :
  (permutations_aux2 t ts r [] f).2 = r := rfl

@[simp] theorem permutations_aux2_snd_cons (t : α) (ts : list α) (r : list β) (y : α) (ys : list α) (f : list α → β) :
  (permutations_aux2 t ts r (y::ys) f).2 = f (t :: y :: ys ++ ts) ::
    (permutations_aux2 t ts r ys (λx : list α, f (y::x))).2 :=
match _, permutations_aux2_fst t ts r _ _ : ∀ o : list α × list β, o.1 = ys ++ ts →
   (permutations_aux2._match_1 t y f o).2 = f (t :: y :: ys ++ ts) :: o.2 with
| ⟨_, zs⟩, rfl := rfl
end

theorem permutations_aux2_append (t : α) (ts : list α) (r : list β) (ys : list α) (f : list α → β) :
  (permutations_aux2 t ts nil ys f).2 ++ r = (permutations_aux2 t ts r ys f).2 :=
by induction ys generalizing f; simp *

theorem mem_permutations_aux2 {t : α} {ts : list α} {ys : list α} {l l' : list α} :
    l' ∈ (permutations_aux2 t ts [] ys (append l)).2 ↔
    ∃ l₁ l₂, l₂ ≠ [] ∧ ys = l₁ ++ l₂ ∧ l' = l ++ l₁ ++ t :: l₂ ++ ts :=
begin
  induction ys with y ys ih generalizing l,
  { simp {contextual := tt} },
  { rw [permutations_aux2_snd_cons, show (λ (x : list α), l ++ y :: x) = append (l ++ [y]),
        by funext; simp, mem_cons_iff, ih], split; intro h,
    { rcases h with e | ⟨l₁, l₂, l0, ye, _⟩,
      { subst l', exact ⟨[], y::ys, by simp⟩ },
      { substs l' ys, exact ⟨y::l₁, l₂, l0, by simp⟩ } },
    { rcases h with ⟨_ | ⟨y', l₁⟩, l₂, l0, ye, rfl⟩,
      { simp [ye] },
      { simp at ye, rcases ye with ⟨rfl, rfl⟩,
        exact or.inr ⟨l₁, l₂, l0, by simp⟩ } } }
end

theorem mem_permutations_aux2' {t : α} {ts : list α} {ys : list α} {l : list α} :
    l ∈ (permutations_aux2 t ts [] ys id).2 ↔
    ∃ l₁ l₂, l₂ ≠ [] ∧ ys = l₁ ++ l₂ ∧ l = l₁ ++ t :: l₂ ++ ts :=
by rw [show @id (list α) = append nil, by funext; refl]; apply mem_permutations_aux2

theorem length_permutations_aux2 (t : α) (ts : list α) (ys : list α) (f : list α → β) :
  length (permutations_aux2 t ts [] ys f).2 = length ys :=
by induction ys generalizing f; simp *

theorem foldr_permutations_aux2 (t : α) (ts : list α) (r L : list (list α)) :
  foldr (λy r, (permutations_aux2 t ts r y id).2) r L = L.bind (λ y, (permutations_aux2 t ts [] y id).2) ++ r :=
by induction L with l L ih; [refl, {simp [ih], rw ← permutations_aux2_append}]

theorem mem_foldr_permutations_aux2 {t : α} {ts : list α} {r L : list (list α)} {l' : list α} :
  l' ∈ foldr (λy r, (permutations_aux2 t ts r y id).2) r L ↔ l' ∈ r ∨
  ∃ l₁ l₂, l₁ ++ l₂ ∈ L ∧ l₂ ≠ [] ∧ l' = l₁ ++ t :: l₂ ++ ts :=
have (∃ (a : list α), a ∈ L ∧
    ∃ (l₁ l₂ : list α), ¬l₂ = nil ∧ a = l₁ ++ l₂ ∧ l' = l₁ ++ t :: (l₂ ++ ts)) ↔
    ∃ (l₁ l₂ : list α), ¬l₂ = nil ∧ l₁ ++ l₂ ∈ L ∧ l' = l₁ ++ t :: (l₂ ++ ts),
from ⟨λ ⟨a, aL, l₁, l₂, l0, e, h⟩, ⟨l₁, l₂, l0, e ▸ aL, h⟩,
      λ ⟨l₁, l₂, l0, aL, h⟩, ⟨_, aL, l₁, l₂, l0, rfl, h⟩⟩,
by rw foldr_permutations_aux2; simp [mem_permutations_aux2', this,
  or.comm, or.left_comm, or.assoc, and.comm, and.left_comm, and.assoc]

theorem length_foldr_permutations_aux2 (t : α) (ts : list α) (r L : list (list α)) :
  length (foldr (λy r, (permutations_aux2 t ts r y id).2) r L) = sum (map length L) + length r :=
by simp [foldr_permutations_aux2, (∘), length_permutations_aux2]

theorem length_foldr_permutations_aux2' (t : α) (ts : list α) (r L : list (list α))
  (n) (H : ∀ l ∈ L, length l = n) :
  length (foldr (λy r, (permutations_aux2 t ts r y id).2) r L) = n * length L + length r :=
begin
  rw [length_foldr_permutations_aux2, (_ : sum (map length L) = n * length L)],
  induction L with l L ih, {simp},
  simp [ih (λ l m, H l (mem_cons_of_mem _ m)), H l (mem_cons_self _ _), mul_add]
end

theorem perm_of_mem_permutations_aux :
  ∀ {ts is l : list α}, l ∈ permutations_aux ts is → l ~ ts ++ is :=
begin
  refine permutations_aux.rec (by simp) _,
  introv IH1 IH2 m,
  rw [permutations_aux_cons, permutations, mem_foldr_permutations_aux2] at m,
  rcases m with m | ⟨l₁, l₂, m, _, e⟩,
  { exact (IH1 m).trans perm_middle },
  { subst e,
    have p : l₁ ++ l₂ ~ is,
    { simp [permutations] at m,
      cases m with e m, {simp [e]},
      exact is.append_nil ▸ IH2 m },
    exact (perm_app_left _ (perm_middle.trans (skip _ p))).trans (skip _ perm_app_comm) }
end

theorem perm_of_mem_permutations {l₁ l₂ : list α}
  (h : l₁ ∈ permutations l₂) : l₁ ~ l₂ :=
(eq_or_mem_of_mem_cons h).elim (λ e, e ▸ perm.refl _)
  (λ m, append_nil l₂ ▸ perm_of_mem_permutations_aux m)

theorem length_permutations_aux :
  ∀ ts is : list α, length (permutations_aux ts is) + is.length.fact = (length ts + length is).fact :=
begin
  refine permutations_aux.rec (by simp) _,
  intros t ts is IH1 IH2,
  have IH2 : length (permutations_aux is nil) + 1 = is.length.fact,
  { simpa using IH2 },
  simp [-add_comm, nat.fact, nat.add_succ, mul_comm] at IH1,
  rw [permutations_aux_cons,
      length_foldr_permutations_aux2' _ _ _ _ _
        (λ l m, perm_length (perm_of_mem_permutations m)),
      permutations, length, length, IH2,
      nat.succ_add, nat.fact_succ, mul_comm (nat.succ _), ← IH1,
      add_comm (_*_), add_assoc, nat.mul_succ, mul_comm]
end

theorem length_permutations (l : list α) : length (permutations l) = (length l).fact :=
length_permutations_aux l []

theorem mem_permutations_of_perm_lemma {is l : list α}
  (H : l ~ [] ++ is → (∃ ts' ~ [], l = ts' ++ is) ∨ l ∈ permutations_aux is [])
  : l ~ is → l ∈ permutations is :=
by simpa [permutations, perm_nil] using H

theorem mem_permutations_aux_of_perm :
  ∀ {ts is l : list α}, l ~ is ++ ts → (∃ is' ~ is, l = is' ++ ts) ∨ l ∈ permutations_aux ts is :=
begin
  refine permutations_aux.rec (by simp) _,
  intros t ts is IH1 IH2 l p,
  rw [permutations_aux_cons, mem_foldr_permutations_aux2],
  rcases IH1 (p.trans perm_middle) with ⟨is', p', e⟩ | m,
  { clear p, subst e,
    rcases mem_split (perm_subset p'.symm (mem_cons_self _ _)) with ⟨l₁, l₂, e⟩,
    subst is',
    have p := perm_cons_inv (perm_middle.symm.trans p'),
    cases l₂ with a l₂',
    { exact or.inl ⟨l₁, by simpa using p⟩ },
    { exact or.inr (or.inr ⟨l₁, a::l₂',
        mem_permutations_of_perm_lemma IH2 p, by simp⟩) } },
  { exact or.inr (or.inl m) }
end

@[simp] theorem mem_permutations (s t : list α) : s ∈ permutations t ↔ s ~ t :=
⟨perm_of_mem_permutations, mem_permutations_of_perm_lemma mem_permutations_aux_of_perm⟩

end permutations

end list