import M4R.Set.Basic

namespace M4R
  namespace Function

    theorem comp_eq (f : β → γ) (g : α → β) (a : α) : f (g a) = (f ∘ g) a := rfl
    theorem comp_assoc (f : γ → δ) (g : β → γ) (h : α → β) : f ∘ g ∘ h = (f ∘ g) ∘ h := rfl

    def restrict (f : α → β) (s : Set α) : s → β := Function.comp f Set.inclusion

    def domain (f : α → β) := α
    def codomain (f : α → β) := β
    def image (f : α → β) : Set β := {y | ∃ x : α, f x = y}
    def image' (f : α → β) (s : Set α) : Set β := {y | ∃ x ∈ s, f x = y}
    def inv_image (f : α → β) (s : Set β) : Set α := {x | f x ∈ s}
    def fibre (f : α → β) (b : β) : Set α := {x | f x = b}

    theorem image'_sub_image (f : α → β) (s : Set α) : image' f s ⊆ image f :=
      fun x ⟨y, hy, hye⟩ => ⟨y, hye⟩
    theorem image'_subset (f : α → β) {s₁ s₂ : Set α} (h : s₁ ⊆ s₂) : image' f s₁ ⊆ image' f s₂ :=
      fun x ⟨y, hys₁, hyx⟩ => ⟨y, h hys₁, hyx⟩

    def injective (f : α → β) : Prop := ∀ ⦃x y : α⦄, f x = f y → x = y
    def surjective (f : α → β) : Prop := ∀ y : β, ∃ x : α, f x = y
    def bijective (f : α → β) : Prop := injective f ∧ surjective f
    def bijective.inj {f : α → β} (h : bijective f) : injective f := h.left
    def bijective.surj {f : α → β} (h : bijective f) : surjective f := h.right

    theorem injective.comp {g : β → γ} {f : α → β} (hg : injective g) (hf : injective f) : injective (g ∘ f) :=
        fun _ _ h => hf (hg h)
    theorem surjective.comp {g : β → γ} {f : α → β} (hg : surjective g) (hf : surjective f) : surjective (g ∘ f) :=
      fun (c : γ) => Exists.elim (hg c) (fun b hb => Exists.elim (hf b) (fun a ha =>
      Exists.intro a (show g (f a) = c from (Eq.trans (congrArg g ha) hb))))
    theorem bijective.comp {g : β → γ} {f : α → β} : bijective g → bijective f → bijective (g ∘ f)
    | ⟨h_ginj, h_gsurj⟩, ⟨h_finj, h_fsurj⟩ => ⟨h_ginj.comp h_finj, h_gsurj.comp h_fsurj⟩

    def left_inverse (g : β → α) (f : α → β) : Prop := ∀ x, g (f x) = x
    def has_left_inverse (f : α → β) : Prop := ∃ finv : β → α, left_inverse finv f

    def right_inverse (g : β → α) (f : α → β) : Prop := left_inverse f g
    def has_right_inverse (f : α → β) : Prop := ∃ finv : β → α, right_inverse finv f

    theorem left_inverse.injective {g : β → α} {f : α → β} : left_inverse g f → injective f :=
      fun h a b hf => h a ▸ h b ▸ hf ▸ rfl
    theorem left_inverse.inv_surjective {g : β → α} {f : α → β} : left_inverse g f → surjective g :=
      fun h a => ⟨f a, h a⟩
    theorem has_left_inverse.injective {f : α → β} : has_left_inverse f → injective f :=
      fun h => Exists.elim h (fun finv inv => inv.injective)
    theorem right_inverse_of_injective_of_left_inverse {f : α → β} {g : β → α}
        (injf : injective f) (lfg : left_inverse f g) :
      right_inverse f g :=
      fun x => injf (lfg (f x))

    theorem right_inverse.surjective {f : α → β} {g : β → α} (h : right_inverse g f) : surjective f :=
      fun y => ⟨g y, h y⟩
    theorem right_inverse.inv_injective {g : β → α} {f : α → β} : right_inverse g f → injective g :=
      fun h a b hg => by rw [←h a, ←h b]; exact congrArg f hg
    theorem has_right_inverse.surjective {f : α → β} : has_right_inverse f → surjective f
    | ⟨finv, inv⟩ => inv.surjective
    theorem left_inverse_of_surjective_of_right_inverse {f : α → β} {g : β → α} (surjf : surjective f)
      (rfg : right_inverse f g) : left_inverse f g :=
      fun y =>
        let ⟨x, hx⟩ := surjf y
        by rw [← hx, rfg]

    theorem bijective_of_inverse {f : α → β} {g : β → α} (hl : left_inverse g f) (hr : right_inverse g f) :
      Function.bijective f := ⟨hl.injective, hr.surjective⟩

    theorem id_injective : @injective α α id := fun _ _ => id
    theorem id_surjective : @surjective α α id := fun y => ⟨y, rfl⟩
    theorem id_bijective : @bijective α α id := ⟨id_injective, id_surjective⟩

    theorem surj_image (f : α → β) : surjective f ↔ image f = Set.Universal := by
      apply Iff.intro
      { intro surj; apply Set.subset.antisymm;
        { exact Set.subset.subUniversal _ }
        { intro y _; exact surj y } }
      intro heq y; simp only [image, Set.Universal] at heq; rw [congrFun heq y]; trivial

    namespace Quotient

      protected def map (ra : α → α → Prop) (rb : β → β → Prop) (f : α → β)
        (h : ∀ a₁ a₂, ra a₁ a₂ → rb (f a₁) (f a₂)) : Quot ra → Quot rb :=
        Quot.lift (fun x => Quot.mk rb (f x)) (fun _ _ hra => Quot.sound (h _ _ hra))

      protected def lift₂ (ra : α → α → Prop) (rb : β → β → Prop)
        (ha : ∀ a : α, ra a a) (hb : ∀ b : β, rb b b) (f : α → β → γ)
        (c : ∀ (a₁ a₂ : α) (b₁ b₂ : β), ra a₁ a₂ → rb b₁ b₂ → f a₁ b₁ = f a₂ b₂)
        (qa : Quot ra) (qb : Quot rb) : γ :=
        Quot.lift
          (fun (x : α) => Quot.lift (f x) (fun (u v : β) => c x x u v (ha x)) qb)
          (fun (x y : α) (h : ra x y) =>
            @Quot.ind β rb
              (fun (q : Quot rb) =>
                  (Quot.lift (f x) (fun (u v : β) => c x x u v (ha x)) q)
                  =
                  (Quot.lift (f y) (fun (u v : β) => c y y u v (ha y)) q))
              (fun (u : β) => c x y u u h (hb u))
              qb)
          qa

      protected def map₂ (ra : α → α → Prop) (rb : β → β → Prop) (rc : γ → γ → Prop)
        (ha : ∀ a : α, ra a a) (hb : ∀ b : β, rb b b) (f : α → β → γ)
        (h : ∀ (a₁ a₂ : α) (b₁ b₂ : β), ra a₁ a₂ → rb b₁ b₂ → rc (f a₁ b₁) (f a₂ b₂)) :
        Quot ra → Quot rb → Quot rc :=
          Quotient.lift₂ ra rb ha hb
            (fun x y => Quot.mk rc (f x y))
            (fun _ _ _ _ h₁ h₂ => Quot.sound (h _ _ _ _ h₁ h₂))

      protected theorem ind₂ (ra : α → α → Prop) (rb : β → β → Prop) {motive : Quot ra → Quot rb → Prop}
        (h : ∀ (a : α) (b : β), motive (Quot.mk ra a) (Quot.mk rb b)) (qa : Quot ra) (qb : Quot rb) :
          motive qa qb :=
            @Quot.ind α ra (fun q : Quot ra => motive q qb)
             (fun a : α => @Quot.ind β rb (motive (Quot.mk ra a)) (fun b : β => h a b) qb) qa

      protected theorem ind₃ (ra : α → α → Prop) (rb : β → β → Prop) (rc : γ → γ → Prop)
        {motive : Quot ra → Quot rb → Quot rc → Prop}
        (h : ∀ (a : α) (b : β) (c : γ), motive (Quot.mk ra a) (Quot.mk rb b) (Quot.mk rc c))
        (qa : Quot ra) (qb : Quot rb) (qc : Quot rc) :
          motive qa qb qc :=
          @Quot.ind α ra (fun q : Quot ra => motive q qb qc) (fun a : α =>
          @Quot.ind β rb (fun q : Quot rb => motive (Quot.mk ra a) q qc) (fun b : β =>
          @Quot.ind γ rc (motive (Quot.mk ra a) (Quot.mk rb b)) (fun c : γ => h a b c) qc) qb) qa

    end Quotient

    section update

      def update [DecidableEq α] {β : α → Sort _} (f : (a : α) → β a) (a' : α) (v : β a') (a : α) : β a :=
        if h : a = a' then (by rw [h]; exact v) else f a

      theorem update_apply [DecidableEq α] (f : α → β) (a' : α) (b : β) (a : α) :
        update f a' b a = if a = a' then b else f a := rfl

      @[simp] theorem update_same [DecidableEq α] {β : α → Sort _} (a : α) (v : β a) (f : (a : α) → β a) :
        update f a v a = v := dif_pos rfl

      @[simp] theorem update_noteq [DecidableEq α] {β : α → Sort _} {a a' : α} (h : a ≠ a') (v : β a')
        (f : (a : α) → β a) : update f a' v a = f a :=
          dif_neg h

    end update
  end Function

  namespace minimal
    open Classical

    private def lbp (s : Set Nat) (m n : Nat) : Prop := m = n + 1 ∧ ∀ k, k ≤ n → k ∉ s

    private def wf_lbp {s : Set Nat} (hs : Nonempty s) : WellFounded (lbp s) :=
      let ⟨n, hn⟩ := hs
      ⟨fun a => have : (∀ m k, n ≤ k + m → Acc (lbp s) k) := fun m => by induction m with
          | zero      => exact fun k kn => ⟨k, fun y r => absurd hn (r.right n (Nat.add_zero k ▸ kn))⟩
          | succ m ih => exact fun k kn => ⟨_, fun y r => ih y (r.left ▸ Nat.succ_add _ _ ▸ Nat.add_succ _ _ ▸ kn)⟩
        this _ _ (Nat.le_add_left _ _)⟩

    protected noncomputable def find (s : Set Nat) (hs : Nonempty s) : {n // n ∈ s ∧ ∀ m, m < n → m ∉ s} :=
      @WellFounded.fix Nat (fun k => (∀ n, n < k → n ∉ s) → {n // n ∈ s ∧ ∀ m, m < n → m ∉ s}) (lbp s) (wf_lbp hs)
        (fun x h₁ h₂ => if hx : x ∈ s then ⟨x, hx, h₂⟩ else
          have : ∀ n, n ≤ x → n ∉ s := fun n hn => Or.elim (Nat.lt_or_eq_of_le hn) (h₂ n) (· ▸ hx)
          h₁ _ ⟨rfl, this⟩ fun n hn => this n (Nat.le_of_succ_le_succ hn))
        0 fun n h => absurd h (Nat.not_lt_zero n)

    theorem min_nat (s : Set Nat) (hs : Nonempty s) : ∃ n ∈ s, ∀ m ∈ s, n ≤ m :=
      let ⟨n, hn, h⟩ := minimal.find s hs
      ⟨n, hn, fun m hm => Nat.le_of_not_lt (mt (h m) (iff_not_not.mpr hm))⟩

    theorem min_exists (s : Set α) (hs : Nonempty s) (f : α → Nat) : ∃ x ∈ s, ∀ y ∈ s, f x ≤ f y :=
      let ⟨x, hx⟩ := hs
      let ⟨n, ⟨y, hy, hyn⟩, hmin⟩ := min_nat (Function.image' f s) ⟨f x, x, hx, rfl⟩
      ⟨y, hy, fun z hz => hyn ▸ hmin (f z) ⟨z, hz, rfl⟩⟩

  end minimal
  namespace maximal

    theorem max_exists (s : Set α) (hs : Nonempty s) (f : α → Nat) (hf : ∃ n, ∀ y ∈ s, f y ≤ n) :
      ∃ x ∈ s, ∀ y ∈ s, f y ≤ f x := by
        let ⟨n, hn⟩ := hf
        let ⟨x, xs, hx⟩ := minimal.min_exists s hs (fun a => n - f a)
        exact ⟨x, xs, fun y ys => (Nat.sub_le_sub (hn y ys) (hn x xs)).mpr (hx y ys)⟩

  end maximal
end M4R


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Johannes Hölzl
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.equiv.list
import Mathlib.data.set.finite
import Mathlib.PostPort

universes u v u_1

namespace Mathlib

/-!
# Countable sets
-/

namespace set

/-- A set is countable if there exists an encoding of the set into the natural numbers.
An encoding is an injection with a partial inverse, which can be viewed as a
constructive analogue of countability. (For the most part, theorems about
`countable` will be classical and `encodable` will be constructive.)
-/
def countable {α : Type u} (s : set α) := Nonempty (encodable ↥s)

theorem countable_iff_exists_injective {α : Type u} {s : set α} :
    countable s ↔ ∃ (f : ↥s → ℕ), function.injective f :=
  sorry

/-- A set `s : set α` is countable if and only if there exists a function `α → ℕ` injective
on `s`. -/
theorem countable_iff_exists_inj_on {α : Type u} {s : set α} :
    countable s ↔ ∃ (f : α → ℕ), inj_on f s :=
  sorry

theorem countable_iff_exists_surjective {α : Type u} [ne : Nonempty α] {s : set α} :
    countable s ↔ ∃ (f : ℕ → α), s ⊆ range f :=
  sorry

/--
A non-empty set is countable iff there exists a surjection from the
natural numbers onto the subtype induced by the set.
-/
theorem countable_iff_exists_surjective_to_subtype {α : Type u} {s : set α} (hs : set.nonempty s) :
    countable s ↔ ∃ (f : ℕ → ↥s), function.surjective f :=
  sorry

/-- Convert `countable s` to `encodable s` (noncomputable). -/
def countable.to_encodable {α : Type u} {s : set α} : countable s → encodable ↥s := Classical.choice

theorem countable_encodable' {α : Type u} (s : set α) [H : encodable ↥s] : countable s :=
  Nonempty.intro H

theorem countable_encodable {α : Type u} [encodable α] (s : set α) : countable s :=
  Nonempty.intro encodable.subtype

/-- If `s : set α` is a nonempty countable set, then there exists a map
`f : ℕ → α` such that `s = range f`. -/
theorem countable.exists_surjective {α : Type u} {s : set α} (hc : countable s)
    (hs : set.nonempty s) : ∃ (f : ℕ → α), s = range f :=
  sorry

@[simp] theorem countable_empty {α : Type u} : countable ∅ :=
  Nonempty.intro
    (encodable.mk (fun (x : ↥∅) => false.elim (subtype.property x)) (fun (n : ℕ) => none)
      fun (x : ↥∅) => false.elim (subtype.property x))

@[simp] theorem countable_singleton {α : Type u} (a : α) : countable (singleton a) :=
  Nonempty.intro (encodable.of_equiv PUnit (equiv.set.singleton a))

theorem countable.mono {α : Type u} {s₁ : set α} {s₂ : set α} (h : s₁ ⊆ s₂) :
    countable s₂ → countable s₁ :=
  sorry

theorem countable.image {α : Type u} {β : Type v} {s : set α} (hs : countable s) (f : α → β) :
    countable (f '' s) :=
  sorry

theorem countable_range {α : Type u} {β : Type v} [encodable α] (f : α → β) : countable (range f) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (countable (range f))) (Eq.symm image_univ)))
    (countable.image (countable_encodable univ) f)

theorem exists_seq_supr_eq_top_iff_countable {α : Type u} [complete_lattice α] {p : α → Prop}
    (h : ∃ (x : α), p x) :
    (∃ (s : ℕ → α), (∀ (n : ℕ), p (s n)) ∧ (supr fun (n : ℕ) => s n) = ⊤) ↔
        ∃ (S : set α), countable S ∧ (∀ (s : α), s ∈ S → p s) ∧ Sup S = ⊤ :=
  sorry

theorem exists_seq_cover_iff_countable {α : Type u} {p : set α → Prop} (h : ∃ (s : set α), p s) :
    (∃ (s : ℕ → set α), (∀ (n : ℕ), p (s n)) ∧ (Union fun (n : ℕ) => s n) = univ) ↔
        ∃ (S : set (set α)), countable S ∧ (∀ (s : set α), s ∈ S → p s) ∧ ⋃₀S = univ :=
  exists_seq_supr_eq_top_iff_countable h

theorem countable_of_injective_of_countable_image {α : Type u} {β : Type v} {s : set α} {f : α → β}
    (hf : inj_on f s) (hs : countable (f '' s)) : countable s :=
  sorry

theorem countable_Union {α : Type u} {β : Type v} {t : α → set β} [encodable α]
    (ht : ∀ (a : α), countable (t a)) : countable (Union fun (a : α) => t a) :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl (countable (Union fun (a : α) => t a)))
        (Union_eq_range_sigma fun (a : α) => t a)))
    (countable_range fun (a : sigma fun (i : α) => ↥(t i)) => ↑(sigma.snd a))

theorem countable.bUnion {α : Type u} {β : Type v} {s : set α} {t : (x : α) → x ∈ s → set β}
    (hs : countable s) (ht : ∀ (a : α) (H : a ∈ s), countable (t a H)) :
    countable (Union fun (a : α) => Union fun (H : a ∈ s) => t a H) :=
  sorry

theorem countable.sUnion {α : Type u} {s : set (set α)} (hs : countable s)
    (h : ∀ (a : set α), a ∈ s → countable a) : countable (⋃₀s) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (countable (⋃₀s))) sUnion_eq_bUnion)) (countable.bUnion hs h)

theorem countable_Union_Prop {β : Type v} {p : Prop} {t : p → set β}
    (ht : ∀ (h : p), countable (t h)) : countable (Union fun (h : p) => t h) :=
  sorry

theorem countable.union {α : Type u} {s₁ : set α} {s₂ : set α} (h₁ : countable s₁)
    (h₂ : countable s₂) : countable (s₁ ∪ s₂) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (countable (s₁ ∪ s₂))) union_eq_Union))
    (countable_Union (iff.mpr bool.forall_bool { left := h₂, right := h₁ }))

theorem countable.insert {α : Type u} {s : set α} (a : α) (h : countable s) :
    countable (insert a s) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (countable (insert a s))) (insert_eq a s)))
    (countable.union (countable_singleton a) h)

theorem finite.countable {α : Type u} {s : set α} : finite s → countable s := sorry

/-- The set of finite subsets of a countable set is countable. -/
theorem countable_set_of_finite_subset {α : Type u} {s : set α} :
    countable s → countable (set_of fun (t : set α) => finite t ∧ t ⊆ s) :=
  sorry

theorem countable_pi {α : Type u} {π : α → Type u_1} [fintype α] {s : (a : α) → set (π a)}
    (hs : ∀ (a : α), countable (s a)) :
    countable (set_of fun (f : (a : α) → π a) => ∀ (a : α), f a ∈ s a) :=
  sorry

theorem countable_prod {α : Type u} {β : Type v} {s : set α} {t : set β} (hs : countable s)
    (ht : countable t) : countable (set.prod s t) :=
  sorry

/-- Enumerate elements in a countable set.-/
def enumerate_countable {α : Type u} {s : set α} (h : countable s) (default : α) : ℕ → α :=
  fun (n : ℕ) => sorry

theorem subset_range_enumerate {α : Type u} {s : set α} (h : countable s) (default : α) :
    s ⊆ range (enumerate_countable h default) :=
  sorry

end set

theorem finset.countable_to_set {α : Type u} (s : finset α) : set.countable ↑s :=
  set.finite.countable (finset.finite_to_set s)

end Mathlib


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.nat.lattice
import logic.denumerable
import logic.function.iterate
import order.hom.basic

/-!
# Relation embeddings from the naturals

This file allows translation from monotone functions `ℕ → α` to order embeddings `ℕ ↪ α` and
defines the limit value of an eventually-constant sequence.

## Main declarations

* `nat_lt`/`nat_gt`: Make an order embedding `ℕ ↪ α` from an increasing/decreasing function `ℕ → α`.
* `monotonic_sequence_limit`: The limit of an eventually-constant monotone sequence `ℕ →o α`.
* `monotonic_sequence_limit_index`: The index of the first occurence of `monotonic_sequence_limit`
  in the sequence.
-/
namespace rel_embedding

variables {α : Type*} {r : α → α → Prop} [is_strict_order α r]

/-- If `f` is a strictly `r`-increasing sequence, then this returns `f` as an order embedding. -/
def nat_lt (f : ℕ → α) (H : ∀ n : ℕ, r (f n) (f (n + 1))) :
  ((<) : ℕ → ℕ → Prop) ↪r r :=
of_monotone f $ nat.rel_of_forall_rel_succ_of_lt r H

@[simp]
lemma nat_lt_apply {f : ℕ → α} {H : ∀ n : ℕ, r (f n) (f (n + 1))} {n : ℕ} :
  nat_lt f H n = f n :=
rfl

/-- If `f` is a strictly `r`-decreasing sequence, then this returns `f` as an order embedding. -/
def nat_gt (f : ℕ → α) (H : ∀ n : ℕ, r (f (n + 1)) (f n)) :
  ((>) : ℕ → ℕ → Prop) ↪r r :=
by haveI := is_strict_order.swap r; exact rel_embedding.swap (nat_lt f H)

theorem well_founded_iff_no_descending_seq :
  well_founded r ↔ is_empty (((>) : ℕ → ℕ → Prop) ↪r r) :=
⟨λ ⟨h⟩, ⟨λ ⟨f, o⟩,
  suffices ∀ a, acc r a → ∀ n, a ≠ f n, from this (f 0) (h _) 0 rfl,
  λ a ac, begin
    induction ac with a _ IH, intros n h, subst a,
    exact IH (f (n+1)) (o.2 (nat.lt_succ_self _)) _ rfl
  end⟩,
λ E, ⟨λ a, classical.by_contradiction $ λ na,
  let ⟨f, h⟩ := classical.axiom_of_choice $
    show ∀ x : {a // ¬ acc r a}, ∃ y : {a // ¬ acc r a}, r y.1 x.1,
    from λ ⟨x, h⟩, classical.by_contradiction $ λ hn, h $
      ⟨_, λ y h, classical.by_contradiction $ λ na, hn ⟨⟨y, na⟩, h⟩⟩ in
  E.elim' (nat_gt (λ n, (f^[n] ⟨a, na⟩).1) $ λ n,
    by { rw [function.iterate_succ'], apply h })⟩⟩

end rel_embedding

namespace nat
variables (s : set ℕ) [decidable_pred (∈ s)] [infinite s]

/-- An order embedding from `ℕ` to itself with a specified range -/
def order_embedding_of_set : ℕ ↪o ℕ :=
(rel_embedding.order_embedding_of_lt_embedding
  (rel_embedding.nat_lt (nat.subtype.of_nat s) (λ n, nat.subtype.lt_succ_self _))).trans
  (order_embedding.subtype s)

/-- `nat.subtype.of_nat` as an order isomorphism between `ℕ` and an infinite decidable subset.
See also `nat.nth` for a version where the subset may be finite. -/
noncomputable def subtype.order_iso_of_nat  :
  ℕ ≃o s :=
rel_iso.of_surjective (rel_embedding.order_embedding_of_lt_embedding
  (rel_embedding.nat_lt (nat.subtype.of_nat s) (λ n, nat.subtype.lt_succ_self _)))
  nat.subtype.of_nat_surjective

variable {s}

@[simp]
lemma coe_order_embedding_of_set : ⇑(order_embedding_of_set s) = coe ∘ subtype.of_nat s := rfl

lemma order_embedding_of_set_apply {n : ℕ} : order_embedding_of_set s n = subtype.of_nat s n := rfl

@[simp]
lemma subtype.order_iso_of_nat_apply {n : ℕ} :
  subtype.order_iso_of_nat s n = subtype.of_nat s n :=
by { simp [subtype.order_iso_of_nat] }

variable (s)

lemma order_embedding_of_set_range : set.range (nat.order_embedding_of_set s) = s :=
subtype.coe_comp_of_nat_range

theorem exists_subseq_of_forall_mem_union {α : Type*} {s t : set α} (e : ℕ → α)
  (he : ∀ n, e n ∈ s ∪ t) :
  ∃ g : ℕ ↪o ℕ, (∀ n, e (g n) ∈ s) ∨ (∀ n, e (g n) ∈ t) :=
begin
  classical,
  have : infinite (e ⁻¹' s) ∨ infinite (e ⁻¹' t),
    by simp only [set.infinite_coe_iff, ← set.infinite_union, ← set.preimage_union,
      set.eq_univ_of_forall (λ n, set.mem_preimage.2 (he n)), set.infinite_univ],
  casesI this,
  exacts [⟨nat.order_embedding_of_set (e ⁻¹' s), or.inl $ λ n, (nat.subtype.of_nat (e ⁻¹' s) _).2⟩,
    ⟨nat.order_embedding_of_set (e ⁻¹' t), or.inr $ λ n, (nat.subtype.of_nat (e ⁻¹' t) _).2⟩]
end

end nat

theorem exists_increasing_or_nonincreasing_subseq' {α : Type*} (r : α → α → Prop) (f : ℕ → α) :
  ∃ (g : ℕ ↪o ℕ), (∀ n : ℕ, r (f (g n)) (f (g (n + 1)))) ∨
    (∀ m n : ℕ, m < n → ¬ r (f (g m)) (f (g n))) :=
begin
  classical,
  let bad : set ℕ := { m | ∀ n, m < n → ¬ r (f m) (f n) },
  by_cases hbad : infinite bad,
  { haveI := hbad,
    refine ⟨nat.order_embedding_of_set bad, or.intro_right _ (λ m n mn, _)⟩,
    have h := set.mem_range_self m,
    rw nat.order_embedding_of_set_range bad at h,
    exact h _ ((order_embedding.lt_iff_lt _).2 mn) },
  { rw [set.infinite_coe_iff, set.infinite, not_not] at hbad,
    obtain ⟨m, hm⟩ : ∃ m, ∀ n, m ≤ n → ¬ n ∈ bad,
    { by_cases he : hbad.to_finset.nonempty,
      { refine ⟨(hbad.to_finset.max' he).succ, λ n hn nbad, nat.not_succ_le_self _
        (hn.trans (hbad.to_finset.le_max' n (hbad.mem_to_finset.2 nbad)))⟩ },
      { exact ⟨0, λ n hn nbad, he ⟨n, hbad.mem_to_finset.2 nbad⟩⟩ } },
    have h : ∀ (n : ℕ), ∃ (n' : ℕ), n < n' ∧ r (f (n + m)) (f (n' + m)),
    { intro n,
      have h := hm _ (le_add_of_nonneg_left n.zero_le),
      simp only [exists_prop, not_not, set.mem_set_of_eq, not_forall] at h,
      obtain ⟨n', hn1, hn2⟩ := h,
      obtain ⟨x, hpos, rfl⟩ := exists_pos_add_of_lt hn1,
      refine ⟨n + x, add_lt_add_left hpos n, _⟩,
      rw [add_assoc, add_comm x m, ← add_assoc],
      exact hn2 },
    let g' : ℕ → ℕ := @nat.rec (λ _, ℕ) m (λ n gn, nat.find (h gn)),
    exact ⟨(rel_embedding.nat_lt (λ n, g' n + m)
      (λ n, nat.add_lt_add_right (nat.find_spec (h (g' n))).1 m)).order_embedding_of_lt_embedding,
      or.intro_left _ (λ n, (nat.find_spec (h (g' n))).2)⟩ }
end

/-- This is the infinitary Erdős–Szekeres theorem, and an important lemma in the usual proof of
    Bolzano-Weierstrass for `ℝ`. -/
theorem exists_increasing_or_nonincreasing_subseq
  {α : Type*} (r : α → α → Prop) [is_trans α r] (f : ℕ → α) :
  ∃ (g : ℕ ↪o ℕ), (∀ m n : ℕ, m < n → r (f (g m)) (f (g n))) ∨
    (∀ m n : ℕ, m < n → ¬ r (f (g m)) (f (g n))) :=
begin
  obtain ⟨g, hr | hnr⟩ := exists_increasing_or_nonincreasing_subseq' r f,
  { refine ⟨g, or.intro_left _ (λ m n mn, _)⟩,
    obtain ⟨x, rfl⟩ := le_iff_exists_add.1 (nat.succ_le_iff.2 mn),
    induction x with x ih,
    { apply hr },
    { apply is_trans.trans _ _ _ _ (hr _),
      exact ih (lt_of_lt_of_le m.lt_succ_self (nat.le_add_right _ _)) } },
  { exact ⟨g, or.intro_right _ hnr⟩ }
end

/-- The "monotone chain condition" below is sometimes a convenient form of well foundedness. -/
lemma well_founded.monotone_chain_condition (α : Type*) [partial_order α] :
  well_founded ((>) : α → α → Prop) ↔ ∀ (a : ℕ →o α), ∃ n, ∀ m, n ≤ m → a n = a m :=
begin
  split; intros h,
  { rw well_founded.well_founded_iff_has_max' at h,
    intros a, have hne : (set.range a).nonempty, { use a 0, simp, },
    obtain ⟨x, ⟨n, hn⟩, range_bounded⟩ := h _ hne,
    use n, intros m hm, rw ← hn at range_bounded, symmetry,
    apply range_bounded (a m) (set.mem_range_self _) (a.monotone hm), },
  { rw rel_embedding.well_founded_iff_no_descending_seq, refine ⟨λ a, _⟩,
    obtain ⟨n, hn⟩ := h (a.swap : ((<) : ℕ → ℕ → Prop) →r ((<) : α → α → Prop)).to_order_hom,
    exact n.succ_ne_self.symm (rel_embedding.to_order_hom_injective _ (hn _ n.le_succ)), },
end

/-- Given an eventually-constant monotone sequence `a₀ ≤ a₁ ≤ a₂ ≤ ...` in a partially-ordered
type, `monotonic_sequence_limit_index a` is the least natural number `n` for which `aₙ` reaches the
constant value. For sequences that are not eventually constant, `monotonic_sequence_limit_index a`
is defined, but is a junk value. -/
noncomputable def monotonic_sequence_limit_index {α : Type*} [preorder α] (a : ℕ →o α) : ℕ :=
Inf { n | ∀ m, n ≤ m → a n = a m }

/-- The constant value of an eventually-constant monotone sequence `a₀ ≤ a₁ ≤ a₂ ≤ ...` in a
partially-ordered type. -/
noncomputable def monotonic_sequence_limit {α : Type*} [preorder α] (a : ℕ →o α) :=
a (monotonic_sequence_limit_index a)

lemma well_founded.supr_eq_monotonic_sequence_limit {α : Type*} [complete_lattice α]
  (h : well_founded ((>) : α → α → Prop)) (a : ℕ →o α) :
  (⨆ m, a m) = monotonic_sequence_limit a :=
begin
  suffices : (⨆ (m : ℕ), a m) ≤ monotonic_sequence_limit a,
  { exact le_antisymm this (le_supr a _), },
  apply supr_le,
  intros m,
  by_cases hm : m ≤ monotonic_sequence_limit_index a,
  { exact a.monotone hm, },
  { replace hm := le_of_not_le hm,
    let S := { n | ∀ m, n ≤ m → a n = a m },
    have hInf : Inf S ∈ S,
    { refine nat.Inf_mem _, rw well_founded.monotone_chain_condition at h, exact h a, },
    change Inf S ≤ m at hm,
    change a m ≤ a (Inf S),
    rw hInf m hm, },
end


import data.int.modeq
import chris_hughes_various.zmod

namespace int
theorem eq_self_mod {n : ℤ} (x : ℤ) : x ≡ (x % n) [ZMOD n] :=
begin
  show x % n = (x % n) % n,
  rw int.mod_mod,
end

end int
open int

theorem mod_3_lt_3 (x : ℤ) : 0 ≤ x % 3 ∧ x % 3 < 3 :=
begin
  split,
    exact mod_nonneg x (dec_trivial),
  exact @mod_lt x 3 (dec_trivial)
end

theorem cheat (d : ℤ) : 0 ≤ d ∧ d < 3 → d = 0 ∨ d = 1 ∨ d = 2 :=
begin
  cases d with d1 d2,
  { rintro ⟨h1,h2⟩,
    cases d1,
    left,refl,
    cases d1,
    right,left,refl,
    cases d1,
    right,right,refl,
    revert h2,exact dec_trivial,
  },
  intro H,
  cases H with H1 H2,
  exfalso,
  revert H1,
  exact dec_trivial,
end

theorem mod_lt_3 (x : ℤ) : x ≡ 0 [ZMOD 3] ∨ x ≡ 1 [ZMOD 3] ∨ x ≡ 2 [ZMOD 3] :=
begin
  let d := x % 3,
  have H : x ≡ d [ZMOD 3],
    exact eq_self_mod x,
  have H2 : 0 ≤ d ∧ d < 3,
    exact mod_3_lt_3 x,
  have H3 : d = 0 ∨ d = 1 ∨ d = 2,
    revert H2,
    exact cheat d,
  cases H3 with H0 H12,
  left,convert H,exact H0.symm,
  cases H12 with H1 H2',
  right,left,convert H,exact H1.symm,
  right,right,convert H,exact H2'.symm,
end

example (x : ℤ) : x ^ 2 ≡ 1 [ZMOD 3] ∨ x ^ 2 ≡ 0 [ZMOD 3] := begin
sorry,
end


import m114 algebra.pi_instances rename_var

lemma abs_inferieur_ssi (x y : ℝ) : |x| ≤ y ↔ -y ≤ x ∧ x ≤ y :=
abs_le

variables {α : Type*} [decidable_linear_order α]
lemma superieur_max_ssi (p q r : α) : r ≥ max p q  ↔ r ≥ p ∧ r ≥ q :=
max_le_iff

lemma inferieur_max_gauche (p q : α) : p ≤ max p q :=
le_max_left _ _

lemma inferieur_max_droite (p q : α) : q ≤ max p q :=
le_max_right _ _

lemma egal_si_abs_diff_neg {a b : ℝ} : |a - b| ≤ 0 → a = b :=
decidable_linear_ordered_comm_group.eq_of_abs_sub_nonpos
-- Pour la lib
lemma egal_si_abs_eps (x y : ℝ) : (∀ ε > 0, |x - y| ≤ ε) → x = y :=
begin
  intro h,
  apply egal_si_abs_diff_neg,
  by_contradiction H,
  push_neg at H,
  specialize h ( |x-y|/2) (by linarith),
  linarith,
end

lemma ineg_triangle (x y : ℝ) : |x + y| ≤ |x| + |y| :=
abs_add x y


import logic.misc
import .misc

/-!
 * Partial functions
 -/

namespace function

@[reducible,inline]
definition partial (α β : Sort _) := α → option β

reserve infixr `↝`:20
infixr ` ↝ ` := function.partial

namespace partial

--- Check if a partial function is defined at a specific point.
protected
definition is_defined_at {α β: Sort _} (f : partial α β) : α → Prop :=
  λ x, f x ≠ option.none

instance defined_decidable {α β : Sort _} {f : partial α β} : decidable_pred f.is_defined_at :=
  λ x, @option.rec_on β (λ y, f x=y → decidable (f.is_defined_at x)) (f x)
    (λ h, is_false (not_not_intro h))
    (λ b h, is_true (λ hn, option.no_confusion (h.symm.trans hn)))
    (@rfl _ (f x))

--- A partial function `f` is defined at a point `x` iff `f x = some b` for some `b`.
lemma defined_iff_some {α β : Sort _} (f : partial α β) {x : α} : f.is_defined_at x ↔ ∃ b, f x = some b :=
  begin
    split,
    show f.is_defined_at x → _, {
      intros hx,
      cases hfx : f x with b,
      case none { exfalso; exact hx hfx },
      exact ⟨b,rfl⟩
    },
    show _ → f.is_defined_at x, {
      intros hsome; cases hsome with b hb,
      intros h,
      have : some b = none,
        from hb.symm.trans h,
      injection this
    },
  end

--- Domain of partial functions.
protected
definition domain {α β : Sort _} (f : partial α β) : Sort _ :=
  subtype f.is_defined_at

--- Obtain an ordinary function by restricting the domain
protected
definition to_fun {α β : Sort _} (f : partial α β) : f.domain → β :=
  λ x, @option.rec_on β (λ y, f x.val=y → β) (f x.val)
    (false.elim ∘ x.property)
    (λ b _, b)
    rfl

--- Specify how to determine the values of the function `f.to_fun` for a partial function `f`.
protected
lemma to_fun_value_of_eq {α β : Sort _} (f : partial α β) {x : f.domain} {y : β} : f x.val = some y → f.to_fun x = y :=
  begin
    intros hxy,
    dsimp [partial.to_fun],
    calc
      @option.rec β (λ y, f x.val=y → β) (false.elim ∘ x.property) (λ b _, b) (f x.val) rfl
          = @option.rec β (λ y, f x.val=y → β) (false.elim ∘ x.property) (λ b _, b) (some y) hxy : by refine dcongr hxy (hcongr_arg _ hxy) (eq_irrel hxy).symm
      ... = y : rfl
  end

--- For each partial function `f`, the values of `f` on its domain is determined by `f.to_fun`.
protected
lemma to_fun_on_domain {α β : Sort _} {f : partial α β} {x : f.domain} : f x.val = some (f.to_fun x) :=
  begin
    cases hx : f x.val with y,
    case option.none { exact (x.property hx).elim },
    refine congr_arg some _,
    exact (f.to_fun_value_of_eq hx).symm
  end

--- Think of an ordinary function as a partial function.
protected
definition from_fun {α β : Sort _} (f : α → β) : partial α β :=
  option.some ∘ f

--- Partial functions compose.
protected
definition comp {α β γ : Sort _} : partial β γ → partial α β → partial α γ :=
  λ g f a, f a >>= g

--- Injectivity of partial maps.
protected
definition injective {α β : Sort _} (f : partial α β) : Prop :=
  ∀ x y, f.is_defined_at x → f.is_defined_at y → f x = f y → x = y

--- Surjectivity of partial maps.
protected
definition surjective {α β : Sort _} (f : partial α β) : Prop :=
  ∀ b, ∃ a, f a = option.some b

protected
lemma injective_on_domain {α : Type _} {β : Sort _} {f : partial α β} : f.injective → ∀ (x y : f.domain), f x.val = f y.val → x = y :=
  begin
    intros hinj x y hfxy,
    exact subtype.eq (hinj x.val y.val x.property y.property hfxy)
  end

--- The injectivity of a partial function `f` is equivalent to the injectivity of `f.to_fun` in the ordinary sense.
protected
lemma injective_iff {α : Type _} {β : Sort _} (f : partial α β) : f.injective ↔ injective f.to_fun :=
  begin
    split,
    show f.injective → _, {
      intros h x y,
      cases hx: f x.val with b,
      case option.none { exfalso; exact x.property hx },
      cases hy: f y.val with c,
      case option.none { exfalso; exact y.property hy },
      rw [f.to_fun_value_of_eq hx],
      rw [f.to_fun_value_of_eq hy],
      intros hbc,
      have hxy : f x.val = f y.val :=
        (hx.trans (congr_arg some hbc)).trans hy.symm,
      exact partial.injective_on_domain h x y hxy,
    },
    show _ → f.injective, {
      intros hinj x y hx hy hfxy,
      cases hfx: f x with b,
      case option.none { exact (hx hfx).elim },
      cases hfy: f y with c,
      case option.none { exact (hy hfy).elim },
      have hbc : b = c,
        by apply option.some.inj; rw [←hfx,←hfy]; exact hfxy,
      have hfxv : f.to_fun ⟨x,hx⟩ = b,
        from f.to_fun_value_of_eq hfx,
      have hfyv : f.to_fun ⟨y,hy⟩ = c,
        from f.to_fun_value_of_eq hfy,
      let hxy := hinj ((hfxv.trans hbc).trans hfyv.symm),
      exact congr_arg subtype.val hxy,
    }
  end

/-
 * Partial function that is dual to the injection from a decidable subtypes.
--/
--- Dual of the injection from a decidable subtype
definition coinj {α : Type _} (p : α → Prop) [decidable_pred p] : partial α (subtype p) :=
  λ x, dite (p x) (λ h, some ⟨x,h⟩) (λ _, none)

section coinj

variables {α : Type _} {p : α → Prop} [decidable_pred p]

--- A point belongs to the domain of `coinj p` if and only if it satisfies `p`.
lemma coinj_domain : ∀ x, (coinj p).is_defined_at x ↔ p x :=
  begin
    intros x,
    dsimp [coinj, partial.is_defined_at],
    by_cases p x,
    rw [dif_pos h]; calc
      ¬some (subtype.mk x h) = none
          ↔ true : iff_true_intro (λ h, option.no_confusion h)
      ... ↔ p x : iff.symm (iff_true_intro h),
    rw [dif_neg h]; calc
      ¬none = none
          ↔ false : ⟨false_of_ne,false.elim⟩
      ... ↔ p x : iff.symm (iff_false_intro h)
  end

--- `coinj p` is injective as a partial function.
lemma coinj_inj : (coinj p).injective :=
  begin
    intros x y hx hy hxy,
    have hpx : p x,
      from (coinj_domain x).mp hx,
    have hpy : p y,
      from (coinj_domain y).mp hy,
    dsimp [coinj] at hxy,
    rw [dif_pos hpx, dif_pos hpy] at hxy,
    exact congr_arg subtype.val (option.some.inj hxy)
  end

end coinj

end partial

end function


/-
Copyright (c) 2020 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen, Devon Tuma
-/

import ring_theory.non_zero_divisors
import data.polynomial.algebra_map

/-!
# Scaling the roots of a polynomial

This file defines `scale_roots p s` for a polynomial `p` in one variable and a ring element `s` to
be the polynomial with root `r * s` for each root `r` of `p` and proves some basic results about it.
-/

section scale_roots

variables {A K R S : Type*} [comm_ring A] [is_domain A] [field K] [comm_ring R] [comm_ring S]
variables {M : submonoid A}

open polynomial
open_locale big_operators polynomial

/-- `scale_roots p s` is a polynomial with root `r * s` for each root `r` of `p`. -/
noncomputable def scale_roots (p : R[X]) (s : R) : R[X] :=
∑ i in p.support, monomial i (p.coeff i * s ^ (p.nat_degree - i))

@[simp] lemma coeff_scale_roots (p : R[X]) (s : R) (i : ℕ) :
  (scale_roots p s).coeff i = coeff p i * s ^ (p.nat_degree - i) :=
by simp [scale_roots, coeff_monomial] {contextual := tt}

lemma coeff_scale_roots_nat_degree (p : R[X]) (s : R) :
  (scale_roots p s).coeff p.nat_degree = p.leading_coeff :=
by rw [leading_coeff, coeff_scale_roots, tsub_self, pow_zero, mul_one]

@[simp] lemma zero_scale_roots (s : R) : scale_roots 0 s = 0 := by { ext, simp }

lemma scale_roots_ne_zero {p : R[X]} (hp : p ≠ 0) (s : R) :
  scale_roots p s ≠ 0 :=
begin
  intro h,
  have : p.coeff p.nat_degree ≠ 0 := mt leading_coeff_eq_zero.mp hp,
  have : (scale_roots p s).coeff p.nat_degree = 0 :=
    congr_fun (congr_arg (coeff : R[X] → ℕ → R) h) p.nat_degree,
  rw [coeff_scale_roots_nat_degree] at this,
  contradiction
end

lemma support_scale_roots_le (p : R[X]) (s : R) :
  (scale_roots p s).support ≤ p.support :=
by { intro, simpa using left_ne_zero_of_mul }

lemma support_scale_roots_eq (p : R[X]) {s : R} (hs : s ∈ non_zero_divisors R) :
  (scale_roots p s).support = p.support :=
le_antisymm (support_scale_roots_le p s)
  begin
    intro i,
    simp only [coeff_scale_roots, polynomial.mem_support_iff],
    intros p_ne_zero ps_zero,
    have := pow_mem hs (p.nat_degree - i) _ ps_zero,
    contradiction
  end

@[simp] lemma degree_scale_roots (p : R[X]) {s : R} :
  degree (scale_roots p s) = degree p :=
begin
  haveI := classical.prop_decidable,
  by_cases hp : p = 0,
  { rw [hp, zero_scale_roots] },
  have := scale_roots_ne_zero hp s,
  refine le_antisymm (finset.sup_mono (support_scale_roots_le p s)) (degree_le_degree _),
  rw coeff_scale_roots_nat_degree,
  intro h,
  have := leading_coeff_eq_zero.mp h,
  contradiction,
end

@[simp] lemma nat_degree_scale_roots (p : R[X]) (s : R) :
  nat_degree (scale_roots p s) = nat_degree p :=
by simp only [nat_degree, degree_scale_roots]

lemma monic_scale_roots_iff {p : R[X]} (s : R) :
  monic (scale_roots p s) ↔ monic p :=
by simp only [monic, leading_coeff, nat_degree_scale_roots, coeff_scale_roots_nat_degree]

lemma scale_roots_eval₂_eq_zero {p : S[X]} (f : S →+* R)
  {r : R} {s : S} (hr : eval₂ f r p = 0) :
  eval₂ f (f s * r) (scale_roots p s) = 0 :=
calc eval₂ f (f s * r) (scale_roots p s) =
  (scale_roots p s).support.sum (λ i, f (coeff p i * s ^ (p.nat_degree - i)) * (f s * r) ^ i) :
  by simp [eval₂_eq_sum, sum_def]
... = p.support.sum (λ i, f (coeff p i * s ^ (p.nat_degree - i)) * (f s * r) ^ i) :
  finset.sum_subset (support_scale_roots_le p s)
  (λ i hi hi', let this : coeff p i * s ^ (p.nat_degree - i) = 0 :=
  by simpa using hi' in by simp [this])
... = p.support.sum (λ (i : ℕ), f (p.coeff i) * f s ^ (p.nat_degree - i + i) * r ^ i) :
  finset.sum_congr rfl
  (λ i hi, by simp_rw [f.map_mul, f.map_pow, pow_add, mul_pow, mul_assoc])
... = p.support.sum (λ (i : ℕ), f s ^ p.nat_degree * (f (p.coeff i) * r ^ i)) :
  finset.sum_congr rfl
  (λ i hi, by { rw [mul_assoc, mul_left_comm, tsub_add_cancel_of_le],
                exact le_nat_degree_of_ne_zero (polynomial.mem_support_iff.mp hi) })
... = f s ^ p.nat_degree * p.support.sum (λ (i : ℕ), (f (p.coeff i) * r ^ i)) : finset.mul_sum.symm
... = f s ^ p.nat_degree * eval₂ f r p : by { simp [eval₂_eq_sum, sum_def] }
... = 0 : by rw [hr, _root_.mul_zero]

lemma scale_roots_aeval_eq_zero [algebra S R] {p : S[X]}
  {r : R} {s : S} (hr : aeval r p = 0) :
  aeval (algebra_map S R s * r) (scale_roots p s) = 0 :=
scale_roots_eval₂_eq_zero (algebra_map S R) hr

lemma scale_roots_eval₂_eq_zero_of_eval₂_div_eq_zero
  {p : A[X]} {f : A →+* K} (hf : function.injective f)
  {r s : A} (hr : eval₂ f (f r / f s) p = 0) (hs : s ∈ non_zero_divisors A) :
  eval₂ f (f r) (scale_roots p s) = 0 :=
begin
  convert scale_roots_eval₂_eq_zero f hr,
  rw [←mul_div_assoc, mul_comm, mul_div_cancel],
  exact map_ne_zero_of_mem_non_zero_divisors _ hf hs
end

lemma scale_roots_aeval_eq_zero_of_aeval_div_eq_zero [algebra A K]
  (inj : function.injective (algebra_map A K)) {p : A[X]} {r s : A}
  (hr : aeval (algebra_map A K r / algebra_map A K s) p = 0) (hs : s ∈ non_zero_divisors A) :
  aeval (algebra_map A K r) (scale_roots p s) = 0 :=
scale_roots_eval₂_eq_zero_of_eval₂_div_eq_zero inj hr hs

end scale_roots


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

! This file was ported from Lean 3 source module analysis.analytic.isolated_zeros
! leanprover-community/mathlib commit 32253a1a1071173b33dc7d6a218cf722c6feb514
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.Analytic.Basic
import Mathbin.Analysis.Calculus.Dslope
import Mathbin.Analysis.Calculus.FderivAnalytic
import Mathbin.Analysis.Calculus.FormalMultilinearSeries
import Mathbin.Analysis.Analytic.Uniqueness

/-!
# Principle of isolated zeros

This file proves the fact that the zeros of a non-constant analytic function of one variable are
isolated. It also introduces a little bit of API in the `has_fpower_series_at` namespace that is
useful in this setup.

## Main results

* `analytic_at.eventually_eq_zero_or_eventually_ne_zero` is the main statement that if a function is
  analytic at `z₀`, then either it is identically zero in a neighborhood of `z₀`, or it does not
  vanish in a punctured neighborhood of `z₀`.
* `analytic_on.eq_on_of_preconnected_of_frequently_eq` is the identity theorem for analytic
  functions: if a function `f` is analytic on a connected set `U` and is zero on a set with an
  accumulation point in `U` then `f` is identically `0` on `U`.
-/

open Classical

open Filter Function Nat FormalMultilinearSeries Emetric Set

open Topology BigOperators

variable {𝕜 : Type _} [NontriviallyNormedField 𝕜] {E : Type _} [NormedAddCommGroup E]
  [NormedSpace 𝕜 E] {s : E} {p q : FormalMultilinearSeries 𝕜 𝕜 E} {f g : 𝕜 → E} {n : ℕ} {z z₀ : 𝕜}
  {y : Fin n → 𝕜}

namespace HasSum

variable {a : ℕ → E}

theorem hasSum_at_zero (a : ℕ → E) : HasSum (fun n => (0 : 𝕜) ^ n • a n) (a 0) := by
  convert hasSum_single 0 fun b h => _ <;> first |simp [Nat.pos_of_ne_zero h]|simp
#align has_sum.has_sum_at_zero HasSum.hasSum_at_zero

theorem exists_hasSum_smul_of_apply_eq_zero (hs : HasSum (fun m => z ^ m • a m) s)
    (ha : ∀ k < n, a k = 0) : ∃ t : E, z ^ n • t = s ∧ HasSum (fun m => z ^ m • a (m + n)) t :=
  by
  obtain rfl | hn := n.eq_zero_or_pos
  · simpa
  by_cases h : z = 0
  · have : s = 0 := hs.unique (by simpa [ha 0 hn, h] using has_sum_at_zero a)
    exact ⟨a n, by simp [h, hn, this], by simpa [h] using has_sum_at_zero fun m => a (m + n)⟩
  · refine' ⟨(z ^ n)⁻¹ • s, by field_simp [smul_smul] , _⟩
    have h1 : (∑ i in Finset.range n, z ^ i • a i) = 0 :=
      Finset.sum_eq_zero fun k hk => by simp [ha k (finset.mem_range.mp hk)]
    have h2 : HasSum (fun m => z ^ (m + n) • a (m + n)) s := by
      simpa [h1] using (hasSum_nat_add_iff' n).mpr hs
    convert h2.const_smul (z⁻¹ ^ n)
    · field_simp [pow_add, smul_smul]
    · simp only [inv_pow]
#align has_sum.exists_has_sum_smul_of_apply_eq_zero HasSum.exists_hasSum_smul_of_apply_eq_zero

end HasSum

namespace HasFpowerSeriesAt

theorem hasFpowerSeriesDslopeFslope (hp : HasFpowerSeriesAt f p z₀) :
    HasFpowerSeriesAt (dslope f z₀) p.fslope z₀ :=
  by
  have hpd : deriv f z₀ = p.coeff 1 := hp.deriv
  have hp0 : p.coeff 0 = f z₀ := hp.coeff_zero 1
  simp only [hasFpowerSeriesAt_iff, apply_eq_pow_smul_coeff, coeff_fslope] at hp⊢
  refine' hp.mono fun x hx => _
  by_cases h : x = 0
  · convert hasSum_single 0 _ <;> intros <;> simp [*]
  · have hxx : ∀ n : ℕ, x⁻¹ * x ^ (n + 1) = x ^ n := fun n => by field_simp [h, pow_succ']
    suffices HasSum (fun n => x⁻¹ • x ^ (n + 1) • p.coeff (n + 1)) (x⁻¹ • (f (z₀ + x) - f z₀)) by
      simpa [dslope, slope, h, smul_smul, hxx] using this
    · simpa [hp0] using ((hasSum_nat_add_iff' 1).mpr hx).const_smul x⁻¹
#align has_fpower_series_at.has_fpower_series_dslope_fslope HasFpowerSeriesAt.hasFpowerSeriesDslopeFslope

theorem hasFpowerSeriesIterateDslopeFslope (n : ℕ) (hp : HasFpowerSeriesAt f p z₀) :
    HasFpowerSeriesAt ((swap dslope z₀^[n]) f) ((fslope^[n]) p) z₀ :=
  by
  induction' n with n ih generalizing f p
  · exact hp
  · simpa using ih (has_fpower_series_dslope_fslope hp)
#align has_fpower_series_at.has_fpower_series_iterate_dslope_fslope HasFpowerSeriesAt.hasFpowerSeriesIterateDslopeFslope

theorem iterate_dslope_fslope_ne_zero (hp : HasFpowerSeriesAt f p z₀) (h : p ≠ 0) :
    (swap dslope z₀^[p.order]) f z₀ ≠ 0 :=
  by
  rw [← coeff_zero (has_fpower_series_iterate_dslope_fslope p.order hp) 1]
  simpa [coeff_eq_zero] using apply_order_ne_zero h
#align has_fpower_series_at.iterate_dslope_fslope_ne_zero HasFpowerSeriesAt.iterate_dslope_fslope_ne_zero

theorem eq_pow_order_mul_iterate_dslope (hp : HasFpowerSeriesAt f p z₀) :
    ∀ᶠ z in 𝓝 z₀, f z = (z - z₀) ^ p.order • (swap dslope z₀^[p.order]) f z :=
  by
  have hq := has_fpower_series_at_iff'.mp (has_fpower_series_iterate_dslope_fslope p.order hp)
  filter_upwards [hq, has_fpower_series_at_iff'.mp hp]with x hx1 hx2
  have : ∀ k < p.order, p.coeff k = 0 := fun k hk => by
    simpa [coeff_eq_zero] using apply_eq_zero_of_lt_order hk
  obtain ⟨s, hs1, hs2⟩ := HasSum.exists_hasSum_smul_of_apply_eq_zero hx2 this
  convert hs1.symm
  simp only [coeff_iterate_fslope] at hx1
  exact hx1.unique hs2
#align has_fpower_series_at.eq_pow_order_mul_iterate_dslope HasFpowerSeriesAt.eq_pow_order_mul_iterate_dslope

theorem locally_ne_zero (hp : HasFpowerSeriesAt f p z₀) (h : p ≠ 0) : ∀ᶠ z in 𝓝[≠] z₀, f z ≠ 0 :=
  by
  rw [eventually_nhdsWithin_iff]
  have h2 := (has_fpower_series_iterate_dslope_fslope p.order hp).ContinuousAt
  have h3 := h2.eventually_ne (iterate_dslope_fslope_ne_zero hp h)
  filter_upwards [eq_pow_order_mul_iterate_dslope hp, h3]with z e1 e2 e3
  simpa [e1, e2, e3] using pow_ne_zero p.order (sub_ne_zero.mpr e3)
#align has_fpower_series_at.locally_ne_zero HasFpowerSeriesAt.locally_ne_zero

theorem locally_zero_iff (hp : HasFpowerSeriesAt f p z₀) : (∀ᶠ z in 𝓝 z₀, f z = 0) ↔ p = 0 :=
  ⟨fun hf => hp.eq_zero_of_eventually hf, fun h => eventually_eq_zero (by rwa [h] at hp)⟩
#align has_fpower_series_at.locally_zero_iff HasFpowerSeriesAt.locally_zero_iff

end HasFpowerSeriesAt

namespace AnalyticAt

/-- The *principle of isolated zeros* for an analytic function, local version: if a function is
analytic at `z₀`, then either it is identically zero in a neighborhood of `z₀`, or it does not
vanish in a punctured neighborhood of `z₀`. -/
theorem eventually_eq_zero_or_eventually_ne_zero (hf : AnalyticAt 𝕜 f z₀) :
    (∀ᶠ z in 𝓝 z₀, f z = 0) ∨ ∀ᶠ z in 𝓝[≠] z₀, f z ≠ 0 :=
  by
  rcases hf with ⟨p, hp⟩
  by_cases h : p = 0
  · exact Or.inl (HasFpowerSeriesAt.eventually_eq_zero (by rwa [h] at hp))
  · exact Or.inr (hp.locally_ne_zero h)
#align analytic_at.eventually_eq_zero_or_eventually_ne_zero AnalyticAt.eventually_eq_zero_or_eventually_ne_zero

theorem eventually_eq_or_eventually_ne (hf : AnalyticAt 𝕜 f z₀) (hg : AnalyticAt 𝕜 g z₀) :
    (∀ᶠ z in 𝓝 z₀, f z = g z) ∨ ∀ᶠ z in 𝓝[≠] z₀, f z ≠ g z := by
  simpa [sub_eq_zero] using (hf.sub hg).eventually_eq_zero_or_eventually_ne_zero
#align analytic_at.eventually_eq_or_eventually_ne AnalyticAt.eventually_eq_or_eventually_ne

theorem frequently_zero_iff_eventually_zero {f : 𝕜 → E} {w : 𝕜} (hf : AnalyticAt 𝕜 f w) :
    (∃ᶠ z in 𝓝[≠] w, f z = 0) ↔ ∀ᶠ z in 𝓝 w, f z = 0 :=
  ⟨hf.eventually_eq_zero_or_eventually_ne_zero.resolve_right, fun h =>
    (h.filter_mono nhdsWithin_le_nhds).Frequently⟩
#align analytic_at.frequently_zero_iff_eventually_zero AnalyticAt.frequently_zero_iff_eventually_zero

theorem frequently_eq_iff_eventually_eq (hf : AnalyticAt 𝕜 f z₀) (hg : AnalyticAt 𝕜 g z₀) :
    (∃ᶠ z in 𝓝[≠] z₀, f z = g z) ↔ ∀ᶠ z in 𝓝 z₀, f z = g z := by
  simpa [sub_eq_zero] using frequently_zero_iff_eventually_zero (hf.sub hg)
#align analytic_at.frequently_eq_iff_eventually_eq AnalyticAt.frequently_eq_iff_eventually_eq

end AnalyticAt

namespace AnalyticOn

variable {U : Set 𝕜}

/-- The *principle of isolated zeros* for an analytic function, global version: if a function is
analytic on a connected set `U` and vanishes in arbitrary neighborhoods of a point `z₀ ∈ U`, then
it is identically zero in `U`.
For higher-dimensional versions requiring that the function vanishes in a neighborhood of `z₀`,
see `eq_on_zero_of_preconnected_of_eventually_eq_zero`. -/
theorem eqOn_zero_of_preconnected_of_frequently_eq_zero (hf : AnalyticOn 𝕜 f U)
    (hU : IsPreconnected U) (h₀ : z₀ ∈ U) (hfw : ∃ᶠ z in 𝓝[≠] z₀, f z = 0) : EqOn f 0 U :=
  hf.eqOn_zero_of_preconnected_of_eventuallyEq_zero hU h₀
    ((hf z₀ h₀).frequently_zero_iff_eventually_zero.1 hfw)
#align analytic_on.eq_on_zero_of_preconnected_of_frequently_eq_zero AnalyticOn.eqOn_zero_of_preconnected_of_frequently_eq_zero

theorem eqOn_zero_of_preconnected_of_mem_closure (hf : AnalyticOn 𝕜 f U) (hU : IsPreconnected U)
    (h₀ : z₀ ∈ U) (hfz₀ : z₀ ∈ closure ({ z | f z = 0 } \ {z₀})) : EqOn f 0 U :=
  hf.eqOn_zero_of_preconnected_of_frequently_eq_zero hU h₀
    (mem_closure_ne_iff_frequently_within.mp hfz₀)
#align analytic_on.eq_on_zero_of_preconnected_of_mem_closure AnalyticOn.eqOn_zero_of_preconnected_of_mem_closure

/-- The *identity principle* for analytic functions, global version: if two functions are
analytic on a connected set `U` and coincide at points which accumulate to a point `z₀ ∈ U`, then
they coincide globally in `U`.
For higher-dimensional versions requiring that the functions coincide in a neighborhood of `z₀`,
see `eq_on_of_preconnected_of_eventually_eq`. -/
theorem eqOn_of_preconnected_of_frequently_eq (hf : AnalyticOn 𝕜 f U) (hg : AnalyticOn 𝕜 g U)
    (hU : IsPreconnected U) (h₀ : z₀ ∈ U) (hfg : ∃ᶠ z in 𝓝[≠] z₀, f z = g z) : EqOn f g U :=
  by
  have hfg' : ∃ᶠ z in 𝓝[≠] z₀, (f - g) z = 0 :=
    hfg.mono fun z h => by rw [Pi.sub_apply, h, sub_self]
  simpa [sub_eq_zero] using fun z hz =>
    (hf.sub hg).eqOn_zero_of_preconnected_of_frequently_eq_zero hU h₀ hfg' hz
#align analytic_on.eq_on_of_preconnected_of_frequently_eq AnalyticOn.eqOn_of_preconnected_of_frequently_eq

theorem eqOn_of_preconnected_of_mem_closure (hf : AnalyticOn 𝕜 f U) (hg : AnalyticOn 𝕜 g U)
    (hU : IsPreconnected U) (h₀ : z₀ ∈ U) (hfg : z₀ ∈ closure ({ z | f z = g z } \ {z₀})) :
    EqOn f g U :=
  hf.eqOn_of_preconnected_of_frequently_eq hg hU h₀ (mem_closure_ne_iff_frequently_within.mp hfg)
#align analytic_on.eq_on_of_preconnected_of_mem_closure AnalyticOn.eqOn_of_preconnected_of_mem_closure

end AnalyticOn


/-
Copyright (c) 2021 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import analysis.normed_space.hahn_banach.extension
import measure_theory.measure.lebesgue

/-!
# A counterexample on Pettis integrability

There are several theories of integration for functions taking values in Banach spaces. Bochner
integration, requiring approximation by simple functions, is the analogue of the one-dimensional
theory. It is very well behaved, but only works for functions with second-countable range.

For functions `f` taking values in a larger Banach space `B`, one can define the Dunford integral
as follows. Assume that, for all continuous linear functional `φ`, the function `φ ∘ f` is
measurable (we say that `f` is weakly measurable, or scalarly measurable) and integrable.
Then `φ ↦ ∫ φ ∘ f` is continuous (by the closed graph theorem), and therefore defines an element
of the bidual `B**`. This is the Dunford integral of `f`.

This Dunford integral is not usable in practice as it does not belong to the right space. Let us
say that a function is Pettis integrable if its Dunford integral belongs to the canonical image of
`B` in `B**`. In this case, we define the Pettis integral as the Dunford integral inside `B`.

This integral is very general, but not really usable to do analysis. This file illustrates this,
by giving an example of a function with nice properties but which is *not* Pettis-integrable.
This function:
- is defined from `[0, 1]` to a complete Banach space;
- is weakly measurable;
- has norm everywhere bounded by `1` (in particular, its norm is integrable);
- and yet it is not Pettis-integrable with respect to Lebesgue measure.

This construction is due to [Ralph S. Phillips, *Integration in a convex linear
topological space*][phillips1940], in Example 10.8. It requires the continuum hypothesis. The
example is the following.

Under the continuum hypothesis, one can find a subset of `ℝ²` which,
along each vertical line, only misses a countable set of points, while it is countable along each
horizontal line. This is due to Sierpinski, and formalized in `sierpinski_pathological_family`.
(In fact, Sierpinski proves that the existence of such a set is equivalent to the continuum
hypothesis).

Let `B` be the set of all bounded functions on `ℝ` (we are really talking about everywhere defined
functions here). Define `f : ℝ → B` by taking `f x` to be the characteristic function of the
vertical slice at position `x` of Sierpinski's set. It is our counterexample.

To show that it is weakly measurable, we should consider `φ ∘ f` where `φ` is an arbitrary
continuous linear form on `B`. There is no reasonable classification of such linear forms (they can
be very wild). But if one restricts such a linear form to characteristic functions, one gets a
finitely additive signed "measure". Such a "measure" can be decomposed into a discrete part
(supported on a countable set) and a continuous part (giving zero mass to countable sets).
For all but countably many points, `f x` will not intersect the discrete support of `φ` thanks to
the definition of the Sierpinski set. This implies that `φ ∘ f` is constant outside of a countable
set, and equal to the total mass of the continuous part of `φ` there. In particular, it is
measurable (and its integral is the total mass of the continuous part of `φ`).

Assume that `f` has a Pettis integral `g`. For all continuous linear form `φ`, then `φ g` should
be the total mass of the continuous part of `φ`. Taking for `φ` the evaluation at the point `x`
(which has no continuous part), one gets `g x = 0`. Take then for `φ` the Lebesgue integral on
`[0, 1]` (or rather an arbitrary extension of Lebesgue integration to all bounded functions,
thanks to Hahn-Banach). Then `φ g` should be the total mass of the continuous part of `φ`,
which is `1`. This contradicts the fact that `g = 0`, and concludes the proof that `f` has no
Pettis integral.

## Implementation notes

The space of all bounded functions is defined as the space of all bounded continuous functions
on a discrete copy of the original type, as mathlib only contains the space of all bounded
continuous functions (which is the useful one).
-/

universe u
variables {α : Type u}
open set bounded_continuous_function measure_theory
open cardinal (aleph)
open_locale cardinal bounded_continuous_function

noncomputable theory

/-- A copy of a type, endowed with the discrete topology -/
def discrete_copy (α : Type u) : Type u := α

instance : topological_space (discrete_copy α) := ⊥
instance : discrete_topology (discrete_copy α) := ⟨rfl⟩
instance [inhabited α] : inhabited (discrete_copy α) := ⟨show α, from default⟩

namespace phillips_1940

/-!
### Extending the integral

Thanks to Hahn-Banach, one can define a (non-canonical) continuous linear functional on the space
of all bounded functions, coinciding with the integral on the integrable ones.
-/

/-- The subspace of integrable functions in the space of all bounded functions on a type.
This is a technical device, used to apply Hahn-Banach theorem to construct an extension of the
integral to all bounded functions. -/
def bounded_integrable_functions [measurable_space α] (μ : measure α) :
  subspace ℝ (discrete_copy α →ᵇ ℝ) :=
{ carrier   := {f | integrable f μ},
  zero_mem' := integrable_zero _ _ _,
  add_mem'  := λ f g hf hg, integrable.add hf hg,
  smul_mem' := λ c f hf, integrable.smul c hf }

/-- The integral, as a continuous linear map on the subspace of integrable functions in the space
of all bounded functions on a type. This is a technical device, that we will extend through
Hahn-Banach. -/
def bounded_integrable_functions_integral_clm [measurable_space α]
  (μ : measure α) [is_finite_measure μ] : bounded_integrable_functions μ →L[ℝ] ℝ :=
linear_map.mk_continuous
  { to_fun := λ f, ∫ x, f x ∂μ,
    map_add' := λ f g, integral_add f.2 g.2,
    map_smul' := λ c f, integral_smul _ _ }
  (μ univ).to_real
  begin
    assume f,
    rw mul_comm,
    apply norm_integral_le_of_norm_le_const,
    apply filter.eventually_of_forall,
    assume x,
    exact bounded_continuous_function.norm_coe_le_norm f x,
  end

/-- Given a measure, there exists a continuous linear form on the space of all bounded functions
(not necessarily measurable) that coincides with the integral on bounded measurable functions. -/
lemma exists_linear_extension_to_bounded_functions
  [measurable_space α] (μ : measure α) [is_finite_measure μ] :
  ∃ φ : (discrete_copy α →ᵇ ℝ) →L[ℝ] ℝ, ∀ (f : discrete_copy α →ᵇ ℝ),
    integrable f μ → φ f = ∫ x, f x ∂μ :=
begin
  rcases exists_extension_norm_eq _ (bounded_integrable_functions_integral_clm μ) with ⟨φ, hφ⟩,
  exact ⟨φ, λ f hf, hφ.1 ⟨f, hf⟩⟩,
end

/-- An arbitrary extension of the integral to all bounded functions, as a continuous linear map.
It is not at all canonical, and constructed using Hahn-Banach. -/
def _root_.measure_theory.measure.extension_to_bounded_functions
  [measurable_space α] (μ : measure α) [is_finite_measure μ] : (discrete_copy α →ᵇ ℝ) →L[ℝ] ℝ :=
(exists_linear_extension_to_bounded_functions μ).some

lemma extension_to_bounded_functions_apply [measurable_space α] (μ : measure α)
  [is_finite_measure μ] (f : discrete_copy α →ᵇ ℝ) (hf : integrable f μ) :
  μ.extension_to_bounded_functions f = ∫ x, f x ∂μ :=
(exists_linear_extension_to_bounded_functions μ).some_spec f hf

/-!
### Additive measures on the space of all sets

We define bounded finitely additive signed measures on the space of all subsets of a type `α`,
and show that such an object can be split into a discrete part and a continuous part.
-/

/-- A bounded signed finitely additive measure defined on *all* subsets of a type. -/
structure bounded_additive_measure (α : Type u) :=
(to_fun : set α → ℝ)
(additive' : ∀ s t, disjoint s t → to_fun (s ∪ t) = to_fun s + to_fun t)
(exists_bound : ∃ (C : ℝ), ∀ s, |to_fun s| ≤ C)

instance : inhabited (bounded_additive_measure α) :=
⟨{ to_fun := λ s, 0,
  additive' := λ s t hst, by simp,
  exists_bound := ⟨0, λ s, by simp⟩ }⟩

instance : has_coe_to_fun (bounded_additive_measure α) (λ _, set α → ℝ) := ⟨λ f, f.to_fun⟩

namespace bounded_additive_measure

/-- A constant bounding the mass of any set for `f`. -/
def C (f : bounded_additive_measure α) := f.exists_bound.some

lemma additive (f : bounded_additive_measure α) (s t : set α)
  (h : disjoint s t) : f (s ∪ t) = f s + f t :=
f.additive' s t h

lemma abs_le_bound (f : bounded_additive_measure α) (s : set α) :
  |f s| ≤ f.C :=
f.exists_bound.some_spec s

lemma le_bound (f : bounded_additive_measure α) (s : set α) :
  f s ≤ f.C :=
le_trans (le_abs_self _) (f.abs_le_bound s)

@[simp] lemma empty (f : bounded_additive_measure α) : f ∅ = 0 :=
begin
  have : (∅ : set α) = ∅ ∪ ∅, by simp only [empty_union],
  apply_fun f at this,
  rwa [f.additive _ _ (empty_disjoint _), self_eq_add_left] at this,
end

instance : has_neg (bounded_additive_measure α) :=
⟨λ f,
{ to_fun := λ s, - f s,
  additive' := λ s t hst, by simp only [f.additive s t hst, add_comm, neg_add_rev],
  exists_bound := ⟨f.C, λ s, by simp [f.abs_le_bound]⟩ }⟩

@[simp] lemma neg_apply (f : bounded_additive_measure α) (s : set α) : (-f) s = - (f s) := rfl

/-- Restricting a bounded additive measure to a subset still gives a bounded additive measure. -/
def restrict (f : bounded_additive_measure α) (t : set α) : bounded_additive_measure α :=
{ to_fun := λ s, f (t ∩ s),
  additive' := λ s s' h, begin
    rw [← f.additive (t ∩ s) (t ∩ s'), inter_union_distrib_left],
    exact h.mono (inter_subset_right _ _) (inter_subset_right _ _),
  end,
  exists_bound := ⟨f.C, λ s, f.abs_le_bound _⟩ }

@[simp] lemma restrict_apply (f : bounded_additive_measure α) (s t : set α) :
  f.restrict s t = f (s ∩ t) := rfl

/-- There is a maximal countable set of positive measure, in the sense that any countable set
not intersecting it has nonpositive measure. Auxiliary lemma to prove `exists_discrete_support`. -/
lemma exists_discrete_support_nonpos (f : bounded_additive_measure α) :
  ∃ (s : set α), s.countable ∧ (∀ t : set α, t.countable → f (t \ s) ≤ 0) :=
begin
  /- The idea of the proof is to construct the desired set inductively, adding at each step a
  countable set with close to maximal measure among those points that have not already been chosen.
  Doing this countably many steps will be enough. Indeed, otherwise, a remaining set would have
  positive measure `ε`. This means that at each step the set we have added also had a large measure,
  say at least `ε / 2`. After `n` steps, the set we have constructed has therefore measure at least
  `n * ε / 2`. This is a contradiction since the measures have to remain uniformly bounded.

  We argue from the start by contradiction, as this means that our inductive construction will
  never be stuck, so we won't have to consider this case separately.

  In this proof, we use explicit coercions `↑s` for `s : A` as otherwise the system tries to find
  a `has_coe_to_fun` instance on `↥A`, which is too costly.
  -/
  by_contra' h,
  -- We will formulate things in terms of the type of countable subsets of `α`, as this is more
  -- convenient to formalize the inductive construction.
  let A : set (set α) := {t | t.countable},
  let empty : A := ⟨∅, countable_empty⟩,
  haveI : nonempty A := ⟨empty⟩,
  -- given a countable set `s`, one can find a set `t` in its complement with measure close to
  -- maximal.
  have : ∀ (s : A), ∃ (t : A), (∀ (u : A), f (↑u \ ↑s) ≤ 2 * f (↑t \ ↑s)),
  { assume s,
    have B : bdd_above (range (λ (u : A), f (↑u \ ↑s))),
      { refine ⟨f.C, λ x hx, _⟩,
        rcases hx with ⟨u, hu⟩,
        rw ← hu,
        exact f.le_bound _ },
    let S := supr (λ (t : A), f (↑t \ ↑s)),
    have S_pos : 0 < S,
    { rcases h s.1 s.2  with ⟨t, t_count, ht⟩,
      apply ht.trans_le,
      let t' : A := ⟨t, t_count⟩,
      change f (↑t' \ ↑s) ≤ S,
      exact le_csupr B t' },
    rcases exists_lt_of_lt_csupr (half_lt_self S_pos) with ⟨t, ht⟩,
    refine ⟨t, λ u, _⟩,
    calc f (↑u \ ↑s) ≤ S : le_csupr B _
      ... = 2 * (S / 2) : by ring
      ... ≤ 2 * f (↑t \ ↑s) : mul_le_mul_of_nonneg_left ht.le (by norm_num) },
  choose! F hF using this,
  -- iterate the above construction, by adding at each step a set with measure close to maximal in
  -- the complement of already chosen points. This is the set `s n` at step `n`.
  let G : A → A := λ u, ⟨(↑u : set α) ∪ ↑(F u), u.2.union (F u).2⟩,
  let s : ℕ → A := λ n, G^[n] empty,
  -- We will get a contradiction from the fact that there is a countable set `u` with positive
  -- measure in the complement of `⋃ n, s n`.
  rcases h (⋃ n, ↑(s n)) (countable_Union (λ n, (s n).2)) with ⟨t, t_count, ht⟩,
  let u : A := ⟨t \ ⋃ n, ↑(s n), t_count.mono (diff_subset _ _)⟩,
  set ε := f (↑u) with hε,
  have ε_pos : 0 < ε := ht,
  have I1 : ∀ n, ε / 2 ≤ f (↑(s (n+1)) \ ↑(s n)),
  { assume n,
    rw [div_le_iff' (show (0 : ℝ) < 2, by norm_num), hε],
    convert hF (s n) u using 3,
    { dsimp [u],
      ext x,
      simp only [not_exists, mem_Union, mem_diff],
      tauto },
    { simp only [s, function.iterate_succ', subtype.coe_mk, union_diff_left] } },
  have I2 : ∀ (n : ℕ), (n : ℝ) * (ε / 2) ≤ f (↑(s n)),
  { assume n,
    induction n with n IH,
    { simp only [s, bounded_additive_measure.empty, id.def, nat.cast_zero, zero_mul,
        function.iterate_zero, subtype.coe_mk], },
    { have : (↑(s (n+1)) : set α) = (↑(s (n+1)) \ ↑(s n)) ∪ ↑(s n),
        by simp only [s, function.iterate_succ', union_comm, union_diff_self, subtype.coe_mk,
          union_diff_left],
      rw [nat.succ_eq_add_one, this, f.additive],
      swap, { exact disjoint_sdiff_self_left },
      calc ((n + 1 : ℕ) : ℝ) * (ε / 2) = ε / 2 + n * (ε / 2) : by simp only [nat.cast_succ]; ring
      ... ≤ f (↑(s (n + 1 : ℕ)) \ ↑(s n)) + f (↑(s n)) :
        add_le_add (I1 n) IH } },
  rcases exists_nat_gt (f.C / (ε / 2)) with ⟨n, hn⟩,
  have : (n : ℝ) ≤ f.C / (ε / 2),
    by { rw le_div_iff (half_pos ε_pos), exact (I2 n).trans (f.le_bound _) },
  exact lt_irrefl _ (this.trans_lt hn)
end

lemma exists_discrete_support (f : bounded_additive_measure α) :
  ∃ s : set α, s.countable ∧ (∀ t : set α, t.countable → f (t \ s) = 0) :=
begin
  rcases f.exists_discrete_support_nonpos with ⟨s₁, s₁_count, h₁⟩,
  rcases (-f).exists_discrete_support_nonpos with ⟨s₂, s₂_count, h₂⟩,
  refine ⟨s₁ ∪ s₂, s₁_count.union s₂_count, λ t ht, le_antisymm _ _⟩,
  { have : t \ (s₁ ∪ s₂) = (t \ (s₁ ∪ s₂)) \ s₁,
      by rw [diff_diff, union_comm, union_assoc, union_self],
    rw this,
    exact h₁ _ (ht.mono (diff_subset _ _)) },
  { have : t \ (s₁ ∪ s₂) = (t \ (s₁ ∪ s₂)) \ s₂,
      by rw [diff_diff, union_assoc, union_self],
    rw this,
    simp only [neg_nonpos, neg_apply] at h₂,
    exact h₂ _ (ht.mono (diff_subset _ _)) },
end

/-- A countable set outside of which the measure gives zero mass to countable sets. We are not
claiming this set is unique, but we make an arbitrary choice of such a set. -/
def discrete_support (f : bounded_additive_measure α) : set α :=
(exists_discrete_support f).some

lemma countable_discrete_support (f : bounded_additive_measure α) :
  f.discrete_support.countable :=
(exists_discrete_support f).some_spec.1

lemma apply_countable (f : bounded_additive_measure α) (t : set α) (ht : t.countable) :
  f (t \ f.discrete_support) = 0 :=
(exists_discrete_support f).some_spec.2 t ht

/-- The discrete part of a bounded additive measure, obtained by restricting the measure to its
countable support. -/
def discrete_part (f : bounded_additive_measure α) : bounded_additive_measure α :=
f.restrict f.discrete_support

/-- The continuous part of a bounded additive measure, giving zero measure to every countable
set. -/
def continuous_part (f : bounded_additive_measure α) : bounded_additive_measure α :=
f.restrict (univ \ f.discrete_support)

lemma eq_add_parts (f : bounded_additive_measure α) (s : set α) :
  f s = f.discrete_part s + f.continuous_part s :=
begin
  simp only [discrete_part, continuous_part, restrict_apply],
  rw [← f.additive, ← inter_distrib_right],
  { simp only [union_univ, union_diff_self, univ_inter] },
  { have : disjoint f.discrete_support (univ \ f.discrete_support) := disjoint_sdiff_self_right,
    exact this.mono (inter_subset_left _ _) (inter_subset_left _ _) }
end

lemma discrete_part_apply (f : bounded_additive_measure α) (s : set α) :
  f.discrete_part s = f (f.discrete_support ∩ s) := rfl

lemma continuous_part_apply_eq_zero_of_countable (f : bounded_additive_measure α)
  (s : set α) (hs : s.countable) : f.continuous_part s = 0 :=
begin
  simp [continuous_part],
  convert f.apply_countable s hs using 2,
  ext x,
  simp [and_comm]
end

lemma continuous_part_apply_diff (f : bounded_additive_measure α)
  (s t : set α) (hs : s.countable) : f.continuous_part (t \ s) = f.continuous_part t :=
begin
  conv_rhs { rw ← diff_union_inter t s },
  rw [additive, self_eq_add_right],
  { exact continuous_part_apply_eq_zero_of_countable _ _ (hs.mono (inter_subset_right _ _)) },
  { exact disjoint.mono_right (inter_subset_right _ _) disjoint_sdiff_self_left },
end

end bounded_additive_measure

open bounded_additive_measure

section

/-!
### Relationship between continuous functionals and finitely additive measures.
-/

lemma norm_indicator_le_one (s : set α) (x : α) :
  ‖(indicator s (1 : α → ℝ)) x‖ ≤ 1 :=
by { simp only [indicator, pi.one_apply], split_ifs; norm_num }

/-- A functional in the dual space of bounded functions gives rise to a bounded additive measure,
by applying the functional to the indicator functions. -/
def _root_.continuous_linear_map.to_bounded_additive_measure
  [topological_space α] [discrete_topology α]
  (f : (α →ᵇ ℝ) →L[ℝ] ℝ) : bounded_additive_measure α :=
{ to_fun := λ s, f (of_normed_add_comm_group_discrete (indicator s 1) 1 (norm_indicator_le_one s)),
  additive' := λ s t hst,
    begin
      have : of_normed_add_comm_group_discrete (indicator (s ∪ t) 1) 1 (norm_indicator_le_one _)
              = of_normed_add_comm_group_discrete (indicator s 1) 1 (norm_indicator_le_one s)
              + of_normed_add_comm_group_discrete (indicator t 1) 1 (norm_indicator_le_one t),
        by { ext x, simp [indicator_union_of_disjoint hst], },
      rw [this, f.map_add],
    end,
  exists_bound := ⟨‖f‖, λ s, begin
    have I : ‖of_normed_add_comm_group_discrete (indicator s 1) 1 (norm_indicator_le_one s)‖ ≤ 1,
      by apply norm_of_normed_add_comm_group_le _ zero_le_one,
    apply le_trans (f.le_op_norm _),
    simpa using mul_le_mul_of_nonneg_left I (norm_nonneg f),
  end⟩ }

@[simp] lemma continuous_part_eval_clm_eq_zero [topological_space α] [discrete_topology α]
  (s : set α) (x : α) :
  (eval_clm ℝ x).to_bounded_additive_measure.continuous_part s = 0 :=
let f := (eval_clm ℝ x).to_bounded_additive_measure in calc
  f.continuous_part s
    = f.continuous_part (s \ {x}) : (continuous_part_apply_diff _ _ _ (countable_singleton x)).symm
... = f ((univ \ f.discrete_support) ∩ (s \ {x})) : rfl
... = indicator ((univ \ f.discrete_support) ∩ (s \ {x})) 1 x : rfl
... = 0 : by simp

lemma to_functions_to_measure [measurable_space α] (μ : measure α) [is_finite_measure μ]
  (s : set α) (hs : measurable_set s) :
  μ.extension_to_bounded_functions.to_bounded_additive_measure s = (μ s).to_real :=
begin
  change μ.extension_to_bounded_functions
    (of_normed_add_comm_group_discrete (indicator s 1) 1 (norm_indicator_le_one s)) = (μ s).to_real,
  rw extension_to_bounded_functions_apply,
  { change ∫ x, s.indicator (λ y, (1 : ℝ)) x ∂μ = _,
    simp [integral_indicator hs] },
  { change integrable (indicator s 1) μ,
    have : integrable (λ x, (1 : ℝ)) μ := integrable_const (1 : ℝ),
    apply this.mono'
      (measurable.indicator (@measurable_const _ _ _ _ (1 : ℝ)) hs).ae_strongly_measurable,
    apply filter.eventually_of_forall,
    exact norm_indicator_le_one _ }
end

lemma to_functions_to_measure_continuous_part [measurable_space α] [measurable_singleton_class α]
  (μ : measure α) [is_finite_measure μ] [has_no_atoms μ]
  (s : set α) (hs : measurable_set s) :
  μ.extension_to_bounded_functions.to_bounded_additive_measure.continuous_part s = (μ s).to_real :=
begin
  let f := μ.extension_to_bounded_functions.to_bounded_additive_measure,
  change f ((univ \ f.discrete_support) ∩ s) = (μ s).to_real,
  rw to_functions_to_measure, swap,
  { exact measurable_set.inter
      (measurable_set.univ.diff (countable.measurable_set f.countable_discrete_support)) hs },
  congr' 1,
  rw [inter_comm, ← inter_diff_assoc, inter_univ],
  exact measure_diff_null (f.countable_discrete_support.measure_zero _)
end

end

/-!
### A set in `ℝ²` large along verticals, small along horizontals

We construct a subset of `ℝ²`, given as a family of sets, which is large along verticals (i.e.,
it only misses a countable set along each vertical) but small along horizontals (it is countable
along horizontals). Such a set can not be measurable as it would contradict Fubini theorem.
We need the continuum hypothesis to construct it.
-/

theorem sierpinski_pathological_family (Hcont : #ℝ = aleph 1) :
  ∃ (f : ℝ → set ℝ), (∀ x, (univ \ f x).countable) ∧ (∀ y, {x : ℝ | y ∈ f x}.countable) :=
begin
  rcases cardinal.ord_eq ℝ with ⟨r, hr, H⟩,
  resetI,
  refine ⟨λ x, {y | r x y}, λ x, _, λ y, _⟩,
  { have : univ \ {y | r x y} = {y | r y x} ∪ {x},
    { ext y,
      simp only [true_and, mem_univ, mem_set_of_eq, mem_insert_iff, union_singleton, mem_diff],
      rcases trichotomous_of r x y with h|rfl|h,
      { simp only [h, not_or_distrib, false_iff, not_true],
        split,
        { rintros rfl, exact irrefl_of r y h },
        { exact asymm h } },
      { simp only [true_or, eq_self_iff_true, iff_true], exact irrefl x },
      { simp only [h, iff_true, or_true], exact asymm h } },
    rw this,
    apply countable.union _ (countable_singleton _),
    rw [cardinal.countable_iff_lt_aleph_one, ← Hcont],
    exact cardinal.card_typein_lt r x H },
  { rw [cardinal.countable_iff_lt_aleph_one, ← Hcont],
    exact cardinal.card_typein_lt r y H }
end

/-- A family of sets in `ℝ` which only miss countably many points, but such that any point is
contained in only countably many of them. -/
def spf (Hcont : #ℝ = aleph 1) (x : ℝ) : set ℝ :=
(sierpinski_pathological_family Hcont).some x

lemma countable_compl_spf (Hcont : #ℝ = aleph 1) (x : ℝ) : (univ \ spf Hcont x).countable :=
(sierpinski_pathological_family Hcont).some_spec.1 x

lemma countable_spf_mem (Hcont : #ℝ = aleph 1) (y : ℝ) : {x | y ∈ spf Hcont x}.countable :=
(sierpinski_pathological_family Hcont).some_spec.2 y

/-!
### A counterexample for the Pettis integral

We construct a function `f` from `[0,1]` to a complete Banach space `B`, which is weakly measurable
(i.e., for any continuous linear form `φ` on `B` the function `φ ∘ f` is measurable), bounded in
norm (i.e., for all `x`, one has `‖f x‖ ≤ 1`), and still `f` has no Pettis integral.

This construction, due to Phillips, requires the continuum hypothesis. We will take for `B` the
space of all bounded functions on `ℝ`, with the supremum norm (no measure here, we are really
talking of everywhere defined functions). And `f x` will be the characteristic function of a set
which is large (it has countable complement), as in the Sierpinski pathological family.
-/

/-- A family of bounded functions `f_x` from `ℝ` (seen with the discrete topology) to `ℝ` (in fact
taking values in `{0, 1}`), indexed by a real parameter `x`, corresponding to the characteristic
functions of the different fibers of the Sierpinski pathological family -/
def f (Hcont : #ℝ = aleph 1) (x : ℝ) : (discrete_copy ℝ →ᵇ ℝ) :=
of_normed_add_comm_group_discrete (indicator (spf Hcont x) 1) 1 (norm_indicator_le_one _)

lemma apply_f_eq_continuous_part (Hcont : #ℝ = aleph 1)
  (φ : (discrete_copy ℝ →ᵇ ℝ) →L[ℝ] ℝ) (x : ℝ)
  (hx : φ.to_bounded_additive_measure.discrete_support ∩ spf Hcont x = ∅) :
  φ (f Hcont x) = φ.to_bounded_additive_measure.continuous_part univ :=
begin
  set ψ := φ.to_bounded_additive_measure with hψ,
  have : φ (f Hcont x) = ψ (spf Hcont x) := rfl,
  have U : univ = spf Hcont x ∪ (univ \ spf Hcont x), by simp only [union_univ, union_diff_self],
  rw [this, eq_add_parts, discrete_part_apply, hx, ψ.empty, zero_add, U,
    ψ.continuous_part.additive _ _ disjoint_sdiff_self_right,
    ψ.continuous_part_apply_eq_zero_of_countable _ (countable_compl_spf Hcont x), add_zero],
end

lemma countable_ne (Hcont : #ℝ = aleph 1) (φ : (discrete_copy ℝ →ᵇ ℝ) →L[ℝ] ℝ) :
  {x | φ.to_bounded_additive_measure.continuous_part univ ≠ φ (f Hcont x)}.countable :=
begin
  have A : {x | φ.to_bounded_additive_measure.continuous_part univ ≠ φ (f Hcont x)}
    ⊆ {x | φ.to_bounded_additive_measure.discrete_support ∩ spf Hcont x ≠ ∅},
  { assume x hx,
    contrapose! hx,
    simp only [not_not, mem_set_of_eq] at hx,
    simp [apply_f_eq_continuous_part Hcont φ x hx], },
  have B : {x | φ.to_bounded_additive_measure.discrete_support ∩ spf Hcont x ≠ ∅}
    ⊆ ⋃ y ∈ φ.to_bounded_additive_measure.discrete_support, {x | y ∈ spf Hcont x},
  { assume x hx,
    dsimp at hx,
    rw [← ne.def, ←nonempty_iff_ne_empty] at hx,
    simp only [exists_prop, mem_Union, mem_set_of_eq],
    exact hx },
  apply countable.mono (subset.trans A B),
  exact countable.bUnion (countable_discrete_support _) (λ a ha, countable_spf_mem Hcont a),
end

lemma comp_ae_eq_const (Hcont : #ℝ = aleph 1) (φ : (discrete_copy ℝ →ᵇ ℝ) →L[ℝ] ℝ) :
  ∀ᵐ x ∂(volume.restrict (Icc (0 : ℝ) 1)),
    φ.to_bounded_additive_measure.continuous_part univ = φ (f Hcont x) :=
begin
  apply ae_restrict_of_ae,
  refine measure_mono_null _ ((countable_ne Hcont φ).measure_zero _),
  assume x,
  simp only [imp_self, mem_set_of_eq, mem_compl_iff],
end

lemma integrable_comp (Hcont : #ℝ = aleph 1) (φ : (discrete_copy ℝ →ᵇ ℝ) →L[ℝ] ℝ) :
  integrable_on (λ x, φ (f Hcont x)) (Icc 0 1) :=
begin
  have : integrable_on (λ x, φ.to_bounded_additive_measure.continuous_part univ) (Icc (0 : ℝ) 1)
    volume, by simp [integrable_on_const],
  apply integrable.congr this (comp_ae_eq_const Hcont φ),
end

lemma integral_comp (Hcont : #ℝ = aleph 1) (φ : (discrete_copy ℝ →ᵇ ℝ) →L[ℝ] ℝ) :
  ∫ x in Icc 0 1, φ (f Hcont x) = φ.to_bounded_additive_measure.continuous_part univ :=
begin
  rw ← integral_congr_ae (comp_ae_eq_const Hcont φ),
  simp,
end

/-!
The next few statements show that the function `f Hcont : ℝ → (discrete_copy ℝ →ᵇ ℝ)` takes its
values in a complete space, is scalarly measurable, is everywhere bounded by `1`, and still has
no Pettis integral.
-/

example : complete_space (discrete_copy ℝ →ᵇ ℝ) := by apply_instance

/-- The function `f Hcont : ℝ → (discrete_copy ℝ →ᵇ ℝ)` is scalarly measurable. -/
lemma measurable_comp (Hcont : #ℝ = aleph 1) (φ : (discrete_copy ℝ →ᵇ ℝ) →L[ℝ] ℝ) :
  measurable (λ x, φ (f Hcont x)) :=
begin
  have : measurable (λ x, φ.to_bounded_additive_measure.continuous_part univ) := measurable_const,
  refine this.measurable_of_countable_ne _,
  exact countable_ne Hcont φ,
end

/-- The function `f Hcont : ℝ → (discrete_copy ℝ →ᵇ ℝ)` is uniformly bounded by `1` in norm. -/
lemma norm_bound (Hcont : #ℝ = aleph 1) (x : ℝ) : ‖f Hcont x‖ ≤ 1 :=
norm_of_normed_add_comm_group_le _ zero_le_one _

/-- The function `f Hcont : ℝ → (discrete_copy ℝ →ᵇ ℝ)` has no Pettis integral. -/
theorem no_pettis_integral (Hcont : #ℝ = aleph 1) :
  ¬ ∃ (g : discrete_copy ℝ →ᵇ ℝ),
      ∀ (φ : (discrete_copy ℝ →ᵇ ℝ) →L[ℝ] ℝ), ∫ x in Icc 0 1, φ (f Hcont x) = φ g :=
begin
  rintros ⟨g, h⟩,
  simp only [integral_comp] at h,
  have : g = 0,
  { ext x,
    have : g x = eval_clm ℝ x g := rfl,
    rw [this, ← h],
    simp },
  simp only [this, continuous_linear_map.map_zero] at h,
  specialize h (volume.restrict (Icc (0 : ℝ) 1)).extension_to_bounded_functions,
  simp_rw [to_functions_to_measure_continuous_part _ _ measurable_set.univ] at h,
  simpa using h,
end

end phillips_1940


/-
Copyright (c) 2015 Haitao Zhang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.

Author : Haitao Zhang
-/
import data algebra.group data
open function eq.ops

open set

namespace coset
-- semigroup coset definition
section
variable {A : Type}
variable [s : semigroup A]
include s
definition lmul (a : A) := λ x, a * x
definition rmul (a : A) := λ x, x * a
definition l a (S : set A) := (lmul a) ' S
definition r a (S : set A) := (rmul a) ' S
lemma lmul_compose : ∀ (a b : A), (lmul a) ∘ (lmul b) = lmul (a*b) :=
      take a, take b,
      funext (assume x, by
        rewrite [↑function.comp, ↑lmul, mul.assoc])
lemma rmul_compose : ∀ (a b : A), (rmul a) ∘ (rmul b) = rmul (b*a) :=
      take a, take b,
      funext (assume x, by
        rewrite [↑function.comp, ↑rmul, mul.assoc])
lemma lcompose a b (S : set A) : l a (l b S) = l (a*b) S :=
      calc (lmul a) ' ((lmul b) ' S) = ((lmul a) ∘ (lmul b)) ' S : image_comp
      ... = lmul (a*b) ' S : lmul_compose
lemma rcompose a b (S : set A) : r a (r b S) = r (b*a) S :=
      calc (rmul a) ' ((rmul b) ' S) = ((rmul a) ∘ (rmul b)) ' S : image_comp
      ... = rmul (b*a) ' S : rmul_compose
lemma l_sub a (S H : set A) : S ⊆ H → (l a S) ⊆ (l a H) := image_subset (lmul a)
definition l_same S (a b : A) := l a S = l b S
definition r_same S (a b : A) := r a S = r b S
lemma l_same.refl S (a : A) : l_same S a a := rfl
lemma l_same.symm S (a b : A) : l_same S a b → l_same S b a := eq.symm
lemma l_same.trans S (a b c : A) : l_same S a b → l_same S b c → l_same S a c := eq.trans
example (S : set A) : equivalence (l_same S) := mk_equivalence (l_same S) (l_same.refl S) (l_same.symm S) (l_same.trans S)
end
end coset

section
variable {A : Type}
variable [s : group A]
include s
definition lmul_by (a : A) := λ x, a * x
definition rmul_by (a : A) := λ x, x * a
definition glcoset a (H : set A) : set A := λ x, H (a⁻¹ * x)
definition grcoset H (a : A) : set A := λ x, H (x * a⁻¹)
end

namespace group_theory
  namespace ops
    infixr `∘>`:55 := glcoset -- stronger than = (50), weaker than * (70)
    infixl `<∘`:55 := grcoset
    infixr `∘c`:55 := conj_by
  end ops
end group_theory

open group_theory.ops
section
variable {A : Type}
variable [s : group A]
include s

lemma conj_inj (g : A) : injective (conj_by g) :=
injective_of_has_left_inverse (exists.intro (conj_by g⁻¹) take a, !conj_inv_cancel)

lemma lmul_inj (a : A) : injective (lmul_by a) :=
take x₁ x₂ Peq, by esimp [lmul_by] at Peq;
  rewrite [-(inv_mul_cancel_left a x₁), -(inv_mul_cancel_left a x₂), Peq]
lemma lmul_inv_on (a : A) (H : set A) : left_inv_on (lmul_by a⁻¹) (lmul_by a) H :=
      take x Px, show a⁻¹*(a*x) = x, by rewrite inv_mul_cancel_left
lemma lmul_inj_on (a : A) (H : set A) : inj_on (lmul_by a) H :=
      inj_on_of_left_inv_on (lmul_inv_on a H)

lemma glcoset_eq_lcoset a (H : set A) : a ∘> H = coset.l a H :=
      ext
      begin
      intro x,
      rewrite [↑glcoset, ↑coset.l, ↑image, ↑set_of, ↑mem, ↑coset.lmul],
      apply iff.intro,
        intro P1,
        apply (exists.intro (a⁻¹ * x)),
        apply and.intro,
          exact P1,
          exact (mul_inv_cancel_left a x),
        show (∃ (x_1 : A), H x_1 ∧ a * x_1 = x) → H (a⁻¹ * x), from
          assume P2, obtain x_1 P3, from P2,
          have P4 : a * x_1 = x, from and.right P3,
          have P5 : x_1 = a⁻¹ * x, from eq_inv_mul_of_mul_eq P4,
          eq.subst P5 (and.left P3)
      end
lemma grcoset_eq_rcoset a (H : set A) : H <∘ a = coset.r a H :=
      begin
        rewrite [↑grcoset, ↑coset.r, ↑image, ↑coset.rmul, ↑set_of],
        apply ext, rewrite ↑mem,
        intro x,
        apply iff.intro,
          show H (x * a⁻¹) → (∃ (x_1 : A), H x_1 ∧ x_1 * a = x), from
            assume PH,
              exists.intro (x * a⁻¹)
                           (and.intro PH (inv_mul_cancel_right x a)),
          show (∃ (x_1 : A), H x_1 ∧ x_1 * a = x) → H (x * a⁻¹), from
            assume Pex,
              obtain x_1 Pand, from Pex,
                eq.subst (eq_mul_inv_of_mul_eq (and.right Pand)) (and.left Pand)
      end
lemma glcoset_sub a (S H : set A) : S ⊆ H → (a ∘> S) ⊆ (a ∘> H) :=
      assume Psub,
      have P : _, from coset.l_sub a S H Psub,
      eq.symm (glcoset_eq_lcoset a S) ▸ eq.symm (glcoset_eq_lcoset a H) ▸ P
lemma glcoset_compose (a b : A) (H : set A) : a ∘> b ∘> H = a*b ∘> H :=
      begin
      rewrite [*glcoset_eq_lcoset], exact (coset.lcompose a b H)
      end
lemma grcoset_compose (a b : A) (H : set A) : H <∘ a <∘ b = H <∘ a*b :=
      begin
      rewrite [*grcoset_eq_rcoset], exact (coset.rcompose b a H)
      end
lemma glcoset_id (H : set A) : 1 ∘> H = H :=
      funext (assume x,
        calc (1 ∘> H) x = H (1⁻¹*x) : rfl
        ... = H (1*x) : {one_inv}
        ... = H x : {one_mul x})
lemma grcoset_id (H : set A) : H <∘ 1 = H :=
      funext (assume x,
        calc H (x*1⁻¹) = H (x*1) : {one_inv}
        ... = H x : {mul_one x})
--lemma glcoset_inv a (H : set A) : a⁻¹ ∘> a ∘> H = H :=
--      funext (assume x,
--        calc glcoset a⁻¹ (glcoset a H) x = H x : {mul_inv_cancel_left a⁻¹ x})
lemma glcoset_inv a (H : set A) : a⁻¹ ∘> a ∘> H = H :=
      calc a⁻¹ ∘> a ∘> H = (a⁻¹*a) ∘> H : glcoset_compose
      ... = 1 ∘> H : mul.left_inv
      ... = H : glcoset_id
lemma grcoset_inv H (a : A) : (H <∘ a) <∘ a⁻¹ = H :=
      funext (assume x,
        calc grcoset (grcoset H a) a⁻¹ x = H x : {inv_mul_cancel_right x a⁻¹})
lemma glcoset_cancel a b (H : set A) : (b*a⁻¹) ∘> a ∘> H = b ∘> H :=
      calc (b*a⁻¹) ∘> a ∘> H = b*a⁻¹*a ∘> H : glcoset_compose
      ... = b ∘> H : {inv_mul_cancel_right b a}
lemma grcoset_cancel a b (H : set A) : H <∘ a <∘ a⁻¹*b = H <∘ b :=
      calc H <∘ a <∘ a⁻¹*b = H <∘ a*(a⁻¹*b) : grcoset_compose
      ... = H <∘ b : {mul_inv_cancel_left a b}
-- test how precedence breaks tie: infixr takes hold since its encountered first
example a b (H : set A) : a ∘> H <∘ b = a ∘> (H <∘ b) := rfl
-- should be true for semigroup as well but irrelevant
lemma lcoset_rcoset_assoc a b (H : set A) : a ∘> H <∘ b = (a ∘> H) <∘ b :=
  funext (assume x, begin
  esimp [glcoset, grcoset], rewrite mul.assoc
  end)
definition mul_closed_on H := ∀ (x y : A), x ∈ H → y ∈ H → x * y ∈ H
lemma closed_lcontract a (H : set A) : mul_closed_on H → a ∈ H → a ∘> H ⊆ H :=
      begin
      rewrite [↑mul_closed_on, ↑glcoset, ↑subset, ↑mem],
      intro Pclosed, intro PHa, intro x, intro PHainvx,
      exact (eq.subst (mul_inv_cancel_left a x)
                      (Pclosed a (a⁻¹*x) PHa PHainvx))
      end
lemma closed_rcontract a (H : set A) : mul_closed_on H → a ∈ H → H <∘ a ⊆ H :=
      assume P1 : mul_closed_on H,
      assume P2 : H a,
      begin
        rewrite ↑subset,
        intro x,
        rewrite [↑grcoset, ↑mem],
        intro P3,
        exact (eq.subst (inv_mul_cancel_right x a) (P1 (x * a⁻¹) a P3 P2))
      end
lemma closed_lcontract_set a (H G : set A) : mul_closed_on G → H ⊆ G → a∈G → a∘>H ⊆ G :=
      assume Pclosed, assume PHsubG, assume PainG,
      have PaGsubG : a ∘> G ⊆ G, from closed_lcontract a G Pclosed PainG,
      have PaHsubaG : a ∘> H ⊆ a ∘> G, from
        eq.symm (glcoset_eq_lcoset a H) ▸ eq.symm (glcoset_eq_lcoset a G) ▸ (coset.l_sub a H G PHsubG),
      subset.trans PaHsubaG PaGsubG
definition subgroup.has_inv H := ∀ (a : A), a ∈ H → a⁻¹ ∈ H
-- two ways to define the same equivalence relatiohship for subgroups
definition in_lcoset [reducible] H (a b : A) := a ∈ b ∘> H
definition in_rcoset [reducible] H (a b : A) := a ∈ H <∘ b
definition same_lcoset [reducible] H (a b : A) := a ∘> H = b ∘> H
definition same_rcoset [reducible] H (a b : A) := H <∘ a = H <∘ b
definition same_left_right_coset (N : set A) := ∀ x, x ∘> N = N <∘ x
structure is_subgroup [class] (H : set A) : Type :=
  (has_one : H 1)
  (mul_closed : mul_closed_on H)
  (has_inv : subgroup.has_inv H)
structure is_normal_subgroup [class] (N : set A) extends is_subgroup N :=
  (normal : same_left_right_coset N)
end

section subgroup
variable {A : Type}
variable [s : group A]
include s
variable {H : set A}
variable [is_subg : is_subgroup H]
include is_subg
section set_reducible
local attribute set [reducible]
lemma subg_has_one : H (1 : A) := @is_subgroup.has_one A s H is_subg
lemma subg_mul_closed : mul_closed_on H := @is_subgroup.mul_closed A s H is_subg
lemma subg_has_inv : subgroup.has_inv H := @is_subgroup.has_inv A s H is_subg
lemma subgroup_coset_id : ∀ a, a ∈ H → (a ∘> H = H ∧ H <∘ a = H) :=
      take a, assume PHa : H a,
      have Pl : a ∘> H ⊆ H, from closed_lcontract a H subg_mul_closed PHa,
      have Pr : H <∘ a ⊆ H, from closed_rcontract a H subg_mul_closed PHa,
      have PHainv : H a⁻¹, from subg_has_inv a PHa,
      and.intro
      (ext (assume x,
        begin
          esimp [glcoset, mem],
          apply iff.intro,
            apply Pl,
            intro PHx, exact (subg_mul_closed a⁻¹ x PHainv PHx)
        end))
      (ext (assume x,
        begin
          esimp [grcoset, mem],
          apply iff.intro,
            apply Pr,
            intro PHx, exact (subg_mul_closed x a⁻¹ PHx PHainv)
        end))
lemma subgroup_lcoset_id : ∀ a, a ∈ H → a ∘> H = H :=
      take a, assume PHa : H a,
      and.left (subgroup_coset_id a PHa)
lemma subgroup_rcoset_id : ∀ a, a ∈ H → H <∘ a = H :=
      take a, assume PHa : H a,
      and.right (subgroup_coset_id a PHa)
lemma subg_in_coset_refl (a : A) : a ∈ a ∘> H ∧ a ∈ H <∘ a :=
      have PH1 : H 1, from subg_has_one,
      have PHinvaa : H (a⁻¹*a), from (eq.symm (mul.left_inv a)) ▸ PH1,
      have PHainva : H (a*a⁻¹), from (eq.symm (mul.right_inv a)) ▸ PH1,
      and.intro PHinvaa PHainva
end set_reducible
lemma subg_in_lcoset_same_lcoset (a b : A) : in_lcoset H a b → same_lcoset H a b :=
      assume Pa_in_b : H (b⁻¹*a),
      have Pbinva : b⁻¹*a ∘> H = H, from subgroup_lcoset_id (b⁻¹*a) Pa_in_b,
      have Pb_binva : b ∘> b⁻¹*a ∘> H = b ∘> H, from Pbinva ▸ rfl,
      have Pbbinva : b*(b⁻¹*a)∘>H = b∘>H, from glcoset_compose b (b⁻¹*a) H ▸ Pb_binva,
      mul_inv_cancel_left b a ▸ Pbbinva
lemma subg_same_lcoset_in_lcoset (a b : A) : same_lcoset H a b → in_lcoset H a b :=
      assume Psame : a∘>H = b∘>H,
      have Pa : a ∈ a∘>H, from and.left (subg_in_coset_refl a),
      by exact (Psame ▸ Pa)
lemma subg_lcoset_same (a b : A) : in_lcoset H a b = (a∘>H = b∘>H) :=
      propext(iff.intro (subg_in_lcoset_same_lcoset a b) (subg_same_lcoset_in_lcoset a b))
lemma subg_rcoset_same (a b : A) : in_rcoset H a b = (H<∘a = H<∘b) :=
      propext(iff.intro
      (assume Pa_in_b : H (a*b⁻¹),
      have Pabinv : H<∘a*b⁻¹ = H, from subgroup_rcoset_id (a*b⁻¹) Pa_in_b,
      have Pabinv_b : H <∘ a*b⁻¹ <∘ b = H <∘ b, from Pabinv ▸ rfl,
      have Pabinvb : H <∘ a*b⁻¹*b = H <∘ b, from grcoset_compose (a*b⁻¹) b H ▸ Pabinv_b,
      inv_mul_cancel_right a b ▸ Pabinvb)
      (assume Psame,
      have Pa : a ∈ H<∘a, from and.right (subg_in_coset_refl a),
      by exact (Psame ▸ Pa)))
lemma subg_same_lcoset.refl (a : A) : same_lcoset H a a := rfl
lemma subg_same_rcoset.refl (a : A) : same_rcoset H a a := rfl
lemma subg_same_lcoset.symm (a b : A) : same_lcoset H a b → same_lcoset H b a := eq.symm
lemma subg_same_rcoset.symm (a b : A) : same_rcoset H a b → same_rcoset H b a := eq.symm
lemma subg_same_lcoset.trans (a b c : A) : same_lcoset H a b → same_lcoset H b c → same_lcoset H a c :=
      eq.trans
lemma subg_same_rcoset.trans (a b c : A) : same_rcoset H a b → same_rcoset H b c → same_rcoset H a c :=
      eq.trans
variable {S : set A}
lemma subg_lcoset_subset_subg (Psub : S ⊆ H) (a : A) : a ∈ H → a ∘> S ⊆ H :=
      assume Pin, have P : a ∘> S ⊆ a ∘> H, from glcoset_sub a S H Psub,
      subgroup_lcoset_id a Pin ▸ P

end subgroup

section normal_subg
open quot
variable {A : Type}
variable [s : group A]
include s
variable (N : set A)
variable [is_nsubg : is_normal_subgroup N]
include is_nsubg

local notation a `~` b := same_lcoset N a b -- note : does not bind as strong as →

lemma nsubg_normal : same_left_right_coset N := @is_normal_subgroup.normal A s N is_nsubg
lemma nsubg_same_lcoset_product : ∀ a1 a2 b1 b2, (a1 ~ b1) → (a2 ~ b2) →  ((a1*a2) ~ (b1*b2)) :=
  take a1, take a2, take b1, take b2,
  assume Psame1 : a1 ∘> N = b1 ∘> N,
  assume Psame2 : a2 ∘> N = b2 ∘> N,
  calc
  a1*a2 ∘> N = a1 ∘> a2 ∘> N : glcoset_compose
  ... = a1 ∘> b2 ∘> N :    by rewrite Psame2
  ... = a1 ∘> (N <∘ b2) :  by rewrite (nsubg_normal N)
  ... = (a1 ∘> N) <∘ b2 :  by rewrite lcoset_rcoset_assoc
  ... = (b1 ∘> N) <∘ b2 :  by rewrite Psame1
  ... = N <∘ b1 <∘ b2 :    by rewrite (nsubg_normal N)
  ... = N <∘ (b1*b2) :     by rewrite grcoset_compose
  ... = (b1*b2) ∘> N :     by rewrite (nsubg_normal N)

example (a b : A) : (a⁻¹ ~ b⁻¹) = (a⁻¹ ∘> N = b⁻¹ ∘> N) := rfl
lemma nsubg_same_lcoset_inv : ∀ a b, (a ~ b) → (a⁻¹ ~ b⁻¹) :=
  take a b, assume Psame : a ∘> N = b ∘> N, calc
  a⁻¹ ∘> N = a⁻¹*b*b⁻¹ ∘> N    : by rewrite mul_inv_cancel_right
  ... = a⁻¹*b ∘> b⁻¹ ∘> N      : by rewrite glcoset_compose
  ... = a⁻¹*b ∘> (N <∘ b⁻¹)    : by rewrite nsubg_normal
  ... = (a⁻¹*b ∘> N) <∘ b⁻¹    : by rewrite lcoset_rcoset_assoc
  ... = (a⁻¹ ∘> b ∘> N) <∘ b⁻¹ : by rewrite glcoset_compose
  ... = (a⁻¹ ∘> a ∘> N) <∘ b⁻¹ : by rewrite Psame
  ... = N <∘ b⁻¹               : by rewrite glcoset_inv
  ... = b⁻¹ ∘> N               : by rewrite nsubg_normal
definition nsubg_setoid [instance] : setoid A :=
  setoid.mk (same_lcoset N)
  (mk_equivalence (same_lcoset N) (subg_same_lcoset.refl) (subg_same_lcoset.symm) (subg_same_lcoset.trans))
definition coset_of : Type := quot (nsubg_setoid N)

definition coset_inv_base (a : A) : coset_of N := ⟦a⁻¹⟧
definition coset_product (a b : A) : coset_of N := ⟦a*b⟧
lemma coset_product_well_defined : ∀ a1 a2 b1 b2, (a1 ~ b1) → (a2 ~ b2) → ⟦a1*a2⟧ = ⟦b1*b2⟧ :=
      take a1 a2 b1 b2, assume P1 P2,
      quot.sound (nsubg_same_lcoset_product N a1 a2 b1 b2 P1 P2)
definition coset_mul (aN bN : coset_of N) : coset_of N :=
  quot.lift_on₂ aN bN (coset_product N) (coset_product_well_defined N)
lemma coset_inv_well_defined : ∀ a b, (a ~ b) → ⟦a⁻¹⟧ = ⟦b⁻¹⟧ :=
      take a b, assume P, quot.sound (nsubg_same_lcoset_inv N a b P)
definition coset_inv (aN : coset_of N) : coset_of N :=
           quot.lift_on aN (coset_inv_base N) (coset_inv_well_defined N)
definition coset_one :  coset_of N := ⟦1⟧

local infixl `cx`:70 := coset_mul N
example (a b c : A) : ⟦a⟧ cx ⟦b*c⟧ = ⟦a*(b*c)⟧ := rfl

lemma coset_product_assoc (a b c : A) : ⟦a⟧ cx ⟦b⟧ cx ⟦c⟧ = ⟦a⟧ cx (⟦b⟧ cx ⟦c⟧) := calc
      ⟦a*b*c⟧ = ⟦a*(b*c)⟧ : {mul.assoc a b c}
      ... = ⟦a⟧ cx ⟦b*c⟧ : rfl
lemma coset_product_left_id (a : A) : ⟦1⟧ cx ⟦a⟧ = ⟦a⟧ := calc
      ⟦1*a⟧ = ⟦a⟧ : {one_mul a}
lemma coset_product_right_id (a : A) : ⟦a⟧ cx ⟦1⟧ = ⟦a⟧ := calc
      ⟦a*1⟧ = ⟦a⟧ : {mul_one a}
lemma coset_product_left_inv (a : A) : ⟦a⁻¹⟧ cx ⟦a⟧ = ⟦1⟧ := calc
      ⟦a⁻¹*a⟧ = ⟦1⟧ : {mul.left_inv a}
lemma coset_mul.assoc (aN bN cN : coset_of N) : aN cx bN cx cN = aN cx (bN cx cN) :=
      quot.ind (λ a, quot.ind (λ b, quot.ind (λ c, coset_product_assoc N a b c) cN) bN) aN
lemma coset_mul.one_mul (aN : coset_of N) : coset_one N cx aN = aN :=
      quot.ind (coset_product_left_id N) aN
lemma coset_mul.mul_one (aN : coset_of N) : aN cx (coset_one N) = aN :=
      quot.ind (coset_product_right_id N) aN
lemma coset_mul.left_inv (aN : coset_of N) : (coset_inv N aN) cx aN = (coset_one N) :=
      quot.ind (coset_product_left_inv N) aN
definition mk_quotient_group : group (coset_of N):=
           group.mk (coset_mul N) (coset_mul.assoc N) (coset_one N)  (coset_mul.one_mul N) (coset_mul.mul_one N) (coset_inv N) (coset_mul.left_inv N)

end normal_subg

namespace group_theory
namespace quotient
section
open quot
variable {A : Type}
variable [s : group A]
include s
variable {N : set A}
variable [is_nsubg : is_normal_subgroup N]
include is_nsubg
definition quotient_group [instance] : group (coset_of N) := mk_quotient_group N

example (aN : coset_of N) : aN * aN⁻¹ = 1 := mul.right_inv aN
definition natural (a : A) : coset_of N := ⟦a⟧

end
end quotient
end group_theory