/-
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
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.fintype.basic
import Mathlib.PostPort

universes u u_1 v u_2 x u_3

namespace Mathlib

/-!
# Finite sets

This file defines predicates `finite : set α → Prop` and `infinite : set α → Prop` and proves some
basic facts about finite sets.
-/

namespace set

/-- A set is finite if the subtype is a fintype, i.e. there is a
  list that enumerates its members. -/
def finite {α : Type u} (s : set α) := Nonempty (fintype ↥s)

/-- A set is infinite if it is not finite. -/
def infinite {α : Type u} (s : set α) := ¬finite s

/-- The subtype corresponding to a finite set is a finite type. Note
that because `finite` isn't a typeclass, this will not fire if it
is made into an instance -/
def finite.fintype {α : Type u} {s : set α} (h : finite s) : fintype ↥s := Classical.choice h

/-- Get a finset from a finite set -/
def finite.to_finset {α : Type u} {s : set α} (h : finite s) : finset α := to_finset s

@[simp] theorem finite.mem_to_finset {α : Type u} {s : set α} {h : finite s} {a : α} :
    a ∈ finite.to_finset h ↔ a ∈ s :=
  mem_to_finset

@[simp] theorem finite.to_finset.nonempty {α : Type u} {s : set α} (h : finite s) :
    finset.nonempty (finite.to_finset h) ↔ set.nonempty s :=
  (fun (this : (∃ (x : α), x ∈ finite.to_finset h) ↔ ∃ (x : α), x ∈ s) => this)
    (exists_congr fun (_x : α) => finite.mem_to_finset)

@[simp] theorem finite.coe_to_finset {α : Type u_1} {s : set α} (h : finite s) :
    ↑(finite.to_finset h) = s :=
  coe_to_finset s

theorem finite.exists_finset {α : Type u} {s : set α} :
    finite s → ∃ (s' : finset α), ∀ (a : α), a ∈ s' ↔ a ∈ s :=
  sorry

theorem finite.exists_finset_coe {α : Type u} {s : set α} (hs : finite s) :
    ∃ (s' : finset α), ↑s' = s :=
  Exists.intro (finite.to_finset hs) (finite.coe_to_finset hs)

/-- Finite sets can be lifted to finsets. -/
protected instance finset.can_lift {α : Type u} : can_lift (set α) (finset α) :=
  can_lift.mk coe finite sorry

theorem finite_mem_finset {α : Type u} (s : finset α) : finite (set_of fun (a : α) => a ∈ s) :=
  Nonempty.intro (fintype.of_finset s fun (_x : α) => iff.rfl)

theorem finite.of_fintype {α : Type u} [fintype α] (s : set α) : finite s :=
  Nonempty.intro (set_fintype s)

theorem exists_finite_iff_finset {α : Type u} {p : set α → Prop} :
    (∃ (s : set α), finite s ∧ p s) ↔ ∃ (s : finset α), p ↑s :=
  sorry

/-- Membership of a subset of a finite type is decidable.

Using this as an instance leads to potential loops with `subtype.fintype` under certain decidability
assumptions, so it should only be declared a local instance. -/
def decidable_mem_of_fintype {α : Type u} [DecidableEq α] (s : set α) [fintype ↥s] (a : α) :
    Decidable (a ∈ s) :=
  decidable_of_iff (a ∈ to_finset s) mem_to_finset

protected instance fintype_empty {α : Type u} : fintype ↥∅ := fintype.of_finset ∅ sorry

theorem empty_card {α : Type u} : fintype.card ↥∅ = 0 := rfl

@[simp] theorem empty_card' {α : Type u} {h : fintype ↥∅} : fintype.card ↥∅ = 0 := sorry

@[simp] theorem finite_empty {α : Type u} : finite ∅ := Nonempty.intro set.fintype_empty

protected instance finite.inhabited {α : Type u} :
    Inhabited (Subtype fun (s : set α) => finite s) :=
  { default := { val := ∅, property := finite_empty } }

/-- A `fintype` structure on `insert a s`. -/
def fintype_insert' {α : Type u} {a : α} (s : set α) [fintype ↥s] (h : ¬a ∈ s) :
    fintype ↥(insert a s) :=
  fintype.of_finset (finset.mk (a ::ₘ finset.val (to_finset s)) sorry) sorry

theorem card_fintype_insert' {α : Type u} {a : α} (s : set α) [fintype ↥s] (h : ¬a ∈ s) :
    fintype.card ↥(insert a s) = fintype.card ↥s + 1 :=
  sorry

@[simp] theorem card_insert {α : Type u} {a : α} (s : set α) [fintype ↥s] (h : ¬a ∈ s)
    {d : fintype ↥(insert a s)} : fintype.card ↥(insert a s) = fintype.card ↥s + 1 :=
  sorry

theorem card_image_of_inj_on {α : Type u} {β : Type v} {s : set α} [fintype ↥s] {f : α → β}
    [fintype ↥(f '' s)] (H : ∀ (x : α), x ∈ s → ∀ (y : α), y ∈ s → f x = f y → x = y) :
    fintype.card ↥(f '' s) = fintype.card ↥s :=
  sorry

theorem card_image_of_injective {α : Type u} {β : Type v} (s : set α) [fintype ↥s] {f : α → β}
    [fintype ↥(f '' s)] (H : function.injective f) : fintype.card ↥(f '' s) = fintype.card ↥s :=
  card_image_of_inj_on
    fun (_x : α) (_x_1 : _x ∈ s) (_x_2 : α) (_x_3 : _x_2 ∈ s) (h : f _x = f _x_2) => H h

protected instance fintype_insert {α : Type u} [DecidableEq α] (a : α) (s : set α) [fintype ↥s] :
    fintype ↥(insert a s) :=
  dite (a ∈ s) (fun (h : a ∈ s) => eq.mpr sorry (eq.mpr sorry _inst_2))
    fun (h : ¬a ∈ s) => fintype_insert' s h

@[simp] theorem finite.insert {α : Type u} (a : α) {s : set α} : finite s → finite (insert a s) :=
  fun (ᾰ : finite s) =>
    nonempty.dcases_on ᾰ
      fun (ᾰ : fintype ↥s) =>
        idRhs (Nonempty (fintype ↥(insert a s))) (Nonempty.intro (set.fintype_insert a s))

theorem to_finset_insert {α : Type u} [DecidableEq α] {a : α} {s : set α} (hs : finite s) :
    finite.to_finset (finite.insert a hs) = insert a (finite.to_finset hs) :=
  sorry

theorem finite.induction_on {α : Type u} {C : set α → Prop} {s : set α} (h : finite s) (H0 : C ∅)
    (H1 : ∀ {a : α} {s : set α}, ¬a ∈ s → finite s → C s → C (insert a s)) : C s :=
  sorry

theorem finite.dinduction_on {α : Type u} {C : (s : set α) → finite s → Prop} {s : set α}
    (h : finite s) (H0 : C ∅ finite_empty)
    (H1 :
      ∀ {a : α} {s : set α},
        ¬a ∈ s → ∀ (h : finite s), C s h → C (insert a s) (finite.insert a h)) :
    C s h :=
  sorry

protected instance fintype_singleton {α : Type u} (a : α) : fintype ↥(singleton a) := unique.fintype

@[simp] theorem card_singleton {α : Type u} (a : α) : fintype.card ↥(singleton a) = 1 :=
  fintype.card_of_subsingleton Inhabited.default

@[simp] theorem finite_singleton {α : Type u} (a : α) : finite (singleton a) :=
  Nonempty.intro (set.fintype_singleton a)

protected instance fintype_pure {α : Type u} (a : α) : fintype ↥(pure a) := set.fintype_singleton

theorem finite_pure {α : Type u} (a : α) : finite (pure a) := Nonempty.intro (set.fintype_pure a)

protected instance fintype_univ {α : Type u} [fintype α] : fintype ↥univ :=
  fintype.of_equiv α (equiv.symm (equiv.set.univ α))

theorem finite_univ {α : Type u} [fintype α] : finite univ := Nonempty.intro set.fintype_univ

theorem infinite_univ_iff {α : Type u} : infinite univ ↔ infinite α := sorry

theorem infinite_univ {α : Type u} [h : infinite α] : infinite univ := iff.mpr infinite_univ_iff h

theorem infinite_coe_iff {α : Type u} {s : set α} : infinite ↥s ↔ infinite s := sorry

theorem infinite.to_subtype {α : Type u} {s : set α} (h : infinite s) : infinite ↥s :=
  iff.mpr infinite_coe_iff h

/-- Embedding of `ℕ` into an infinite set. -/
def infinite.nat_embedding {α : Type u} (s : set α) (h : infinite s) : ℕ ↪ ↥s :=
  infinite.nat_embedding ↥s

theorem infinite.exists_subset_card_eq {α : Type u} {s : set α} (hs : infinite s) (n : ℕ) :
    ∃ (t : finset α), ↑t ⊆ s ∧ finset.card t = n :=
  sorry

protected instance fintype_union {α : Type u} [DecidableEq α] (s : set α) (t : set α) [fintype ↥s]
    [fintype ↥t] : fintype ↥(s ∪ t) :=
  fintype.of_finset (to_finset s ∪ to_finset t) sorry

theorem finite.union {α : Type u} {s : set α} {t : set α} : finite s → finite t → finite (s ∪ t) :=
  sorry

protected instance fintype_sep {α : Type u} (s : set α) (p : α → Prop) [fintype ↥s]
    [decidable_pred p] : fintype ↥(has_sep.sep (fun (a : α) => p a) s) :=
  fintype.of_finset (finset.filter p (to_finset s)) sorry

protected instance fintype_inter {α : Type u} (s : set α) (t : set α) [fintype ↥s]
    [decidable_pred t] : fintype ↥(s ∩ t) :=
  set.fintype_sep s t

/-- A `fintype` structure on a set defines a `fintype` structure on its subset. -/
def fintype_subset {α : Type u} (s : set α) {t : set α} [fintype ↥s] [decidable_pred t]
    (h : t ⊆ s) : fintype ↥t :=
  eq.mpr sorry (set.fintype_inter s t)

theorem finite.subset {α : Type u} {s : set α} : finite s → ∀ {t : set α}, t ⊆ s → finite t :=
  fun (ᾰ : finite s) {t : set α} (ᾰ_1 : t ⊆ s) =>
    nonempty.dcases_on ᾰ
      fun (ᾰ_1_1 : fintype ↥s) =>
        idRhs (Nonempty (fintype ↥t)) (Nonempty.intro (fintype_subset s ᾰ_1))

theorem infinite_mono {α : Type u} {s : set α} {t : set α} (h : s ⊆ t) : infinite s → infinite t :=
  mt fun (ht : finite t) => finite.subset ht h

protected instance fintype_image {α : Type u} {β : Type v} [DecidableEq β] (s : set α) (f : α → β)
    [fintype ↥s] : fintype ↥(f '' s) :=
  fintype.of_finset (finset.image f (to_finset s)) sorry

protected instance fintype_range {α : Type u} {β : Type v} [DecidableEq β] (f : α → β) [fintype α] :
    fintype ↥(range f) :=
  fintype.of_finset (finset.image f finset.univ) sorry

theorem finite_range {α : Type u} {β : Type v} (f : α → β) [fintype α] : finite (range f) :=
  Nonempty.intro (set.fintype_range f)

theorem finite.image {α : Type u} {β : Type v} {s : set α} (f : α → β) :
    finite s → finite (f '' s) :=
  fun (ᾰ : finite s) =>
    nonempty.dcases_on ᾰ
      fun (ᾰ : fintype ↥s) =>
        idRhs (Nonempty (fintype ↥(f '' s))) (Nonempty.intro (set.fintype_image s f))

theorem infinite_of_infinite_image {α : Type u} {β : Type v} (f : α → β) {s : set α}
    (hs : infinite (f '' s)) : infinite s :=
  mt (finite.image f) hs

theorem finite.dependent_image {α : Type u} {β : Type v} {s : set α} (hs : finite s)
    {F : (i : α) → i ∈ s → β} {t : set β}
    (H : ∀ (y : β), y ∈ t → ∃ (x : α), ∃ (hx : x ∈ s), y = F x hx) : finite t :=
  sorry

protected instance fintype_map {α : Type u_1} {β : Type u_1} [DecidableEq β] (s : set α) (f : α → β)
    [fintype ↥s] : fintype ↥(f <$> s) :=
  set.fintype_image

theorem finite.map {α : Type u_1} {β : Type u_1} {s : set α} (f : α → β) :
    finite s → finite (f <$> s) :=
  finite.image

/-- If a function `f` has a partial inverse and sends a set `s` to a set with `[fintype]` instance,
then `s` has a `fintype` structure as well. -/
def fintype_of_fintype_image {α : Type u} {β : Type v} (s : set α) {f : α → β} {g : β → Option α}
    (I : function.is_partial_inv f g) [fintype ↥(f '' s)] : fintype ↥s :=
  fintype.of_finset (finset.mk (multiset.filter_map g (finset.val (to_finset (f '' s)))) sorry)
    sorry

theorem finite_of_finite_image {α : Type u} {β : Type v} {s : set α} {f : α → β} (hi : inj_on f s) :
    finite (f '' s) → finite s :=
  sorry

theorem finite_image_iff {α : Type u} {β : Type v} {s : set α} {f : α → β} (hi : inj_on f s) :
    finite (f '' s) ↔ finite s :=
  { mp := finite_of_finite_image hi, mpr := finite.image f }

theorem infinite_image_iff {α : Type u} {β : Type v} {s : set α} {f : α → β} (hi : inj_on f s) :
    infinite (f '' s) ↔ infinite s :=
  not_congr (finite_image_iff hi)

theorem infinite_of_inj_on_maps_to {α : Type u} {β : Type v} {s : set α} {t : set β} {f : α → β}
    (hi : inj_on f s) (hm : maps_to f s t) (hs : infinite s) : infinite t :=
  infinite_mono (iff.mp maps_to' hm) (iff.mpr (infinite_image_iff hi) hs)

theorem infinite_range_of_injective {α : Type u} {β : Type v} [infinite α] {f : α → β}
    (hi : function.injective f) : infinite (range f) :=
  sorry

theorem infinite_of_injective_forall_mem {α : Type u} {β : Type v} [infinite α] {s : set β}
    {f : α → β} (hi : function.injective f) (hf : ∀ (x : α), f x ∈ s) : infinite s :=
  infinite_mono
    (eq.mp (Eq._oldrec (Eq.refl (∀ (x : α), f x ∈ s)) (Eq.symm (propext range_subset_iff))) hf)
    (infinite_range_of_injective hi)

theorem finite.preimage {α : Type u} {β : Type v} {s : set β} {f : α → β} (I : inj_on f (f ⁻¹' s))
    (h : finite s) : finite (f ⁻¹' s) :=
  finite_of_finite_image I (finite.subset h (image_preimage_subset f s))

theorem finite.preimage_embedding {α : Type u} {β : Type v} {s : set β} (f : α ↪ β) (h : finite s) :
    finite (⇑f ⁻¹' s) :=
  sorry

protected instance fintype_Union {α : Type u} [DecidableEq α] {ι : Type u_1} [fintype ι]
    (f : ι → set α) [(i : ι) → fintype ↥(f i)] : fintype ↥(Union fun (i : ι) => f i) :=
  fintype.of_finset (finset.bUnion finset.univ fun (i : ι) => to_finset (f i)) sorry

theorem finite_Union {α : Type u} {ι : Type u_1} [fintype ι] {f : ι → set α}
    (H : ∀ (i : ι), finite (f i)) : finite (Union fun (i : ι) => f i) :=
  Nonempty.intro (set.fintype_Union fun (i : ι) => f i)

/-- A union of sets with `fintype` structure over a set with `fintype` structure has a `fintype`
structure. -/
def fintype_set_bUnion {α : Type u} [DecidableEq α] {ι : Type u_1} {s : set ι} [fintype ↥s]
    (f : ι → set α) (H : (i : ι) → i ∈ s → fintype ↥(f i)) :
    fintype ↥(Union fun (i : ι) => Union fun (H : i ∈ s) => f i) :=
  eq.mpr sorry (set.fintype_Union fun (x : ↥s) => f ↑x)

protected instance fintype_set_bUnion' {α : Type u} [DecidableEq α] {ι : Type u_1} {s : set ι}
    [fintype ↥s] (f : ι → set α) [H : (i : ι) → fintype ↥(f i)] :
    fintype ↥(Union fun (i : ι) => Union fun (H : i ∈ s) => f i) :=
  fintype_set_bUnion (fun (i : ι) => f i) fun (i : ι) (_x : i ∈ s) => H i

theorem finite.sUnion {α : Type u} {s : set (set α)} (h : finite s)
    (H : ∀ (t : set α), t ∈ s → finite t) : finite (⋃₀s) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (finite (⋃₀s))) sUnion_eq_Union))
    (finite_Union
      (eq.mpr (id (propext set_coe.forall)) (eq.mp (Eq.refl (∀ (t : set α), t ∈ s → finite t)) H)))

theorem finite.bUnion {α : Type u_1} {ι : Type u_2} {s : set ι} {f : (i : ι) → i ∈ s → set α} :
    finite s →
        (∀ (i : ι) (H : i ∈ s), finite (f i H)) →
          finite (Union fun (i : ι) => Union fun (H : i ∈ s) => f i H) :=
  sorry

protected instance fintype_lt_nat (n : ℕ) : fintype ↥(set_of fun (i : ℕ) => i < n) :=
  fintype.of_finset (finset.range n) sorry

protected instance fintype_le_nat (n : ℕ) : fintype ↥(set_of fun (i : ℕ) => i ≤ n) :=
  eq.mpr sorry (eq.mp sorry (set.fintype_lt_nat (n + 1)))

theorem finite_le_nat (n : ℕ) : finite (set_of fun (i : ℕ) => i ≤ n) :=
  Nonempty.intro (set.fintype_le_nat n)

theorem finite_lt_nat (n : ℕ) : finite (set_of fun (i : ℕ) => i < n) :=
  Nonempty.intro (set.fintype_lt_nat n)

protected instance fintype_prod {α : Type u} {β : Type v} (s : set α) (t : set β) [fintype ↥s]
    [fintype ↥t] : fintype ↥(set.prod s t) :=
  fintype.of_finset (finset.product (to_finset s) (to_finset t)) sorry

theorem finite.prod {α : Type u} {β : Type v} {s : set α} {t : set β} :
    finite s → finite t → finite (set.prod s t) :=
  sorry

/-- `image2 f s t` is finitype if `s` and `t` are. -/
protected instance fintype_image2 {α : Type u} {β : Type v} {γ : Type x} [DecidableEq γ]
    (f : α → β → γ) (s : set α) (t : set β) [hs : fintype ↥s] [ht : fintype ↥t] :
    fintype ↥(image2 f s t) :=
  eq.mpr sorry (set.fintype_image (set.prod s t) fun (x : α × β) => f (prod.fst x) (prod.snd x))

theorem finite.image2 {α : Type u} {β : Type v} {γ : Type x} (f : α → β → γ) {s : set α} {t : set β}
    (hs : finite s) (ht : finite t) : finite (image2 f s t) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (finite (image2 f s t))) (Eq.symm (image_prod f))))
    (finite.image (fun (x : α × β) => f (prod.fst x) (prod.snd x)) (finite.prod hs ht))

/-- If `s : set α` is a set with `fintype` instance and `f : α → set β` is a function such that
each `f a`, `a ∈ s`, has a `fintype` structure, then `s >>= f` has a `fintype` structure. -/
def fintype_bUnion {α : Type u_1} {β : Type u_1} [DecidableEq β] (s : set α) [fintype ↥s]
    (f : α → set β) (H : (a : α) → a ∈ s → fintype ↥(f a)) : fintype ↥(s >>= f) :=
  fintype_set_bUnion (fun (i : α) => f i) H

protected instance fintype_bUnion' {α : Type u_1} {β : Type u_1} [DecidableEq β] (s : set α)
    [fintype ↥s] (f : α → set β) [H : (a : α) → fintype ↥(f a)] : fintype ↥(s >>= f) :=
  fintype_bUnion s f fun (i : α) (_x : i ∈ s) => H i

theorem finite_bUnion {α : Type u_1} {β : Type u_1} {s : set α} {f : α → set β} :
    finite s → (∀ (a : α), a ∈ s → finite (f a)) → finite (s >>= f) :=
  sorry

protected instance fintype_seq {α : Type u} {β : Type u} [DecidableEq β] (f : set (α → β))
    (s : set α) [fintype ↥f] [fintype ↥s] : fintype ↥(f <*> s) :=
  eq.mpr sorry (set.fintype_bUnion' f fun (_x : α → β) => _x <$> s)

theorem finite.seq {α : Type u} {β : Type u} {f : set (α → β)} {s : set α} :
    finite f → finite s → finite (f <*> s) :=
  sorry

/-- There are finitely many subsets of a given finite set -/
theorem finite.finite_subsets {α : Type u} {a : set α} (h : finite a) :
    finite (set_of fun (b : set α) => b ⊆ a) :=
  sorry

theorem exists_min_image {α : Type u} {β : Type v} [linear_order β] (s : set α) (f : α → β)
    (h1 : finite s) : set.nonempty s → ∃ (a : α), ∃ (H : a ∈ s), ∀ (b : α), b ∈ s → f a ≤ f b :=
  sorry

theorem exists_max_image {α : Type u} {β : Type v} [linear_order β] (s : set α) (f : α → β)
    (h1 : finite s) : set.nonempty s → ∃ (a : α), ∃ (H : a ∈ s), ∀ (b : α), b ∈ s → f b ≤ f a :=
  sorry

end set

namespace finset

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

@[simp] theorem coe_bUnion {α : Type u} {β : Type v} [DecidableEq β] {s : finset α}
    {f : α → finset β} :
    ↑(finset.bUnion s f) = set.Union fun (x : α) => set.Union fun (H : x ∈ ↑s) => ↑(f x) :=
  sorry

@[simp] theorem finite_to_set_to_finset {α : Type u_1} (s : finset α) :
    set.finite.to_finset (finite_to_set s) = s :=
  sorry

end finset

namespace set

theorem finite_subset_Union {α : Type u} {s : set α} (hs : finite s) {ι : Type u_1} {t : ι → set α}
    (h : s ⊆ Union fun (i : ι) => t i) :
    ∃ (I : set ι), finite I ∧ s ⊆ Union fun (i : ι) => Union fun (H : i ∈ I) => t i :=
  sorry

theorem eq_finite_Union_of_finite_subset_Union {α : Type u} {ι : Type u_1} {s : ι → set α}
    {t : set α} (tfin : finite t) (h : t ⊆ Union fun (i : ι) => s i) :
    ∃ (I : set ι),
        finite I ∧
          ∃ (σ : ↥(set_of fun (i : ι) => i ∈ I) → set α),
            (∀ (i : ↥(set_of fun (i : ι) => i ∈ I)), finite (σ i)) ∧
              (∀ (i : ↥(set_of fun (i : ι) => i ∈ I)), σ i ⊆ s ↑i) ∧
                t = Union fun (i : ↥(set_of fun (i : ι) => i ∈ I)) => σ i :=
  sorry

/-- An increasing union distributes over finite intersection. -/
theorem Union_Inter_of_monotone {ι : Type u_1} {ι' : Type u_2} {α : Type u_3} [fintype ι]
    [linear_order ι'] [Nonempty ι'] {s : ι → ι' → set α} (hs : ∀ (i : ι), monotone (s i)) :
    (Union fun (j : ι') => Inter fun (i : ι) => s i j) =
        Inter fun (i : ι) => Union fun (j : ι') => s i j :=
  sorry

protected instance nat.fintype_Iio (n : ℕ) : fintype ↥(Iio n) :=
  fintype.of_finset (finset.range n) sorry

/--
If `P` is some relation between terms of `γ` and sets in `γ`,
such that every finite set `t : set γ` has some `c : γ` related to it,
then there is a recursively defined sequence `u` in `γ`
so `u n` is related to the image of `{0, 1, ..., n-1}` under `u`.

(We use this later to show sequentially compact sets
are totally bounded.)
-/
theorem seq_of_forall_finite_exists {γ : Type u_1} {P : γ → set γ → Prop}
    (h : ∀ (t : set γ), finite t → ∃ (c : γ), P c t) :
    ∃ (u : ℕ → γ), ∀ (n : ℕ), P (u n) (u '' Iio n) :=
  sorry

theorem finite_range_ite {α : Type u} {β : Type v} {p : α → Prop} [decidable_pred p] {f : α → β}
    {g : α → β} (hf : finite (range f)) (hg : finite (range g)) :
    finite (range fun (x : α) => ite (p x) (f x) (g x)) :=
  finite.subset (finite.union hf hg) range_ite_subset

theorem finite_range_const {α : Type u} {β : Type v} {c : β} : finite (range fun (x : α) => c) :=
  finite.subset (finite_singleton c) range_const_subset

theorem range_find_greatest_subset {α : Type u} {P : α → ℕ → Prop} [(x : α) → decidable_pred (P x)]
    {b : ℕ} : (range fun (x : α) => nat.find_greatest (P x) b) ⊆ ↑(finset.range (b + 1)) :=
  sorry

theorem finite_range_find_greatest {α : Type u} {P : α → ℕ → Prop} [(x : α) → decidable_pred (P x)]
    {b : ℕ} : finite (range fun (x : α) => nat.find_greatest (P x) b) :=
  finite.subset (finset.finite_to_set (finset.range (b + 1))) range_find_greatest_subset

theorem card_lt_card {α : Type u} {s : set α} {t : set α} [fintype ↥s] [fintype ↥t] (h : s ⊂ t) :
    fintype.card ↥s < fintype.card ↥t :=
  sorry

theorem card_le_of_subset {α : Type u} {s : set α} {t : set α} [fintype ↥s] [fintype ↥t]
    (hsub : s ⊆ t) : fintype.card ↥s ≤ fintype.card ↥t :=
  sorry

theorem eq_of_subset_of_card_le {α : Type u} {s : set α} {t : set α} [fintype ↥s] [fintype ↥t]
    (hsub : s ⊆ t) (hcard : fintype.card ↥t ≤ fintype.card ↥s) : s = t :=
  or.elim (eq_or_ssubset_of_subset hsub) id
    fun (h : s ⊂ t) => absurd hcard (not_le_of_lt (card_lt_card h))

theorem subset_iff_to_finset_subset {α : Type u} (s : set α) (t : set α) [fintype ↥s] [fintype ↥t] :
    s ⊆ t ↔ to_finset s ⊆ to_finset t :=
  { mp :=
      fun (h : s ⊆ t) (x : α) (hx : x ∈ to_finset s) =>
        iff.mpr mem_to_finset (h (iff.mp mem_to_finset hx)),
    mpr :=
      fun (h : to_finset s ⊆ to_finset t) (x : α) (hx : x ∈ s) =>
        iff.mp mem_to_finset (h (iff.mpr mem_to_finset hx)) }

theorem card_range_of_injective {α : Type u} {β : Type v} [fintype α] {f : α → β}
    (hf : function.injective f) [fintype ↥(range f)] : fintype.card ↥(range f) = fintype.card α :=
  Eq.symm (fintype.card_congr (equiv.set.range f hf))

theorem finite.exists_maximal_wrt {α : Type u} {β : Type v} [partial_order β] (f : α → β)
    (s : set α) (h : finite s) :
    set.nonempty s → ∃ (a : α), ∃ (H : a ∈ s), ∀ (a' : α), a' ∈ s → f a ≤ f a' → f a = f a' :=
  sorry

theorem finite.card_to_finset {α : Type u} {s : set α} [fintype ↥s] (h : finite s) :
    finset.card (finite.to_finset h) = fintype.card ↥s :=
  sorry

theorem to_finset_compl {α : Type u_1} [fintype α] (s : set α) : to_finset (sᶜ) = (to_finset sᶜ) :=
  sorry

theorem to_finset_inter {α : Type u_1} [fintype α] (s : set α) (t : set α) :
    to_finset (s ∩ t) = to_finset s ∩ to_finset t :=
  sorry

theorem to_finset_union {α : Type u_1} [fintype α] (s : set α) (t : set α) :
    to_finset (s ∪ t) = to_finset s ∪ to_finset t :=
  sorry

/--A finite set is bounded above.-/
protected theorem finite.bdd_above {α : Type u} [semilattice_sup α] [Nonempty α] {s : set α}
    (hs : finite s) : bdd_above s :=
  finite.induction_on hs bdd_above_empty
    fun (a : α) (s : set α) (_x : ¬a ∈ s) (_x : finite s) (h : bdd_above s) => bdd_above.insert a h

/--A finite union of sets which are all bounded above is still bounded above.-/
theorem finite.bdd_above_bUnion {α : Type u} {β : Type v} [semilattice_sup α] [Nonempty α]
    {I : set β} {S : β → set α} (H : finite I) :
    bdd_above (Union fun (i : β) => Union fun (H : i ∈ I) => S i) ↔
        ∀ (i : β), i ∈ I → bdd_above (S i) :=
  sorry

/--A finite set is bounded below.-/
protected theorem finite.bdd_below {α : Type u} [semilattice_inf α] [Nonempty α] {s : set α}
    (hs : finite s) : bdd_below s :=
  finite.bdd_above hs

/--A finite union of sets which are all bounded below is still bounded below.-/
theorem finite.bdd_below_bUnion {α : Type u} {β : Type v} [semilattice_inf α] [Nonempty α]
    {I : set β} {S : β → set α} (H : finite I) :
    bdd_below (Union fun (i : β) => Union fun (H : i ∈ I) => S i) ↔
        ∀ (i : β), i ∈ I → bdd_below (S i) :=
  finite.bdd_above_bUnion H

end set

namespace finset

/-- A finset is bounded above. -/
protected theorem bdd_above {α : Type u} [semilattice_sup α] [Nonempty α] (s : finset α) :
    bdd_above ↑s :=
  set.finite.bdd_above (finite_to_set s)

/-- A finset is bounded below. -/
protected theorem bdd_below {α : Type u} [semilattice_inf α] [Nonempty α] (s : finset α) :
    bdd_below ↑s :=
  set.finite.bdd_below (finite_to_set s)

end finset

theorem fintype.exists_max {α : Type u} [fintype α] [Nonempty α] {β : Type u_1} [linear_order β]
    (f : α → β) : ∃ (x₀ : α), ∀ (x : α), f x ≤ f x₀ :=
  sorry

end Mathlib


/-
Copyright (c) 2019 Alexander Bentkamp. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Alexander Bentkamp, Yury Kudryashov, Yaël Dillies
-/
import algebra.order.invertible
import algebra.order.smul
import linear_algebra.affine_space.midpoint
import linear_algebra.ray
import tactic.positivity

/-!
# Segments in vector spaces

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

In a 𝕜-vector space, we define the following objects and properties.
* `segment 𝕜 x y`: Closed segment joining `x` and `y`.
* `open_segment 𝕜 x y`: Open segment joining `x` and `y`.

## Notations

We provide the following notation:
* `[x -[𝕜] y] = segment 𝕜 x y` in locale `convex`

## TODO

Generalize all this file to affine spaces.

Should we rename `segment` and `open_segment` to `convex.Icc` and `convex.Ioo`? Should we also
define `clopen_segment`/`convex.Ico`/`convex.Ioc`?
-/

variables {𝕜 E F G ι : Type*} {π : ι → Type*}

open function set
open_locale pointwise

section ordered_semiring
variables [ordered_semiring 𝕜] [add_comm_monoid E]

section has_smul
variables (𝕜) [has_smul 𝕜 E] {s : set E} {x y : E}

/-- Segments in a vector space. -/
def segment (x y : E) : set E :=
{z : E | ∃ (a b : 𝕜) (ha : 0 ≤ a) (hb : 0 ≤ b) (hab : a + b = 1), a • x + b • y = z}

/-- Open segment in a vector space. Note that `open_segment 𝕜 x x = {x}` instead of being `∅` when
the base semiring has some element between `0` and `1`. -/
def open_segment (x y : E) : set E :=
{z : E | ∃ (a b : 𝕜) (ha : 0 < a) (hb : 0 < b) (hab : a + b = 1), a • x + b • y = z}

localized "notation (name := segment) `[` x ` -[` 𝕜 `] ` y `]` := segment 𝕜 x y" in convex

lemma segment_eq_image₂ (x y : E) :
  [x -[𝕜] y] = (λ p : 𝕜 × 𝕜, p.1 • x + p.2 • y) '' {p | 0 ≤ p.1 ∧ 0 ≤ p.2 ∧ p.1 + p.2 = 1} :=
by simp only [segment, image, prod.exists, mem_set_of_eq, exists_prop, and_assoc]

lemma open_segment_eq_image₂ (x y : E) :
  open_segment 𝕜 x y =
    (λ p : 𝕜 × 𝕜, p.1 • x + p.2 • y) '' {p | 0 < p.1 ∧ 0 < p.2 ∧ p.1 + p.2 = 1} :=
by simp only [open_segment, image, prod.exists, mem_set_of_eq, exists_prop, and_assoc]

lemma segment_symm (x y : E) : [x -[𝕜] y] = [y -[𝕜] x] :=
set.ext $ λ z,
⟨λ ⟨a, b, ha, hb, hab, H⟩, ⟨b, a, hb, ha, (add_comm _ _).trans hab, (add_comm _ _).trans H⟩,
  λ ⟨a, b, ha, hb, hab, H⟩, ⟨b, a, hb, ha, (add_comm _ _).trans hab, (add_comm _ _).trans H⟩⟩

lemma open_segment_symm (x y : E) : open_segment 𝕜 x y = open_segment 𝕜 y x :=
set.ext $ λ z,
⟨λ ⟨a, b, ha, hb, hab, H⟩, ⟨b, a, hb, ha, (add_comm _ _).trans hab, (add_comm _ _).trans H⟩,
  λ ⟨a, b, ha, hb, hab, H⟩, ⟨b, a, hb, ha, (add_comm _ _).trans hab, (add_comm _ _).trans H⟩⟩

lemma open_segment_subset_segment (x y : E) : open_segment 𝕜 x y ⊆ [x -[𝕜] y] :=
λ z ⟨a, b, ha, hb, hab, hz⟩, ⟨a, b, ha.le, hb.le, hab, hz⟩

lemma segment_subset_iff :
  [x -[𝕜] y] ⊆ s ↔ ∀ a b : 𝕜, 0 ≤ a → 0 ≤ b → a + b = 1 → a • x + b • y ∈ s :=
⟨λ H a b ha hb hab, H ⟨a, b, ha, hb, hab, rfl⟩,
  λ H z ⟨a, b, ha, hb, hab, hz⟩, hz ▸ H a b ha hb hab⟩

lemma open_segment_subset_iff :
  open_segment 𝕜 x y ⊆ s ↔ ∀ a b : 𝕜, 0 < a → 0 < b → a + b = 1 → a • x + b • y ∈ s :=
⟨λ H a b ha hb hab, H ⟨a, b, ha, hb, hab, rfl⟩,
  λ H z ⟨a, b, ha, hb, hab, hz⟩, hz ▸ H a b ha hb hab⟩

end has_smul

open_locale convex

section mul_action_with_zero
variables (𝕜) [mul_action_with_zero 𝕜 E]

lemma left_mem_segment (x y : E) : x ∈ [x -[𝕜] y] :=
⟨1, 0, zero_le_one, le_refl 0, add_zero 1, by rw [zero_smul, one_smul, add_zero]⟩

lemma right_mem_segment (x y : E) : y ∈ [x -[𝕜] y] := segment_symm 𝕜 y x ▸ left_mem_segment 𝕜 y x

end mul_action_with_zero

section module
variables (𝕜) [module 𝕜 E] {s : set E} {x y z : E}

@[simp] lemma segment_same (x : E) : [x -[𝕜] x] = {x} :=
set.ext $ λ z, ⟨λ ⟨a, b, ha, hb, hab, hz⟩,
  by simpa only [(add_smul _ _ _).symm, mem_singleton_iff, hab, one_smul, eq_comm] using hz,
  λ h, mem_singleton_iff.1 h ▸ left_mem_segment 𝕜 z z⟩

lemma insert_endpoints_open_segment (x y : E) :
  insert x (insert y (open_segment 𝕜 x y)) = [x -[𝕜] y] :=
begin
  simp only [subset_antisymm_iff, insert_subset, left_mem_segment, right_mem_segment,
    open_segment_subset_segment, true_and],
  rintro z ⟨a, b, ha, hb, hab, rfl⟩,
  refine hb.eq_or_gt.imp _ (λ hb', ha.eq_or_gt.imp _ $ λ ha', _),
  { rintro rfl,
    rw [← add_zero a, hab, one_smul, zero_smul, add_zero] },
  { rintro rfl,
    rw [← zero_add b, hab, one_smul, zero_smul, zero_add] },
  { exact ⟨a, b, ha', hb', hab, rfl⟩ }
end

variables {𝕜}

lemma mem_open_segment_of_ne_left_right (hx : x ≠ z) (hy : y ≠ z) (hz : z ∈ [x -[𝕜] y]) :
  z ∈ open_segment 𝕜 x y :=
begin
  rw [←insert_endpoints_open_segment] at hz,
  exact ((hz.resolve_left hx.symm).resolve_left hy.symm)
end

lemma open_segment_subset_iff_segment_subset (hx : x ∈ s) (hy : y ∈ s) :
  open_segment 𝕜 x y ⊆ s ↔ [x -[𝕜] y] ⊆ s :=
by simp only [←insert_endpoints_open_segment, insert_subset, *, true_and]

end module
end ordered_semiring

open_locale convex

section ordered_ring
variables (𝕜) [ordered_ring 𝕜] [add_comm_group E] [add_comm_group F] [add_comm_group G] [module 𝕜 E]
  [module 𝕜 F]

section densely_ordered
variables [nontrivial 𝕜] [densely_ordered 𝕜]

@[simp] lemma open_segment_same (x : E) : open_segment 𝕜 x x = {x} :=
set.ext $ λ z, ⟨λ ⟨a, b, ha, hb, hab, hz⟩,
  by simpa only [←add_smul, mem_singleton_iff, hab, one_smul, eq_comm] using hz,
  λ (h : z = x), begin
    obtain ⟨a, ha₀, ha₁⟩ := densely_ordered.dense (0 : 𝕜) 1 zero_lt_one,
    refine ⟨a, 1 - a, ha₀, sub_pos_of_lt ha₁, add_sub_cancel'_right _ _, _⟩,
    rw [←add_smul, add_sub_cancel'_right, one_smul, h],
  end⟩

end densely_ordered

lemma segment_eq_image (x y : E) : [x -[𝕜] y] = (λ θ : 𝕜, (1 - θ) • x + θ • y) '' Icc (0 : 𝕜) 1 :=
set.ext $ λ z,
  ⟨λ ⟨a, b, ha, hb, hab, hz⟩,
    ⟨b, ⟨hb, hab ▸ le_add_of_nonneg_left ha⟩, hab ▸ hz ▸ by simp only [add_sub_cancel]⟩,
    λ ⟨θ, ⟨hθ₀, hθ₁⟩, hz⟩, ⟨1-θ, θ, sub_nonneg.2 hθ₁, hθ₀, sub_add_cancel _ _, hz⟩⟩

lemma open_segment_eq_image (x y : E) :
  open_segment 𝕜 x y = (λ (θ : 𝕜), (1 - θ) • x + θ • y) '' Ioo (0 : 𝕜) 1 :=
set.ext $ λ z,
  ⟨λ ⟨a, b, ha, hb, hab, hz⟩,
    ⟨b, ⟨hb, hab ▸ lt_add_of_pos_left _ ha⟩, hab ▸ hz ▸ by simp only [add_sub_cancel]⟩,
    λ ⟨θ, ⟨hθ₀, hθ₁⟩, hz⟩, ⟨1 - θ, θ, sub_pos.2 hθ₁, hθ₀, sub_add_cancel _ _, hz⟩⟩

lemma segment_eq_image' (x y : E) : [x -[𝕜] y] = (λ (θ : 𝕜), x + θ • (y - x)) '' Icc (0 : 𝕜) 1 :=
by { convert segment_eq_image 𝕜 x y, ext θ, simp only [smul_sub, sub_smul, one_smul], abel }

lemma open_segment_eq_image' (x y : E) :
  open_segment 𝕜 x y = (λ (θ : 𝕜), x + θ • (y - x)) '' Ioo (0 : 𝕜) 1 :=
by { convert open_segment_eq_image 𝕜 x y, ext θ, simp only [smul_sub, sub_smul, one_smul], abel }

lemma segment_eq_image_line_map (x y : E) : [x -[𝕜] y] = affine_map.line_map x y '' Icc (0 : 𝕜) 1 :=
by { convert segment_eq_image 𝕜 x y, ext, exact affine_map.line_map_apply_module _ _ _ }

lemma open_segment_eq_image_line_map (x y : E) :
  open_segment 𝕜 x y = affine_map.line_map x y '' Ioo (0 : 𝕜) 1 :=
by { convert open_segment_eq_image 𝕜 x y, ext, exact affine_map.line_map_apply_module _ _ _ }

@[simp] lemma image_segment (f : E →ᵃ[𝕜] F) (a b : E) : f '' [a -[𝕜] b] = [f a -[𝕜] f b] :=
set.ext $ λ x, by simp_rw [segment_eq_image_line_map, mem_image, exists_exists_and_eq_and,
  affine_map.apply_line_map]

@[simp] lemma image_open_segment (f : E →ᵃ[𝕜] F) (a b : E) :
  f '' open_segment 𝕜 a b = open_segment 𝕜 (f a) (f b) :=
set.ext $ λ x, by simp_rw [open_segment_eq_image_line_map, mem_image, exists_exists_and_eq_and,
  affine_map.apply_line_map]

@[simp] lemma vadd_segment [add_torsor G E] [vadd_comm_class G E E] (a : G) (b c : E) :
  a +ᵥ [b -[𝕜] c] = [a +ᵥ b -[𝕜] a +ᵥ c] :=
image_segment 𝕜 ⟨_, linear_map.id, λ _ _, vadd_comm _ _ _⟩ b c

@[simp] lemma vadd_open_segment [add_torsor G E] [vadd_comm_class G E E] (a : G) (b c : E) :
  a +ᵥ open_segment 𝕜 b c = open_segment 𝕜 (a +ᵥ b) (a +ᵥ c) :=
image_open_segment 𝕜 ⟨_, linear_map.id, λ _ _, vadd_comm _ _ _⟩ b c

@[simp] lemma mem_segment_translate (a : E) {x b c} : a + x ∈ [a + b -[𝕜] a + c] ↔ x ∈ [b -[𝕜] c] :=
by simp_rw [←vadd_eq_add, ←vadd_segment, vadd_mem_vadd_set_iff]

@[simp] lemma mem_open_segment_translate (a : E) {x b c : E} :
  a + x ∈ open_segment 𝕜 (a + b) (a + c) ↔ x ∈ open_segment 𝕜 b c :=
by simp_rw [←vadd_eq_add, ←vadd_open_segment, vadd_mem_vadd_set_iff]

lemma segment_translate_preimage (a b c : E) : (λ x, a + x) ⁻¹' [a + b -[𝕜] a + c] = [b -[𝕜] c] :=
set.ext $ λ x, mem_segment_translate 𝕜 a

lemma open_segment_translate_preimage (a b c : E) :
  (λ x, a + x) ⁻¹' open_segment 𝕜 (a + b) (a + c) = open_segment 𝕜 b c :=
set.ext $ λ x, mem_open_segment_translate 𝕜 a

lemma segment_translate_image (a b c : E) : (λ x, a + x) '' [b -[𝕜] c] = [a + b -[𝕜] a + c] :=
segment_translate_preimage 𝕜 a b c ▸ image_preimage_eq _ $ add_left_surjective a

lemma open_segment_translate_image (a b c : E) :
  (λ x, a + x) '' open_segment 𝕜 b c = open_segment 𝕜 (a + b) (a + c) :=
open_segment_translate_preimage 𝕜 a b c ▸ image_preimage_eq _ $ add_left_surjective a

end ordered_ring

lemma same_ray_of_mem_segment [strict_ordered_comm_ring 𝕜] [add_comm_group E] [module 𝕜 E]
  {x y z : E} (h : x ∈ [y -[𝕜] z]) : same_ray 𝕜 (x - y) (z - x) :=
begin
  rw segment_eq_image' at h,
  rcases h with ⟨θ, ⟨hθ₀, hθ₁⟩, rfl⟩,
  simpa only [add_sub_cancel', ←sub_sub, sub_smul, one_smul]
    using (same_ray_nonneg_smul_left (z - y) hθ₀).nonneg_smul_right (sub_nonneg.2 hθ₁)
end

section linear_ordered_ring
variables [linear_ordered_ring 𝕜] [add_comm_group E] [module 𝕜 E] {x y : E}

lemma midpoint_mem_segment [invertible (2 : 𝕜)] (x y : E) : midpoint 𝕜 x y ∈ [x -[𝕜] y] :=
begin
  rw segment_eq_image_line_map,
  exact ⟨⅟2, ⟨inv_of_nonneg.mpr zero_le_two, inv_of_le_one one_le_two⟩, rfl⟩,
end

lemma mem_segment_sub_add [invertible (2 : 𝕜)] (x y : E) : x ∈ [x - y -[𝕜] x + y] :=
by { convert @midpoint_mem_segment 𝕜 _ _ _ _ _ _ _, rw midpoint_sub_add }

lemma mem_segment_add_sub [invertible (2 : 𝕜)] (x y : E) : x ∈ [x + y -[𝕜] x - y] :=
by { convert @midpoint_mem_segment 𝕜 _ _ _ _ _ _ _, rw midpoint_add_sub }

@[simp] lemma left_mem_open_segment_iff [densely_ordered 𝕜] [no_zero_smul_divisors 𝕜 E] :
  x ∈ open_segment 𝕜 x y ↔ x = y :=
begin
  split,
  { rintro ⟨a, b, ha, hb, hab, hx⟩,
    refine smul_right_injective _ hb.ne' ((add_right_inj (a • x)).1 _),
    rw [hx, ←add_smul, hab, one_smul] },
  { rintro rfl,
    rw open_segment_same,
    exact mem_singleton _ }
end

@[simp] lemma right_mem_open_segment_iff [densely_ordered 𝕜] [no_zero_smul_divisors 𝕜 E] :
  y ∈ open_segment 𝕜 x y ↔ x = y :=
by rw [open_segment_symm, left_mem_open_segment_iff, eq_comm]

end linear_ordered_ring

section linear_ordered_semifield
variables [linear_ordered_semifield 𝕜] [add_comm_group E] [module 𝕜 E] {x y z : E}

lemma mem_segment_iff_div : x ∈ [y -[𝕜] z] ↔
  ∃ a b : 𝕜, 0 ≤ a ∧ 0 ≤ b ∧ 0 < a + b ∧ (a / (a + b)) • y + (b / (a + b)) • z = x :=
begin
  split,
  { rintro ⟨a, b, ha, hb, hab, rfl⟩,
    use [a, b, ha, hb],
    simp * },
  { rintro ⟨a, b, ha, hb, hab, rfl⟩,
    refine ⟨a / (a + b), b / (a + b), div_nonneg ha hab.le, div_nonneg hb hab.le, _, rfl⟩,
    rw [←add_div, div_self hab.ne'] }
end

lemma mem_open_segment_iff_div : x ∈ open_segment 𝕜 y z ↔
  ∃ a b : 𝕜, 0 < a ∧ 0 < b ∧ (a / (a + b)) • y + (b / (a + b)) • z = x :=
begin
  split,
  { rintro ⟨a, b, ha, hb, hab, rfl⟩,
    use [a, b, ha, hb],
    rw [hab, div_one, div_one] },
  { rintro ⟨a, b, ha, hb, rfl⟩,
    have hab : 0 < a + b := by positivity,
    refine ⟨a / (a + b), b / (a + b), by positivity, by positivity, _, rfl⟩,
    rw [←add_div, div_self hab.ne'] }
end

end linear_ordered_semifield

section linear_ordered_field
variables [linear_ordered_field 𝕜] [add_comm_group E] [module 𝕜 E] {x y z : E}

lemma mem_segment_iff_same_ray : x ∈ [y -[𝕜] z] ↔ same_ray 𝕜 (x - y) (z - x) :=
begin
  refine ⟨same_ray_of_mem_segment, λ h, _⟩,
  rcases h.exists_eq_smul_add with ⟨a, b, ha, hb, hab, hxy, hzx⟩,
  rw [add_comm, sub_add_sub_cancel] at hxy hzx,
  rw [←mem_segment_translate _ (-x), neg_add_self],
  refine ⟨b, a, hb, ha, add_comm a b ▸ hab, _⟩,
  rw [←sub_eq_neg_add, ←neg_sub, hxy, ←sub_eq_neg_add, hzx, smul_neg, smul_comm, neg_add_self]
end

open affine_map

/-- If `z = line_map x y c` is a point on the line passing through `x` and `y`, then the open
segment `open_segment 𝕜 x y` is included in the union of the open segments `open_segment 𝕜 x z`,
`open_segment 𝕜 z y`, and the point `z`. Informally, `(x, y) ⊆ {z} ∪ (x, z) ∪ (z, y)`. -/
lemma open_segment_subset_union (x y : E) {z : E} (hz : z ∈ range (line_map x y : 𝕜 → E)) :
  open_segment 𝕜 x y ⊆ insert z (open_segment 𝕜 x z ∪ open_segment 𝕜 z y) :=
begin
  rcases hz with ⟨c, rfl⟩,
  simp only [open_segment_eq_image_line_map, ← maps_to'],
  rintro a ⟨h₀, h₁⟩,
  rcases lt_trichotomy a c with hac|rfl|hca,
  { right, left,
    have hc : 0 < c, from h₀.trans hac,
    refine ⟨a / c, ⟨div_pos h₀ hc, (div_lt_one hc).2 hac⟩, _⟩,
    simp only [← homothety_eq_line_map, ← homothety_mul_apply, div_mul_cancel _ hc.ne'] },
  { left, refl },
  { right, right,
    have hc : 0 < 1 - c, from sub_pos.2 (hca.trans h₁),
    simp only [← line_map_apply_one_sub y],
    refine ⟨(a - c) / (1 - c), ⟨div_pos (sub_pos.2 hca) hc,
      (div_lt_one hc).2 $ sub_lt_sub_right h₁ _⟩, _⟩,
    simp only [← homothety_eq_line_map, ← homothety_mul_apply, sub_mul, one_mul,
      div_mul_cancel _ hc.ne', sub_sub_sub_cancel_right] }
end

end linear_ordered_field

/-!
#### Segments in an ordered space

Relates `segment`, `open_segment` and `set.Icc`, `set.Ico`, `set.Ioc`, `set.Ioo`
-/
section ordered_semiring
variables [ordered_semiring 𝕜]

section ordered_add_comm_monoid
variables [ordered_add_comm_monoid E] [module 𝕜 E] [ordered_smul 𝕜 E] {x y : E}

lemma segment_subset_Icc (h : x ≤ y) : [x -[𝕜] y] ⊆ Icc x y :=
begin
  rintro z ⟨a, b, ha, hb, hab, rfl⟩,
  split,
  calc
    x   = a • x + b • x :(convex.combo_self hab _).symm
    ... ≤ a • x + b • y : add_le_add_left (smul_le_smul_of_nonneg h hb) _,
  calc
    a • x + b • y
        ≤ a • y + b • y : add_le_add_right (smul_le_smul_of_nonneg h ha) _
    ... = y : convex.combo_self hab _,
end

end ordered_add_comm_monoid

section ordered_cancel_add_comm_monoid
variables [ordered_cancel_add_comm_monoid E] [module 𝕜 E] [ordered_smul 𝕜 E] {x y : E}

lemma open_segment_subset_Ioo (h : x < y) : open_segment 𝕜 x y ⊆ Ioo x y :=
begin
  rintro z ⟨a, b, ha, hb, hab, rfl⟩,
  split,
  calc
    x   = a • x + b • x : (convex.combo_self hab _).symm
    ... < a • x + b • y : add_lt_add_left (smul_lt_smul_of_pos h hb) _,
  calc
    a • x + b • y
        < a • y + b • y : add_lt_add_right (smul_lt_smul_of_pos h ha) _
    ... = y : convex.combo_self hab _,
end

end ordered_cancel_add_comm_monoid

section linear_ordered_add_comm_monoid
variables [linear_ordered_add_comm_monoid E] [module 𝕜 E] [ordered_smul 𝕜 E] {𝕜} {a b : 𝕜}

lemma segment_subset_uIcc (x y : E) : [x -[𝕜] y] ⊆ uIcc x y :=
begin
  cases le_total x y,
  { rw uIcc_of_le h,
    exact segment_subset_Icc h },
  { rw [uIcc_of_ge h, segment_symm],
    exact segment_subset_Icc h }
end

lemma convex.min_le_combo (x y : E) (ha : 0 ≤ a) (hb : 0 ≤ b) (hab : a + b = 1) :
  min x y ≤ a • x + b • y :=
(segment_subset_uIcc x y ⟨_, _, ha, hb, hab, rfl⟩).1

lemma convex.combo_le_max (x y : E) (ha : 0 ≤ a) (hb : 0 ≤ b) (hab : a + b = 1) :
  a • x + b • y ≤ max x y :=
(segment_subset_uIcc x y ⟨_, _, ha, hb, hab, rfl⟩).2

end linear_ordered_add_comm_monoid
end ordered_semiring

section linear_ordered_field
variables [linear_ordered_field 𝕜] {x y z : 𝕜}

lemma Icc_subset_segment : Icc x y ⊆ [x -[𝕜] y] :=
begin
  rintro z ⟨hxz, hyz⟩,
  obtain rfl | h := (hxz.trans hyz).eq_or_lt,
  { rw segment_same,
    exact hyz.antisymm hxz },
  rw ←sub_nonneg at hxz hyz,
  rw ←sub_pos at h,
  refine ⟨(y - z) / (y - x), (z - x) / (y - x), div_nonneg hyz h.le, div_nonneg hxz h.le, _, _⟩,
  { rw [←add_div, sub_add_sub_cancel, div_self h.ne'] },
  { rw [smul_eq_mul, smul_eq_mul, ←mul_div_right_comm, ←mul_div_right_comm, ←add_div,
      div_eq_iff h.ne', add_comm, sub_mul, sub_mul, mul_comm x, sub_add_sub_cancel, mul_sub] }
end

@[simp] lemma segment_eq_Icc (h : x ≤ y) : [x -[𝕜] y] = Icc x y :=
(segment_subset_Icc h).antisymm Icc_subset_segment

lemma Ioo_subset_open_segment : Ioo x y ⊆ open_segment 𝕜 x y :=
λ z hz, mem_open_segment_of_ne_left_right hz.1.ne hz.2.ne' $ Icc_subset_segment $
  Ioo_subset_Icc_self hz

@[simp] lemma open_segment_eq_Ioo (h : x < y) : open_segment 𝕜 x y = Ioo x y :=
(open_segment_subset_Ioo h).antisymm Ioo_subset_open_segment

lemma segment_eq_Icc' (x y : 𝕜) : [x -[𝕜] y] = Icc (min x y) (max x y) :=
begin
  cases le_total x y,
  { rw [segment_eq_Icc h, max_eq_right h, min_eq_left h] },
  { rw [segment_symm, segment_eq_Icc h, max_eq_left h, min_eq_right h] }
end

lemma open_segment_eq_Ioo' (hxy : x ≠ y) : open_segment 𝕜 x y = Ioo (min x y) (max x y) :=
begin
  cases hxy.lt_or_lt,
  { rw [open_segment_eq_Ioo h, max_eq_right h.le, min_eq_left h.le] },
  { rw [open_segment_symm, open_segment_eq_Ioo h, max_eq_left h.le, min_eq_right h.le] }
end

lemma segment_eq_uIcc (x y : 𝕜) : [x -[𝕜] y] = uIcc x y := segment_eq_Icc' _ _

/-- A point is in an `Icc` iff it can be expressed as a convex combination of the endpoints. -/
lemma convex.mem_Icc (h : x ≤ y) :
  z ∈ Icc x y ↔ ∃ a b, 0 ≤ a ∧ 0 ≤ b ∧ a + b = 1 ∧ a * x + b * y = z :=
by { rw ←segment_eq_Icc h, simp_rw [←exists_prop], refl }

/-- A point is in an `Ioo` iff it can be expressed as a strict convex combination of the endpoints.
-/
lemma convex.mem_Ioo (h : x < y) :
  z ∈ Ioo x y ↔ ∃ a b, 0 < a ∧ 0 < b ∧ a + b = 1 ∧ a * x + b * y = z :=
by { rw ←open_segment_eq_Ioo h, simp_rw [←exists_prop], refl }

/-- A point is in an `Ioc` iff it can be expressed as a semistrict convex combination of the
endpoints. -/
lemma convex.mem_Ioc (h : x < y) :
  z ∈ Ioc x y ↔ ∃ a b, 0 ≤ a ∧ 0 < b ∧ a + b = 1 ∧ a * x + b * y = z :=
begin
  refine ⟨λ hz, _, _⟩,
  { obtain ⟨a, b, ha, hb, hab, rfl⟩ := (convex.mem_Icc h.le).1 (Ioc_subset_Icc_self hz),
    obtain rfl | hb' := hb.eq_or_lt,
    { rw add_zero at hab,
      rw [hab, one_mul, zero_mul, add_zero] at hz,
      exact (hz.1.ne rfl).elim },
    { exact ⟨a, b, ha, hb', hab, rfl⟩ } },
  { rintro ⟨a, b, ha, hb, hab, rfl⟩,
    obtain rfl | ha' := ha.eq_or_lt,
    { rw zero_add at hab,
      rwa [hab, one_mul, zero_mul, zero_add, right_mem_Ioc] },
    { exact Ioo_subset_Ioc_self ((convex.mem_Ioo h).2 ⟨a, b, ha', hb, hab, rfl⟩) } }
end

/-- A point is in an `Ico` iff it can be expressed as a semistrict convex combination of the
endpoints. -/
lemma convex.mem_Ico (h : x < y) :
  z ∈ Ico x y ↔ ∃ a b, 0 < a ∧ 0 ≤ b ∧ a + b = 1 ∧ a * x + b * y = z :=
begin
  refine ⟨λ hz, _, _⟩,
  { obtain ⟨a, b, ha, hb, hab, rfl⟩ := (convex.mem_Icc h.le).1 (Ico_subset_Icc_self hz),
    obtain rfl | ha' := ha.eq_or_lt,
    { rw zero_add at hab,
      rw [hab, one_mul, zero_mul, zero_add] at hz,
      exact (hz.2.ne rfl).elim },
    { exact ⟨a, b, ha', hb, hab, rfl⟩ } },
  { rintro ⟨a, b, ha, hb, hab, rfl⟩,
    obtain rfl | hb' := hb.eq_or_lt,
    { rw add_zero at hab,
      rwa [hab, one_mul, zero_mul, add_zero, left_mem_Ico] },
    { exact Ioo_subset_Ico_self ((convex.mem_Ioo h).2 ⟨a, b, ha, hb', hab, rfl⟩) } }
end

end linear_ordered_field

namespace prod
variables [ordered_semiring 𝕜] [add_comm_monoid E] [add_comm_monoid F] [module 𝕜 E] [module 𝕜 F]

lemma segment_subset (x y : E × F) : segment 𝕜 x y ⊆ segment 𝕜 x.1 y.1 ×ˢ segment 𝕜 x.2 y.2 :=
begin
  rintro z ⟨a, b, ha, hb, hab, hz⟩,
  exact ⟨⟨a, b, ha, hb, hab, congr_arg prod.fst hz⟩, a, b, ha, hb, hab, congr_arg prod.snd hz⟩,
end

lemma open_segment_subset (x y : E × F) :
  open_segment 𝕜 x y ⊆ open_segment 𝕜 x.1 y.1 ×ˢ open_segment 𝕜 x.2 y.2 :=
begin
  rintro z ⟨a, b, ha, hb, hab, hz⟩,
  exact ⟨⟨a, b, ha, hb, hab, congr_arg prod.fst hz⟩, a, b, ha, hb, hab, congr_arg prod.snd hz⟩,
end

lemma image_mk_segment_left (x₁ x₂ : E) (y : F) :
  (λ x, (x, y)) '' [x₁ -[𝕜] x₂] = [(x₁, y) -[𝕜] (x₂, y)] :=
begin
  ext ⟨x', y'⟩,
  simp_rw [set.mem_image, segment, set.mem_set_of, prod.smul_mk, prod.mk_add_mk,
    prod.mk.inj_iff, ←exists_and_distrib_right, @exists_comm E, exists_eq_left'],
  refine exists₅_congr (λ a b ha hb hab, _),
  rw convex.combo_self hab,
end

lemma image_mk_segment_right (x : E) (y₁ y₂ : F) :
  (λ y, (x, y)) '' [y₁ -[𝕜] y₂] = [(x, y₁) -[𝕜] (x, y₂)] :=
begin
  ext ⟨x', y'⟩,
  simp_rw [set.mem_image, segment, set.mem_set_of, prod.smul_mk, prod.mk_add_mk,
    prod.mk.inj_iff, ←exists_and_distrib_right, @exists_comm F, exists_eq_left'],
  refine exists₅_congr (λ a b ha hb hab, _),
  rw convex.combo_self hab,
end

lemma image_mk_open_segment_left (x₁ x₂ : E) (y : F) :
  (λ x, (x, y)) '' open_segment 𝕜 x₁ x₂ = open_segment 𝕜 (x₁, y) (x₂, y) :=
begin
  ext ⟨x', y'⟩,
  simp_rw [set.mem_image, open_segment, set.mem_set_of, prod.smul_mk, prod.mk_add_mk,
    prod.mk.inj_iff, ←exists_and_distrib_right, @exists_comm E, exists_eq_left'],
  refine exists₅_congr (λ a b ha hb hab, _),
  rw convex.combo_self hab,
end

@[simp] lemma image_mk_open_segment_right (x : E) (y₁ y₂ : F) :
  (λ y, (x, y)) '' open_segment 𝕜 y₁ y₂ = open_segment 𝕜 (x, y₁) (x, y₂) :=
begin
  ext ⟨x', y'⟩,
  simp_rw [set.mem_image, open_segment, set.mem_set_of, prod.smul_mk, prod.mk_add_mk,
    prod.mk.inj_iff, ←exists_and_distrib_right, @exists_comm F, exists_eq_left'],
  refine exists₅_congr (λ a b ha hb hab, _),
  rw convex.combo_self hab,
end

end prod

namespace pi
variables [ordered_semiring 𝕜] [Π i, add_comm_monoid (π i)] [Π i, module 𝕜 (π i)] {s : set ι}

lemma segment_subset (x y : Π i, π i) : segment 𝕜 x y ⊆ s.pi (λ i, segment 𝕜 (x i) (y i)) :=
by { rintro z ⟨a, b, ha, hb, hab, hz⟩ i -, exact ⟨a, b, ha, hb, hab, congr_fun hz i⟩ }

lemma open_segment_subset (x y : Π i, π i) :
  open_segment 𝕜 x y ⊆ s.pi (λ i, open_segment 𝕜 (x i) (y i)) :=
by { rintro z ⟨a, b, ha, hb, hab, hz⟩ i -, exact ⟨a, b, ha, hb, hab, congr_fun hz i⟩ }

variables [decidable_eq ι]

lemma image_update_segment (i : ι) (x₁ x₂ : π i) (y : Π i, π i) :
  update y i '' [x₁ -[𝕜] x₂] = [update y i x₁ -[𝕜] update y i x₂] :=
begin
  ext z,
  simp_rw [set.mem_image, segment, set.mem_set_of, ←update_smul, ←update_add, update_eq_iff,
    ←exists_and_distrib_right, @exists_comm (π i), exists_eq_left'],
  refine exists₅_congr (λ a b ha hb hab, _),
  rw convex.combo_self hab,
end

lemma image_update_open_segment (i : ι) (x₁ x₂ : π i) (y : Π i, π i) :
  update y i '' open_segment 𝕜 x₁ x₂ = open_segment 𝕜 (update y i x₁) (update y i x₂) :=
begin
  ext z,
  simp_rw [set.mem_image, open_segment, set.mem_set_of, ←update_smul, ←update_add, update_eq_iff,
    ←exists_and_distrib_right, @exists_comm (π i), exists_eq_left'],
  refine exists₅_congr (λ a b ha hb hab, _),
  rw convex.combo_self hab,
end

end pi


/-
Copyright (c) 2019 Zhouhang Zhou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Zhouhang Zhou
-/
import algebra.pointwise
import order.filter.basic
/-!
# Pointwise operations on filters.

The pointwise operations on filters have nice properties, such as
  • `map m (f₁ * f₂) = map m f₁ * map m f₂`
  • `𝓝 x * 𝓝 y = 𝓝 (x * y)`

-/

open classical set

universes u v w
variables {α : Type u} {β : Type v} {γ : Type w}

open_locale classical

namespace filter
open set

@[to_additive]
instance [has_one α] : has_one (filter α) := ⟨principal 1⟩

@[simp, to_additive]
lemma mem_one [has_one α] (s : set α) : s ∈ (1 : filter α) ↔ (1:α) ∈ s :=
calc
  s ∈ (1:filter α) ↔ 1 ⊆ s : iff.rfl
  ... ↔ (1 : α) ∈ s : by simp

@[to_additive]
instance [monoid α] : has_mul (filter α) := ⟨λf g,
{ sets             := { s | ∃t₁ t₂, t₁ ∈ f ∧ t₂ ∈ g ∧ t₁ * t₂ ⊆ s },
  univ_sets        :=
  begin
    have h₁ : (∃x, x ∈ f) := ⟨univ, univ_sets f⟩,
    have h₂ : (∃x, x ∈ g) := ⟨univ, univ_sets g⟩,
    simpa using and.intro h₁ h₂
  end,
  sets_of_superset := λx y hx hxy,
  begin
   rcases hx with ⟨t₁, ht₁, t₂, ht₂, t₁t₂⟩,
   exact ⟨t₁, ht₁, t₂, ht₂, subset.trans t₁t₂ hxy⟩
  end,
  inter_sets       := λx y,
  begin
    simp only [exists_prop, mem_set_of_eq, subset_inter_iff],
    rintros ⟨s₁, s₂, hs₁, hs₂, s₁s₂⟩ ⟨t₁, t₂, ht₁, ht₂, t₁t₂⟩,
    exact ⟨s₁ ∩ t₁, s₂ ∩ t₂, inter_sets f hs₁ ht₁, inter_sets g hs₂ ht₂,
    subset.trans (mul_subset_mul (inter_subset_left _ _) (inter_subset_left _ _)) s₁s₂,
    subset.trans (mul_subset_mul (inter_subset_right _ _) (inter_subset_right _ _)) t₁t₂⟩,
  end }⟩

@[to_additive]
lemma mem_mul [monoid α] {f g : filter α} {s : set α} :
  s ∈ f * g ↔ ∃t₁ t₂, t₁ ∈ f ∧ t₂ ∈ g ∧ t₁ * t₂  ⊆ s := iff.rfl

@[to_additive]
lemma mul_mem_mul [monoid α] {f g : filter α} {s t : set α} (hs : s ∈ f) (ht : t ∈ g) :
  s * t ∈ f * g := ⟨_, _, hs, ht, subset.refl _⟩

@[to_additive]
protected lemma mul_le_mul [monoid α] {f₁ f₂ g₁ g₂ : filter α} (hf : f₁ ≤ f₂) (hg : g₁ ≤ g₂) :
  f₁ * g₁ ≤ f₂ * g₂ := assume _ ⟨s, t, hs, ht, hst⟩, ⟨s, t, hf hs, hg ht, hst⟩

@[to_additive]
lemma ne_bot.mul [monoid α] {f g : filter α} : ne_bot f → ne_bot g → ne_bot (f * g) :=
begin
  simp only [forall_sets_nonempty_iff_ne_bot.symm],
  rintros hf hg s ⟨a, b, ha, hb, ab⟩,
  exact ((hf a ha).mul (hg b hb)).mono ab
end

@[to_additive]
protected lemma mul_assoc [monoid α] (f g h : filter α) : f * g * h = f * (g * h) :=
begin
  ext s, split,
  { rintros ⟨a, b, ⟨a₁, a₂, ha₁, ha₂, a₁a₂⟩, hb, ab⟩,
    refine ⟨a₁, a₂ * b, ha₁, mul_mem_mul ha₂ hb, _⟩, rw [← mul_assoc],
    exact calc
      a₁ * a₂ * b ⊆ a * b : mul_subset_mul a₁a₂ (subset.refl _)
      ...         ⊆ s     : ab },
  { rintros ⟨a, b, ha, ⟨b₁, b₂, hb₁, hb₂, b₁b₂⟩, ab⟩,
    refine ⟨a * b₁, b₂, mul_mem_mul ha hb₁, hb₂, _⟩, rw [mul_assoc],
    exact calc
      a * (b₁ * b₂) ⊆ a * b : mul_subset_mul (subset.refl _) b₁b₂
      ...           ⊆ s     : ab }
end

@[to_additive]
protected lemma one_mul [monoid α] (f : filter α) : 1 * f = f :=
begin
  ext s, split,
  { rintros ⟨t₁, t₂, ht₁, ht₂, t₁t₂⟩,
    refine mem_sets_of_superset (mem_sets_of_superset ht₂ _) t₁t₂,
    assume x hx,
    exact ⟨1, x, by rwa [← mem_one], hx, one_mul _⟩ },
  { assume hs, refine ⟨(1:set α), s, mem_principal_self _, hs, by simp only [one_mul]⟩ }
end

@[to_additive]
protected lemma mul_one [monoid α] (f : filter α) : f * 1 = f :=
begin
  ext s, split,
  { rintros ⟨t₁, t₂, ht₁, ht₂, t₁t₂⟩,
    refine mem_sets_of_superset (mem_sets_of_superset ht₁ _) t₁t₂,
    assume x hx,
    exact ⟨x, 1, hx, by rwa [← mem_one], mul_one _⟩ },
  { assume hs,
    refine ⟨s, (1:set α), hs, mem_principal_self _, by simp only [mul_one]⟩ }
end

@[to_additive filter.add_monoid]
instance [monoid α] : monoid (filter α) :=
{ mul_assoc := filter.mul_assoc,
  one_mul := filter.one_mul,
  mul_one := filter.mul_one,
  .. filter.has_mul,
  .. filter.has_one }

section map
open is_mul_hom

variables [monoid α] [monoid β] {f : filter α} (m : α → β)

@[to_additive]
protected lemma map_mul [is_mul_hom m] {f₁ f₂ : filter α} : map m (f₁ * f₂) = map m f₁ * map m f₂ :=
begin
  ext s,
  simp only [mem_mul], split,
  { rintro ⟨t₁, t₂, ht₁, ht₂, t₁t₂⟩,
    have : m '' (t₁ * t₂) ⊆ s := subset.trans (image_subset m t₁t₂) (image_preimage_subset _ _),
    refine ⟨m '' t₁, m '' t₂, image_mem_map ht₁, image_mem_map ht₂, _⟩,
    rwa ← image_mul m },
  { rintro ⟨t₁, t₂, ht₁, ht₂, t₁t₂⟩,
    refine ⟨m ⁻¹' t₁, m ⁻¹' t₂, ht₁, ht₂, image_subset_iff.1 _⟩,
    rw image_mul m,
    exact subset.trans
      (mul_subset_mul (image_preimage_subset _ _) (image_preimage_subset _ _)) t₁t₂ },
end

@[to_additive]
protected lemma map_one [is_monoid_hom m] : map m (1:filter α) = 1 :=
le_antisymm
  (le_principal_iff.2 $ mem_map_sets_iff.2 ⟨(1:set α), by simp,
    by { assume x, simp [is_monoid_hom.map_one m] }⟩)
  (le_map $ assume s hs,
   begin
     simp only [mem_one],
     exact ⟨(1:α), (mem_one s).1 hs, is_monoid_hom.map_one _⟩
   end)

-- TODO: prove similar statements when `m` is group homomorphism etc.
@[to_additive map.is_add_monoid_hom]
lemma map.is_monoid_hom [is_monoid_hom m] : is_monoid_hom (map m) :=
{ map_one := filter.map_one m,
  map_mul := λ _ _, filter.map_mul m }

-- The other direction does not hold in general.
@[to_additive]
lemma comap_mul_comap_le [is_mul_hom m] {f₁ f₂ : filter β} :
  comap m f₁ * comap m f₂ ≤ comap m (f₁ * f₂) :=
begin
  rintros s ⟨t, ⟨t₁, t₂, ht₁, ht₂, t₁t₂⟩, mt⟩,
  refine ⟨m ⁻¹' t₁, m ⁻¹' t₂, ⟨t₁, ht₁, subset.refl _⟩, ⟨t₂, ht₂, subset.refl _⟩, _⟩,
  have := subset.trans (preimage_mono t₁t₂) mt,
  exact subset.trans (preimage_mul_preimage_subset m) this
end

variables {m}

@[to_additive]
lemma tendsto.mul_mul [is_mul_hom m] {f₁ g₁ : filter α} {f₂ g₂ : filter β} :
  tendsto m f₁ f₂ → tendsto m g₁ g₂ → tendsto m (f₁ * g₁) (f₂ * g₂) :=
assume hf hg, by { rw [tendsto, filter.map_mul m], exact filter.mul_le_mul hf hg }

end map

end filter


import category_theory.category.default

universes v u  -- The order in this declaration matters: v often needs to be explicitly specified while u often can be omitted

namespace category_theory

variables (C : Type u) [category.{v} C]

/-
# Category world

## Level 1: Definition of category

A category `C` consists of
  * a collection of objects `X, Y, Z, ...`
  * a collection of morphisms `f, g, h, ...`
so that:
  * each morphism has specified domain and codomain objects;
    `f : X ⟶ Y` signifies that `f` is a morphism with
    domain `X` and codomain `Y`
  * each object has a designated identity morphism `𝟙 X : X ⟶ X`
  * for any pair of morphisms `f, g` with the codomain of `f` equal
    to the domain of `g`,the exists a specified composite morphism
    `f ≫ g` whose domain is that of `f` and codomain that of `g`,
    i.e. `f : X ⟶ Y, g : Y ⟶ Z` then `f ≫ g : X ⟶ Z`
This data is subject to the following axioms:
  * For any `f : X ⟶ Y`,
  -/
  /- Axiom :
    f ≫ 𝟙 Y = f-/
  /- Axiom:
    𝟙 X ≫ f = f-/

  /-* For any composable triple of morphisms `f, g, h`, we have associativity
  `f ≫ (g ≫ h) = (f ≫ g) ≫ h`-/
  /- Axiom:
    f ≫ (g ≫ h) = (f ≫ g) ≫ h-/

/-First we start out with some easy lemmas to get us warmed up.-/

/- Lemma
If $$f : X ⟶ Y$$ and $$g : X ⟶ Y$$ are morphisms such that $$f = g$$, then $$f ≫ h = g ≫ h$$.
-/
lemma eq_precomp_eq {X Y Z : C} {f g : X ⟶ Y} (w : f = g) (h : Y ⟶ Z) : f ≫ h = g ≫ h :=
begin
  rw w,
end

end category_theory


def f (x y : Nat) :=
  match x with
  | 0   => y + 1
  | n+1 => y + 1

private theorem matchEq (x y : Nat) :
  (match x with
   | 0   => y + 1
   | n+1 => y + 1) = y + 1 := by
  cases x <;> simp

theorem fex1 : f x y = y + 1 := by
  simp [f, matchEq]

theorem fex2 : f x y = y + 1 := by
  simp [f]
  rw [matchEq]


/-
Copyright (c) 2021 Frédéric Dupuis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Frédéric Dupuis, Heather Macbeth
-/

import analysis.inner_product_space.dual
import analysis.inner_product_space.pi_L2

/-!
# Adjoint of operators on Hilbert spaces

Given an operator `A : E →L[𝕜] F`, where `E` and `F` are Hilbert spaces, its adjoint
`adjoint A : F →L[𝕜] E` is the unique operator such that `⟪x, A y⟫ = ⟪adjoint A x, y⟫` for all
`x` and `y`.

We then use this to put a C⋆-algebra structure on `E →L[𝕜] E` with the adjoint as the star
operation.

This construction is used to define an adjoint for linear maps (i.e. not continuous) between
finite dimensional spaces.

## Main definitions

* `continuous_linear_map.adjoint : (E →L[𝕜] F) ≃ₗᵢ⋆[𝕜] (F →L[𝕜] E)`: the adjoint of a continuous
  linear map, bundled as a conjugate-linear isometric equivalence.
* `linear_map.adjoint : (E →ₗ[𝕜] F) ≃ₗ⋆[𝕜] (F →ₗ[𝕜] E)`: the adjoint of a linear map between
  finite-dimensional spaces, this time only as a conjugate-linear equivalence, since there is no
  norm defined on these maps.

## Implementation notes

* The continuous conjugate-linear version `adjoint_aux` is only an intermediate
  definition and is not meant to be used outside this file.

## Tags

adjoint

-/

noncomputable theory
open is_R_or_C
open_locale complex_conjugate

variables {𝕜 E F G : Type*} [is_R_or_C 𝕜]
variables [normed_add_comm_group E] [normed_add_comm_group F] [normed_add_comm_group G]
variables [inner_product_space 𝕜 E] [inner_product_space 𝕜 F] [inner_product_space 𝕜 G]
local notation `⟪`x`, `y`⟫` := @inner 𝕜 _ _ x y

/-! ### Adjoint operator -/

open inner_product_space

namespace continuous_linear_map

variables [complete_space E] [complete_space G]

/-- The adjoint, as a continuous conjugate-linear map.  This is only meant as an auxiliary
definition for the main definition `adjoint`, where this is bundled as a conjugate-linear isometric
equivalence. -/
def adjoint_aux : (E →L[𝕜] F) →L⋆[𝕜] (F →L[𝕜] E) :=
(continuous_linear_map.compSL _ _ _ _ _ ((to_dual 𝕜 E).symm : normed_space.dual 𝕜 E →L⋆[𝕜] E)).comp
  (to_sesq_form : (E →L[𝕜] F) →L[𝕜] F →L⋆[𝕜] normed_space.dual 𝕜 E)

@[simp] lemma adjoint_aux_apply (A : E →L[𝕜] F) (x : F) :
  adjoint_aux A x = ((to_dual 𝕜 E).symm : (normed_space.dual 𝕜 E) → E) ((to_sesq_form A) x) := rfl

lemma adjoint_aux_inner_left (A : E →L[𝕜] F) (x : E) (y : F) : ⟪adjoint_aux A y, x⟫ = ⟪y, A x⟫ :=
by { simp only [adjoint_aux_apply, to_dual_symm_apply, to_sesq_form_apply_coe, coe_comp',
                innerSL_apply_coe]}

lemma adjoint_aux_inner_right (A : E →L[𝕜] F) (x : E) (y : F) : ⟪x, adjoint_aux A y⟫ = ⟪A x, y⟫ :=
by rw [←inner_conj_symm, adjoint_aux_inner_left, inner_conj_symm]

variables [complete_space F]

lemma adjoint_aux_adjoint_aux (A : E →L[𝕜] F) : adjoint_aux (adjoint_aux A) = A :=
begin
  ext v,
  refine ext_inner_left 𝕜 (λ w, _),
  rw [adjoint_aux_inner_right, adjoint_aux_inner_left],
end

@[simp] lemma adjoint_aux_norm (A : E →L[𝕜] F) : ‖adjoint_aux A‖ = ‖A‖ :=
begin
  refine le_antisymm _ _,
  { refine continuous_linear_map.op_norm_le_bound _ (norm_nonneg _) (λ x, _),
    rw [adjoint_aux_apply, linear_isometry_equiv.norm_map],
    exact to_sesq_form_apply_norm_le },
  { nth_rewrite_lhs 0 [←adjoint_aux_adjoint_aux A],
    refine continuous_linear_map.op_norm_le_bound _ (norm_nonneg _) (λ x, _),
    rw [adjoint_aux_apply, linear_isometry_equiv.norm_map],
    exact to_sesq_form_apply_norm_le }
end

/-- The adjoint of a bounded operator from Hilbert space E to Hilbert space F. -/
def adjoint : (E →L[𝕜] F) ≃ₗᵢ⋆[𝕜] (F →L[𝕜] E) :=
linear_isometry_equiv.of_surjective
{ norm_map' := adjoint_aux_norm,
  ..adjoint_aux }
(λ A, ⟨adjoint_aux A, adjoint_aux_adjoint_aux A⟩)

localized "postfix (name := adjoint) `†`:1000 := continuous_linear_map.adjoint" in inner_product

/-- The fundamental property of the adjoint. -/
lemma adjoint_inner_left (A : E →L[𝕜] F) (x : E) (y : F) : ⟪A† y, x⟫ = ⟪y, A x⟫ :=
adjoint_aux_inner_left A x y

/-- The fundamental property of the adjoint. -/
lemma adjoint_inner_right (A : E →L[𝕜] F) (x : E) (y : F) : ⟪x, A† y⟫ = ⟪A x, y⟫ :=
adjoint_aux_inner_right A x y

/-- The adjoint is involutive -/
@[simp] lemma adjoint_adjoint (A : E →L[𝕜] F) : A†† = A :=
adjoint_aux_adjoint_aux A

/-- The adjoint of the composition of two operators is the composition of the two adjoints
in reverse order. -/
@[simp] lemma adjoint_comp (A : F →L[𝕜] G) (B : E →L[𝕜] F) : (A ∘L B)† = B† ∘L A† :=
begin
  ext v,
  refine ext_inner_left 𝕜 (λ w, _),
  simp only [adjoint_inner_right, continuous_linear_map.coe_comp', function.comp_app],
end

lemma apply_norm_sq_eq_inner_adjoint_left (A : E →L[𝕜] E) (x : E) : ‖A x‖^2 = re ⟪(A† * A) x, x⟫ :=
have h : ⟪(A† * A) x, x⟫ = ⟪A x, A x⟫ := by { rw [←adjoint_inner_left], refl },
by rw [h, ←inner_self_eq_norm_sq _]

lemma apply_norm_eq_sqrt_inner_adjoint_left (A : E →L[𝕜] E) (x : E) :
  ‖A x‖ = real.sqrt (re ⟪(A† * A) x, x⟫) :=
by rw [←apply_norm_sq_eq_inner_adjoint_left, real.sqrt_sq (norm_nonneg _)]

lemma apply_norm_sq_eq_inner_adjoint_right (A : E →L[𝕜] E) (x : E) : ‖A x‖^2 = re ⟪x, (A† * A) x⟫ :=
have h : ⟪x, (A† * A) x⟫ = ⟪A x, A x⟫ := by { rw [←adjoint_inner_right], refl },
by rw [h, ←inner_self_eq_norm_sq _]

lemma apply_norm_eq_sqrt_inner_adjoint_right (A : E →L[𝕜] E) (x : E) :
  ‖A x‖ = real.sqrt (re ⟪x, (A† * A) x⟫) :=
by rw [←apply_norm_sq_eq_inner_adjoint_right, real.sqrt_sq (norm_nonneg _)]

/-- The adjoint is unique: a map `A` is the adjoint of `B` iff it satisfies `⟪A x, y⟫ = ⟪x, B y⟫`
for all `x` and `y`. -/
lemma eq_adjoint_iff (A : E →L[𝕜] F) (B : F →L[𝕜] E) :
  A = B† ↔ (∀ x y, ⟪A x, y⟫ = ⟪x, B y⟫) :=
begin
  refine ⟨λ h x y, by rw [h, adjoint_inner_left], λ h, _⟩,
  ext x,
  exact ext_inner_right 𝕜 (λ y, by simp only [adjoint_inner_left, h x y])
end

@[simp] lemma adjoint_id : (continuous_linear_map.id 𝕜 E).adjoint = continuous_linear_map.id 𝕜 E :=
begin
  refine eq.symm _,
  rw eq_adjoint_iff,
  simp,
end

lemma _root_.submodule.adjoint_subtypeL (U : submodule 𝕜 E)
  [complete_space U] :
  (U.subtypeL)† = orthogonal_projection U :=
begin
  symmetry,
  rw eq_adjoint_iff,
  intros x u,
  rw [U.coe_inner, inner_orthogonal_projection_left_eq_right,
      orthogonal_projection_mem_subspace_eq_self],
  refl
end

lemma _root_.submodule.adjoint_orthogonal_projection (U : submodule 𝕜 E)
  [complete_space U] :
  (orthogonal_projection U : E →L[𝕜] U)† = U.subtypeL :=
by rw [← U.adjoint_subtypeL, adjoint_adjoint]

/-- `E →L[𝕜] E` is a star algebra with the adjoint as the star operation. -/
instance : has_star (E →L[𝕜] E) := ⟨adjoint⟩
instance : has_involutive_star (E →L[𝕜] E) := ⟨adjoint_adjoint⟩
instance : star_semigroup (E →L[𝕜] E) := ⟨adjoint_comp⟩
instance : star_ring (E →L[𝕜] E) := ⟨linear_isometry_equiv.map_add adjoint⟩
instance : star_module 𝕜 (E →L[𝕜] E) := ⟨linear_isometry_equiv.map_smulₛₗ adjoint⟩

lemma star_eq_adjoint (A : E →L[𝕜] E) : star A = A† := rfl

/-- A continuous linear operator is self-adjoint iff it is equal to its adjoint. -/
lemma is_self_adjoint_iff' {A : E →L[𝕜] E} : is_self_adjoint A ↔ A.adjoint = A := iff.rfl

instance : cstar_ring (E →L[𝕜] E) :=
⟨begin
  intros A,
  rw [star_eq_adjoint],
  refine le_antisymm _ _,
  { calc ‖A† * A‖ ≤ ‖A†‖ * ‖A‖      : op_norm_comp_le _ _
              ... = ‖A‖ * ‖A‖       : by rw [linear_isometry_equiv.norm_map] },
  { rw [←sq, ←real.sqrt_le_sqrt_iff (norm_nonneg _), real.sqrt_sq (norm_nonneg _)],
    refine op_norm_le_bound _ (real.sqrt_nonneg _) (λ x, _),
    have := calc
      re ⟪(A† * A) x, x⟫ ≤ ‖(A† * A) x‖ * ‖x‖     : re_inner_le_norm _ _
                    ...  ≤ ‖A† * A‖ * ‖x‖ * ‖x‖   : mul_le_mul_of_nonneg_right
                                                    (le_op_norm _ _) (norm_nonneg _),
    calc ‖A x‖ = real.sqrt (re ⟪(A† * A) x, x⟫)     : by rw [apply_norm_eq_sqrt_inner_adjoint_left]
          ...  ≤ real.sqrt (‖A† * A‖ * ‖x‖ * ‖x‖)   : real.sqrt_le_sqrt this
          ...  = real.sqrt (‖A† * A‖) * ‖x‖
            : by rw [mul_assoc, real.sqrt_mul (norm_nonneg _), real.sqrt_mul_self (norm_nonneg _)] }
end⟩

section real

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

-- Todo: Generalize this to `is_R_or_C`.
lemma is_adjoint_pair_inner (A : E' →L[ℝ] F') :
  linear_map.is_adjoint_pair (sesq_form_of_inner : E' →ₗ[ℝ] E' →ₗ[ℝ] ℝ)
  (sesq_form_of_inner : F' →ₗ[ℝ] F' →ₗ[ℝ] ℝ) A (A†) :=
λ x y, by simp only [sesq_form_of_inner_apply_apply, adjoint_inner_left, to_linear_map_eq_coe,
  coe_coe]

end real

end continuous_linear_map

/-! ### Self-adjoint operators -/

namespace is_self_adjoint

open continuous_linear_map

variables [complete_space E] [complete_space F]

lemma adjoint_eq {A : E →L[𝕜] E} (hA : is_self_adjoint A) : A.adjoint = A := hA

/-- Every self-adjoint operator on an inner product space is symmetric. -/
lemma is_symmetric {A : E →L[𝕜] E} (hA : is_self_adjoint A) :
  (A : E →ₗ[𝕜] E).is_symmetric :=
λ x y, by rw_mod_cast [←A.adjoint_inner_right, hA.adjoint_eq]

/-- Conjugating preserves self-adjointness -/
lemma conj_adjoint {T : E →L[𝕜] E} (hT : is_self_adjoint T) (S : E →L[𝕜] F) :
  is_self_adjoint (S ∘L T ∘L S.adjoint) :=
begin
  rw is_self_adjoint_iff' at ⊢ hT,
  simp only [hT, adjoint_comp, adjoint_adjoint],
  exact continuous_linear_map.comp_assoc _ _ _,
end

/-- Conjugating preserves self-adjointness -/
lemma adjoint_conj {T : E →L[𝕜] E} (hT : is_self_adjoint T) (S : F →L[𝕜] E) :
  is_self_adjoint (S.adjoint ∘L T ∘L S) :=
begin
  rw is_self_adjoint_iff' at ⊢ hT,
  simp only [hT, adjoint_comp, adjoint_adjoint],
  exact continuous_linear_map.comp_assoc _ _ _,
end

lemma _root_.continuous_linear_map.is_self_adjoint_iff_is_symmetric {A : E →L[𝕜] E} :
  is_self_adjoint A ↔ (A : E →ₗ[𝕜] E).is_symmetric :=
⟨λ hA, hA.is_symmetric, λ hA, ext $ λ x, ext_inner_right 𝕜 $
  λ y, (A.adjoint_inner_left y x).symm ▸ (hA x y).symm⟩

lemma _root_.linear_map.is_symmetric.is_self_adjoint {A : E →L[𝕜] E}
  (hA : (A : E →ₗ[𝕜] E).is_symmetric) : is_self_adjoint A :=
by rwa ←continuous_linear_map.is_self_adjoint_iff_is_symmetric at hA

/-- The orthogonal projection is self-adjoint. -/
lemma _root_.orthogonal_projection_is_self_adjoint (U : submodule 𝕜 E)
  [complete_space U] :
  is_self_adjoint (U.subtypeL ∘L orthogonal_projection U) :=
(orthogonal_projection_is_symmetric U).is_self_adjoint

lemma conj_orthogonal_projection {T : E →L[𝕜] E}
  (hT : is_self_adjoint T) (U : submodule 𝕜 E) [complete_space U] :
  is_self_adjoint (U.subtypeL ∘L orthogonal_projection U ∘L T ∘L U.subtypeL ∘L
    orthogonal_projection U) :=
begin
  rw ←continuous_linear_map.comp_assoc,
  nth_rewrite 0 ←(orthogonal_projection_is_self_adjoint U).adjoint_eq,
  refine hT.adjoint_conj _,
end

end is_self_adjoint

namespace linear_map

variables [complete_space E]
variables {T : E →ₗ[𝕜] E}

/-- The **Hellinger--Toeplitz theorem**: Construct a self-adjoint operator from an everywhere
  defined symmetric operator.-/
def is_symmetric.to_self_adjoint (hT : is_symmetric T) : self_adjoint (E →L[𝕜] E) :=
⟨⟨T, hT.continuous⟩, continuous_linear_map.is_self_adjoint_iff_is_symmetric.mpr hT⟩

lemma is_symmetric.coe_to_self_adjoint (hT : is_symmetric T) :
  (hT.to_self_adjoint : E →ₗ[𝕜] E) = T := rfl

lemma is_symmetric.to_self_adjoint_apply (hT : is_symmetric T) {x : E} :
  hT.to_self_adjoint x = T x := rfl

end linear_map

namespace linear_map

variables [finite_dimensional 𝕜 E] [finite_dimensional 𝕜 F] [finite_dimensional 𝕜 G]
local attribute [instance, priority 20] finite_dimensional.complete

/-- The adjoint of an operator from the finite-dimensional inner product space E to the finite-
dimensional inner product space F. -/
def adjoint : (E →ₗ[𝕜] F) ≃ₗ⋆[𝕜] (F →ₗ[𝕜] E) :=
((linear_map.to_continuous_linear_map : (E →ₗ[𝕜] F) ≃ₗ[𝕜] (E →L[𝕜] F)).trans
  continuous_linear_map.adjoint.to_linear_equiv).trans
  linear_map.to_continuous_linear_map.symm

lemma adjoint_to_continuous_linear_map (A : E →ₗ[𝕜] F) :
  A.adjoint.to_continuous_linear_map = A.to_continuous_linear_map.adjoint := rfl

lemma adjoint_eq_to_clm_adjoint (A : E →ₗ[𝕜] F) :
  A.adjoint = A.to_continuous_linear_map.adjoint := rfl

/-- The fundamental property of the adjoint. -/
lemma adjoint_inner_left (A : E →ₗ[𝕜] F) (x : E) (y : F) : ⟪adjoint A y, x⟫ = ⟪y, A x⟫ :=
begin
  rw [←coe_to_continuous_linear_map A, adjoint_eq_to_clm_adjoint],
  exact continuous_linear_map.adjoint_inner_left _ x y,
end

/-- The fundamental property of the adjoint. -/
lemma adjoint_inner_right (A : E →ₗ[𝕜] F) (x : E) (y : F) : ⟪x, adjoint A y⟫ = ⟪A x, y⟫ :=
begin
  rw [←coe_to_continuous_linear_map A, adjoint_eq_to_clm_adjoint],
  exact continuous_linear_map.adjoint_inner_right _ x y,
end

/-- The adjoint is involutive -/
@[simp] lemma adjoint_adjoint (A : E →ₗ[𝕜] F) : A.adjoint.adjoint = A :=
begin
  ext v,
  refine ext_inner_left 𝕜 (λ w, _),
  rw [adjoint_inner_right, adjoint_inner_left],
end

/-- The adjoint of the composition of two operators is the composition of the two adjoints
in reverse order. -/
@[simp] lemma adjoint_comp (A : F →ₗ[𝕜] G) (B : E →ₗ[𝕜] F) :
  (A ∘ₗ B).adjoint = B.adjoint ∘ₗ A.adjoint :=
begin
  ext v,
  refine ext_inner_left 𝕜 (λ w, _),
  simp only [adjoint_inner_right, linear_map.coe_comp, function.comp_app],
end

/-- The adjoint is unique: a map `A` is the adjoint of `B` iff it satisfies `⟪A x, y⟫ = ⟪x, B y⟫`
for all `x` and `y`. -/
lemma eq_adjoint_iff (A : E →ₗ[𝕜] F) (B : F →ₗ[𝕜] E) :
  A = B.adjoint ↔ (∀ x y, ⟪A x, y⟫ = ⟪x, B y⟫) :=
begin
  refine ⟨λ h x y, by rw [h, adjoint_inner_left], λ h, _⟩,
  ext x,
  exact ext_inner_right 𝕜 (λ y, by simp only [adjoint_inner_left, h x y])
end

/-- The adjoint is unique: a map `A` is the adjoint of `B` iff it satisfies `⟪A x, y⟫ = ⟪x, B y⟫`
for all basis vectors `x` and `y`. -/
lemma eq_adjoint_iff_basis {ι₁ : Type*} {ι₂ : Type*} (b₁ : basis ι₁ 𝕜 E) (b₂ : basis ι₂ 𝕜 F)
  (A : E →ₗ[𝕜] F) (B : F →ₗ[𝕜] E) :
  A = B.adjoint ↔ (∀ (i₁ : ι₁) (i₂ : ι₂), ⟪A (b₁ i₁), b₂ i₂⟫ = ⟪b₁ i₁, B (b₂ i₂)⟫) :=
begin
  refine ⟨λ h x y, by rw [h, adjoint_inner_left], λ h, _⟩,
  refine basis.ext b₁ (λ i₁, _),
  exact ext_inner_right_basis b₂ (λ i₂, by simp only [adjoint_inner_left, h i₁ i₂]),
end

lemma eq_adjoint_iff_basis_left {ι : Type*} (b : basis ι 𝕜 E) (A : E →ₗ[𝕜] F) (B : F →ₗ[𝕜] E) :
  A = B.adjoint ↔ (∀ i y, ⟪A (b i), y⟫ = ⟪b i, B y⟫) :=
begin
  refine ⟨λ h x y, by rw [h, adjoint_inner_left], λ h, basis.ext b (λ i, _)⟩,
  exact ext_inner_right 𝕜 (λ y, by simp only [h i, adjoint_inner_left]),
end

lemma eq_adjoint_iff_basis_right {ι : Type*} (b : basis ι 𝕜 F) (A : E →ₗ[𝕜] F) (B : F →ₗ[𝕜] E) :
  A = B.adjoint ↔ (∀ i x, ⟪A x, b i⟫ = ⟪x, B (b i)⟫) :=
begin
  refine ⟨λ h x y, by rw [h, adjoint_inner_left], λ h, _⟩,
  ext x,
  refine ext_inner_right_basis b (λ i, by simp only [h i, adjoint_inner_left]),
end

/-- `E →ₗ[𝕜] E` is a star algebra with the adjoint as the star operation. -/
instance : has_star (E →ₗ[𝕜] E) := ⟨adjoint⟩
instance : has_involutive_star (E →ₗ[𝕜] E) := ⟨adjoint_adjoint⟩
instance : star_semigroup (E →ₗ[𝕜] E) := ⟨adjoint_comp⟩
instance : star_ring (E →ₗ[𝕜] E) := ⟨linear_equiv.map_add adjoint⟩
instance : star_module 𝕜 (E →ₗ[𝕜] E) := ⟨linear_equiv.map_smulₛₗ adjoint⟩

lemma star_eq_adjoint (A : E →ₗ[𝕜] E) : star A = A.adjoint := rfl

/-- A continuous linear operator is self-adjoint iff it is equal to its adjoint. -/
lemma is_self_adjoint_iff' {A : E →ₗ[𝕜] E} : is_self_adjoint A ↔ A.adjoint = A := iff.rfl

lemma is_symmetric_iff_is_self_adjoint (A : E →ₗ[𝕜] E) :
  is_symmetric A ↔ is_self_adjoint A :=
by { rw [is_self_adjoint_iff', is_symmetric, ← linear_map.eq_adjoint_iff], exact eq_comm }

section real

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

-- Todo: Generalize this to `is_R_or_C`.
lemma is_adjoint_pair_inner (A : E' →ₗ[ℝ] F') :
  is_adjoint_pair (sesq_form_of_inner : E' →ₗ[ℝ] E' →ₗ[ℝ] ℝ)
  (sesq_form_of_inner : F' →ₗ[ℝ] F' →ₗ[ℝ] ℝ) A A.adjoint :=
λ x y, by simp only [sesq_form_of_inner_apply_apply, adjoint_inner_left]

end real

/-- The Gram operator T†T is symmetric. -/
lemma is_symmetric_adjoint_mul_self (T : E →ₗ[𝕜] E) : is_symmetric (T.adjoint * T) :=
λ x y, by simp only [mul_apply, adjoint_inner_left, adjoint_inner_right]

/-- The Gram operator T†T is a positive operator. -/
lemma re_inner_adjoint_mul_self_nonneg (T : E →ₗ[𝕜] E) (x : E) :
  0 ≤ re ⟪ x, (T.adjoint * T) x ⟫ := by {simp only [mul_apply, adjoint_inner_right,
    inner_self_eq_norm_sq_to_K], norm_cast, exact sq_nonneg _}

@[simp] lemma im_inner_adjoint_mul_self_eq_zero (T : E →ₗ[𝕜] E) (x : E) :
  im ⟪ x, linear_map.adjoint T (T x) ⟫ = 0 := by {simp only [mul_apply,
    adjoint_inner_right, inner_self_eq_norm_sq_to_K], norm_cast}

end linear_map

namespace matrix
variables {m n : Type*} [fintype m] [decidable_eq m] [fintype n] [decidable_eq n]
open_locale complex_conjugate

/-- The adjoint of the linear map associated to a matrix is the linear map associated to the
conjugate transpose of that matrix. -/
lemma to_euclidean_lin_conj_transpose_eq_adjoint (A : matrix m n 𝕜) :
  A.conj_transpose.to_euclidean_lin = A.to_euclidean_lin.adjoint :=
begin
  rw linear_map.eq_adjoint_iff,
  intros x y,
  simp_rw [euclidean_space.inner_eq_star_dot_product, pi_Lp_equiv_to_euclidean_lin,
    to_lin'_apply, star_mul_vec, conj_transpose_conj_transpose, dot_product_mul_vec],
end

end matrix


variables A B C : Prop

premise P : A ->B

example : ((C/\A) -> (B/\C)) :=
assume H1: (C/\A),
have H2: C, from and.left H1,
have H3: A, from and.right H1,
have H4: B, from P H3,
show B/\C, from and.intro H4 H2.


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.monoid_algebra.basic
import algebra.char_p.invertible
import linear_algebra.basis

/-!
# Maschke's theorem

We prove **Maschke's theorem** for finite groups,
in the formulation that every submodule of a `k[G]` module has a complement,
when `k` is a field with `invertible (fintype.card G : k)`.

We do the core computation in greater generality.
For any `[comm_ring k]` in which  `[invertible (fintype.card G : k)]`,
and a `k[G]`-linear map `i : V → W` which admits a `k`-linear retraction `π`,
we produce a `k[G]`-linear retraction by
taking the average over `G` of the conjugates of `π`.

## Implementation Notes
* These results assume `invertible (fintype.card G : k)` which is equivalent to the more
familiar `¬(ring_char k ∣ fintype.card G)`. It is possible to convert between them using
`invertible_of_ring_char_not_dvd` and `not_ring_char_dvd_of_invertible`.

## Future work
It's not so far to give the usual statement, that every finite dimensional representation
of a finite group is semisimple (i.e. a direct sum of irreducibles).
-/

universes u

noncomputable theory
open module
open monoid_algebra
open_locale big_operators

section

-- At first we work with any `[comm_ring k]`, and add the assumption that
-- `[invertible (fintype.card G : k)]` when it is required.
variables {k : Type u} [comm_ring k] {G : Type u} [group G]

variables {V : Type u} [add_comm_group V] [module k V] [module (monoid_algebra k G) V]
variables [is_scalar_tower k (monoid_algebra k G) V]
variables {W : Type u} [add_comm_group W] [module k W] [module (monoid_algebra k G) W]
variables [is_scalar_tower k (monoid_algebra k G) W]

/-!
We now do the key calculation in Maschke's theorem.

Given `V → W`, an inclusion of `k[G]` modules,,
assume we have some retraction `π` (i.e. `∀ v, π (i v) = v`),
just as a `k`-linear map.
(When `k` is a field, this will be available cheaply, by choosing a basis.)

We now construct a retraction of the inclusion as a `k[G]`-linear map,
by the formula
$$ \frac{1}{|G|} \sum_{g \in G} g⁻¹ • π(g • -). $$
-/

namespace linear_map

variables (π : W →ₗ[k] V)
include π

/--
We define the conjugate of `π` by `g`, as a `k`-linear map.
-/
def conjugate (g : G) : W →ₗ[k] V :=
((group_smul.linear_map k V g⁻¹).comp π).comp (group_smul.linear_map k W g)

variables (i : V →ₗ[monoid_algebra k G] W) (h : ∀ v : V, π (i v) = v)

section
include h

lemma conjugate_i (g : G) (v : V) : (conjugate π g) (i v) = v :=
begin
  dsimp [conjugate],
  simp only [←i.map_smul, h, ←mul_smul, single_mul_single, mul_one, mul_left_inv],
  change (1 : monoid_algebra k G) • v = v,
  simp,
end
end

variables (G) [fintype G]

/--
The sum of the conjugates of `π` by each element `g : G`, as a `k`-linear map.

(We postpone dividing by the size of the group as long as possible.)
-/
def sum_of_conjugates : W →ₗ[k] V :=
∑ g : G, π.conjugate g

/--
In fact, the sum over `g : G` of the conjugate of `π` by `g` is a `k[G]`-linear map.
-/
def sum_of_conjugates_equivariant : W →ₗ[monoid_algebra k G] V :=
monoid_algebra.equivariant_of_linear_of_comm (π.sum_of_conjugates G) (λ g v,
begin
  simp only [sum_of_conjugates, linear_map.sum_apply,
    -- We have a `module (monoid_algebra k G)` instance but are working with `finsupp`s,
    -- so help the elaborator unfold everything correctly.
    @finset.smul_sum (monoid_algebra k G)],
  dsimp [conjugate],
  conv_lhs
  { rw [←finset.univ_map_embedding (mul_right_embedding g⁻¹)],
    simp only [mul_right_embedding], },
  simp only [←mul_smul, single_mul_single, mul_inv_rev, mul_one, function.embedding.coe_fn_mk,
    finset.sum_map, inv_inv, inv_mul_cancel_right]
end)

section
variables [inv : invertible (fintype.card G : k)]
include inv

/--
We construct our `k[G]`-linear retraction of `i` as
$$ \frac{1}{|G|} \sum_{g \in G} g⁻¹ • π(g • -). $$
-/
def equivariant_projection : W →ₗ[monoid_algebra k G] V :=
⅟(fintype.card G : k) • (π.sum_of_conjugates_equivariant G)

include h

lemma equivariant_projection_condition (v : V) : (π.equivariant_projection G) (i v) = v :=
begin
  rw [equivariant_projection, smul_apply, sum_of_conjugates_equivariant,
    equivariant_of_linear_of_comm_apply, sum_of_conjugates],
  rw [linear_map.sum_apply],
  simp only [conjugate_i π i h],
  rw [finset.sum_const, finset.card_univ, nsmul_eq_smul_cast k,
    ←mul_smul, invertible.inv_of_mul_self, one_smul],
end
end
end linear_map
end

namespace char_zero

variables {k : Type u} [field k] {G : Type u} [fintype G] [group G] [char_zero k]

instance : invertible (fintype.card G : k) :=
invertible_of_ring_char_not_dvd (by simp [fintype.card_eq_zero_iff])

end char_zero

namespace monoid_algebra

-- Now we work over a `[field k]`.
variables {k : Type u} [field k] {G : Type u} [fintype G] [invertible (fintype.card G : k)]
variables [group G]
variables {V : Type u} [add_comm_group V] [module k V] [module (monoid_algebra k G) V]
variables [is_scalar_tower k (monoid_algebra k G) V]
variables {W : Type u} [add_comm_group W] [module k W] [module (monoid_algebra k G) W]
variables [is_scalar_tower k (monoid_algebra k G) W]

lemma exists_left_inverse_of_injective
  (f : V →ₗ[monoid_algebra k G] W) (hf : f.ker = ⊥) :
  ∃ (g : W →ₗ[monoid_algebra k G] V), g.comp f = linear_map.id :=
begin
  obtain ⟨φ, hφ⟩ := (f.restrict_scalars k).exists_left_inverse_of_injective
    (by simp only [hf, submodule.restrict_scalars_bot, linear_map.ker_restrict_scalars]),
  refine ⟨φ.equivariant_projection G, _⟩,
  apply linear_map.ext,
  intro v,
  simp only [linear_map.id_coe, id.def, linear_map.comp_apply],
  apply linear_map.equivariant_projection_condition,
  intro v,
  have := congr_arg linear_map.to_fun hφ,
  exact congr_fun this v
end

namespace submodule

lemma exists_is_compl
  (p : submodule (monoid_algebra k G) V) :
  ∃ q : submodule (monoid_algebra k G) V, is_compl p q :=
let ⟨f, hf⟩ := monoid_algebra.exists_left_inverse_of_injective p.subtype p.ker_subtype in
⟨f.ker, linear_map.is_compl_of_proj $ linear_map.ext_iff.1 hf⟩

/-- This also implies an instance `is_semisimple_module (monoid_algebra k G) V`. -/
instance complemented_lattice : complemented_lattice (submodule (monoid_algebra k G) V) :=
⟨exists_is_compl⟩

end submodule
end monoid_algebra


import tactic --hide

-- Level name : Distributive laws 1

/-
This level proves the *distributivity* of `∧` over `∨`.
-/

/-Lemma
If $P,Q,R$ are logical statements then $P ∧ (Q ∨ R)$ is true iff $(P ∧ Q) ∨ (P ∧ R)$ is true.
-/
lemma distributivity_one (P Q R : Prop) : P ∧ (Q ∨ R) ↔ (P ∧ Q) ∨ (P ∧ R) :=
begin
  split,
  intro h,
  cases h with h1 h2,
  cases h2 with h2 h3,
  left,
  split,
  exact h1,
  exact h2,
  right,
  split,
  exact h1,
  exact h3,
  intro h,
  cases h with h1 h2,
  split,
  exact h1.1,
  left,
  exact h1.2,
  split,
  exact h2.1,
  right,
  exact h2.2,
end


/-
Copyright (c) 2019 Patrick Massot All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot, Simon Hudon
-/
import tactic.core
import logic.basic

/-!
# A tactic pushing negations into an expression
-/

open tactic expr

/- Enable the option `trace.push_neg.use_distrib` in order to have `¬ (p ∧ q)` normalized to
`¬ p ∨ ¬ q`, rather than the default `p → ¬ q`. -/
declare_trace push_neg.use_distrib

namespace push_neg
section

universe u
variable  {α : Sort u}
variables (p q : Prop)
variable  (s : α → Prop)

local attribute [instance, priority 10] classical.prop_decidable
theorem not_not_eq : (¬ ¬ p) = p := propext not_not
theorem not_and_eq : (¬ (p ∧ q)) = (p → ¬ q) := propext not_and
theorem not_and_distrib_eq : (¬ (p ∧ q)) = (¬ p ∨ ¬ q) := propext not_and_distrib
theorem not_or_eq : (¬ (p ∨ q)) = (¬ p ∧ ¬ q) := propext not_or_distrib
theorem not_forall_eq : (¬ ∀ x, s x) = (∃ x, ¬ s x) := propext not_forall
theorem not_exists_eq : (¬ ∃ x, s x) = (∀ x, ¬ s x) := propext not_exists
theorem not_implies_eq : (¬ (p → q)) = (p ∧ ¬ q) := propext not_imp

theorem classical.implies_iff_not_or : (p → q) ↔ (¬ p ∨ q) := imp_iff_not_or

theorem not_eq (a b : α) : (¬ a = b) ↔ (a ≠ b) := iff.rfl

variable  {β : Type u}
variable [linear_order β]
theorem not_le_eq (a b : β) : (¬ (a ≤ b)) = (b < a) := propext not_le
theorem not_lt_eq (a b : β) : (¬ (a < b)) = (b ≤ a) := propext not_lt
end

meta def whnf_reducible (e : expr) : tactic expr := whnf e reducible

private meta def transform_negation_step (e : expr) :
  tactic (option (expr × expr)) :=
do e ← whnf_reducible e,
   match e with
   | `(¬ %%ne) :=
      (do ne ← whnf_reducible ne,
      match ne with
      | `(¬ %%a)      := do pr ← mk_app ``not_not_eq [a],
                            return (some (a, pr))
      | `(%%a ∧ %%b)  := do distrib ← get_bool_option `trace.push_neg.use_distrib ff,
                            if distrib then do
                              pr ← mk_app ``not_and_distrib_eq [a, b],
                              return (some (`(¬ (%%a : Prop) ∨ ¬ %%b), pr))
                            else do
                              pr ← mk_app ``not_and_eq [a, b],
                              return (some (`((%%a : Prop) → ¬ %%b), pr))
      | `(%%a ∨ %%b)  := do pr ← mk_app ``not_or_eq [a, b],
                            return (some (`(¬ %%a ∧ ¬ %%b), pr))
      | `(%%a ≤ %%b)  := do e ← to_expr ``(%%b < %%a),
                            pr ← mk_app ``not_le_eq [a, b],
                            return (some (e, pr))
      | `(%%a < %%b)  := do e ← to_expr ``(%%b ≤ %%a),
                            pr ← mk_app ``not_lt_eq [a, b],
                            return (some (e, pr))
      | `(Exists %%p) := do pr ← mk_app ``not_exists_eq [p],
                            e ← match p with
                                | (lam n bi typ bo) := do
                                    body ← mk_app ``not [bo],
                                    return (pi n bi typ body)
                                | _ := tactic.fail "Unexpected failure negating ∃"
                                end,
                            return (some (e, pr))
      | (pi n bi d p) := if p.has_var then do
                            pr ← mk_app ``not_forall_eq [lam n bi d p],
                            body ← mk_app ``not [p],
                            e ←  mk_app ``Exists [lam n bi d body],
                            return (some (e, pr))
                         else do
                            pr ← mk_app ``not_implies_eq [d, p],
                            `(%%_ = %%e') ← infer_type pr,
                            return (some (e', pr))
      | _             := return none
      end)
    | _        := return none
  end

private meta def transform_negation : expr → tactic (option (expr × expr))
| e :=
do (some (e', pr)) ← transform_negation_step e | return none,
   (some (e'', pr')) ← transform_negation e' | return (some (e', pr)),
   pr'' ← mk_eq_trans pr pr',
   return (some (e'', pr''))

meta def normalize_negations (t : expr) : tactic (expr × expr) :=
do (_, e, pr) ← simplify_top_down ()
                   (λ _, λ e, do
                       oepr ← transform_negation e,
                       match oepr with
                       | (some (e', pr)) := return ((), e', pr)
                       | none            := do pr ← mk_eq_refl e, return ((), e, pr)
                       end)
                   t { eta := ff },
   return (e, pr)

meta def push_neg_at_hyp (h : name) : tactic unit :=
do H ← get_local h,
   t ← infer_type H,
   (e, pr) ← normalize_negations t,
   replace_hyp H e pr,
   skip

meta def push_neg_at_goal : tactic unit :=
do H ← target,
   (e, pr) ← normalize_negations H,
   replace_target e pr
end push_neg

open interactive (parse loc.ns loc.wildcard)
open interactive.types (location texpr)
open lean.parser (tk ident many) interactive.loc
local postfix (name := parser.optional) `?`:9001 := optional
local postfix (name := parser.many) *:9001 := many
open push_neg

/--
Push negations in the goal of some assumption.

For instance, a hypothesis `h : ¬ ∀ x, ∃ y, x ≤ y` will be transformed by `push_neg at h` into
`h : ∃ x, ∀ y, y < x`. Variables names are conserved.

This tactic pushes negations inside expressions. For instance, given an assumption
```lean
h : ¬ ∀ ε > 0, ∃ δ > 0, ∀ x, |x - x₀| ≤ δ → |f x - y₀| ≤ ε)
```
writing `push_neg at h` will turn `h` into
```lean
h : ∃ ε, ε > 0 ∧ ∀ δ, δ > 0 → (∃ x, |x - x₀| ≤ δ ∧ ε < |f x - y₀|),
```

(the pretty printer does *not* use the abreviations `∀ δ > 0` and `∃ ε > 0` but this issue
has nothing to do with `push_neg`).
Note that names are conserved by this tactic, contrary to what would happen with `simp`
using the relevant lemmas. One can also use this tactic at the goal using `push_neg`,
at every assumption and the goal using `push_neg at *` or at selected assumptions and the goal
using say `push_neg at h h' ⊢` as usual.
-/
meta def tactic.interactive.push_neg : parse location → tactic unit
| (loc.ns loc_l) :=
  loc_l.mmap'
    (λ l, match l with
          | some h := do push_neg_at_hyp h,
                          try $ interactive.simp_core { eta := ff } failed tt
                                 [simp_arg_type.expr ``(push_neg.not_eq)] []
                                 (interactive.loc.ns [some h])
          | none   := do push_neg_at_goal,
                          try `[simp only [push_neg.not_eq] { eta := ff }]
          end)
| loc.wildcard := do
    push_neg_at_goal,
    local_context >>= mmap' (λ h, push_neg_at_hyp (local_pp_name h)) ,
    try `[simp only [push_neg.not_eq] at * { eta := ff }]

add_tactic_doc
{ name       := "push_neg",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.push_neg],
  tags       := ["logic"] }

lemma imp_of_not_imp_not (P Q : Prop) : (¬ Q → ¬ P) → (P → Q) :=
λ h hP, classical.by_contradiction (λ h', h h' hP)

/-- Matches either an identifier "h" or a pair of identifiers "h with k" -/
meta def name_with_opt : lean.parser (name × option name) :=
prod.mk <$> ident <*> (some <$> (tk "with" *> ident) <|> return none)

/--
Transforms the goal into its contrapositive.

* `contrapose`     turns a goal `P → Q` into `¬ Q → ¬ P`
* `contrapose!`    turns a goal `P → Q` into `¬ Q → ¬ P` and pushes negations inside `P` and `Q`
  using `push_neg`
* `contrapose h`   first reverts the local assumption `h`, and then uses `contrapose` and `intro h`
* `contrapose! h`  first reverts the local assumption `h`, and then uses `contrapose!` and `intro h`
* `contrapose h with new_h` uses the name `new_h` for the introduced hypothesis
-/
meta def tactic.interactive.contrapose (push : parse (tk "!" )?) :
  parse name_with_opt? → tactic unit
| (some (h, h')) := get_local h >>= revert >> tactic.interactive.contrapose none >>
  intro (h'.get_or_else h) >> skip
| none :=
  do `(%%P → %%Q) ← target | fail
    "The goal is not an implication, and you didn't specify an assumption",
  cp ← mk_mapp ``imp_of_not_imp_not [P, Q] <|> fail
    "contrapose only applies to nondependent arrows between props",
  apply cp,
  when push.is_some $ try (tactic.interactive.push_neg (loc.ns [none]))

add_tactic_doc
{ name       := "contrapose",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.contrapose],
  tags       := ["logic"] }

/-!
## `#push_neg` command
A user command to run `push_neg`. Mostly copied from the `#norm_num` and `#simp` commands.
-/

namespace tactic

open lean.parser
open interactive.types
setup_tactic_parser

/--
The syntax is `#push_neg e`, where `e` is an expression,
which will print the `push_neg` form of `e`.

`#push_neg` understands local variables, so you can use them to
introduce parameters.
-/
@[user_command] meta def push_neg_cmd (_ : parse $ tk "#push_neg") : lean.parser unit :=
do
  e ← texpr,

  /- Synthesize a `tactic_state` including local variables as hypotheses under which
     `normalize_negations` may be safely called with expected behaviour given the `variables` in the
     environment. -/
  (ts, _) ← synthesize_tactic_state_with_variables_as_hyps [e],

  /- Enter the `tactic` monad, *critically* using the synthesized tactic state `ts`. -/
  result ← lean.parser.of_tactic $ λ _, do
  { /- Resolve the local variables added by the parser to `e` (when it was parsed) against the local
       hypotheses added to the `ts : tactic_state` which we are using. -/
    e ← to_expr e,

    /- Run `push_neg` on the expression. -/
    (e_neg, _) ← normalize_negations e,

    /- Run a `simp` to change any `¬ a = b` to `a ≠ b`; report the result, or, if the `simp` fails
    (because no `¬ a = b` appear in the expression), return what `push_neg` gave. -/
    prod.fst <$> e_neg.simp { eta := ff } failed tt [] [simp_arg_type.expr ``(push_neg.not_eq)]
    <|> pure e_neg } ts,

  /- Trace the result. -/
  trace result

add_tactic_doc
{ name                     := "#push_neg",
  category                 := doc_category.cmd,
  decl_names               := [`tactic.push_neg_cmd],
  tags                     := ["logic"] }

end tactic