import M4R.Set.MemStructure

namespace List
  open M4R

  protected def mem (a : α) : List α → Prop
  | []   => False
  | b::l => a = b ∨ List.mem a l

  instance ListMem : M4R.Mem α (List α) where mem := List.mem

  protected def sizeOf : List α → Nat := lengthTR
  instance ListSizeOf : SizeOf (List α) where sizeOf := List.sizeOf

  @[simp] theorem sizeOf_cons (a : α) (as : List α) : sizeOf (a::as) = (sizeOf as).succ := by
    simp only [sizeOf, List.sizeOf]; rw [←length_eq_lenghtTR, length_cons]

  theorem eq_nil_of_length_eq_zero {l : List α} : l.length = 0 → l = [] := by
    induction l with
    | nil  => intros; rfl
    | cons => intros; contradiction

  theorem length_eq_one {l : List α} : length l = 1 ↔ ∃ a, l = [a] :=
    ⟨by match l with
    | nil => intro; contradiction
    | cons a l =>
      intro h
      simp at h
      rw [eq_nil_of_length_eq_zero h]
      exact ⟨a, rfl⟩,
    fun ⟨a, e⟩ => e.symm ▸ rfl⟩

  theorem cons_ext {a b : α} {s t : List α} : a :: s = b :: t ↔ a = b ∧ s = t :=
    ⟨List.cons.inj, fun ⟨h₁, h₂⟩ => congr (congrArg List.cons h₁) h₂⟩

  @[simp] theorem mem_nil_iff (a : α) : a ∈ ([] : List α) ↔ False :=
    Iff.rfl
  @[simp] theorem not_mem_nil (a : α) : a ∉ ([] : List α) :=
    Iff.mp (mem_nil_iff a)

  theorem mem_cons_self (a : α) (l : List α) : a ∈ a :: l :=
    Or.inl rfl

  @[simp] theorem mem_cons_of_mem (y : α) {a : α} {l : List α} : a ∈ l → a ∈ y :: l :=
    Or.inr

  @[simp] theorem eq_or_mem_of_mem_cons {a y : α} {l : List α} : a ∈ y::l → a = y ∨ a ∈ l := by
    simp only [Mem.mem, List.mem]; exact id

  theorem mem_cons_iff {a b : α} {l : List α} : a ∈ b :: l ↔ a = b ∨ a ∈ l :=
    ⟨eq_or_mem_of_mem_cons, fun h =>
      Or.elim h (fun h' => by rw [h']; exact mem_cons_self b l) (mem_cons_of_mem b)⟩

  theorem length_pos_of_mem {a : α} : ∀ {l : List α}, a ∈ l → 0 < length l
  | b::l, _ => Nat.zero_lt_succ _

  theorem exists_mem_of_length_pos : ∀ {l : List α}, 0 < length l → ∃ a, a ∈ l
  | b::l, _ => ⟨b, mem_cons_self _ _⟩

  theorem length_pos_iff_exists_mem {l : List α} : 0 < length l ↔ ∃ a, a ∈ l :=
    ⟨exists_mem_of_length_pos, fun ⟨a, h⟩ => length_pos_of_mem h⟩

  theorem forall_mem_nil (p : α → Prop) : ∀ x ∈ [], p x := fun _ _ => by contradiction

  theorem forall_mem_cons {p : α → Prop} {a : α} {l : List α} :
    (∀ x ∈ a :: l, p x) ↔ p a ∧ ∀ x ∈ l, p x :=
      ⟨fun h => ⟨h a (mem_cons_self a l), fun x xl => h x (mem_cons_of_mem a xl)⟩, fun ⟨h₁, h₂⟩ x hx => by
        cases hx with
        | inl h => rw [h]; exact h₁
        | inr h => exact h₂ x h⟩

  theorem forall_mem_of_forall_mem_cons {p : α → Prop} {a : α} {l : List α}
    (h : ∀ x ∈ a :: l, p x) : ∀ x ∈ l, p x :=
      (forall_mem_cons.mp h).right

  @[simp] theorem forall_mem_ne {a : α} {l : List α} : (∀ (a' : α), a' ∈ l → ¬a = a') ↔ a ∉ l :=
    ⟨fun h m => h _ m rfl, fun h a' m e => h (e.symm ▸ m)⟩

  theorem not_mem_cons_of_ne_of_not_mem {a y : α} {l : List α} : a ≠ y → a ∉ l → a ∉ y::l :=
    fun h₁ h₂ h₃ => Or.elim (eq_or_mem_of_mem_cons h₃) h₁ h₂

  theorem mem_split {l : List α} (h : a ∈ l) : ∃ s t : List α, l = s ++ a :: t := by
    induction l with
    | nil         => contradiction
    | cons b l ih => apply Or.elim h (fun ab =>
      by rw [ab]; exact ⟨[], l, rfl⟩) (fun ainl =>
        by let ⟨s, t, p⟩ := ih ainl; rw [p]; exact ⟨b::s, t, rfl⟩)

  theorem mem_of_ne_of_mem {a y : α} {l : List α} (h₁ : a ≠ y) (h₂ : a ∈ y :: l) : a ∈ l :=
    Or.elim (eq_or_mem_of_mem_cons h₂) (fun e => absurd e h₁) id

  theorem eq_nil_of_subset_nil : ∀ {l : List α}, l ⊆ [] → l = []
  | []  , s => rfl
  | a::l, s => False.elim (s (mem_cons_self a l))

  protected theorem in_singleton {a a' : α} : a' ∈ [a] → a' = a := by
    intro ha'
    simp only [Mem.mem, List.mem, or_false] at ha'
    exact ha'

  protected theorem self_singleton (a : α) : a ∈ [a] := by
    simp only [Mem.mem, List.mem]

  @[simp] theorem mem_append {a : α} {s t : List α} : a ∈ s ++ t ↔ a ∈ s ∨ a ∈ t := by
      induction s with
      | nil => simp
      | cons _ _ ih => exact
        ⟨fun p => Or.elim p (fun x => Or.inl (Or.inl x)) (fun x => Or.assoc.mp (Or.inr (ih.mp x))),
          fun p => Or.elim p (fun q => Or.elim q Or.inl
            (fun x => Or.inr (ih.mpr (Or.inl x)))) (fun x => Or.inr (ih.mpr (Or.inr x)))⟩

  @[simp] theorem appendSingleton {a : α} {l : List α} : [a] ++ l = a::l := rfl

  protected theorem in_double (a b : α) : ∀ x ∈ [a, b], x = a ∨ x = b := fun x hx =>
    Or.elim (eq_or_mem_of_mem_cons hx) Or.inl fun hb => Or.inr (List.in_singleton hb)

  section map

    @[simp] theorem map_nil (f : α → β) : map f [] = [] := rfl

    @[simp] theorem map_append (f : α → β) : ∀ l₁ l₂, map f (l₁ ++ l₂) = (map f l₁) ++ (map f l₂) := fun l₁ => by
      induction l₁ with
      | nil => intros; rfl
      | cons x l₁ ih => simp only [map, cons_append, cons_ext]; exact fun l₂ => ⟨trivial, ih l₂⟩

    theorem map_singleton (f : α → β) (a : α) : map f [a] = [f a] := rfl

    theorem mem_map_of_mem (f : α → β) {a : α} {l : List α} (h : a ∈ l) : f a ∈ l.map f := by
      induction l with
      | nil => cases h
      | cons _ _ ih =>
        cases h with
        | inl h' => rw [h']; apply Or.inl; rfl
        | inr h' => exact Or.inr (ih h')

    theorem exists_of_mem_map {f : α → β} {b : β} {l : List α} (h : b ∈ l.map f) :
      ∃ a, a ∈ l ∧ f a = b := by
      induction l with
      | nil => cases h
      | cons c _ ih =>
        cases (eq_or_mem_of_mem_cons h) with
        | inl h' => exact ⟨c, mem_cons_self _ _, h'.symm⟩
        | inr h' => let ⟨a, ha₁, ha₂⟩ := ih h'; exact ⟨a, mem_cons_of_mem _ ha₁, ha₂⟩

    @[simp] theorem mem_map {f : α → β} {b : β} {l : List α} : b ∈ l.map f ↔ ∃ a, a ∈ l ∧ f a = b :=
      ⟨exists_of_mem_map, fun ⟨a, la, h⟩ => by rw [←h]; exact mem_map_of_mem f la⟩

    @[simp] theorem map_cons (f : α → β) (a : α) (l : List α) : (a :: l).map f = (f a) :: (l.map f) := rfl

    @[simp] theorem map_comp (f : α → β) (g : β → γ) (l : List α) : (l.map f).map g = l.map (g ∘ f) := by
      induction l with
      | nil => rfl
      | cons a l ih => simp only [map_cons, ih]

    @[simp] theorem map_id (l : List α) : map id l = l := by
      induction l with
      | nil => rfl
      | cons a b ih => simp only [map, id_eq, ih]

    theorem filterMap_Eq_map (f : α → β) : filterMap (some ∘ f) = map f := by
      apply funext; intro l
      induction l with
      | nil => simp only [filterMap, map]
      | cons _ _ ih => simp only [filterMap, map, cons.injEq, true_and]; exact ih

    theorem map_congr {f g : α → β} {s t : List α} (h₁ : s = t) (h₂ : ∀ x ∈ t, f x = g x) :
      s.map f = t.map g := by
        rw [h₁]; clear h₁
        induction t with
        | nil => rfl
        | cons a l ih₂ =>
          simp only [List.map_cons, List.cons_ext]
          exact ⟨h₂ a (List.mem_cons_self a l), ih₂ fun x hx => h₂ x (mem_cons_of_mem a hx)⟩

    @[simp] theorem length_map (f : α → β) (l : List α) : (l.map f).length = l.length := by
      induction l with
      | nil => rfl
      | cons a b ih => rw [map_cons, length_cons, length_cons, ih]
  end map

  inductive Sublist : List α → List α → Prop
  | nil : Sublist [] []
  | cons (l₁ l₂ a) : Sublist l₁ l₂ → Sublist l₁ (a::l₂)
  | cons' (l₁ l₂ a) : Sublist l₁ l₂ → Sublist (a::l₁) (a::l₂)
  infix:50 " <+ " => Sublist

  namespace Sublist

    theorem length_le_of_sublist {l₁ l₂ : List α} : l₁ <+ l₂ → length l₁ ≤ length l₂
    | nil => Nat.le_refl 0
    | cons l₁ l₂ a s => Nat.le_succ_of_le (length_le_of_sublist s)
    | cons' l₁ l₂ a s => Nat.succ_le_succ (length_le_of_sublist s)

    @[simp] theorem nil_sublist : ∀ (l : List α), [] <+ l
    | []     => nil
    | a :: l => cons _ _ a (nil_sublist l)

    @[simp] protected theorem refl : ∀ (l : List α), l <+ l
    | []       => nil
    | (a :: l) => cons' _ _ a (Sublist.refl l)

    protected theorem trans {l₁ l₂ l₃ : List α} (h₁ : l₁ <+ l₂) (h₂ : l₂ <+ l₃) : l₁ <+ l₃ :=
      @Sublist.recOn α (fun l₂ l₃ h => (l₁ : List α) → l₁ <+ l₂ → l₁ <+ l₃) _ _ h₂
        (fun _ => id)
        (fun l₂ l₃ a h₂ IH l₁ h₁ => cons _ _ _ (IH l₁ h₁))
        (fun l₂ l₃ a h₂ IH l₁ h₁ =>
          @Sublist.casesOn α (fun l₁ l₂' _ => l₂' = a :: l₂ → l₁ <+ a :: l₃) _ _ h₁
            (fun _ => nil_sublist _)
            (fun l₁ l₂' a' h₁' e => by rw [(List.cons_ext.mp e).right] at h₁'; exact cons _ _ _ (IH _ h₁'))
            (fun l₁ l₂' a' h₁' e => by
              have ⟨e₁, e₂⟩ := List.cons_ext.mp e; rw [e₁]; rw [e₂] at h₁'
              exact cons' _ _ _ (IH _ h₁')) rfl)
        l₁ h₁

    @[simp] theorem sublist_cons (a : α) (l : List α) : l <+ a::l :=
      cons _ _ _ (Sublist.refl l)

    theorem sublist_of_cons_sublist {a : α} {l₁ l₂ : List α} : a::l₁ <+ l₂ → l₁ <+ l₂ :=
      Sublist.trans (sublist_cons a l₁)

    protected theorem cons_cons {l₁ l₂ : List α} (a : α) (s : l₁ <+ l₂) : a::l₁ <+ a::l₂ :=
      cons' _ _ _ s

    @[simp] theorem sublist_append_left : ∀ (l₁ l₂ : List α), l₁ <+ l₁++l₂
    | []   , l₂ => nil_sublist _
    | a::l₁, l₂ => (sublist_append_left l₁ l₂).cons_cons _

    @[simp] theorem sublist_append_right : ∀ (l₁ l₂ : List α), l₂ <+ l₁++l₂
    | []   , l₂ => Sublist.refl _
    | a::l₁, l₂ => cons _ _ _ (sublist_append_right l₁ l₂)

    theorem sublist_cons_of_sublist (a : α) {l₁ l₂ : List α} : l₁ <+ l₂ → l₁ <+ a::l₂ :=
      cons _ _ _

    theorem sublist_append_of_sublist_left {l l₁ l₂ : List α} (s : l <+ l₁) : l <+ l₁++l₂ :=
      s.trans $ sublist_append_left _ _

    theorem sublist_append_of_sublist_right {l l₁ l₂ : List α} (s : l <+ l₂) : l <+ l₁++l₂ :=
      s.trans (sublist_append_right _ _)

    theorem sublist_of_cons_sublist_cons {l₁ l₂ : List α} {a : α} : a::l₁ <+ a::l₂ → l₁ <+ l₂ := fun h => by
      cases h with
      | cons _ _ _ h => exact sublist_of_cons_sublist h
      | cons' _ _ _ h => exact h

    theorem cons_sublist_cons_iff {l₁ l₂ : List α} {a : α} : a::l₁ <+ a::l₂ ↔ l₁ <+ l₂ :=
    ⟨sublist_of_cons_sublist_cons, Sublist.cons_cons _⟩

    @[simp] theorem append_sublist_append_left {l₁ l₂ : List α} : ∀ l, l++l₁ <+ l++l₂ ↔ l₁ <+ l₂
    | []   => Iff.rfl
    | a::l => cons_sublist_cons_iff.trans (append_sublist_append_left l)

    theorem append_right {l₁ l₂ : List α} (h : l₁ <+ l₂) (l : List α) : l₁++l <+ l₂++l := by
      induction h with
      | nil => simp only [nil_append]; exact Sublist.refl l
      | cons l₁ l₂ a s ih => exact sublist_cons_of_sublist a ih
      | cons' l₁ l₂ a s ih => exact ih.cons_cons a

    protected theorem reverse {l₁ l₂ : List α} (h : l₁ <+ l₂) : l₁.reverse <+ l₂.reverse := by
      induction h with
      | nil => simp only [List.reverse_nil]; exact Sublist.refl _
      | cons l₁ l₂ a s ih => rw [reverse_cons]; exact sublist_append_of_sublist_left ih
      | cons' l₁ l₂ a s ih => rw [reverse_cons, reverse_cons]; exact ih.append_right [a]

    @[simp] theorem reverse_sublist_iff {l₁ l₂ : List α} : l₁.reverse <+ l₂.reverse ↔ l₁ <+ l₂ :=
      ⟨fun h => l₁.reverse_reverse ▸ l₂.reverse_reverse ▸ h.reverse, Sublist.reverse⟩

    @[simp] theorem append_sublist_append_right {l₁ l₂ : List α} : ∀ l, l₁++l <+ l₂++l ↔ l₁ <+ l₂ := fun l =>
      ⟨fun h => by
        have := h.reverse
        rw [reverse_append, reverse_append, append_sublist_append_left] at this
        exact reverse_sublist_iff.mp this,
      fun h => h.append_right l⟩

    protected theorem subset {l₁ l₂ : List α} : l₁ <+ l₂ → l₁ ⊆ l₂
    | nil, b, h => h
    | cons l₁ l₂ a s, b, h => mem_cons_of_mem _ (Sublist.subset s h)
    | cons' l₁ l₂ a s, b, h => by
      cases eq_or_mem_of_mem_cons h with
      | inl h => exact h ▸ mem_cons_self _ _
      | inr h => exact mem_cons_of_mem _ (Sublist.subset s h)

    @[simp] theorem singleton_sublist {a : α} {l : List α} : [a] <+ l ↔ a ∈ l :=
      ⟨fun h => h.subset (List.self_singleton _),
      fun h => by
        let ⟨s, t, e⟩ := mem_split h; rw [e]
        exact ((Sublist.nil_sublist t).cons_cons a).trans (Sublist.sublist_append_right s (a::t))⟩

    theorem eq_nil_of_sublist_nil {l : List α} (s : l <+ []) : l = [] :=
      eq_nil_of_subset_nil s.subset

    theorem eq_of_sublist_of_length_eq {l₁ l₂ : List α} : l₁ <+ l₂ → length l₁ = length l₂ → l₁ = l₂
    | nil, h => rfl
    | cons l₁ l₂ a s, h => absurd (length_le_of_sublist s) $ Nat.not_le_of_gt (by rw [h]; apply Nat.lt_succ_self)
    | cons' l₁ l₂ a s, h => by simp at h; rw [eq_of_sublist_of_length_eq s h]

    theorem eq_of_sublist_of_length_le {l₁ l₂ : List α} (s : l₁ <+ l₂) (h : length l₂ ≤ length l₁) :
      l₁ = l₂ :=
        eq_of_sublist_of_length_eq s (Nat.le_antisymm (length_le_of_sublist s) h)

    theorem sublist_or_mem_of_sublist {l l₁ l₂ : List α} {a : α} (h : l <+ l₁ ++ a::l₂) :
      l <+ l₁ ++ l₂ ∨ a ∈ l := by
        induction l₁ generalizing l with
        | nil =>
          cases h with
          | cons  _ _ _ h => apply Or.inl; simp only [nil_append, h]
          | cons' _ _ _ _ => apply Or.inr; exact mem_cons_self _ _
        | cons b l₁ ih =>
          cases h with
          | cons  _ _ _ h => exact Or.imp_left (sublist_cons_of_sublist _) (ih h)
          | cons' _ _ _ h =>
            exact (ih h).imp (Sublist.cons_cons _) (mem_cons_of_mem _)

    theorem filter_map (f : α → Option β) {l₁ l₂ : List α}
      (s : l₁ <+ l₂) : filterMap f l₁ <+ filterMap f l₂ := by
        induction s with
        | nil => simp
        | cons l₁ l₂ a s ih =>
          simp only [filterMap]
          cases f a with
          | none => exact ih
          | some b => exact Sublist.cons _ _ b ih
        | cons' l₁ l₂ a s ih =>
          simp only [filterMap]
          cases f a with
          | none => exact ih
          | some b => exact Sublist.cons' _ _ b ih

  end Sublist

  section pmap

    @[simp] def pmap {p : α → Prop} (f : ∀ a, p a → β) : ∀ l : List α, (∀ a ∈ l, p a) → List β
    | []  , H => []
    | a::l, H => f a (forall_mem_cons.mp H).left :: pmap f l (forall_mem_cons.mp H).right

    @[simp] theorem pmap_eq_map (p : α → Prop) (f : α → β) (l : List α) (H) :
      @pmap _ _ p (fun a _ => f a) l H = map f l := by
        induction l with
        | nil => rfl
        | cons _ _ ih => simp only [pmap, map, ih]

    theorem pmap_congr {p q : α → Prop} {f : ∀ a, p a → β} {g : ∀ a, q a → β} (l : List α) {H₁ H₂}
      (h : ∀ a h₁ h₂, f a h₁ = g a h₂) : pmap f l H₁ = pmap g l H₂ := by
        induction l with
        | nil => rfl
        | cons _ _ ih => simp only [pmap, cons.injEq]; exact ⟨h _ _ _, ih⟩

    theorem map_pmap {p : α → Prop} (g : β → γ) (f : ∀ a, p a → β)
      (l H) : map g (pmap f l H) = pmap (fun a h => g (f a h)) l H := by
        induction l with
        | nil => rfl
        | cons _ _ ih => simp only [pmap, map, ih]

    section attach
      def attach (l : List α) : List {x // x ∈ l} := pmap Subtype.mk l (fun _ => id)

      theorem pmap_eq_map_attach {p : α → Prop} (f : ∀ a, p a → β) (l H) :
        pmap f l H = l.attach.map (fun ⟨x, hx⟩ => f x (H _ hx)) := by
          simp only [attach, map_pmap]; exact pmap_congr l (fun a h₁ h₂ => rfl)

      theorem attach_map_val (l : List α) : l.attach.map Subtype.val = l := by
        simp only [attach, map_pmap]; exact (pmap_eq_map _ _ _ _).trans (map_id l)

      @[simp] theorem mem_attach (l : List α) : ∀ x, x ∈ l.attach
      | ⟨a, h⟩ => by
        have := mem_map.mp (by rw [attach_map_val]; exact h)
        cases this with
        | intro x h' => match x, h' with
          | ⟨x, hx⟩, ⟨h₁, h₂⟩ =>
            have : ({ val := a, property := h } : Subtype (· ∈ l)) = { val := x, property := hx } := by
              simp only [Subtype.mk.injEq, h₂]
            rw [this]
            exact h₁
    end attach

    @[simp] theorem mem_pmap {p : α → Prop} {f : ∀ a, p a → β} {l H b} :
      b ∈ pmap f l H ↔ ∃ (a : α) (h : a ∈ l), f a (H a h) = b := by
        simp only [pmap_eq_map_attach, mem_map, mem_attach, true_and, Subtype.exists]
        exact Iff.rfl

    theorem pmap_length {p : α → Prop} (f : ∀ a, p a → β) {l : List α} (hl : ∀ a ∈ l, p a) : (l.pmap f hl).length = l.length := by
      induction l with
      | nil          => rfl
      | cons a l ih => rw [length_cons, ←ih (fun x hx => hl x (mem_cons_of_mem a hx))]; rfl
  end pmap

  open Classical

  section insert
    protected noncomputable def insert (a : α) (l : List α) : List α :=
      if a ∈ l then l else a :: l

    @[simp] theorem insert_nil (a : α) : ([]).insert a = [a] := by simp only [List.insert, mem_nil_iff, ite_false]

    @[simp] theorem insert_of_mem {a : α} {l : List α} (h : a ∈ l) : l.insert a = l := by
      simp only [List.insert, if_pos h]

    @[simp] theorem insert_of_not_mem {a : α} {l : List α} (h : a ∉ l) : l.insert a = a :: l :=
      by simp only [List.insert, if_neg h]

    @[simp] theorem mem_insert_iff {l : List α} : a ∈ l.insert b ↔ a = b ∨ a ∈ l := by
      byCases h : b ∈ l
      { rw [insert_of_mem h]; exact ⟨Or.inr, fun h' => Or.elim h' (fun h'' => by rw [h'']; exact h) id⟩ }
      simp only [insert_of_not_mem h, mem_cons_iff]; exact Iff.rfl

    theorem Sublist.insert (a : α) (l : List α) : l <+ l.insert a := by
      byCases h : a ∈ l
      simp only [List.insert, h, ite_true, Sublist.refl]
      simp only [List.insert, h, ite_false, Sublist.sublist_cons]

  end insert

  section fold

    @[simp] theorem foldl_cons (f : α → β → α) (a : α) (b : β) (l : List β) :
    foldl f a (b::l) = foldl f (f a b) l := rfl

    @[simp] theorem foldr_cons (f : α → β → β) (init : β) (a : α) (l : List α) :
      foldr f init (a::l) = f a (foldr f init l) := rfl

    @[simp] theorem foldl_append (f : α → β → α) (a : α) (l₁ l₂ : List β) :
      foldl f a (l₁++l₂) = foldl f (foldl f a l₁) l₂ :=
        match l₁ with
        | []      => rfl
        | b::l₁ => by simp only [cons_append, foldl_cons, foldl_append f (f a b) l₁ l₂]

    @[simp] theorem foldl_empty (f : α → β → α) (a : α) :
      foldl f a [] = a := rfl

    @[simp] theorem foldr_empty (f : α → β → β) (a : β) :
      foldr f a [] = a := rfl

    @[simp] theorem foldl_singleton (f : α → β → α) (a : α) (b : β) :
      foldl f a [b] = f a b := rfl

  end fold

  section union

    protected noncomputable def union (l₁ l₂ : List α) : List α :=
      foldr List.insert l₂ l₁

    noncomputable instance ListUnion : Union (List α) where union := List.union

    @[simp] theorem nil_union (l : List α) : [] ∪ l = l := rfl

    @[simp] theorem cons_union (l₁ l₂ : List α) (a : α) : a :: l₁ ∪ l₂ = (l₁ ∪ l₂).insert a := rfl

    @[simp] theorem mem_union {l₁ l₂ : List α} : a ∈ l₁ ∪ l₂ ↔ a ∈ l₁ ∨ a ∈ l₂ := by
      induction l₁ with
      | nil => simp
      | cons x l ih =>
        simp only [cons_union, mem_insert_iff, mem_cons_iff, ih, Or.assoc]; exact Iff.rfl

    theorem sublist_suffix_of_union : ∀ l₁ l₂ : List α, ∃ t, t <+ l₁ ∧ t ++ l₂ = l₁ ∪ l₂
    | []   , l₂ => ⟨[], Sublist.refl _, rfl⟩
    | a::l₁, l₂ =>
      let ⟨t, s, e⟩ := sublist_suffix_of_union l₁ l₂
      if h : a ∈ l₁ ∪ l₂ then
        ⟨t, Sublist.sublist_cons_of_sublist _ s, by simp only [e, cons_union, insert_of_mem h]⟩
      else
        ⟨a::t, s.cons_cons _, by simp only [cons_append, cons_union, e, insert_of_not_mem h]⟩

    theorem union_sublist_append (l₁ l₂ : List α) : l₁ ∪ l₂ <+ l₁ ++ l₂ :=
      let ⟨t, s, e⟩ := sublist_suffix_of_union l₁ l₂
      e ▸ (Sublist.append_sublist_append_right _).mpr s

  end union

  section filter'
    noncomputable def filter' (p : α → Prop) : List α → List α
    | []     => []
    | (a::l) => if p a then a :: filter' p l else filter' p l

    @[simp] theorem filter'_nil (p : α → Prop) : filter' p [] = [] := rfl

    @[simp] theorem filter'_cons_of_pos {a : α} (l: List α) (h : p a) : filter' p (a :: l) = a :: filter' p l :=
      if_pos h

    @[simp] theorem filter'_cons_of_neg {a : α} (s) (h : ¬ p a) : filter' p (a :: s) = filter' p s :=
      if_neg h

    @[simp] theorem filter'_append {p : α → Prop} :
      ∀ (l₁ l₂ : List α), filter' p (l₁++l₂) = filter' p l₁ ++ filter' p l₂
    | []   , l₂ => rfl
    | a::l₁, l₂ => by
      byCases pa : p a; repeat { simp [pa, filter'_append] }

    theorem filter_map_eq_filter' (p : α → Prop) : filterMap (Option.guard p) = filter' p := by
      apply funext; intro l
      induction l with
      | nil => rfl
      | cons a l ih =>
        byCases pa : p a
        { simp only [filterMap, Option.guard, if_pos pa, filter'_cons_of_pos _ pa]
          exact cons_ext.mpr ⟨rfl, ih⟩ }
        { simp only [filterMap, Option.guard, if_neg pa, filter'_cons_of_neg _ pa]
          exact ih }

    @[simp] theorem filter'_sublist {p : α → Prop} : ∀ (l : List α), filter' p l <+ l
    | []   => Sublist.nil
    | a::l =>
      if pa : p a then by
        simp only [filter'_cons_of_pos, pa]; apply Sublist.cons'; exact filter'_sublist l
      else by
        simp only [filter'_cons_of_neg, pa]; apply Sublist.cons; exact filter'_sublist l

    @[simp] theorem filter'_subset (p : α → Prop) (l : List α) : filter' p l ⊆ l :=
      (filter'_sublist l).subset

    theorem of_mem_filter' {p : α → Prop} {a : α} : ∀ {l : List α}, a ∈ filter' p l → p a
    | b::l, ain =>
      if pb : p b then
        have : a ∈ b :: filter' p l := by simp only [filter'_cons_of_pos _ pb] at ain; exact ain
        Or.elim (eq_or_mem_of_mem_cons this)
          (fun h => by rw [←h] at pb; exact pb)
          of_mem_filter'
      else by
        simp only [filter'_cons_of_neg _ pb] at ain; exact of_mem_filter' ain

    theorem mem_of_mem_filter' {p : α → Prop} {a : α} {l} (h : a ∈ filter' p l) : a ∈ l :=
      filter'_subset p l h

    theorem mem_filter'_of_mem {p : α → Prop} {a : α} : ∀ {l}, a ∈ l → p a → a ∈ filter' p l
    | _::l, Or.inl rfl, pa => by rw [filter'_cons_of_pos _ pa]; exact mem_cons_self _ _
    | b::l, Or.inr ain, pa =>
      if pb : p b then by
        rw [filter'_cons_of_pos _ pb]; exact mem_cons_of_mem _ (mem_filter'_of_mem ain pa)
      else by
        rw [filter'_cons_of_neg _ pb]; exact mem_filter'_of_mem ain pa

    @[simp] theorem mem_filter' {p : α → Prop} {a : α} {l : List α} : a ∈ filter' p l ↔ a ∈ l ∧ p a :=
      ⟨fun h => ⟨mem_of_mem_filter' h, of_mem_filter' h⟩, fun ⟨h₁, h₂⟩ => mem_filter'_of_mem h₁ h₂⟩

    theorem filter'_eq_self {l : List α} : filter' p l = l ↔ ∀ a ∈ l, p a := by
      induction l with
      | nil => simp only [filter'_nil, true_iff]; exact forall_mem_nil p
      | cons a l ih =>
        rw [forall_mem_cons]; byCases h : p a
        { rw [filter'_cons_of_pos _ h, List.cons.injEq, ih]
          exact ⟨fun h' => ⟨h, h'.right⟩, fun h' => ⟨rfl, h'.right⟩⟩ }
        { rw [filter'_cons_of_neg _ h]
          exact iff_of_false (by
            intro e; have := @filter'_sublist α p l
            rw [e] at this
            have h' := Nat.lt_succ_self (length l)
            have h'' := Sublist.length_le_of_sublist this
            simp only [length] at h''
            exact absurd (Nat.lt_of_lt_of_le h' h'') (Nat.lt_irrefl _)) (mt And.left h) }

  end filter'

  theorem Sublist.filter' (p : α → Prop) {l₁ l₂ : List α} (s : l₁ <+ l₂) : filter' p l₁ <+ filter' p l₂ :=
    filter_map_eq_filter' p ▸ s.filter_map _

  section erasep

    protected def erasep (p : α → Prop) [DecidablePred p] : List α → List α
    | []   => []
    | a::l => if p a then l else a :: List.erasep p l

    variable {p : α → Prop} [DecidablePred p]

    @[simp] theorem erasep_nil : [].erasep p = [] := rfl

    theorem erasep_cons (a : α) (l : List α) :
      (a :: l).erasep p = if p a then l else a :: l.erasep p := rfl

    @[simp] theorem erasep_cons_of_pos {a : α} {l : List α} (h : p a) : (a :: l).erasep p = l := by
      simp only [erasep_cons, h, ite_true]

    @[simp] theorem erasep_cons_of_neg {a : α} {l : List α} (h : ¬ p a) :
      (a::l).erasep p = a :: l.erasep p := by
        simp only [erasep_cons, h, ite_false]

    theorem erasep_of_forall_not {l : List α}
      (h : ∀ a ∈ l, ¬ p a) : l.erasep p = l := by
        induction l with
        | nil => rfl
        | cons _ _ ih =>
          simp only [h _ (Or.inl rfl), ih (forall_mem_of_forall_mem_cons h), erasep_cons_of_neg]

    theorem exists_of_erasep {l : List α} {a} (al : a ∈ l) (pa : p a) :
      ∃ a l₁ l₂, (∀ b ∈ l₁, ¬ p b) ∧ p a ∧ l = l₁ ++ a :: l₂ ∧ l.erasep p = l₁ ++ l₂ := by
        induction l with
        | nil => cases al
        | cons b l ih =>
          byCases pb : p b
          { exact ⟨b, [], l, forall_mem_nil _, pb, by simp only [pb, nil_append, erasep_cons_of_pos]⟩ }
          cases al with
          | inl h => rw [h] at pa; exact absurd pa pb
          | inr h =>
            let ⟨c, l₁, l₂, h₁, h₂, h₃, h₄⟩ := ih h
            exact ⟨c, b::l₁, l₂, forall_mem_cons.mpr ⟨pb, h₁⟩, h₂, by rw [h₃]; rfl, by
              simp only [pb, h₄, erasep_cons_of_neg, cons_append]⟩

    theorem exists_or_eq_self_of_erasep (p : α → Prop) [DecidablePred p] (l : List α) :
      l.erasep p = l ∨ ∃ a l₁ l₂, (∀ b ∈ l₁, ¬ p b) ∧ p a ∧ l = l₁ ++ a :: l₂ ∧ l.erasep p = l₁ ++ l₂ := by
        byCases h : ∃ a ∈ l, p a
        { let ⟨a, ha, pa⟩ := h; exact Or.inr (exists_of_erasep ha pa) }
        { simp only [not_exists, not_and] at h; exact Or.inl (erasep_of_forall_not h) }

    theorem erasep_append_left {a : α} (pa : p a) :
      ∀ {l₁ : List α} (l₂ : List α), a ∈ l₁ → (l₁++l₂).erasep p = l₁.erasep p ++ l₂
    | x::xs, l₂, h => by
      byCases h' : p x
      { simp only [h', erasep_cons_of_pos, cons_append] }
      simp only [h', erasep_cons_of_neg, cons_append, cons.injEq, true_and]
      rw [erasep_append_left pa l₂ (mem_of_ne_of_mem (mt _ h') h)]
      intro h; rw [h] at pa; exact pa

    theorem erasep_append_right :
      ∀ {l₁ : List α} (l₂ : List α), (∀ b ∈ l₁, ¬ p b) → (l₁++l₂).erasep p = l₁ ++ l₂.erasep p
    | []   , l₂, h => rfl
    | x::xs, l₂, h => by
      simp only [(forall_mem_cons.mp h).left, erasep_append_right _ (forall_mem_cons.mp h).right,
        erasep_cons_of_neg, cons_append]

    theorem erasep_sublist (l : List α) : l.erasep p <+ l := by
      cases exists_or_eq_self_of_erasep p l with
      | inl h => rw [h]; exact Sublist.refl _
      | inr h =>
        let ⟨c, l₁, l₂, h₁, h₂, h₃, h₄⟩ := h
        rw [h₄, h₃]; simp

    theorem erasep_subset (l : List α) : l.erasep p ⊆ l :=
      (erasep_sublist l).subset

    theorem mem_of_mem_erasep {a : α} {l : List α} : a ∈ l.erasep p → a ∈ l :=
      @erasep_subset _ _ _ _ _

    @[simp] theorem mem_erasep_of_neg {a : α} {l : List α} (pa : ¬ p a) : a ∈ l.erasep p ↔ a ∈ l :=
      ⟨mem_of_mem_erasep, fun al => by
        cases exists_or_eq_self_of_erasep p l with
        | inl h => rw [h]; exact al
        | inr h =>
          let ⟨c, l₁, l₂, h₁, h₂, h₃, h₄⟩ := h
          rw [h₄]; rw [h₃] at al
          apply List.mem_append.mpr
          cases List.mem_append.mp al with
          | inl h' => exact Or.inl h'
          | inr h' =>
            cases h' with
            | inl h' =>
              have : a ≠ c := fun h' => by rw [h'] at pa; exact absurd h₂ pa
              exact absurd h' this
            | inr h' => exact Or.inr h'⟩

  end erasep

  theorem Sublist.erasep {l₁ l₂ : List α} (s : l₁ <+ l₂) : l₁.erasep p <+ l₂.erasep p := by
      induction s with
      | nil => rw [erasep_nil]; exact Sublist.nil
      | cons l₁ l₂ a s ih =>
        byCases h : p a
        { rw [erasep_cons_of_pos h]; exact ih.trans (erasep_sublist _) }
        { rw [erasep_cons_of_neg h]; exact ih.cons _ _ _ }
      | cons' l₁ l₂ a s ih =>
        byCases h : p a
        { rw [erasep_cons_of_pos h, erasep_cons_of_pos h]; exact s }
        { rw [erasep_cons_of_neg h, erasep_cons_of_neg h]; exact ih.cons' _ _ _ }

  section erase
    @[simp] theorem erase_nil (a : α) : [].erase a = [] := rfl

    theorem erase_cons (a b : α) (l : List α) :
      (b :: l).erase a = (if b = a then l else b :: List.erase l a) := by
        byCases h₁ : b = a
        { have h₂ : a == a := decide_eq_true rfl
        simp only [h₁, List.erase, h₂, ite_true] }
        { have h₂ : (b == a) = false := decide_eq_false h₁
        simp only [h₁, List.erase, h₂, ite_false] }

    @[simp] theorem erase_cons_head (a : α) (l : List α) : (a :: l).erase a = l := by
      simp only [erase_cons, ite_true]

    @[simp] theorem erase_cons_tail {a b : α} (l : List α) (h : b ≠ a) :
      (b::l).erase a = b :: l.erase a := by
        simp only [erase_cons, if_neg h]

    theorem erase_eq_erasep (a : α) (l : List α) : l.erase a = l.erasep (Eq a) := by
      induction l with
      | nil => rfl
      | cons b l ih =>
        byCases h : a = b
        { simp only [h, erase_cons_head, erasep_cons_of_pos] }
        { simp only [ne_eq, h, Ne.symm h, ih, erase_cons_tail, erasep_cons_of_neg] }

    @[simp] theorem erase_of_not_mem {a : α} {l : List α} (h : a ∉ l) : l.erase a = l := by
      rw [erase_eq_erasep, erasep_of_forall_not]
      intro b h' h''; rw [h''] at h; exact absurd h' h

    theorem exists_erase_eq {a : α} {l : List α} (h : a ∈ l) :
      ∃ l₁ l₂, a ∉ l₁ ∧ l = l₁ ++ a :: l₂ ∧ l.erase a = l₁ ++ l₂ := by
        let ⟨_, l₁, l₂, h₁, rfl, h₂, h₃⟩ := exists_of_erasep h rfl
        rw [erase_eq_erasep]; exact ⟨l₁, l₂, fun h => h₁ _ h rfl, h₂, h₃⟩

    theorem erase_append_left {a : α} {l₁ : List α} (l₂) (h : a ∈ l₁) :
      (l₁++l₂).erase a = l₁.erase a ++ l₂ := by
        simp only [erase_eq_erasep]; exact erasep_append_left (by rfl) l₂ h

    theorem erase_append_right {a : α} {l₁ : List α} (l₂) (h : a ∉ l₁) :
      (l₁++l₂).erase a = l₁ ++ l₂.erase a := by
        rw [erase_eq_erasep, erase_eq_erasep, erasep_append_right]
        intro b h' h''; rw [h''] at h; exact absurd h' h

    theorem erase_sublist (a : α) (l : List α) : l.erase a <+ l := by
      rw [erase_eq_erasep]; apply erasep_sublist

    theorem erase_subset (a : α) (l : List α) : l.erase a ⊆ l :=
      (erase_sublist a l).subset

    theorem mem_of_mem_erase {a b : α} {l : List α} : a ∈ l.erase b → a ∈ l :=
      have := erase_subset b l
      @this a

    @[simp] theorem mem_erase_of_ne {a b : α} {l : List α} (ab : a ≠ b) : a ∈ l.erase b ↔ a ∈ l := by
      rw [erase_eq_erasep]; exact mem_erasep_of_neg ab.symm

    theorem erase_comm (a b : α) (l : List α) : (l.erase a).erase b = (l.erase b).erase a :=
    if ab : a = b then by rw [ab] else
    if ha : a ∈ l then
    if hb : b ∈ l then match l, l.erase a, exists_erase_eq ha, hb with
    | _, _, ⟨l₁, l₂, ha', rfl, rfl⟩, hb =>
      if h₁ : b ∈ l₁ then
        by rw [erase_append_left _ h₁, erase_append_left _ h₁,
              erase_append_right _ (mt mem_of_mem_erase ha'), erase_cons_head]
      else
        by rw [erase_append_right _ h₁, erase_append_right _ h₁, erase_append_right _ ha',
              erase_cons_tail _ ab, erase_cons_head]
    else by simp only [erase_of_not_mem hb, erase_of_not_mem (mt mem_of_mem_erase hb)]
    else by simp only [erase_of_not_mem ha, erase_of_not_mem (mt mem_of_mem_erase ha)]

  end erase

  theorem Sublist.erase (a : α) {l₁ l₂ : List α} (h : l₁ <+ l₂) : l₁.erase a <+ l₂.erase a := by
      simp [erase_eq_erasep]; exact Sublist.erasep h

  section diff
    protected noncomputable def diff : List α → List α → List α
    | l , []    => l
    | l₁, a::l₂ => if a ∈ l₁ then List.diff (l₁.erase a) l₂ else List.diff l₁ l₂

    @[simp] theorem diff_nil (l : List α) : l.diff [] = l := rfl

    @[simp] theorem diff_cons (l₁ l₂ : List α) (a : α) : l₁.diff (a::l₂) = (l₁.erase a).diff l₂ :=
      if h : a ∈ l₁ then by simp only [List.diff, if_pos h]
      else by simp only [List.diff, if_neg h, erase_of_not_mem h]

    theorem diff_cons_right (l₁ l₂ : List α) (a : α) : l₁.diff (a::l₂) = (l₁.diff l₂).erase a := by
      induction l₂ generalizing l₁ with
      | nil => simp
      | cons b l₂ ih =>
        rw [diff_cons, diff_cons, erase_comm, ←diff_cons, ih, ←diff_cons]

    theorem diff_erase (l₁ l₂ : List α) (a : α) : (l₁.diff l₂).erase a = (l₁.erase a).diff l₂ := by
      rw [←diff_cons_right, diff_cons]

    @[simp] theorem nil_diff (l : List α) : [].diff l = [] := by
      induction l with
      | nil => rfl
      | cons a l ih =>
        simp only [diff_cons, erase_of_not_mem (not_mem_nil _), ih]

  end diff

  @[simp] def repeat (a : α) : Nat → List α
  | 0          => []
  | Nat.succ n => a :: repeat a n

  namespace repeat

    @[simp] theorem length_append (s t : List α) : length (s ++ t) = length s + length t := by
      induction s with
      | nil => simp only [nil_append, length_nil, Nat.zero_add]
      | cons a s ih => simp [Nat.succ_add]

    @[simp] theorem length_repeat (a : α) (n : Nat) : length (repeat a n) = n := by
      induction n with
      | zero => rfl
      | succ n ih => simp [ih]

    @[simp] theorem repeat_sublist_repeat (a : α) {m n} : repeat a m <+ repeat a n ↔ m ≤ n :=
      ⟨fun h => by
        rw [←length_repeat a m, ←length_repeat a n]
        exact Sublist.length_le_of_sublist h,
      fun h => by
        induction h with
        | refl => exact Sublist.refl _
        | step k ih => simp; exact Sublist.cons _ _ a ih⟩

    @[simp] theorem repeat_succ (a : α) (n) : repeat a (n + 1) = a :: repeat a n := rfl

    theorem mem_repeat {a b : α} : ∀ {n : Nat}, b ∈ repeat a n ↔ n ≠ 0 ∧ b = a
    | 0     => by simp
    | n + 1 => by
      simp [mem_repeat, Nat.succ_ne_zero, List.mem_cons_iff]
      exact ⟨fun h => by
        cases h with
        | inl h => exact h
        | inr h => exact h.right,
        Or.inl⟩

    theorem eq_of_mem_repeat {a b : α} {n} (h :  b ∈ repeat a n) : b = a :=
      (mem_repeat.mp h).right

    theorem eq_repeat_of_mem {a : α} : ∀ {l : List α}, (∀ b ∈ l, b = a) → l = repeat a l.length
    | []  , _ => rfl
    | b::l, h => by
      have ⟨h₁, h₂⟩ := forall_mem_cons.mp h
      simp only [length, repeat, cons.injEq]; exact ⟨h₁, eq_repeat_of_mem h₂⟩

    theorem eq_repeat' {a : α} {l : List α} : l = repeat a l.length ↔ ∀ b ∈ l, b = a :=
      ⟨fun h => h.symm ▸ fun b => eq_of_mem_repeat, eq_repeat_of_mem⟩

    theorem eq_repeat {a : α} {n} {l : List α} : l = repeat a n ↔ length l = n ∧ ∀ b ∈ l, b = a :=
      ⟨fun h => h.symm ▸ ⟨length_repeat _ _, fun b => eq_of_mem_repeat⟩,
      fun ⟨e, al⟩ => e ▸ eq_repeat_of_mem al⟩

    theorem repeat_add (a : α) (m n) : repeat a (m + n) = repeat a m ++ repeat a n := by
      induction m with
      | zero   => simp
      | succ m ih => simp [Nat.succ_add, ih]

    theorem repeat_subset_singleton (a : α) (n) : repeat a n ⊆ [a] := fun b h => by
      rw [eq_of_mem_repeat h]; exact List.self_singleton a

  end repeat

  def countp (p : α → Prop) [DecidablePred p] : List α → Nat
  | []    => 0
  | x::xs => if p x then Nat.succ (countp p xs) else countp p xs

  section countp
    variable (p : α → Prop)

    @[simp] theorem countp_nil : countp p [] = 0 := rfl

    @[simp] theorem countp_cons_of_pos {a : α} (l : List α) (pa : p a) : countp p (a::l) = countp p l + 1 :=
      if_pos pa

    @[simp] theorem countp_cons_of_neg {a : α} (l : List α) (pa : ¬ p a) : countp p (a::l) = countp p l :=
      if_neg pa

    theorem countp_eq_length_filter' (l : List α) : countp p l = length (filter' p l) := by
      induction l with
      | nil => rfl
      | cons x l ih =>
        byCases h : p x
        simp only [filter'_cons_of_pos _ h, countp, ih, if_pos h, length]
        simp only [countp_cons_of_neg _ _ h, ih, filter'_cons_of_neg _ h]

    theorem countp_pos {l : List α} : 0 < countp p l ↔ ∃ a ∈ l, p a := by
      rw [countp_eq_length_filter', length_pos_iff_exists_mem]
      simp only [mem_filter']; exact Iff.rfl

  end countp

  theorem Sublist.countp_le {l₁ l₂ : List α} (s : l₁ <+ l₂) : countp p l₁ ≤ countp p l₂ := by
    simp only [countp_eq_length_filter']
    exact length_le_of_sublist (@Sublist.filter' _ p _ _ s)

  def count [DecidableEq α] (a : α) : List α → Nat := countp (Eq a)

  theorem Sublist.count_le {l₁ l₂ : List α} (h : l₁ <+ l₂) (a : α) : count a l₁ ≤ count a l₂ :=
    @Sublist.countp_le α (Eq a) _ _ h

  namespace count

    @[simp] theorem count_nil (a : α) : count a [] = 0 := rfl

    @[simp] theorem count_cons_of_pos (a : α) (l : List α) : count a (a::l) = count a l + 1 :=
      countp_cons_of_pos _ l rfl

    @[simp] theorem count_cons_of_neg {a b : α} (h : a ≠ b) (l : List α) : count a (b::l) = count a l :=
      countp_cons_of_neg _ l h

    @[simp] theorem count_repeat (a : α) (n : Nat) : count a (repeat a n) = n := by
      simp only [count] rw [countp_eq_length_filter', filter'_eq_self.mpr, repeat.length_repeat]
      exact fun b m => (repeat.eq_of_mem_repeat m).symm

    theorem le_count_iff_repeat_sublist {a : α} {l : List α} {n : Nat} :
      n ≤ count a l ↔ repeat a n <+ l :=
        ⟨fun h => by
          exact ((repeat.repeat_sublist_repeat a).mpr h).trans (by
            have : filter' (Eq a) l = repeat a (count a l) := repeat.eq_repeat.mpr
              ⟨by simp only [count, countp_eq_length_filter'],
              fun b m => (of_mem_filter' m).symm⟩
            rw [←this]; exact filter'_sublist _),
        fun h => by
          rw [←count_repeat a n]
          exact h.count_le a⟩

    theorem count_pos {a : α} {l : List α} : 0 < count a l ↔ a ∈ l := by
      simp only [count, countp_pos]
      exact ⟨fun ⟨_, h₁, h₂⟩ => h₂ ▸ h₁, fun h => ⟨a, h, rfl⟩⟩

  end count

  section bag_inter

    protected noncomputable def bag_inter : List α → List α → List α
    | []   , _  => []
    | _    , [] => []
    | a::l₁, l₂ => if a ∈ l₂ then a :: List.bag_inter l₁ (l₂.erase a) else List.bag_inter l₁ l₂

    @[simp] theorem nil_bag_inter (l : List α) : [].bag_inter l = [] := by
      cases l; repeat rfl

    @[simp] theorem bag_inter_nil (l : List α) : l.bag_inter [] = [] := by
      cases l; repeat rfl

    @[simp] theorem cons_bag_inter_of_pos (l₁ : List α) (h : a ∈ l₂) :
      (a :: l₁).bag_inter l₂ = a :: l₁.bag_inter (l₂.erase a) := by
      cases l₂; contradiction; exact if_pos h

    @[simp] theorem cons_bag_inter_of_neg (l₁ : List α) (h : a ∉ l₂) :
      (a :: l₁).bag_inter l₂ = l₁.bag_inter l₂ := by
        cases l₂; simp only [bag_inter_nil]
        simp only [erase_of_not_mem h, List.bag_inter, if_neg h]

    theorem bag_inter_sublist_left : ∀ l₁ l₂ : List α, l₁.bag_inter l₂ <+ l₁
    | []     , l₂ => by simp only [nil_bag_inter, Sublist.nil_sublist]
    | b :: l₁, l₂ => by
      byCases h : b ∈ l₂
      { rw [List.cons_bag_inter_of_pos _ h]
        exact (bag_inter_sublist_left _ _).cons_cons _ }
      { rw [List.cons_bag_inter_of_neg _ h]
        exact Sublist.sublist_cons_of_sublist b (bag_inter_sublist_left l₁ l₂) }

  end bag_inter
  section pw_filter
    variable (r : α → α → Prop)

    noncomputable def pw_filter : List α → List α
    | []      => []
    | x :: xs =>
      let xs := pw_filter xs
      if ∀ y ∈ xs, r x y then x :: xs else xs

    @[simp] theorem pw_filter_nil : pw_filter r [] = [] := rfl

    @[simp] theorem pw_filter_cons_of_pos {r} {a : α} {l : List α} (h : ∀ b ∈ pw_filter r l, r a b) :
      pw_filter r (a :: l) = a :: pw_filter r l := if_pos h

    @[simp] theorem pw_filter_cons_of_neg {r} {a : α} {l : List α} (h : ¬ ∀ b ∈ pw_filter r l, r a b) :
      pw_filter r (a :: l) = pw_filter r l := if_neg h

    theorem pw_filter_sublist : ∀ (l : List α), pw_filter r l <+ l
    | []     => Sublist.nil_sublist _
    | x :: l => by
      byCases h : ∀ y ∈ pw_filter r l, r x y
      { exact pw_filter_cons_of_pos h ▸ (pw_filter_sublist l).cons_cons _ }
      { exact pw_filter_cons_of_neg h ▸ Sublist.sublist_cons_of_sublist _ (pw_filter_sublist l) }

    theorem pw_filter_subset (l : List α) : pw_filter r l ⊆ l :=
      (pw_filter_sublist r _).subset

    theorem forall_mem_pw_filter {r} (neg_trans : ∀ {x y z}, r x z → r x y ∨ r y z)
      (a : α) (l : List α) : (∀ b ∈ pw_filter r l, r a b) ↔ ∀ b ∈ l, r a b :=
        ⟨by
          induction l with
          | nil => intros; contradiction
          | cons x l ih =>
            byCases h : ∀ y ∈ pw_filter r l, r x y
            { simp only [pw_filter_cons_of_pos h, forall_mem_cons, and_imp]
              exact fun r h => ⟨r, ih h⟩ }
            { simp only [pw_filter_cons_of_neg h, forall_mem_cons]
              exact fun ha => ⟨by
                simp only [not_forall] at h; let ⟨y, hy, hxy⟩ := h
                exact (neg_trans (ha y hy)).resolve_right hxy, ih ha⟩ },
        fun h b hb => h b (pw_filter_subset r l hb)⟩

  end pw_filter
  section dedup

    noncomputable def dedup : List α → List α := pw_filter (· ≠ ·)

    @[simp] theorem mem_dedup {a : α} {l : List α} : a ∈ dedup l ↔ a ∈ l :=
      ⟨(pw_filter_subset (· ≠ ·) l ·), fun ha => by
        have := not_iff_not.mpr (@forall_mem_pw_filter α (· ≠ ·) (fun hxz => by
          rw [←not_and_iff_or_not]; exact fun ⟨hxy, hyz⟩ => hxz (hxy.trans hyz)) a l)
        simp only [not_forall, iff_not_not] at this
        let ⟨y, hy, hay⟩ := this.mpr ⟨a, ha, rfl⟩; exact hay ▸ hy⟩

    theorem dedup_sublist : ∀ (l : List α), l.dedup <+ l := pw_filter_sublist _

  end dedup

  def disjoint (s t : List α) : Prop := ∀ x, x ∈ s → x ∉ t

  theorem disjoint.symm {s t : List α} : disjoint s t ↔ disjoint t s :=
    have : ∀ s t : List α, disjoint s t → disjoint t s :=
      fun s t h x ht hs => h x hs ht
    ⟨this s t, this t s⟩

  theorem disjoint_iff_ne {l₁ l₂ : List α} : disjoint l₁ l₂ ↔ ∀ a ∈ l₁, ∀ b ∈ l₂, a ≠ b :=
    ⟨fun h x hx y hy hxy => absurd hy (hxy ▸ h x hx), fun h x h₁ h₂ => absurd rfl (h x h₁ x h₂)⟩

end List


/-
Copyright (c) 2021 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov

! This file was ported from Lean 3 source module data.bool.set
! leanprover-community/mathlib commit ed60ee25ed00d7a62a0d1e5808092e1324cee451
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Bool.Basic
import Mathbin.Data.Set.Image

/-!
# Booleans and set operations

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

This file contains two trivial lemmas about `bool`, `set.univ`, and `set.range`.
-/

open Set

namespace Bool

#print Bool.univ_eq /-
@[simp]
theorem univ_eq : (univ : Set Bool) = {false, true} :=
  (eq_univ_of_forall Bool.dichotomy).symm
#align bool.univ_eq Bool.univ_eq
-/

#print Bool.range_eq /-
@[simp]
theorem range_eq {α : Type _} (f : Bool → α) : range f = {f false, f true} := by
  rw [← image_univ, univ_eq, image_pair]
#align bool.range_eq Bool.range_eq
-/

/- warning: bool.compl_singleton -> Bool.compl_singleton is a dubious translation:
lean 3 declaration is
  forall (b : Bool), Eq.{1} (Set.{0} Bool) (HasCompl.compl.{0} (Set.{0} Bool) (BooleanAlgebra.toHasCompl.{0} (Set.{0} Bool) (Set.booleanAlgebra.{0} Bool)) (Singleton.singleton.{0, 0} Bool (Set.{0} Bool) (Set.hasSingleton.{0} Bool) b)) (Singleton.singleton.{0, 0} Bool (Set.{0} Bool) (Set.hasSingleton.{0} Bool) (not b))
but is expected to have type
  forall (b : Bool), Eq.{1} (Set.{0} Bool) (HasCompl.compl.{0} (Set.{0} Bool) (BooleanAlgebra.toHasCompl.{0} (Set.{0} Bool) (Set.instBooleanAlgebraSet.{0} Bool)) (Singleton.singleton.{0, 0} Bool (Set.{0} Bool) (Set.instSingletonSet.{0} Bool) b)) (Singleton.singleton.{0, 0} Bool (Set.{0} Bool) (Set.instSingletonSet.{0} Bool) (not b))
Case conversion may be inaccurate. Consider using '#align bool.compl_singleton Bool.compl_singletonₓ'. -/
@[simp]
theorem compl_singleton (b : Bool) : ({b}ᶜ : Set Bool) = {!b} :=
  ext fun _ => eq_not_iff.symm
#align bool.compl_singleton Bool.compl_singleton

end Bool


import analysis.normed_space.conformal_linear_map
import analysis.calculus.times_cont_diff

noncomputable theory
open filter continuous_linear_map
open_locale real_inner_product_space classical filter topological_space

section conformality

lemma is_conformal_map.symm {R : Type*} {X Y : Type*} [nondiscrete_normed_field R]
  [normed_group X] [normed_group Y] [normed_space R X] [normed_space R Y]
  {f' : X ≃L[R] Y} (hf' : is_conformal_map (f' : X →L[R] Y)) :
  is_conformal_map (f'.symm : Y →L[R] X) :=
begin
  rcases hf' with ⟨c, hc, li, hli⟩,
  simp only [f'.coe_coe] at hli,
  have surj : li.to_linear_map.range = ⊤ :=
  begin
    refine linear_map.range_eq_top.mpr (λ y, ⟨c • f'.symm y, _⟩),
    simp only [li.coe_to_linear_map, li.map_smul],
    have : c • li (f'.symm y) = f' (f'.symm y) := by simp only [hli, pi.smul_apply],
    rw [this, f'.apply_symm_apply]
  end,
  let le := linear_equiv.of_bijective li.to_linear_map
    (linear_map.ker_eq_bot.mpr li.injective) surj,
  let lie : X ≃ₗᵢ[R] Y :=
  { to_linear_equiv := le,
    norm_map' := by simp },
  refine ⟨c⁻¹, inv_ne_zero hc, lie.symm.to_linear_isometry, _⟩,
  ext1 y,
  have key : (li : X → Y) = lie,
  { ext1 x,
    simp only [linear_isometry_equiv.coe_mk, linear_equiv.of_bijective_apply,
        li.coe_to_linear_map] },
  rw [f'.symm.coe_coe, f'.symm_apply_eq, hli],
  simp only [pi.smul_apply, function.comp_app, li.map_smul, lie.symm.coe_to_linear_isometry],
  rw [key, lie.apply_symm_apply, smul_smul, mul_inv_cancel hc, one_smul]
end

end conformality

section similarity_all

variables {E F : Type*} [inner_product_space ℝ E] [inner_product_space ℝ F]

section similarity1

def similarity_factor (x : E) {f' : E →L[ℝ] F} (h : is_conformal_map f') : ℝ :=
classical.some ((is_conformal_map_iff _).mp h)

lemma similarity_factor_prop (x : E) {f' : E →L[ℝ] F} (h : is_conformal_map f') :
  0 < similarity_factor x h ∧ ∀ u v, ⟪f' u, f' v⟫ = (similarity_factor x h) * ⟪u, v⟫ :=
classical.some_spec ((is_conformal_map_iff _).mp h)

lemma is_conformal_map_of_eq {f' : E →L[ℝ] F} {f'' : E →L[ℝ] F}
  (hf' : is_conformal_map f') (H : f' = f'') : is_conformal_map f'' :=
H ▸ hf'

lemma similarity_factor_eq_of_eq [nontrivial E] {x : E} {f' : E →L[ℝ] F} {f'' : E →L[ℝ] F}
  (hf' : is_conformal_map f') (H : f' = f'') :
  similarity_factor x (is_conformal_map_of_eq hf' H) = similarity_factor x hf' :=
begin
  rcases exists_ne (0 : E) with ⟨u, hu⟩,
  have minor₁ := (similarity_factor_prop x hf').2 u u,
  have minor₂ := (similarity_factor_prop x $ is_conformal_map_of_eq hf' H).2 u u,
  have minor₃ : ⟪u, u⟫ ≠ 0 := λ w, hu (inner_self_eq_zero.mp w),
  have key : ⟪f' u, f' u⟫ = ⟪f'' u, f'' u⟫ := by rw H,
  rw [minor₁, minor₂] at key,
  exact mul_right_cancel' minor₃ key.symm
end

variables {f' : E → (E →L[ℝ] F)}

/-- TODO: refine the hypothesis `h` -/
lemma similarity_factor_times_cont_diff_at [nontrivial E] (x : E)
  (h : ∀ y, is_conformal_map $ f' y) {n : ℕ} (H : times_cont_diff_at ℝ n f' x) :
  times_cont_diff_at ℝ n (λ y, similarity_factor y $ h y) x :=
begin
  rcases exists_ne (0 : E) with ⟨v, hv⟩,
  have minor₁ : ∥v∥ ≠ 0 := λ w, hv (norm_eq_zero.mp w),
  have minor₂ : ∀ y, similarity_factor y (h y) = ∥f' y v∥ ^ 2 / ∥v∥ ^ 2 :=
  λ y, by rw [← mul_div_cancel (similarity_factor y $ h y) (pow_ne_zero 2 minor₁), pow_two,
              ← real_inner_self_eq_norm_sq, ← (similarity_factor_prop y $ h y).2,
              real_inner_self_eq_norm_sq, ← pow_two],
  have minor₃ : (λ x, similarity_factor x $ h x) =
    λ x, ∥(λ y, ((apply ℝ F v) ∘ f') y) x∥ ^ 2 / ∥v∥ ^ 2,
  { ext1 x,
    simp only [minor₂ x, apply_apply, function.comp_app] },
  rw [minor₃],
  apply times_cont_diff_at.div_const,
  apply times_cont_diff_at.norm_sq,
  simp only [congr_arg],
  exact times_cont_diff_at.comp _ (apply ℝ F v).times_cont_diff.times_cont_diff_at H
end

end similarity1

section similarity2

def similarity_factor_sqrt (x : E) {f' : E →L[ℝ] F} (h : is_conformal_map f') : ℝ :=
real.sqrt (similarity_factor x h)

lemma similarity_factor_sqrt_eq' {x : E} {f' : E →L[ℝ] F} (h : is_conformal_map f') :
  similarity_factor_sqrt x h ^ 2 = similarity_factor x h :=
by simp only [similarity_factor_sqrt, real.sq_sqrt (le_of_lt (similarity_factor_prop x h).1)]

lemma similarity_factor_sqrt_prop (x : E) {f' : E →L[ℝ] F} (h : is_conformal_map f') :
  similarity_factor_sqrt x h ≠ 0 ∧
  ∀ u v, ⟪f' u, f' v⟫ = (similarity_factor_sqrt x h) ^ 2 * ⟪u, v⟫ :=
begin
  refine ⟨real.sqrt_ne_zero'.mpr (similarity_factor_prop x h).1, λ u v, _⟩,
  simp only [(similarity_factor_prop x h).2, similarity_factor_sqrt,
             real.sq_sqrt (le_of_lt (similarity_factor_prop x h).1)]
end

variables {f' : E → (E →L[ℝ] F)}

/-- TODO: refine the hypothesis `h` -/
lemma similarity_factor_sqrt_times_cont_diff_at [nontrivial E] (x : E)
  (h : ∀ y, is_conformal_map $ f' y) {n : ℕ} (H : times_cont_diff_at ℝ n f' x) :
  times_cont_diff_at ℝ n (λ y, similarity_factor_sqrt y $ h y) x :=
begin
  simp only [similarity_factor_sqrt],
  refine times_cont_diff_at.sqrt _ (ne_of_gt (similarity_factor_prop x $ h x).1),
  exact similarity_factor_times_cont_diff_at x h H
end

lemma similarity_factor_sqrt_eq (h : ∀ y, is_conformal_map $ f' y) :
  (λ x, (similarity_factor_sqrt x $ h x) ^ 2) = (λ x, similarity_factor x $ h x) :=
begin
  ext1 y,
  simp only [similarity_factor_sqrt, real.sq_sqrt (le_of_lt (similarity_factor_prop y $ h y).1)]
end

lemma similarity_factor_sqrt_eq_of_eq [nontrivial E] {x : E}
  {f' : E →L[ℝ] F} {f'' : E →L[ℝ] F} (hf' : is_conformal_map f') (H : f' = f'') :
  similarity_factor_sqrt x (is_conformal_map_of_eq hf' H) = similarity_factor_sqrt x hf' :=
by simp only [similarity_factor_sqrt, similarity_factor_eq_of_eq]

end similarity2

section similarity3

def similarity_factor_sqrt_inv (x : E) {f' : E →L[ℝ] F} (h : is_conformal_map f') : ℝ :=
(similarity_factor_sqrt x h)⁻¹

lemma similarity_factor_sqrt_inv_eq' (x : E) {f' : E →L[ℝ] F} (h : is_conformal_map f') :
  (similarity_factor_sqrt_inv x h)⁻¹ ^ 2 = similarity_factor x h :=
by simp only [similarity_factor_sqrt_inv, similarity_factor_sqrt,
              inv_inv', real.sq_sqrt (le_of_lt (similarity_factor_prop x h).1)]

lemma similarity_factor_sqrt_inv_prop (x : E) {f' : E →L[ℝ] F} (h : is_conformal_map f') :
  similarity_factor_sqrt_inv x h ≠ 0 ∧
  ∀ u v, ⟪f' u, f' v⟫ = ((similarity_factor_sqrt_inv x h)⁻¹) ^ 2 * ⟪u, v⟫ :=
begin
  refine ⟨inv_ne_zero (similarity_factor_sqrt_prop x h).1, λ u v, _⟩,
  simp only [(similarity_factor_sqrt_prop x h).2, similarity_factor_sqrt_inv, inv_inv']
end

variables {f' : E → (E →L[ℝ] F)}

/-- TODO: refine the hypothesis `h` -/
lemma similarity_factor_sqrt_inv_eq (h : ∀ y, is_conformal_map $ f' y) :
  (λ x, (similarity_factor_sqrt_inv x $ h x)⁻¹ ^ 2) = (λ x, similarity_factor x $ h x) :=
begin
  ext1 y,
  simp only [similarity_factor_sqrt_inv, inv_inv'],
  have := congr_fun (similarity_factor_sqrt_eq h) y,
  simpa [congr_arg] using this
end

lemma similarity_factor_sqrt_inv_eq_of_eq [nontrivial E] {x : E}
  {f' : E →L[ℝ] F} {f'' : E →L[ℝ] F} (hf' : is_conformal_map f') (H : f' = f'') :
  similarity_factor_sqrt_inv x (is_conformal_map_of_eq hf' H) = similarity_factor_sqrt_inv x hf' :=
by simp only [similarity_factor_sqrt_inv, similarity_factor_sqrt_eq_of_eq]

/-- TODO: refine the hypothesis `h` -/
lemma similarity_factor_sqrt_inv_eq_comp_inv (h : ∀ y, is_conformal_map $ f' y) :
  (λ x, similarity_factor_sqrt_inv x $ h x) = (λ x, x⁻¹) ∘ (λ x, similarity_factor_sqrt x $ h x) :=
begin
  ext1,
  simp only [function.comp_app, similarity_factor_sqrt_inv]
end

/-- TODO: refine the hypothesis `h` -/
lemma similarity_factor_sqrt_inv_times_cont_diff_at [nontrivial E] (x : E)
  (h : ∀ y, is_conformal_map $ f' y) {n : ℕ} (H : times_cont_diff_at ℝ n f' x) :
  times_cont_diff_at ℝ n (λ x, similarity_factor_sqrt_inv x $ h x) x :=
begin
  simp only [similarity_factor_sqrt_inv],
  refine times_cont_diff_at.inv _ (similarity_factor_sqrt_prop x $ h x).1,
  exact similarity_factor_sqrt_times_cont_diff_at x h H
end

/-- TODO: refine the hypothesis `h` -/
lemma similarity_factor_sqrt_inv_fderiv [nontrivial E] (x : E) (h : ∀ y, is_conformal_map $ f' y)
  {n : ℕ} (hn : 0 < n) (H : times_cont_diff_at ℝ n f' x) :
  (fderiv ℝ (λ y, similarity_factor_sqrt_inv y $ h y) x : E → ℝ) =
  -(fderiv ℝ (λ y, similarity_factor_sqrt y $ h y) x) * (λ y, (similarity_factor x $ h x)⁻¹) :=
begin
  have minor₁ := (similarity_factor_sqrt_prop x $ h x).1,
  have minor₂ : (1 : with_top ℕ) ≤ n :=
    by { apply with_top.coe_le_coe.mpr, linarith [hn] },
  have minor₃ := (similarity_factor_sqrt_times_cont_diff_at x h H).differentiable_at minor₂,
  rw [similarity_factor_sqrt_inv_eq_comp_inv, fderiv.comp _ (differentiable_at_inv _), fderiv_inv];
  [skip, exact minor₁, exact minor₃, exact minor₁],
  simp only [continuous_linear_map.coe_comp'],
  ext1 y,
  simp only [function.comp_app, continuous_linear_map.smul_right_apply,
             continuous_linear_map.one_apply, smul_eq_mul, pi.mul_apply,
             pi.neg_apply, pi.inv_apply],
  rw [similarity_factor_sqrt_eq' (h x), neg_mul_comm]
end

end similarity3

end similarity_all


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro, Patrick Massot

Specific classes of maps between topological spaces: embeddings, open maps, quotient maps.
-/
import topology.order topology.separation
noncomputable theory

open set filter lattice
local attribute [instance] classical.prop_decidable

variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*}

section embedding

/-- A function between topological spaces is an embedding if it is injective,
  and for all `s : set α`, `s` is open iff it is the preimage of an open set. -/
def embedding [tα : topological_space α] [tβ : topological_space β] (f : α → β) : Prop :=
function.injective f ∧ tα = tβ.induced f

variables [topological_space α] [topological_space β] [topological_space γ] [topological_space δ]

lemma embedding_id : embedding (@id α) :=
⟨assume a₁ a₂ h, h, induced_id.symm⟩

lemma embedding_compose {f : α → β} {g : β → γ} (hf : embedding f) (hg : embedding g) :
  embedding (g ∘ f) :=
⟨assume a₁ a₂ h, hf.left $ hg.left h, by rw [hf.right, hg.right, induced_compose]⟩

lemma embedding_prod_mk {f : α → β} {g : γ → δ} (hf : embedding f) (hg : embedding g) :
  embedding (λx:α×γ, (f x.1, g x.2)) :=
⟨assume ⟨x₁, x₂⟩ ⟨y₁, y₂⟩, by simp; exact assume h₁ h₂, ⟨hf.left h₁, hg.left h₂⟩,
  by rw [prod.topological_space, prod.topological_space, hf.right, hg.right,
         induced_compose, induced_compose, induced_sup, induced_compose, induced_compose]⟩

lemma embedding_of_embedding_compose {f : α → β} {g : β → γ} (hf : continuous f) (hg : continuous g)
  (hgf : embedding (g ∘ f)) : embedding f :=
⟨assume a₁ a₂ h, hgf.left $ by simp [h, (∘)],
  le_antisymm
    (by rw [hgf.right, ← continuous_iff_induced_le];
        apply continuous_induced_dom.comp hg)
    (by rwa ← continuous_iff_induced_le)⟩

lemma embedding_open {f : α → β} {s : set α}
  (hf : embedding f) (h : is_open (range f)) (hs : is_open s) : is_open (f '' s) :=
let ⟨t, ht, h_eq⟩ := by rw [hf.right] at hs; exact hs in
have is_open (t ∩ range f), from is_open_inter ht h,
h_eq ▸ by rwa [image_preimage_eq_inter_range]

lemma embedding_is_closed {f : α → β} {s : set α}
  (hf : embedding f) (h : is_closed (range f)) (hs : is_closed s) : is_closed (f '' s) :=
let ⟨t, ht, h_eq⟩ := by rw [hf.right, is_closed_induced_iff] at hs; exact hs in
have is_closed (t ∩ range f), from is_closed_inter ht h,
h_eq.symm ▸ by rwa [image_preimage_eq_inter_range]

lemma embedding.map_nhds_eq [topological_space α] [topological_space β] {f : α → β}
  (hf : embedding f) (a : α) (h : range f ∈ nhds (f a)) : (nhds a).map f = nhds (f a) :=
by rw [hf.2]; exact map_nhds_induced_eq h

lemma embedding.tendsto_nhds_iff {ι : Type*}
  {f : ι → β} {g : β → γ} {a : filter ι} {b : β} (hg : embedding g) :
  tendsto f a (nhds b) ↔ tendsto (g ∘ f) a (nhds (g b)) :=
by rw [tendsto, tendsto, hg.right, nhds_induced_eq_comap, ← map_le_iff_le_comap, filter.map_map]

lemma embedding.continuous_iff {f : α → β} {g : β → γ} (hg : embedding g) :
  continuous f ↔ continuous (g ∘ f) :=
by simp [continuous_iff_continuous_at, continuous_at, embedding.tendsto_nhds_iff hg]

lemma embedding.continuous {f : α → β} (hf : embedding f) : continuous f :=
hf.continuous_iff.mp continuous_id

lemma embedding.closure_eq_preimage_closure_image {e : α → β} (he : embedding e) (s : set α) :
  closure s = e ⁻¹' closure (e '' s) :=
by ext x; rw [set.mem_preimage_eq, ← closure_induced he.1, he.2]

end embedding

-- TODO: use embeddings from above!
structure dense_embedding [topological_space α] [topological_space β] (e : α → β) : Prop :=
(dense   : ∀x, x ∈ closure (range e))
(inj     : function.injective e)
(induced : ∀a, comap e (nhds (e a)) = nhds a)

theorem dense_embedding.mk'
  [topological_space α] [topological_space β] (e : α → β)
  (c     : continuous e)
  (dense : ∀x, x ∈ closure (range e))
  (inj   : function.injective e)
  (H     : ∀ (a:α) s ∈ nhds a,
    ∃t ∈ nhds (e a), ∀ b, e b ∈ t → b ∈ s) :
  dense_embedding e :=
⟨dense, inj, λ a, le_antisymm
  (by simpa [le_def] using H a)
  (tendsto_iff_comap.1 $ c.tendsto _)⟩

namespace dense_embedding
variables [topological_space α] [topological_space β]
variables {e : α → β} (de : dense_embedding e)

protected lemma embedding (de : dense_embedding e) : embedding e :=
⟨de.inj, eq_of_nhds_eq_nhds begin intro a, rw [← de.induced a, nhds_induced_eq_comap] end⟩

protected lemma continuous_at (de : dense_embedding e) {a : α} : continuous_at e a :=
by rw [continuous_at, ←de.induced a]; exact tendsto_comap

protected lemma continuous (de : dense_embedding e) {a : α} : continuous e :=
continuous_iff_continuous_at.mpr $ λ a, de.continuous_at

lemma inj_iff (de : dense_embedding e) {x y} : e x = e y ↔ x = y := de.inj.eq_iff

lemma closure_range : closure (range e) = univ :=
let h := de.dense in
set.ext $ assume x, ⟨assume _, trivial, assume _, @h x⟩

lemma self_sub_closure_image_preimage_of_open {s : set β} (de : dense_embedding e) :
  is_open s → s ⊆ closure (e '' (e ⁻¹' s)) :=
begin
  intros s_op b b_in_s,
  rw [image_preimage_eq_inter_range, mem_closure_iff],
  intros U U_op b_in,
  rw ←inter_assoc,
  have ne_e : U ∩ s ≠ ∅ := ne_empty_of_mem ⟨b_in, b_in_s⟩,
  exact (dense_iff_inter_open.1 de.closure_range) _ (is_open_inter U_op s_op) ne_e
end

lemma closure_image_nhds_of_nhds {s : set α} {a : α} (de : dense_embedding e) :
  s ∈ nhds a → closure (e '' s) ∈ nhds (e a) :=
begin
  rw [← de.induced a, mem_comap_sets],
  intro h,
  rcases h with ⟨t, t_nhd, sub⟩,
  rw mem_nhds_sets_iff at t_nhd,
  rcases t_nhd with ⟨U, U_sub, ⟨U_op, e_a_in_U⟩⟩,
  have := calc e ⁻¹' U ⊆ e⁻¹' t : preimage_mono U_sub
                   ... ⊆ s      : sub,
  have := calc U ⊆ closure (e '' (e ⁻¹' U)) : self_sub_closure_image_preimage_of_open de U_op
             ... ⊆ closure (e '' s)         : closure_mono (image_subset e this),
  have U_nhd : U ∈ nhds (e a) := mem_nhds_sets U_op e_a_in_U,
  exact (nhds (e a)).sets_of_superset U_nhd this
end

variables [topological_space δ] {f : γ → α} {g : γ → δ} {h : δ → β}
/--
 γ -f→ α
g↓     ↓e
 δ -h→ β
-/
lemma tendsto_comap_nhds_nhds  {d : δ} {a : α} (de : dense_embedding e) (H : tendsto h (nhds d) (nhds (e a)))
  (comm : h ∘ g = e ∘ f) : tendsto f (comap g (nhds d)) (nhds a) :=
begin
  have lim1 : map g (comap g (nhds d)) ≤ nhds d := map_comap_le,
  replace lim1 : map h (map g (comap g (nhds d))) ≤ map h (nhds d) := map_mono lim1,
  rw [filter.map_map, comm, ← filter.map_map, map_le_iff_le_comap] at lim1,
  have lim2 :  comap e (map h (nhds d)) ≤  comap e  (nhds (e a)) := comap_mono H,
  rw de.induced at lim2,
  exact le_trans lim1 lim2,
end

protected lemma nhds_inf_neq_bot (de : dense_embedding e) {b : β} : nhds b ⊓ principal (range e) ≠ ⊥ :=
begin
  have h := de.dense,
  simp [closure_eq_nhds] at h,
  exact h _
end

lemma comap_nhds_neq_bot (de : dense_embedding e) {b : β} : comap e (nhds b) ≠ ⊥ :=
forall_sets_neq_empty_iff_neq_bot.mp $
assume s ⟨t, ht, (hs : e ⁻¹' t ⊆ s)⟩,
have t ∩ range e ∈ nhds b ⊓ principal (range e),
  from inter_mem_inf_sets ht (subset.refl _),
let ⟨_, ⟨hx₁, y, rfl⟩⟩ := inhabited_of_mem_sets de.nhds_inf_neq_bot this in
subset_ne_empty hs $ ne_empty_of_mem hx₁

variables [topological_space γ]
/-- If `e : α → β` is a dense embedding, then any function `α → γ` extends to a function `β → γ`.
It only extends the parts of `β` which are not mapped by `e`, everything else equal to `f (e a)`.
This allows us to gain equality even if `γ` is not T2. -/
def extend (de : dense_embedding e) (f : α → γ) (b : β) : γ :=
have nonempty γ, from
  let ⟨_, ⟨_, a, _⟩⟩ := exists_mem_of_ne_empty (mem_closure_iff.1 (de.dense b) _ is_open_univ trivial) in
  ⟨f a⟩,
if hb : b ∈ range e
then f (classical.some hb)
else @lim _ _ (classical.inhabited_of_nonempty this) (map f (comap e (nhds b)))

lemma extend_e_eq {f : α → γ} (a : α) : de.extend f (e a) = f a :=
have e a ∈ range e := ⟨a, rfl⟩,
begin
  simp [extend, this],
  congr,
  refine classical.some_spec2 (λx, x = a) _,
  exact assume a h, de.inj h
end

lemma extend_eq [t2_space γ] {b : β} {c : γ} {f : α → γ} (hf : map f (comap e (nhds b)) ≤ nhds c) :
  de.extend f b = c :=
begin
  by_cases hb : b ∈ range e,
  { rcases hb with ⟨a, rfl⟩,
    rw [extend_e_eq],
    have f_a_c : tendsto f (pure a) (nhds c),
    { rw [de.induced] at hf,
      refine le_trans (map_mono _) hf,
      exact pure_le_nhds a },
    have f_a_fa : tendsto f (pure a) (nhds (f a)),
    { rw [tendsto, filter.map_pure], exact pure_le_nhds _  },
    exact tendsto_nhds_unique pure_neq_bot f_a_fa f_a_c },
  { simp [extend, hb],
    exact @lim_eq _ _ (id _) _ _ _ (by simp; exact comap_nhds_neq_bot de) hf }
end

lemma tendsto_extend [regular_space γ] {b : β} {f : α → γ} (de : dense_embedding e)
  (hf : {b | ∃c, tendsto f (comap e $ nhds b) (nhds c)} ∈ nhds b) :
  tendsto (de.extend f) (nhds b) (nhds (de.extend f b)) :=
let φ := {b | tendsto f (comap e $ nhds b) (nhds $ de.extend f b)} in
have hφ : φ ∈ nhds b,
  from (nhds b).sets_of_superset hf $ assume b ⟨c, hc⟩,
    show tendsto f (comap e (nhds b)) (nhds (de.extend f b)), from (de.extend_eq hc).symm ▸ hc,
assume s hs,
let ⟨s'', hs''₁, hs''₂, hs''₃⟩ := nhds_is_closed hs in
let ⟨s', hs'₁, (hs'₂ : e ⁻¹' s' ⊆ f ⁻¹' s'')⟩ := mem_of_nhds hφ hs''₁ in
let ⟨t, (ht₁ : t ⊆ φ ∩ s'), ht₂, ht₃⟩ := mem_nhds_sets_iff.mp $ inter_mem_sets hφ hs'₁ in
have h₁ : closure (f '' (e ⁻¹' s')) ⊆ s'',
  by rw [closure_subset_iff_subset_of_is_closed hs''₃, image_subset_iff]; exact hs'₂,
have h₂ : t ⊆ de.extend f ⁻¹' closure (f '' (e ⁻¹' t)), from
  assume b' hb',
  have nhds b' ≤ principal t, by simp; exact mem_nhds_sets ht₂ hb',
  have map f (comap e (nhds b')) ≤ nhds (de.extend f b') ⊓ principal (f '' (e ⁻¹' t)),
    from calc _ ≤ map f (comap e (nhds b' ⊓ principal t)) : map_mono $ comap_mono $ le_inf (le_refl _) this
      ... ≤ map f (comap e (nhds b')) ⊓ map f (comap e (principal t)) :
        le_inf (map_mono $ comap_mono $ inf_le_left) (map_mono $ comap_mono $ inf_le_right)
      ... ≤ map f (comap e (nhds b')) ⊓ principal (f '' (e ⁻¹' t)) : by simp [le_refl]
      ... ≤ _ : inf_le_inf ((ht₁ hb').left) (le_refl _),
  show de.extend f b' ∈ closure (f '' (e ⁻¹' t)),
  begin
    rw [closure_eq_nhds],
    apply neq_bot_of_le_neq_bot _ this,
    simp,
    exact de.comap_nhds_neq_bot
  end,
(nhds b).sets_of_superset
  (show t ∈ nhds b, from mem_nhds_sets ht₂ ht₃)
  (calc t ⊆ de.extend f ⁻¹' closure (f '' (e ⁻¹' t)) : h₂
    ... ⊆ de.extend f ⁻¹' closure (f '' (e ⁻¹' s')) :
      preimage_mono $ closure_mono $ image_subset f $ preimage_mono $ subset.trans ht₁ $ inter_subset_right _ _
    ... ⊆ de.extend f ⁻¹' s'' : preimage_mono h₁
    ... ⊆ de.extend f ⁻¹' s : preimage_mono hs''₂)

lemma continuous_extend [regular_space γ] {f : α → γ} (de : dense_embedding e)
  (hf : ∀b, ∃c, tendsto f (comap e (nhds b)) (nhds c)) : continuous (de.extend f) :=
continuous_iff_continuous_at.mpr $ assume b, de.tendsto_extend $ univ_mem_sets' hf

end dense_embedding

/-- A function between topological spaces is a quotient map if it is surjective,
  and for all `s : set β`, `s` is open iff its preimage is an open set. -/
def quotient_map {α : Type*} {β : Type*} [tα : topological_space α] [tβ : topological_space β] (f : α → β) : Prop :=
function.surjective f ∧ tβ = tα.coinduced f

namespace quotient_map
variables [topological_space α] [topological_space β] [topological_space γ] [topological_space δ]

protected lemma id : quotient_map (@id α) :=
⟨assume a, ⟨a, rfl⟩, coinduced_id.symm⟩

protected lemma comp {f : α → β} {g : β → γ} (hf : quotient_map f) (hg : quotient_map g) :
  quotient_map (g ∘ f) :=
⟨function.surjective_comp hg.left hf.left, by rw [hg.right, hf.right, coinduced_compose]⟩

protected lemma of_quotient_map_compose {f : α → β} {g : β → γ}
  (hf : continuous f) (hg : continuous g)
  (hgf : quotient_map (g ∘ f)) : quotient_map g :=
⟨assume b, let ⟨a, h⟩ := hgf.left b in ⟨f a, h⟩,
  le_antisymm
    (by rwa ← continuous_iff_le_coinduced)
    (by rw [hgf.right, ← continuous_iff_le_coinduced];
        apply hf.comp continuous_coinduced_rng)⟩

protected lemma continuous_iff {f : α → β} {g : β → γ} (hf : quotient_map f) :
  continuous g ↔ continuous (g ∘ f) :=
by rw [continuous_iff_le_coinduced, continuous_iff_le_coinduced, hf.right, coinduced_compose]

protected lemma continuous {f : α → β} (hf : quotient_map f) : continuous f :=
hf.continuous_iff.mp continuous_id

end quotient_map

section is_open_map
variables [topological_space α] [topological_space β]

def is_open_map (f : α → β) := ∀ U : set α, is_open U → is_open (f '' U)

lemma is_open_map_iff_nhds_le (f : α → β) : is_open_map f ↔ ∀(a:α), nhds (f a) ≤ (nhds a).map f :=
begin
  split,
  { assume h a s hs,
    rcases mem_nhds_sets_iff.1 hs with ⟨t, hts, ht, hat⟩,
    exact filter.mem_sets_of_superset
      (mem_nhds_sets (h t ht) (mem_image_of_mem _ hat))
      (image_subset_iff.2 hts) },
  { refine assume h s hs, is_open_iff_mem_nhds.2 _,
    rintros b ⟨a, ha, rfl⟩,
    exact h _ (filter.image_mem_map $ mem_nhds_sets hs ha) }
end

end is_open_map

namespace is_open_map
variables [topological_space α] [topological_space β] [topological_space γ]
open function

protected lemma id : is_open_map (@id α) := assume s hs, by rwa [image_id]

protected lemma comp
  {f : α → β} {g : β → γ} (hf : is_open_map f) (hg : is_open_map g) : is_open_map (g ∘ f) :=
by intros s hs; rw [image_comp]; exact hg _ (hf _ hs)

lemma of_inverse {f : α → β} {f' : β → α}
  (h : continuous f') (l_inv : left_inverse f f') (r_inv : right_inverse f f') :
  is_open_map f :=
assume s hs,
have f' ⁻¹' s = f '' s, by ext x; simp [mem_image_iff_of_inverse r_inv l_inv],
this ▸ h s hs

lemma to_quotient_map {f : α → β}
  (open_map : is_open_map f) (cont : continuous f) (surj : function.surjective f) :
  quotient_map f :=
⟨ surj,
  begin
    ext s,
    show is_open s ↔ is_open (f ⁻¹' s),
    split,
    { exact cont s },
    { assume h,
      rw ← @image_preimage_eq _ _ _ s surj,
      exact open_map _ h }
  end⟩

end is_open_map

section sierpinski
variables [topological_space α]

@[simp] lemma is_open_singleton_true : is_open ({true} : set Prop) :=
topological_space.generate_open.basic _ (by simp)

lemma continuous_Prop {p : α → Prop} : continuous p ↔ is_open {x | p x} :=
⟨assume h : continuous p,
  have is_open (p ⁻¹' {true}),
    from h _ is_open_singleton_true,
  by simp [preimage, eq_true] at this; assumption,
  assume h : is_open {x | p x},
  continuous_generated_from $ assume s (hs : s ∈ {{true}}),
    by simp at hs; simp [hs, preimage, eq_true, h]⟩

end sierpinski


/-
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 measure_theory.covering.liminf_limsup
! leanprover-community/mathlib commit b2ff9a3d7a15fd5b0f060b135421d6a89a999c2f
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.MeasureTheory.Covering.DensityTheorem

/-!
# Liminf, limsup, and doubling measures.

This file is a place to collect lemmas about liminf and limsup for subsets of a metric space
carrying a doubling measure.

## Main results:

 * `blimsup_cthickening_mul_ae_eq`: the limsup of the closed thickening of a sequence of subsets
   of a metric space is unchanged almost everywhere for a doubling measure if the sequence of
   distances is multiplied by a positive scale factor. This is a generalisation of a result of
   Cassels, appearing as Lemma 9 on page 217 of
   [J.W.S. Cassels, *Some metrical theorems in Diophantine approximation. I*](cassels1950).
 * `blimsup_thickening_mul_ae_eq`: a variant of `blimsup_cthickening_mul_ae_eq` for thickenings
   rather than closed thickenings.

-/

open Set Filter Metric MeasureTheory TopologicalSpace

open NNReal ENNReal Topology

variable {α : Type _} [MetricSpace α] [SecondCountableTopology α] [MeasurableSpace α] [BorelSpace α]

variable (μ : Measure α) [IsLocallyFiniteMeasure μ] [IsDoublingMeasure μ]

/-- This is really an auxiliary result en route to `blimsup_cthickening_ae_le_of_eventually_mul_le`
(which is itself an auxiliary result en route to `blimsup_cthickening_mul_ae_eq`).

NB: The `set : α` type ascription is present because of issue #16932 on GitHub. -/
theorem blimsup_cthickening_ae_le_of_eventually_mul_le_aux (p : ℕ → Prop) {s : ℕ → Set α}
    (hs : ∀ i, IsClosed (s i)) {r₁ r₂ : ℕ → ℝ} (hr : Tendsto r₁ atTop (𝓝[>] 0)) (hrp : 0 ≤ r₁)
    {M : ℝ} (hM : 0 < M) (hM' : M < 1) (hMr : ∀ᶠ i in atTop, M * r₁ i ≤ r₂ i) :
    (blimsup (fun i => cthickening (r₁ i) (s i)) atTop p : Set α) ≤ᵐ[μ]
      (blimsup (fun i => cthickening (r₂ i) (s i)) atTop p : Set α) :=
  by
  /- Sketch of proof:

    Assume that `p` is identically true for simplicity. Let `Y₁ i = cthickening (r₁ i) (s i)`, define
    `Y₂` similarly except using `r₂`, and let `(Z i) = ⋃_{j ≥ i} (Y₂ j)`. Our goal is equivalent to
    showing that `μ ((limsup Y₁) \ (Z i)) = 0` for all `i`.

    Assume for contradiction that `μ ((limsup Y₁) \ (Z i)) ≠ 0` for some `i` and let
    `W = (limsup Y₁) \ (Z i)`. Apply Lebesgue's density theorem to obtain a point `d` in `W` of
    density `1`. Since `d ∈ limsup Y₁`, there is a subsequence of `j ↦ Y₁ j`, indexed by
    `f 0 < f 1 < ...`, such that `d ∈ Y₁ (f j)` for all `j`. For each `j`, we may thus choose
    `w j ∈ s (f j)` such that `d ∈ B j`, where `B j = closed_ball (w j) (r₁ (f j))`. Note that
    since `d` has density one, `μ (W ∩ (B j)) / μ (B j) → 1`.

    We obtain our contradiction by showing that there exists `η < 1` such that
    `μ (W ∩ (B j)) / μ (B j) ≤ η` for sufficiently large `j`. In fact we claim that `η = 1 - C⁻¹`
    is such a value where `C` is the scaling constant of `M⁻¹` for the doubling measure `μ`.

    To prove the claim, let `b j = closed_ball (w j) (M * r₁ (f j))` and for given `j` consider the
    sets `b j` and `W ∩ (B j)`. These are both subsets of `B j` and are disjoint for large enough `j`
    since `M * r₁ j ≤ r₂ j` and thus `b j ⊆ Z i ⊆ Wᶜ`. We thus have:
    `μ (b j) + μ (W ∩ (B j)) ≤ μ (B j)`. Combining this with `μ (B j) ≤ C * μ (b j)` we obtain
    the required inequality. -/
  set Y₁ : ℕ → Set α := fun i => cthickening (r₁ i) (s i)
  set Y₂ : ℕ → Set α := fun i => cthickening (r₂ i) (s i)
  let Z : ℕ → Set α := fun i => ⋃ (j) (h : p j ∧ i ≤ j), Y₂ j
  suffices ∀ i, μ (at_top.blimsup Y₁ p \ Z i) = 0 by
    rwa [ae_le_set, @blimsup_eq_infi_bsupr_of_nat _ _ _ Y₂, infi_eq_Inter, diff_Inter,
      measure_Union_null_iff]
  intros
  set W := at_top.blimsup Y₁ p \ Z i
  by_contra contra
  obtain ⟨d, hd, hd'⟩ :
    ∃ d,
      d ∈ W ∧
        ∀ {ι : Type _} {l : Filter ι} (w : ι → α) (δ : ι → ℝ),
          tendsto δ l (𝓝[>] 0) →
            (∀ᶠ j in l, d ∈ closed_ball (w j) (2 * δ j)) →
              tendsto (fun j => μ (W ∩ closed_ball (w j) (δ j)) / μ (closed_ball (w j) (δ j))) l
                (𝓝 1) :=
    measure.exists_mem_of_measure_ne_zero_of_ae contra
      (IsDoublingMeasure.ae_tendsto_measure_inter_div μ W 2)
  replace hd : d ∈ blimsup Y₁ at_top p := ((mem_diff _).mp hd).1
  obtain ⟨f : ℕ → ℕ, hf⟩ := exists_forall_mem_of_has_basis_mem_blimsup' at_top_basis hd
  simp only [forall_and] at hf
  obtain ⟨hf₀ : ∀ j, d ∈ cthickening (r₁ (f j)) (s (f j)), hf₁, hf₂ : ∀ j, j ≤ f j⟩ := hf
  have hf₃ : tendsto f at_top at_top :=
    tendsto_at_top_at_top.mpr fun j => ⟨f j, fun i hi => (hf₂ j).trans (hi.trans <| hf₂ i)⟩
  replace hr : tendsto (r₁ ∘ f) at_top (𝓝[>] 0) := hr.comp hf₃
  replace hMr : ∀ᶠ j in at_top, M * r₁ (f j) ≤ r₂ (f j) := hf₃.eventually hMr
  replace hf₀ : ∀ j, ∃ w ∈ s (f j), d ∈ closed_ball w (2 * r₁ (f j))
  · intro j
    specialize hrp (f j)
    rw [Pi.zero_apply] at hrp
    rcases eq_or_lt_of_le hrp with (hr0 | hrp')
    · specialize hf₀ j
      rw [← hr0, cthickening_zero, (hs (f j)).closure_eq] at hf₀
      exact ⟨d, hf₀, by simp [← hr0]⟩
    ·
      exact
        mem_Union₂.mp
          (cthickening_subset_Union_closed_ball_of_lt (s (f j)) (by positivity)
            (lt_two_mul_self hrp') (hf₀ j))
  choose w hw hw' using hf₀
  let C := IsDoublingMeasure.scalingConstantOf μ M⁻¹
  have hC : 0 < C := lt_of_lt_of_le zero_lt_one (IsDoublingMeasure.one_le_scalingConstantOf μ M⁻¹)
  suffices
    ∃ η < (1 : ℝ≥0),
      ∀ᶠ j in at_top, μ (W ∩ closed_ball (w j) (r₁ (f j))) / μ (closed_ball (w j) (r₁ (f j))) ≤ η
    by
    obtain ⟨η, hη, hη'⟩ := this
    replace hη' : 1 ≤ η := by
      simpa only [ENNReal.one_le_coe_iff] using
        le_of_tendsto (hd' w (fun j => r₁ (f j)) hr <| eventually_of_forall hw') hη'
    exact (lt_self_iff_false _).mp (lt_of_lt_of_le hη hη')
  refine' ⟨1 - C⁻¹, tsub_lt_self zero_lt_one (inv_pos.mpr hC), _⟩
  replace hC : C ≠ 0 := ne_of_gt hC
  let b : ℕ → Set α := fun j => closed_ball (w j) (M * r₁ (f j))
  let B : ℕ → Set α := fun j => closed_ball (w j) (r₁ (f j))
  have h₁ : ∀ j, b j ⊆ B j := fun j =>
    closed_ball_subset_closed_ball (mul_le_of_le_one_left (hrp (f j)) hM'.le)
  have h₂ : ∀ j, W ∩ B j ⊆ B j := fun j => inter_subset_right W (B j)
  have h₃ : ∀ᶠ j in at_top, Disjoint (b j) (W ∩ B j) :=
    by
    apply hMr.mp
    rw [eventually_at_top]
    refine'
      ⟨i, fun j hj hj' => Disjoint.inf_right (B j) <| Disjoint.inf_right' (blimsup Y₁ at_top p) _⟩
    change Disjoint (b j) (Z iᶜ)
    rw [disjoint_compl_right_iff_subset]
    refine'
      (closed_ball_subset_cthickening (hw j) (M * r₁ (f j))).trans
        ((cthickening_mono hj' _).trans fun a ha => _)
    simp only [mem_Union, exists_prop]
    exact ⟨f j, ⟨hf₁ j, hj.le.trans (hf₂ j)⟩, ha⟩
  have h₄ : ∀ᶠ j in at_top, μ (B j) ≤ C * μ (b j) :=
    (hr.eventually (IsDoublingMeasure.eventually_measure_le_scaling_constant_mul' μ M hM)).mono
      fun j hj => hj (w j)
  refine' (h₃.and h₄).mono fun j hj₀ => _
  change μ (W ∩ B j) / μ (B j) ≤ ↑(1 - C⁻¹)
  rcases eq_or_ne (μ (B j)) ∞ with (hB | hB)
  · simp [hB]
  apply ENNReal.div_le_of_le_mul
  rw [WithTop.coe_sub, ENNReal.coe_one, ENNReal.sub_mul fun _ _ => hB, one_mul]
  replace hB : ↑C⁻¹ * μ (B j) ≠ ∞
  · refine' ENNReal.mul_ne_top _ hB
    rwa [ENNReal.coe_inv hC, Ne.def, ENNReal.inv_eq_top, ENNReal.coe_eq_zero]
  obtain ⟨hj₁ : Disjoint (b j) (W ∩ B j), hj₂ : μ (B j) ≤ C * μ (b j)⟩ := hj₀
  replace hj₂ : ↑C⁻¹ * μ (B j) ≤ μ (b j)
  · rw [ENNReal.coe_inv hC, ← ENNReal.div_eq_inv_mul]
    exact ENNReal.div_le_of_le_mul' hj₂
  have hj₃ : ↑C⁻¹ * μ (B j) + μ (W ∩ B j) ≤ μ (B j) :=
    by
    refine' le_trans (add_le_add_right hj₂ _) _
    rw [← measure_union' hj₁ measurableSet_closedBall]
    exact measure_mono (union_subset (h₁ j) (h₂ j))
  replace hj₃ := tsub_le_tsub_right hj₃ (↑C⁻¹ * μ (B j))
  rwa [ENNReal.add_sub_cancel_left hB] at hj₃
#align blimsup_cthickening_ae_le_of_eventually_mul_le_aux blimsup_cthickening_ae_le_of_eventually_mul_le_aux

/-- This is really an auxiliary result en route to `blimsup_cthickening_mul_ae_eq`.

NB: The `set : α` type ascription is present because of issue #16932 on GitHub. -/
theorem blimsup_cthickening_ae_le_of_eventually_mul_le (p : ℕ → Prop) {s : ℕ → Set α} {M : ℝ}
    (hM : 0 < M) {r₁ r₂ : ℕ → ℝ} (hr : Tendsto r₁ atTop (𝓝[>] 0))
    (hMr : ∀ᶠ i in atTop, M * r₁ i ≤ r₂ i) :
    (blimsup (fun i => cthickening (r₁ i) (s i)) atTop p : Set α) ≤ᵐ[μ]
      (blimsup (fun i => cthickening (r₂ i) (s i)) atTop p : Set α) :=
  by
  let R₁ i := max 0 (r₁ i)
  let R₂ i := max 0 (r₂ i)
  have hRp : 0 ≤ R₁ := fun i => le_max_left 0 (r₁ i)
  replace hMr : ∀ᶠ i in at_top, M * R₁ i ≤ R₂ i
  · refine' hMr.mono fun i hi => _
    rw [mul_max_of_nonneg _ _ hM.le, MulZeroClass.mul_zero]
    exact max_le_max (le_refl 0) hi
  simp_rw [← cthickening_max_zero (r₁ _), ← cthickening_max_zero (r₂ _)]
  cases' le_or_lt 1 M with hM' hM'
  · apply HasSubset.Subset.eventuallyLE
    change _ ≤ _
    refine' mono_blimsup' (hMr.mono fun i hi hp => cthickening_mono _ (s i))
    exact (le_mul_of_one_le_left (hRp i) hM').trans hi
  · simp only [← @cthickening_closure _ _ _ (s _)]
    have hs : ∀ i, IsClosed (closure (s i)) := fun i => isClosed_closure
    exact
      blimsup_cthickening_ae_le_of_eventually_mul_le_aux μ p hs (tendsto_nhds_max_right hr) hRp hM
        hM' hMr
#align blimsup_cthickening_ae_le_of_eventually_mul_le blimsup_cthickening_ae_le_of_eventually_mul_le

/-- Given a sequence of subsets `sᵢ` of a metric space, together with a sequence of radii `rᵢ`
such that `rᵢ → 0`, the set of points which belong to infinitely many of the closed
`rᵢ`-thickenings of `sᵢ` is unchanged almost everywhere for a doubling measure if the `rᵢ` are all
scaled by a positive constant.

This lemma is a generalisation of Lemma 9 appearing on page 217 of
[J.W.S. Cassels, *Some metrical theorems in Diophantine approximation. I*](cassels1950).

See also `blimsup_thickening_mul_ae_eq`.

NB: The `set : α` type ascription is present because of issue #16932 on GitHub. -/
theorem blimsup_cthickening_mul_ae_eq (p : ℕ → Prop) (s : ℕ → Set α) {M : ℝ} (hM : 0 < M)
    (r : ℕ → ℝ) (hr : Tendsto r atTop (𝓝 0)) :
    (blimsup (fun i => cthickening (M * r i) (s i)) atTop p : Set α) =ᵐ[μ]
      (blimsup (fun i => cthickening (r i) (s i)) atTop p : Set α) :=
  by
  have :
    ∀ (p : ℕ → Prop) {r : ℕ → ℝ} (hr : tendsto r at_top (𝓝[>] 0)),
      (blimsup (fun i => cthickening (M * r i) (s i)) at_top p : Set α) =ᵐ[μ]
        (blimsup (fun i => cthickening (r i) (s i)) at_top p : Set α) :=
    by
    clear p hr r
    intro p r hr
    have hr' : tendsto (fun i => M * r i) at_top (𝓝[>] 0) := by
      convert tendsto_nhds_within_Ioi.const_mul hM hr <;> simp only [MulZeroClass.mul_zero]
    refine' eventually_le_antisymm_iff.mpr ⟨_, _⟩
    ·
      exact
        blimsup_cthickening_ae_le_of_eventually_mul_le μ p (inv_pos.mpr hM) hr'
          (eventually_of_forall fun i => by rw [inv_mul_cancel_left₀ hM.ne' (r i)])
    ·
      exact
        blimsup_cthickening_ae_le_of_eventually_mul_le μ p hM hr
          (eventually_of_forall fun i => le_refl _)
  let r' : ℕ → ℝ := fun i => if 0 < r i then r i else 1 / ((i : ℝ) + 1)
  have hr' : tendsto r' at_top (𝓝[>] 0) :=
    by
    refine'
      tendsto_nhds_within_iff.mpr
        ⟨tendsto.if' hr tendsto_one_div_add_atTop_nhds_0_nat, eventually_of_forall fun i => _⟩
    by_cases hi : 0 < r i
    · simp [hi, r']
    · simp only [hi, r', one_div, mem_Ioi, if_false, inv_pos]
      positivity
  have h₀ : ∀ i, p i ∧ 0 < r i → cthickening (r i) (s i) = cthickening (r' i) (s i) :=
    by
    rintro i ⟨-, hi⟩
    congr
    change r i = ite (0 < r i) (r i) _
    simp [hi]
  have h₁ : ∀ i, p i ∧ 0 < r i → cthickening (M * r i) (s i) = cthickening (M * r' i) (s i) :=
    by
    rintro i ⟨-, hi⟩
    simp only [hi, mul_ite, if_true]
  have h₂ : ∀ i, p i ∧ r i ≤ 0 → cthickening (M * r i) (s i) = cthickening (r i) (s i) :=
    by
    rintro i ⟨-, hi⟩
    have hi' : M * r i ≤ 0 := mul_nonpos_of_nonneg_of_nonpos hM.le hi
    rw [cthickening_of_nonpos hi, cthickening_of_nonpos hi']
  have hp : p = fun i => p i ∧ 0 < r i ∨ p i ∧ r i ≤ 0 :=
    by
    ext i
    simp [← and_or_left, lt_or_le 0 (r i)]
  rw [hp, blimsup_or_eq_sup, blimsup_or_eq_sup, sup_eq_union,
    blimsup_congr (eventually_of_forall h₀), blimsup_congr (eventually_of_forall h₁),
    blimsup_congr (eventually_of_forall h₂)]
  exact ae_eq_set_union (this (fun i => p i ∧ 0 < r i) hr') (ae_eq_refl _)
#align blimsup_cthickening_mul_ae_eq blimsup_cthickening_mul_ae_eq

theorem blimsup_cthickening_ae_eq_blimsup_thickening {p : ℕ → Prop} {s : ℕ → Set α} {r : ℕ → ℝ}
    (hr : Tendsto r atTop (𝓝 0)) (hr' : ∀ᶠ i in atTop, p i → 0 < r i) :
    (blimsup (fun i => cthickening (r i) (s i)) atTop p : Set α) =ᵐ[μ]
      (blimsup (fun i => thickening (r i) (s i)) atTop p : Set α) :=
  by
  refine' eventually_le_antisymm_iff.mpr ⟨_, HasSubset.Subset.eventuallyLE (_ : _ ≤ _)⟩
  · rw [eventually_le_congr (blimsup_cthickening_mul_ae_eq μ p s (@one_half_pos ℝ _) r hr).symm
        eventually_eq.rfl]
    apply HasSubset.Subset.eventuallyLE
    change _ ≤ _
    refine' mono_blimsup' (hr'.mono fun i hi pi => cthickening_subset_thickening' (hi pi) _ (s i))
    nlinarith [hi pi]
  · exact mono_blimsup fun i pi => thickening_subset_cthickening _ _
#align blimsup_cthickening_ae_eq_blimsup_thickening blimsup_cthickening_ae_eq_blimsup_thickening

/-- An auxiliary result en route to `blimsup_thickening_mul_ae_eq`. -/
theorem blimsup_thickening_mul_ae_eq_aux (p : ℕ → Prop) (s : ℕ → Set α) {M : ℝ} (hM : 0 < M)
    (r : ℕ → ℝ) (hr : Tendsto r atTop (𝓝 0)) (hr' : ∀ᶠ i in atTop, p i → 0 < r i) :
    (blimsup (fun i => thickening (M * r i) (s i)) atTop p : Set α) =ᵐ[μ]
      (blimsup (fun i => thickening (r i) (s i)) atTop p : Set α) :=
  by
  have h₁ := blimsup_cthickening_ae_eq_blimsup_thickening μ hr hr'
  have h₂ := blimsup_cthickening_mul_ae_eq μ p s hM r hr
  replace hr : tendsto (fun i => M * r i) at_top (𝓝 0);
  · convert hr.const_mul M
    simp
  replace hr' : ∀ᶠ i in at_top, p i → 0 < M * r i := hr'.mono fun i hi hip => mul_pos hM (hi hip)
  have h₃ := blimsup_cthickening_ae_eq_blimsup_thickening μ hr hr'
  exact h₃.symm.trans (h₂.trans h₁)
#align blimsup_thickening_mul_ae_eq_aux blimsup_thickening_mul_ae_eq_aux

/-- Given a sequence of subsets `sᵢ` of a metric space, together with a sequence of radii `rᵢ`
such that `rᵢ → 0`, the set of points which belong to infinitely many of the
`rᵢ`-thickenings of `sᵢ` is unchanged almost everywhere for a doubling measure if the `rᵢ` are all
scaled by a positive constant.

This lemma is a generalisation of Lemma 9 appearing on page 217 of
[J.W.S. Cassels, *Some metrical theorems in Diophantine approximation. I*](cassels1950).

See also `blimsup_cthickening_mul_ae_eq`.

NB: The `set : α` type ascription is present because of issue #16932 on GitHub. -/
theorem blimsup_thickening_mul_ae_eq (p : ℕ → Prop) (s : ℕ → Set α) {M : ℝ} (hM : 0 < M) (r : ℕ → ℝ)
    (hr : Tendsto r atTop (𝓝 0)) :
    (blimsup (fun i => thickening (M * r i) (s i)) atTop p : Set α) =ᵐ[μ]
      (blimsup (fun i => thickening (r i) (s i)) atTop p : Set α) :=
  by
  let q : ℕ → Prop := fun i => p i ∧ 0 < r i
  have h₁ :
    blimsup (fun i => thickening (r i) (s i)) at_top p =
      blimsup (fun i => thickening (r i) (s i)) at_top q :=
    by
    refine' blimsup_congr' (eventually_of_forall fun i h => _)
    replace hi : 0 < r i
    · contrapose! h
      apply thickening_of_nonpos h
    simp only [hi, iff_self_and, imp_true_iff]
  have h₂ :
    blimsup (fun i => thickening (M * r i) (s i)) at_top p =
      blimsup (fun i => thickening (M * r i) (s i)) at_top q :=
    by
    refine' blimsup_congr' (eventually_of_forall fun i h => _)
    replace h : 0 < r i
    · rw [← zero_lt_mul_left hM]
      contrapose! h
      apply thickening_of_nonpos h
    simp only [h, iff_self_and, imp_true_iff]
  rw [h₁, h₂]
  exact blimsup_thickening_mul_ae_eq_aux μ q s hM r hr (eventually_of_forall fun i hi => hi.2)
#align blimsup_thickening_mul_ae_eq blimsup_thickening_mul_ae_eq