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

! This file was ported from Lean 3 source module topology.filter
! leanprover-community/mathlib commit 4c19a16e4b705bf135cf9a80ac18fcc99c438514
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Order.Filter.Lift
import Mathlib.Topology.Separation
import Mathlib.Data.Set.Intervals.Monotone

/-!
# Topology on the set of filters on a type

This file introduces a topology on `Filter α`. It is generated by the sets
`Set.Iic (𝓟 s) = {l : Filter α | s ∈ l}`, `s : Set α`. A set `s : Set (Filter α)` is open if and
only if it is a union of a family of these basic open sets, see `Filter.isOpen_iff`.

This topology has the following important properties.

* If `X` is a topological space, then the map `𝓝 : X → Filter X` is a topology inducing map.

* In particular, it is a continuous map, so `𝓝 ∘ f` tends to `𝓝 (𝓝 a)` whenever `f` tends to `𝓝 a`.

* If `X` is an ordered topological space with order topology and no max element, then `𝓝 ∘ f` tends
  to `𝓝 Filter.atTop` whenever `f` tends to `Filter.atTop`.

* It turns `Filter X` into a T₀ space and the order on `Filter X` is the dual of the
  `specializationOrder (Filter X)`.

## Tags

filter, topological space
-/

open Set Filter TopologicalSpace

open Filter Topology

variable {ι : Sort _} {α β X Y : Type _}

namespace Filter

/-- The topology on `Filter α` is generated by the sets `Set.Iic (𝓟 s) = {l : Filter α | s ∈ l}`,
`s : Set α`. A set `s : Set (Filter α)` is open if and only if it is a union of a family of these
basic open sets, see `Filter.isOpen_iff`. -/
instance : TopologicalSpace (Filter α) :=
  generateFrom <| range <| Iic ∘ 𝓟

theorem isOpen_Iic_principal {s : Set α} : IsOpen (Iic (𝓟 s)) :=
  GenerateOpen.basic _ (mem_range_self _)
#align filter.is_open_Iic_principal Filter.isOpen_Iic_principal

theorem isOpen_setOf_mem {s : Set α} : IsOpen { l : Filter α | s ∈ l } := by
  simpa only [Iic_principal] using isOpen_Iic_principal
#align filter.is_open_set_of_mem Filter.isOpen_setOf_mem

theorem isTopologicalBasis_Iic_principal :
    IsTopologicalBasis (range (Iic ∘ 𝓟 : Set α → Set (Filter α))) :=
  { exists_subset_inter := by
      rintro _ ⟨s, rfl⟩ _ ⟨t, rfl⟩ l hl
      exact ⟨Iic (𝓟 s) ∩ Iic (𝓟 t), ⟨s ∩ t, by simp⟩, hl, Subset.rfl⟩
    unionₛ_eq := unionₛ_eq_univ_iff.2 fun l => ⟨Iic ⊤, ⟨univ, congr_arg Iic principal_univ⟩,
      mem_Iic.2 le_top⟩
    eq_generateFrom := rfl }
#align filter.is_topological_basis_Iic_principal Filter.isTopologicalBasis_Iic_principal

theorem isOpen_iff {s : Set (Filter α)} : IsOpen s ↔ ∃ T : Set (Set α), s = ⋃ t ∈ T, Iic (𝓟 t) :=
  isTopologicalBasis_Iic_principal.open_iff_eq_unionₛ.trans <| by
    simp only [exists_subset_range_and_iff, unionₛ_image, (· ∘ ·)]
#align filter.is_open_iff Filter.isOpen_iff

theorem nhds_eq (l : Filter α) : 𝓝 l = l.lift' (Iic ∘ 𝓟) :=
  nhds_generateFrom.trans <| by
    simp only [mem_setOf_eq, @and_comm (l ∈ _), infᵢ_and, infᵢ_range, Filter.lift', Filter.lift,
      (· ∘ ·), mem_Iic, le_principal_iff]
#align filter.nhds_eq Filter.nhds_eq

theorem nhds_eq' (l : Filter α) : 𝓝 l = l.lift' fun s => { l' | s ∈ l' } := by
  simpa only [(· ∘ ·), Iic_principal] using nhds_eq l
#align filter.nhds_eq' Filter.nhds_eq'

protected theorem tendsto_nhds {la : Filter α} {lb : Filter β} {f : α → Filter β} :
    Tendsto f la (𝓝 lb) ↔ ∀ s ∈ lb, ∀ᶠ a in la, s ∈ f a := by
  simp only [nhds_eq', tendsto_lift', mem_setOf_eq]
#align filter.tendsto_nhds Filter.tendsto_nhds

protected theorem HasBasis.nhds {l : Filter α} {p : ι → Prop} {s : ι → Set α} (h : HasBasis l p s) :
    HasBasis (𝓝 l) p fun i => Iic (𝓟 (s i)) := by
  rw [nhds_eq]
  exact h.lift' monotone_principal.Iic
#align filter.has_basis.nhds Filter.HasBasis.nhds

/-- Neighborhoods of a countably generated filter is a countably generated filter. -/
instance {l : Filter α} [IsCountablyGenerated l] : IsCountablyGenerated (𝓝 l) :=
  let ⟨_b, hb⟩ := l.exists_antitone_basis
  HasCountableBasis.isCountablyGenerated <| ⟨hb.nhds, Set.to_countable _⟩

theorem HasBasis.nhds' {l : Filter α} {p : ι → Prop} {s : ι → Set α} (h : HasBasis l p s) :
    HasBasis (𝓝 l) p fun i => { l' | s i ∈ l' } := by simpa only [Iic_principal] using h.nhds
#align filter.has_basis.nhds' Filter.HasBasis.nhds'

theorem mem_nhds_iff {l : Filter α} {S : Set (Filter α)} : S ∈ 𝓝 l ↔ ∃ t ∈ l, Iic (𝓟 t) ⊆ S :=
  l.basis_sets.nhds.mem_iff
#align filter.mem_nhds_iff Filter.mem_nhds_iff

theorem mem_nhds_iff' {l : Filter α} {S : Set (Filter α)} :
    S ∈ 𝓝 l ↔ ∃ t ∈ l, ∀ ⦃l' : Filter α⦄, t ∈ l' → l' ∈ S :=
  l.basis_sets.nhds'.mem_iff
#align filter.mem_nhds_iff' Filter.mem_nhds_iff'

@[simp]
theorem nhds_bot : 𝓝 (⊥ : Filter α) = pure ⊥ := by
  simp [nhds_eq, (· ∘ ·), lift'_bot monotone_principal.Iic]
#align filter.nhds_bot Filter.nhds_bot

@[simp]
theorem nhds_top : 𝓝 (⊤ : Filter α) = ⊤ := by simp [nhds_eq]
#align filter.nhds_top Filter.nhds_top

@[simp]
theorem nhds_principal (s : Set α) : 𝓝 (𝓟 s) = 𝓟 (Iic (𝓟 s)) :=
  (hasBasis_principal s).nhds.eq_of_same_basis (hasBasis_principal _)
#align filter.nhds_principal Filter.nhds_principal

@[simp]
theorem nhds_pure (x : α) : 𝓝 (pure x : Filter α) = 𝓟 {⊥, pure x} := by
  rw [← principal_singleton, nhds_principal, principal_singleton, Iic_pure]
#align filter.nhds_pure Filter.nhds_pure

@[simp]
theorem nhds_infᵢ (f : ι → Filter α) : 𝓝 (⨅ i, f i) = ⨅ i, 𝓝 (f i) := by
  simp only [nhds_eq]
  apply lift'_infᵢ_of_map_univ <;> simp
#align filter.nhds_infi Filter.nhds_infᵢ

@[simp]
theorem nhds_inf (l₁ l₂ : Filter α) : 𝓝 (l₁ ⊓ l₂) = 𝓝 l₁ ⊓ 𝓝 l₂ := by
  simpa only [infᵢ_bool_eq] using nhds_infᵢ fun b => cond b l₁ l₂
#align filter.nhds_inf Filter.nhds_inf

theorem monotone_nhds : Monotone (𝓝 : Filter α → Filter (Filter α)) :=
  Monotone.of_map_inf nhds_inf
#align filter.monotone_nhds Filter.monotone_nhds

theorem interₛ_nhds (l : Filter α) : ⋂₀ { s | s ∈ 𝓝 l } = Iic l := by
  simp_rw [nhds_eq, (· ∘ ·), interₛ_lift'_sets monotone_principal.Iic, Iic, le_principal_iff,
    ← setOf_forall, ← Filter.le_def]
#align filter.Inter_nhds Filter.interₛ_nhds

@[simp]
theorem nhds_mono {l₁ l₂ : Filter α} : 𝓝 l₁ ≤ 𝓝 l₂ ↔ l₁ ≤ l₂ := by
  refine' ⟨fun h => _, fun h => monotone_nhds h⟩
  rw [← Iic_subset_Iic, ← interₛ_nhds, ← interₛ_nhds]
  exact interₛ_subset_interₛ h
#align filter.nhds_mono Filter.nhds_mono

protected theorem mem_interior {s : Set (Filter α)} {l : Filter α} :
    l ∈ interior s ↔ ∃ t ∈ l, Iic (𝓟 t) ⊆ s := by rw [mem_interior_iff_mem_nhds, mem_nhds_iff]
#align filter.mem_interior Filter.mem_interior

protected theorem mem_closure {s : Set (Filter α)} {l : Filter α} :
    l ∈ closure s ↔ ∀ t ∈ l, ∃ l' ∈ s, t ∈ l' := by
  simp only [closure_eq_compl_interior_compl, Filter.mem_interior, mem_compl_iff, not_exists,
    not_forall, Classical.not_not, exists_prop, not_and, and_comm, subset_def, mem_Iic,
    le_principal_iff]
#align filter.mem_closure Filter.mem_closure

@[simp]
protected theorem closure_singleton (l : Filter α) : closure {l} = Ici l := by
  ext l'
  simp [Filter.mem_closure, Filter.le_def]
#align filter.closure_singleton Filter.closure_singleton

@[simp]
theorem specializes_iff_le {l₁ l₂ : Filter α} : l₁ ⤳ l₂ ↔ l₁ ≤ l₂ := by
  simp only [specializes_iff_closure_subset, Filter.closure_singleton, Ici_subset_Ici]
#align filter.specializes_iff_le Filter.specializes_iff_le

instance : T0Space (Filter α) :=
  ⟨fun _ _ h => (specializes_iff_le.1 h.specializes).antisymm
    (specializes_iff_le.1 h.symm.specializes)⟩

theorem nhds_atTop [Preorder α] : 𝓝 atTop = ⨅ x : α, 𝓟 (Iic (𝓟 (Ici x))) := by
  simp only [atTop, nhds_infᵢ, nhds_principal]
#align filter.nhds_at_top Filter.nhds_atTop

protected theorem tendsto_nhds_atTop_iff [Preorder β] {l : Filter α} {f : α → Filter β} :
    Tendsto f l (𝓝 atTop) ↔ ∀ y, ∀ᶠ a in l, Ici y ∈ f a := by
  simp only [nhds_atTop, tendsto_infᵢ, tendsto_principal, mem_Iic, le_principal_iff]
#align filter.tendsto_nhds_at_top_iff Filter.tendsto_nhds_atTop_iff

theorem nhds_atBot [Preorder α] : 𝓝 atBot = ⨅ x : α, 𝓟 (Iic (𝓟 (Iic x))) :=
  @nhds_atTop αᵒᵈ _
#align filter.nhds_at_bot Filter.nhds_atBot

protected theorem tendsto_nhds_atBot_iff [Preorder β] {l : Filter α} {f : α → Filter β} :
    Tendsto f l (𝓝 atBot) ↔ ∀ y, ∀ᶠ a in l, Iic y ∈ f a :=
  @Filter.tendsto_nhds_atTop_iff α βᵒᵈ _ _ _
#align filter.tendsto_nhds_at_bot_iff Filter.tendsto_nhds_atBot_iff

variable [TopologicalSpace X]

theorem nhds_nhds (x : X) : 𝓝 (𝓝 x) = ⨅ (s : Set X) (_hs : IsOpen s) (_hx : x ∈ s), 𝓟 (Iic (𝓟 s)) :=
  by simp only [(nhds_basis_opens x).nhds.eq_binfᵢ, infᵢ_and, @infᵢ_comm _ (_ ∈ _)]
#align filter.nhds_nhds Filter.nhds_nhds

theorem inducing_nhds : Inducing (𝓝 : X → Filter X) :=
  inducing_iff_nhds.2 fun x =>
    (nhds_def' _).trans <| by
      simp (config := { contextual := true }) only [nhds_nhds, comap_infᵢ, comap_principal,
        Iic_principal, preimage_setOf_eq, ← mem_interior_iff_mem_nhds, setOf_mem_eq,
        IsOpen.interior_eq]
#align filter.inducing_nhds Filter.inducing_nhds

@[continuity]
theorem continuous_nhds : Continuous (𝓝 : X → Filter X) :=
  inducing_nhds.continuous
#align filter.continuous_nhds Filter.continuous_nhds

protected theorem Tendsto.nhds {f : α → X} {l : Filter α} {x : X} (h : Tendsto f l (𝓝 x)) :
    Tendsto (𝓝 ∘ f) l (𝓝 (𝓝 x)) :=
  (continuous_nhds.tendsto _).comp h
#align filter.tendsto.nhds Filter.Tendsto.nhds

end Filter

variable [TopologicalSpace X] [TopologicalSpace Y] {f : X → Y} {x : X} {s : Set X}

protected nonrec theorem ContinuousWithinAt.nhds (h : ContinuousWithinAt f s x) :
    ContinuousWithinAt (𝓝 ∘ f) s x :=
  h.nhds
#align continuous_within_at.nhds ContinuousWithinAt.nhds

protected nonrec theorem ContinuousAt.nhds (h : ContinuousAt f x) : ContinuousAt (𝓝 ∘ f) x :=
  h.nhds
#align continuous_at.nhds ContinuousAt.nhds

protected nonrec theorem ContinuousOn.nhds (h : ContinuousOn f s) : ContinuousOn (𝓝 ∘ f) s :=
  fun x hx => (h x hx).nhds
#align continuous_on.nhds ContinuousOn.nhds

protected nonrec theorem Continuous.nhds (h : Continuous f) : Continuous (𝓝 ∘ f) :=
  Filter.continuous_nhds.comp h
#align continuous.nhds Continuous.nhds


import group_theory.subgroup
import group_theory.quotient_group
import data.fintype
import data.multiset
import .SES .induction .category_theory .list_equiv

universes u v w

open is_subgroup

inductive normal_series (T : Group.{u}): Group.{u} → Type (u+1)
| initial {} : ∀ {T'}, (T' ≅ T) → normal_series T'
| step : ∀ {H G K : Group.{u}},
       SES H G K
       → normal_series H
       → normal_series G

def length {T} : ∀ {G : Group}, normal_series T G → nat
| _ (normal_series.initial _) := 0
| _ (normal_series.step _ σ) := 1 + length σ

def ℓ := @length

def factors {T : Group} : ∀ {G : Group}, normal_series T G → list Group
| _ (normal_series.initial _) := []
| _ (@normal_series.step _ _ _ K _ σ) := K :: factors σ

def is_composition_series
  {G : Group} (σ : normal_series 1 G)
  := list.foldr (∧) true
     $ list.map (λ K : Group, simple_group K ∧ ¬ subsingleton K)
     $ factors σ

lemma is_composition_series.initial {T : Group} {h : T ≅ 1}
  : is_composition_series (normal_series.initial h) := trivial

lemma is_composition_series.step
  {H G K : Group} (S : SES H G K) (σ : normal_series 1 H)
  : is_composition_series (normal_series.step S σ)
  ↔ is_composition_series σ ∧ simple_group K ∧ ¬ subsingleton K :=
  and_comm _ _

noncomputable
def normal_series.pullback : ∀ {H G K : Group} (S : SES H G K),
  normal_series 1 K → normal_series H G
| H G K S (normal_series.initial h) :=
  normal_series.initial (category_theory.iso.symm
                        $ @SES.iso_of_right_triv _ _ _
                              ⟨λ x y : K, Group.iso_inj h (subsingleton.elim _ _)⟩
                              S)
| H G K S (@normal_series.step _ _ Kn Cn S' σ) :=
  normal_series.step (third_iso S S')
  $ normal_series.pullback (SES.pullback S S') σ

lemma normal_series.pullback_factors {H G K : Group.{u}} (S : SES H G K)
  (σ : normal_series 1 K)
  : factors (σ.pullback S) = factors σ :=
begin
  revert S G H, induction σ; intros H G S,
  { constructor },
  { dsimp [normal_series.pullback, factors],
    apply congr_arg, apply_assumption }
end

def normal_series.transport {T G H : Group} (iso : G ≅ H)
  : normal_series T G → normal_series T H
| (normal_series.initial iso') := normal_series.initial (iso.symm ≪≫ iso')
| (normal_series.step S σ) := normal_series.step (S.transport_iso_mid iso) σ

lemma normal_series.transport_factors {T G H : Group} (iso : G ≅ H)
  (σ : normal_series T G) : factors (σ.transport iso) = factors σ
  := by cases σ; refl

def normal_series.merge {H : Group} (σ : normal_series 1 H)
  : ∀ {G : Group}, normal_series H G → normal_series 1 G
| G (normal_series.initial iso) := normal_series.transport iso.symm σ
| G (@normal_series.step _ H' _ K S σ') :=
  normal_series.step S (normal_series.merge σ')

lemma normal_series.merge_factors {H : Group} (σ : normal_series 1 H)
  {G : Group} (σ' : normal_series H G)
  : factors (normal_series.merge σ σ') = factors σ' ++ factors σ :=
begin
  induction σ',
  { dsimp [normal_series.merge], rw normal_series.transport_factors, refl },
  { dsimp [factors, normal_series.merge], apply congr_arg, assumption }
end

noncomputable
def normal_series.of_SES {H G K : Group} (S : SES H G K)
  (σ : normal_series 1 H) (σ' : normal_series 1 K)
  := normal_series.merge σ $ normal_series.pullback S σ'

lemma list.foldr_append_assoc {α} (f : α → α → α) (a : α) (xs ys : list α)
  (hid : ∀ x : α, f a x = x)
  (hassoc : ∀ x y z, f x (f y z) = f (f x y) z)
: list.foldr f a (xs ++ ys) = f (list.foldr f a xs) (list.foldr f a ys) :=
begin
  induction xs with x xs ih,
  { symmetry, apply hid },
  { dsimp [list.foldr], rw ih, apply hassoc }
end

lemma is_composition_series.of_SES {H G K : Group} (S : SES H G K)
  (σ : normal_series 1 H) (σ' : normal_series 1 K)
  : is_composition_series σ
  → is_composition_series σ'
  → is_composition_series (normal_series.of_SES S σ σ') :=
begin
  dsimp [is_composition_series], intros h h',
  dsimp [normal_series.of_SES],
  rw [normal_series.merge_factors, normal_series.pullback_factors],
  rw [list.map_append, list.foldr_append_assoc],
  constructor; assumption,
  { intro P, exact propext (true_and P) },
  { intros, exact propext (and_assoc _ _).symm }
end

local attribute [instance] classical.prop_decidable
lemma composition_series_of
  : ∀ {G : Group} (is_fin : fintype G),
    ∃ σ : normal_series 1 G, is_composition_series σ :=
  finite_group.induction_subquot (λ (G : Group) _, ∃ σ : normal_series 1 G, is_composition_series σ)
  (λ G is_fin hsub hquot,
   if h : simple_group G
   then if h' : subsingleton G
        then ⟨normal_series.initial $ @Group.subsingleton_iso _ _ h' _,
              is_composition_series.initial⟩
        else exists.intro (normal_series.step (SES.self_right G)
                          $ normal_series.initial $ by refl)
                      $ iff.mpr (is_composition_series.step (SES.self_right G)
                                 $ normal_series.initial $ by refl)
                      $ ⟨@is_composition_series.initial _ $ by refl, h, h'⟩
   else by { have ex_n : ∃ (N : set G), normal_subgroup N ∧ N ≠ is_subgroup.trivial G ∧ N ≠ set.univ,
             { by_contradiction h', apply h, constructor, intros,
               by_contradiction h'', apply h',
               existsi N, existsi _inst_1, constructor; intro; apply h'',
               apply or.inl, assumption, apply or.inr, assumption },
             cases classical.subtype_of_exists ex_n with H h,
             cases @hsub H h.left.to_is_subgroup h.right.right with σ σ_comp,
             cases @hquot H h.left h.right.left with σ' σ'_comp,
             existsi normal_series.of_SES _ σ σ',
             apply is_composition_series.of_SES; assumption,
             apply SES.normal_quotient })

lemma jordan_holder :
  ∀ {G : Group} (is_fin : fintype G) {G' : Group} (iso : G ≅ G')
  (σ : normal_series 1 G) (σ' : normal_series 1 G'),
  is_composition_series σ → is_composition_series σ' →
  equiv_group_lists (factors σ) (factors σ') :=
  finite_group.induction_ord
    (λ (G : Group) _, ∀ {G' : Group} (iso : G ≅ G')
                        (σ : normal_series 1 G) (σ' : normal_series 1 G'),
                      is_composition_series σ → is_composition_series σ'→
                      equiv_group_lists (factors σ) (factors σ'))
  $ by { intros G is_fin ih G' iso σ σ' hσ hσ',
         cases σ with _ _ H _ K S σ; cases σ' with _ _ H' _ K' S' σ',
         { apply and.intro rfl, existsi list.nil, constructor; trivial },
         { exfalso, rw is_composition_series.step at hσ',
           apply hσ'.right.right, constructor, intros x y,
           cases S'.g_surj x, subst h, cases S'.g_surj y, subst h,
           apply congr_arg, apply Group.iso_inj (iso.symm ≪≫ σ_a),
            apply subsingleton.elim },
         { exfalso, rw is_composition_series.step at hσ,
           apply hσ.right.right, constructor, intros x y,
           cases S.g_surj x, subst h, cases S.g_surj y, subst h,
           apply congr_arg, apply Group.iso_inj (iso ≪≫ σ'_a), apply subsingleton.elim },
         cases classical.type_decidable (SES.equiv iso S S') with heqv,
         { rw is_composition_series.step at hσ hσ',
           cases @ih _ _
              (@Group.normal_subgroup_card_lt_of_nontriv_quot _ _ _ is_fin S hσ.right.right)
              H' heqv.α σ σ' hσ.left hσ'.left with hlen h, cases h with L hL,
           apply and.intro (congr_arg nat.succ hlen),
           existsi list.cons K L,
           exact ⟨list.perm.skip _ hL.left, ⟨heqv.β⟩, hL.right⟩ },
         rw is_composition_series.step at hσ hσ',
         cases SES.not_contains_of_simple_quot_and_proper iso S S' hσ.right.left hσ'.right.right val with x hx,
         cases SES.not_contains_of_simple_quot_and_proper iso.symm S' S hσ'.right.left hσ.right.right _ with x' hx',
         tactic.swap,
         { intro eqv, apply val, rw ← iso.symm_symm_eq, apply SES.equiv_symm, assumption },
         have H_S : SES (Group.of (pullback (S.f ≫ iso.hom) S'.f)) H K'
         := @partial_second_iso H H' G G' K K' iso hσ'.right.left S S' x hx,
         have H'_S : SES (Group.of (pullback (S'.f ≫ iso.inv) S.f)) H' K
         := @partial_second_iso H' H G' G K' K iso.symm hσ.right.left S' S x' hx',
         let is_fin' := @fintype.of_bijective _ _ is_fin iso.hom (Group.iso_bij iso),
         have card_G_eq_card_G' : @fintype.card _ is_fin = @fintype.card _ is_fin',
         { rw fintype.card_eq, constructor, constructor,
           apply Group.iso_left_inverse iso, apply Group.iso_right_inverse iso },
         let is_fin_H : fintype H := @fintype.of_injective _ _ is_fin S.f S.f_inj,
         let H_card_lt : @fintype.card H is_fin_H < @fintype.card G is_fin
         := @Group.normal_subgroup_card_lt_of_nontriv_quot _ _ _ is_fin S hσ.right.right,
         let is_fin_H' : fintype H' := @fintype.of_injective _ _ is_fin' S'.f S'.f_inj,
         have H'_card_lt : @fintype.card H' is_fin_H' < @fintype.card G is_fin,
         { rw card_G_eq_card_G',
           exact @Group.normal_subgroup_card_lt_of_nontriv_quot _ _ _ is_fin' S' hσ'.right.right },
         let pullback₁_fin : fintype (Group.of $ pullback (S.f ≫ iso.hom) S'.f)
         := @pullback_inj_fin _ _ _ (S.f ≫ iso.hom) S'.f
                              (function.injective_comp (Group.iso_inj iso) S.f_inj)
                              S'.f_inj is_fin',
         have pullback₁_card_lt : @fintype.card _ pullback₁_fin < @fintype.card G is_fin,
         { apply @nat.lt_of_le_of_lt _ (@fintype.card _ (@pullback_inj_fin _ _ _ (S.f ≫ iso.hom) S'.f
                                                          (function.injective_comp (Group.iso_inj iso) S.f_inj)
                                                          S'.f_inj is_fin')),
           apply nat.le_of_eq, refl, rw card_G_eq_card_G',
           apply pullback_card_lt_of_conflict _ _ x,
           intro b, intro h, apply hx,
           transitivity S'.g (S'.f b), rw ← h, refl, apply S'.is_cc },
         let pullback₂_fin : fintype (Group.of $ pullback (S'.f ≫ iso.inv) S.f)
         := @pullback_inj_fin _ _ _ (S'.f ≫ iso.inv) S.f
                             (function.injective_comp (Group.iso_inj iso.symm) S'.f_inj)
                              S.f_inj is_fin,
         cases @composition_series_of (Group.of (pullback (S.f ≫ iso.hom) S'.f))
                                     pullback₁_fin with pullback₁_σ pullback₁_σ_comp,
         cases @composition_series_of (Group.of (pullback (S'.f ≫ iso.inv) S.f))
                                     pullback₂_fin with pullback₂_σ pullback₂_σ_comp,
         have heqv_pullback₁₂ :=
            ih _ pullback₁_fin pullback₁_card_lt
               (Group.pullback_of_isos_is_iso iso _ _)
               pullback₁_σ pullback₂_σ pullback₁_σ_comp pullback₂_σ_comp,
         let H_σ := normal_series.step H_S pullback₁_σ,
         have H_σ_comp : is_composition_series H_σ := ⟨hσ'.right, pullback₁_σ_comp⟩,
         have heqv_H :=
            ih _ is_fin_H H_card_lt (category_theory.iso.refl H)
               σ H_σ hσ.left H_σ_comp,
         let H'_σ := normal_series.step H'_S pullback₂_σ,
         have H'_σ_comp : is_composition_series H'_σ := ⟨hσ.right, pullback₂_σ_comp⟩,
         have heqvH' :=
            ih _ is_fin_H' H'_card_lt (category_theory.iso.refl H')
               H'_σ σ' H'_σ_comp hσ'.left,
         dsimp [factors],
         transitivity list.cons K (factors H_σ),
         apply equiv_group_lists.skip, assumption,
         transitivity list.cons K' (factors H'_σ),
         apply equiv_group_lists.swap', assumption,
         apply equiv_group_lists.skip, assumption }


/-
Copyright (c) 2021 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import tactic.tfae
import order.atoms
import order.order_iso_nat
import order.zorn
import data.finset.order

/-!
# Compactness properties for complete lattices

For complete lattices, there are numerous equivalent ways to express the fact that the relation `>`
is well-founded. In this file we define three especially-useful characterisations and provide
proofs that they are indeed equivalent to well-foundedness.

## Main definitions
 * `complete_lattice.is_sup_closed_compact`
 * `complete_lattice.is_Sup_finite_compact`
 * `complete_lattice.is_compact_element`
 * `complete_lattice.is_compactly_generated`

## Main results
The main result is that the following four conditions are equivalent for a complete lattice:
 * `well_founded (>)`
 * `complete_lattice.is_sup_closed_compact`
 * `complete_lattice.is_Sup_finite_compact`
 * `∀ k, complete_lattice.is_compact_element k`

This is demonstrated by means of the following four lemmas:
 * `complete_lattice.well_founded.is_Sup_finite_compact`
 * `complete_lattice.is_Sup_finite_compact.is_sup_closed_compact`
 * `complete_lattice.is_sup_closed_compact.well_founded`
 * `complete_lattice.is_Sup_finite_compact_iff_all_elements_compact`

 We also show well-founded lattices are compactly generated
 (`complete_lattice.compactly_generated_of_well_founded`).

## References
- [G. Călugăreanu, *Lattice Concepts of Module Theory*][calugareanu]

## Tags

complete lattice, well-founded, compact
-/

variables {α : Type*} [complete_lattice α]

namespace complete_lattice

variables (α)

/-- A compactness property for a complete lattice is that any `sup`-closed non-empty subset
contains its `Sup`. -/
def is_sup_closed_compact : Prop :=
  ∀ (s : set α) (h : s.nonempty), (∀ a b, a ∈ s → b ∈ s → a ⊔ b ∈ s) → (Sup s) ∈ s

/-- A compactness property for a complete lattice is that any subset has a finite subset with the
same `Sup`. -/
def is_Sup_finite_compact : Prop :=
∀ (s : set α), ∃ (t : finset α), ↑t ⊆ s ∧ Sup s = t.sup id

/-- An element `k` of a complete lattice is said to be compact if any set with `Sup`
above `k` has a finite subset with `Sup` above `k`.  Such an element is also called
"finite" or "S-compact". -/
def is_compact_element {α : Type*} [complete_lattice α] (k : α) :=
∀ s : set α, k ≤ Sup s → ∃ t : finset α, ↑t ⊆ s ∧ k ≤ t.sup id

/-- An element `k` is compact if and only if any directed set with `Sup` above
`k` already got above `k` at some point in the set. -/
theorem is_compact_element_iff_le_of_directed_Sup_le (k : α) :
  is_compact_element k ↔
  ∀ s : set α, s.nonempty → directed_on (≤) s → k ≤ Sup s → ∃ x : α, x ∈ s ∧ k ≤ x :=
begin
  classical,
  split,
  { intros hk s hne hdir hsup,
    obtain ⟨t, ht⟩ := hk s hsup,
    -- certainly every element of t is below something in s, since ↑t ⊆ s.
    have t_below_s : ∀ x ∈ t, ∃ y ∈ s, x ≤ y, from λ x hxt, ⟨x, ht.left hxt, le_rfl⟩,
    obtain ⟨x, ⟨hxs, hsupx⟩⟩ := finset.sup_le_of_le_directed s hne hdir t t_below_s,
    exact ⟨x, ⟨hxs, le_trans ht.right hsupx⟩⟩, },
  { intros hk s hsup,
    -- Consider the set of finite joins of elements of the (plain) set s.
    let S : set α := { x | ∃ t : finset α, ↑t ⊆ s ∧ x = t.sup id },
    -- S is directed, nonempty, and still has sup above k.
    have dir_US : directed_on (≤) S,
    { rintros x ⟨c, hc⟩ y ⟨d, hd⟩,
      use x ⊔ y,
      split,
      { use c ∪ d,
        split,
        { simp only [hc.left, hd.left, set.union_subset_iff, finset.coe_union, and_self], },
        { simp only [hc.right, hd.right, finset.sup_union], }, },
      simp only [and_self, le_sup_left, le_sup_right], },
    have sup_S : Sup s ≤ Sup S,
    { apply Sup_le_Sup,
      intros x hx, use {x},
      simpa only [and_true, id.def, finset.coe_singleton, eq_self_iff_true, finset.sup_singleton,
        set.singleton_subset_iff], },
    have Sne : S.nonempty,
    { suffices : ⊥ ∈ S, from set.nonempty_of_mem this,
      use ∅,
      simp only [set.empty_subset, finset.coe_empty, finset.sup_empty,
        eq_self_iff_true, and_self], },
    -- Now apply the defn of compact and finish.
    obtain ⟨j, ⟨hjS, hjk⟩⟩ := hk S Sne dir_US (le_trans hsup sup_S),
    obtain ⟨t, ⟨htS, htsup⟩⟩ := hjS,
    use t, exact ⟨htS, by rwa ←htsup⟩, },
end

/-- A compact element `k` has the property that any directed set lying strictly below `k` has
its Sup strictly below `k`. -/
lemma is_compact_element.directed_Sup_lt_of_lt {α : Type*} [complete_lattice α] {k : α}
  (hk : is_compact_element k) {s : set α} (hemp : s.nonempty) (hdir : directed_on (≤) s)
  (hbelow : ∀ x ∈ s, x < k) : Sup s < k :=
begin
  rw is_compact_element_iff_le_of_directed_Sup_le at hk,
  by_contradiction,
  have sSup : Sup s ≤ k, from Sup_le (λ s hs, (hbelow s hs).le),
  replace sSup : Sup s = k := eq_iff_le_not_lt.mpr ⟨sSup, h⟩,
  obtain ⟨x, hxs, hkx⟩ := hk s hemp hdir sSup.symm.le,
  obtain hxk := hbelow x hxs,
  exact hxk.ne (hxk.le.antisymm hkx),
end

lemma finset_sup_compact_of_compact {α β : Type*} [complete_lattice α] {f : β → α}
  (s : finset β) (h : ∀ x ∈ s, is_compact_element (f x)) : is_compact_element (s.sup f) :=
begin
  classical,
  rw is_compact_element_iff_le_of_directed_Sup_le,
  intros d hemp hdir hsup,
  change f with id ∘ f, rw ←finset.sup_finset_image,
  apply finset.sup_le_of_le_directed d hemp hdir,
  rintros x hx,
  obtain ⟨p, ⟨hps, rfl⟩⟩ := finset.mem_image.mp hx,
  specialize h p hps,
  rw is_compact_element_iff_le_of_directed_Sup_le at h,
  specialize h d hemp hdir (le_trans (finset.le_sup hps) hsup),
  simpa only [exists_prop],
end

lemma well_founded.is_Sup_finite_compact (h : well_founded ((>) : α → α → Prop)) :
  is_Sup_finite_compact α :=
begin
  intros s,
  let p : set α := { x | ∃ (t : finset α), ↑t ⊆ s ∧ t.sup id = x },
  have hp : p.nonempty, { use [⊥, ∅], simp, },
  obtain ⟨m, ⟨t, ⟨ht₁, ht₂⟩⟩, hm⟩ := well_founded.well_founded_iff_has_max'.mp h p hp,
  use t, simp only [ht₁, ht₂, true_and], apply le_antisymm,
  { apply Sup_le, intros y hy, classical,
    have hy' : (insert y t).sup id ∈ p,
    { use insert y t, simp, rw set.insert_subset, exact ⟨hy, ht₁⟩, },
    have hm' : m ≤ (insert y t).sup id, { rw ← ht₂, exact finset.sup_mono (t.subset_insert y), },
    rw ← hm _ hy' hm', simp, },
  { rw [← ht₂, finset.sup_id_eq_Sup], exact Sup_le_Sup ht₁, },
end

lemma is_Sup_finite_compact.is_sup_closed_compact (h : is_Sup_finite_compact α) :
  is_sup_closed_compact α :=
begin
  intros s hne hsc, obtain ⟨t, ht₁, ht₂⟩ := h s, clear h,
  cases t.eq_empty_or_nonempty with h h,
  { subst h, rw finset.sup_empty at ht₂, rw ht₂,
    simp [eq_singleton_bot_of_Sup_eq_bot_of_nonempty ht₂ hne], },
  { rw ht₂, exact t.sup_closed_of_sup_closed h ht₁ hsc, },
end

lemma is_sup_closed_compact.well_founded (h : is_sup_closed_compact α) :
  well_founded ((>) : α → α → Prop) :=
begin
  refine rel_embedding.well_founded_iff_no_descending_seq.mpr ⟨λ a, _⟩,
  suffices : Sup (set.range a) ∈ set.range a,
  { obtain ⟨n, hn⟩ := set.mem_range.mp this,
    have h' : Sup (set.range a) < a (n+1), { change _ > _, simp [← hn, a.map_rel_iff], },
    apply lt_irrefl (a (n+1)), apply lt_of_le_of_lt _ h', apply le_Sup, apply set.mem_range_self, },
  apply h (set.range a),
  { use a 37, apply set.mem_range_self, },
  { rintros x y ⟨m, hm⟩ ⟨n, hn⟩, use m ⊔ n, rw [← hm, ← hn], apply a.to_rel_hom.map_sup, },
end

lemma is_Sup_finite_compact_iff_all_elements_compact :
  is_Sup_finite_compact α ↔ (∀ k : α, is_compact_element k) :=
begin
  split,
  { intros h k s hs,
    obtain ⟨t, ⟨hts, htsup⟩⟩ := h s,
    use [t, hts],
    rwa ←htsup, },
  { intros h s,
    obtain ⟨t, ⟨hts, htsup⟩⟩ := h (Sup s) s (by refl),
    have : Sup s = t.sup id,
    { suffices : t.sup id ≤ Sup s, by { apply le_antisymm; assumption },
      simp only [id.def, finset.sup_le_iff],
      intros x hx,
      apply le_Sup, exact hts hx, },
    use [t, hts], assumption, },
end

lemma well_founded_characterisations :
  tfae [well_founded ((>) : α → α → Prop),
        is_Sup_finite_compact α,
        is_sup_closed_compact α,
        ∀ k : α, is_compact_element k] :=
begin
  tfae_have : 1 → 2, by { exact well_founded.is_Sup_finite_compact α, },
  tfae_have : 2 → 3, by { exact is_Sup_finite_compact.is_sup_closed_compact α, },
  tfae_have : 3 → 1, by { exact is_sup_closed_compact.well_founded α, },
  tfae_have : 2 ↔ 4, by { exact is_Sup_finite_compact_iff_all_elements_compact α },
  tfae_finish,
end

lemma well_founded_iff_is_Sup_finite_compact :
  well_founded ((>) : α → α → Prop) ↔ is_Sup_finite_compact α :=
(well_founded_characterisations α).out 0 1

lemma is_Sup_finite_compact_iff_is_sup_closed_compact :
  is_Sup_finite_compact α ↔ is_sup_closed_compact α :=
(well_founded_characterisations α).out 1 2

lemma is_sup_closed_compact_iff_well_founded :
  is_sup_closed_compact α ↔ well_founded ((>) : α → α → Prop) :=
(well_founded_characterisations α).out 2 0

alias well_founded_iff_is_Sup_finite_compact ↔ _ is_Sup_finite_compact.well_founded
alias is_Sup_finite_compact_iff_is_sup_closed_compact ↔
      _ is_sup_closed_compact.is_Sup_finite_compact
alias is_sup_closed_compact_iff_well_founded ↔ _ well_founded.is_sup_closed_compact

end complete_lattice

/-- A complete lattice is said to be compactly generated if any
element is the `Sup` of compact elements. -/
class is_compactly_generated (α : Type*) [complete_lattice α] : Prop :=
(exists_Sup_eq :
  ∀ (x : α), ∃ (s : set α), (∀ x ∈ s, complete_lattice.is_compact_element x) ∧ Sup s = x)

section
variables {α} [is_compactly_generated α] {a b : α} {s : set α}

@[simp]
lemma Sup_compact_le_eq (b) : Sup {c : α | complete_lattice.is_compact_element c ∧ c ≤ b} = b :=
begin
  rcases is_compactly_generated.exists_Sup_eq b with ⟨s, hs, rfl⟩,
  exact le_antisymm (Sup_le (λ c hc, hc.2)) (Sup_le_Sup (λ c cs, ⟨hs c cs, le_Sup cs⟩)),
end

@[simp]
theorem Sup_compact_eq_top :
  Sup {a : α | complete_lattice.is_compact_element a} = ⊤ :=
begin
  refine eq.trans (congr rfl (set.ext (λ x, _))) (Sup_compact_le_eq ⊤),
  exact (and_iff_left le_top).symm,
end

theorem le_iff_compact_le_imp {a b : α} :
  a ≤ b ↔ ∀ c : α, complete_lattice.is_compact_element c → c ≤ a → c ≤ b :=
⟨λ ab c hc ca, le_trans ca ab, λ h, begin
  rw [← Sup_compact_le_eq a, ← Sup_compact_le_eq b],
  exact Sup_le_Sup (λ c hc, ⟨hc.1, h c hc.1 hc.2⟩),
end⟩

/-- This property is sometimes referred to as `α` being upper continuous. -/
theorem inf_Sup_eq_of_directed_on (h : directed_on (≤) s):
  a ⊓ Sup s = ⨆ b ∈ s, a ⊓ b :=
le_antisymm (begin
  rw le_iff_compact_le_imp,
  by_cases hs : s.nonempty,
  { intros c hc hcinf,
    rw le_inf_iff at hcinf,
    rw complete_lattice.is_compact_element_iff_le_of_directed_Sup_le at hc,
    rcases hc s hs h hcinf.2 with ⟨d, ds, cd⟩,
    exact (le_inf hcinf.1 cd).trans (le_bsupr d ds) },
  { rw set.not_nonempty_iff_eq_empty at hs,
    simp [hs] }
end) supr_inf_le_inf_Sup

/-- This property is equivalent to `α` being upper continuous. -/
theorem inf_Sup_eq_supr_inf_sup_finset :
  a ⊓ Sup s = ⨆ (t : finset α) (H : ↑t ⊆ s), a ⊓ (t.sup id) :=
le_antisymm (begin
  rw le_iff_compact_le_imp,
  intros c hc hcinf,
  rw le_inf_iff at hcinf,
  rcases hc s hcinf.2 with ⟨t, ht1, ht2⟩,
  exact (le_inf hcinf.1 ht2).trans (le_bsupr t ht1),
end)
  (supr_le $ λ t, supr_le $ λ h, inf_le_inf_left _ ((finset.sup_id_eq_Sup t).symm ▸ (Sup_le_Sup h)))

theorem complete_lattice.set_independent_iff_finite {s : set α} :
  complete_lattice.set_independent s ↔
    ∀ t : finset α, ↑t ⊆ s → complete_lattice.set_independent (↑t : set α) :=
⟨λ hs t ht, hs.mono ht, λ h a ha, begin
  rw [disjoint_iff, inf_Sup_eq_supr_inf_sup_finset, supr_eq_bot],
  intro t,
  rw [supr_eq_bot, finset.sup_id_eq_Sup],
  intro ht,
  classical,
  have h' := (h (insert a t) _ (t.mem_insert_self a)).eq_bot,
  { rwa [finset.coe_insert, set.insert_diff_self_of_not_mem] at h',
    exact λ con, ((set.mem_diff a).1 (ht con)).2 (set.mem_singleton a) },
  { rw [finset.coe_insert, set.insert_subset],
    exact ⟨ha, set.subset.trans ht (set.diff_subset _ _)⟩ }
end⟩

lemma complete_lattice.set_independent_Union_of_directed {η : Type*}
  {s : η → set α} (hs : directed (⊆) s)
  (h : ∀ i, complete_lattice.set_independent (s i)) :
  complete_lattice.set_independent (⋃ i, s i) :=
begin
  by_cases hη : nonempty η,
  { resetI,
    rw complete_lattice.set_independent_iff_finite,
    intros t ht,
    obtain ⟨I, fi, hI⟩ := set.finite_subset_Union t.finite_to_set ht,
    obtain ⟨i, hi⟩ := hs.finset_le fi.to_finset,
    exact (h i).mono (set.subset.trans hI $ set.bUnion_subset $
      λ j hj, hi j (fi.mem_to_finset.2 hj)) },
  { rintros a ⟨_, ⟨i, _⟩, _⟩,
    exfalso, exact hη ⟨i⟩, },
end

lemma complete_lattice.independent_sUnion_of_directed {s : set (set α)}
  (hs : directed_on (⊆) s)
  (h : ∀ a ∈ s, complete_lattice.set_independent a) :
  complete_lattice.set_independent (⋃₀ s) :=
by rw set.sUnion_eq_Union; exact
  complete_lattice.set_independent_Union_of_directed hs.directed_coe (by simpa using h)

end

namespace complete_lattice

lemma compactly_generated_of_well_founded (h : well_founded ((>) : α → α → Prop)) :
  is_compactly_generated α :=
begin
  rw [well_founded_iff_is_Sup_finite_compact, is_Sup_finite_compact_iff_all_elements_compact] at h,
  -- x is the join of the set of compact elements {x}
  exact ⟨λ x, ⟨{x}, ⟨λ x _, h x, Sup_singleton⟩⟩⟩,
end

/-- A compact element `k` has the property that any `b < `k lies below a "maximal element below
`k`", which is to say `[⊥, k]` is coatomic. -/
theorem Iic_coatomic_of_compact_element {k : α} (h : is_compact_element k) :
  is_coatomic (set.Iic k) :=
⟨λ ⟨b, hbk⟩, begin
  by_cases htriv : b = k,
  { left, ext, simp only [htriv, set.Iic.coe_top, subtype.coe_mk], },
  right,
  rcases zorn.zorn_nonempty_partial_order₀ (set.Iio k) _ b (lt_of_le_of_ne hbk htriv)
    with ⟨a, a₀, ba, h⟩,
  { refine ⟨⟨a, le_of_lt a₀⟩, ⟨ne_of_lt a₀, λ c hck, by_contradiction $ λ c₀, _⟩, ba⟩,
    cases h c.1 (lt_of_le_of_ne c.2 (λ con, c₀ (subtype.ext con))) hck.le,
    exact lt_irrefl _ hck, },
  { intros S SC cC I IS,
    by_cases hS : S.nonempty,
    { exact ⟨Sup S, h.directed_Sup_lt_of_lt hS cC.directed_on SC, λ _, le_Sup⟩, },
    exact ⟨b, lt_of_le_of_ne hbk htriv, by simp only [set.not_nonempty_iff_eq_empty.mp hS,
      set.mem_empty_eq, forall_const, forall_prop_of_false, not_false_iff]⟩, },
end⟩

lemma coatomic_of_top_compact (h : is_compact_element (⊤ : α)) : is_coatomic α :=
(@order_iso.Iic_top α _ _).is_coatomic_iff.mp (Iic_coatomic_of_compact_element h)

end complete_lattice

section
variables [is_modular_lattice α] [is_compactly_generated α]

@[priority 100]
instance is_atomic_of_is_complemented [is_complemented α] : is_atomic α :=
⟨λ b, begin
  by_cases h : {c : α | complete_lattice.is_compact_element c ∧ c ≤ b} ⊆ {⊥},
  { left,
    rw [← Sup_compact_le_eq b, Sup_eq_bot],
    exact h },
  { rcases set.not_subset.1 h with ⟨c, ⟨hc, hcb⟩, hcbot⟩,
    right,
    have hc' := complete_lattice.Iic_coatomic_of_compact_element hc,
    rw ← is_atomic_iff_is_coatomic at hc',
    haveI := hc',
    obtain con | ⟨a, ha, hac⟩ := eq_bot_or_exists_atom_le (⟨c, le_refl c⟩ : set.Iic c),
    { exfalso,
      apply hcbot,
      simp only [subtype.ext_iff, set.Iic.coe_bot, subtype.coe_mk] at con,
      exact con },
    rw [← subtype.coe_le_coe, subtype.coe_mk] at hac,
    exact ⟨a, ha.of_is_atom_coe_Iic, hac.trans hcb⟩ },
end⟩

/-- See Lemma 5.1, Călugăreanu -/
@[priority 100]
instance is_atomistic_of_is_complemented [is_complemented α] : is_atomistic α :=
⟨λ b, ⟨{a | is_atom a ∧ a ≤ b}, begin
  symmetry,
  have hle : Sup {a : α | is_atom a ∧ a ≤ b} ≤ b := (Sup_le $ λ _, and.right),
  apply (lt_or_eq_of_le hle).resolve_left (λ con, _),
  obtain ⟨c, hc⟩ := exists_is_compl (⟨Sup {a : α | is_atom a ∧ a ≤ b}, hle⟩ : set.Iic b),
  obtain rfl | ⟨a, ha, hac⟩ := eq_bot_or_exists_atom_le c,
  { exact ne_of_lt con (subtype.ext_iff.1 (eq_top_of_is_compl_bot hc)) },
  { apply ha.1,
    rw eq_bot_iff,
    apply le_trans (le_inf _ hac) hc.1,
    rw [← subtype.coe_le_coe, subtype.coe_mk],
    exact le_Sup ⟨ha.of_is_atom_coe_Iic, a.2⟩ }
end, λ _, and.left⟩⟩

/-- See Theorem 6.6, Călugăreanu -/
theorem is_complemented_of_Sup_atoms_eq_top (h : Sup {a : α | is_atom a} = ⊤) : is_complemented α :=
⟨λ b, begin
  obtain ⟨s, ⟨s_ind, b_inf_Sup_s, s_atoms⟩, s_max⟩ := zorn.zorn_subset
    {s : set α | complete_lattice.set_independent s ∧ b ⊓ Sup s = ⊥ ∧ ∀ a ∈ s, is_atom a} _,
  { refine ⟨Sup s, le_of_eq b_inf_Sup_s, _⟩,
    rw [← h, Sup_le_iff],
    intros a ha,
    rw ← inf_eq_left,
    refine (eq_bot_or_eq_of_le_atom ha inf_le_left).resolve_left (λ con, ha.1 _),
    rw [eq_bot_iff, ← con],
    refine le_inf (le_refl a) ((le_Sup _).trans le_sup_right),
    rw ← disjoint_iff at *,
    have a_dis_Sup_s : disjoint a (Sup s) := con.mono_right le_sup_right,
    rw ← s_max (s ∪ {a}) ⟨λ x hx, _, ⟨_, λ x hx, _⟩⟩ (set.subset_union_left _ _),
    { exact set.mem_union_right _ (set.mem_singleton _) },
    { rw [set.mem_union, set.mem_singleton_iff] at hx,
      by_cases xa : x = a,
      { simp only [xa, set.mem_singleton, set.insert_diff_of_mem, set.union_singleton],
        exact con.mono_right (le_trans (Sup_le_Sup (set.diff_subset s {a})) le_sup_right) },
      { have h : (s ∪ {a}) \ {x} = (s \ {x}) ∪ {a},
        { simp only [set.union_singleton],
          rw set.insert_diff_of_not_mem,
          rw set.mem_singleton_iff,
          exact ne.symm xa },
        rw [h, Sup_union, Sup_singleton],
        apply (s_ind (hx.resolve_right xa)).disjoint_sup_right_of_disjoint_sup_left
          (a_dis_Sup_s.mono_right _).symm,
        rw [← Sup_insert, set.insert_diff_singleton,
          set.insert_eq_of_mem (hx.resolve_right xa)] } },
    { rw [Sup_union, Sup_singleton, ← disjoint_iff],
      exact b_inf_Sup_s.disjoint_sup_right_of_disjoint_sup_left con.symm },
    { rw [set.mem_union, set.mem_singleton_iff] at hx,
      cases hx,
      { exact s_atoms x hx },
      { rw hx,
        exact ha } } },
  { intros c hc1 hc2,
    refine ⟨⋃₀ c, ⟨complete_lattice.independent_sUnion_of_directed hc2.directed_on
      (λ s hs, (hc1 hs).1), _, λ a ha, _⟩, λ _, set.subset_sUnion_of_mem⟩,
    { rw [Sup_sUnion, ← Sup_image, inf_Sup_eq_of_directed_on, supr_eq_bot],
      { intro i,
        rw supr_eq_bot,
        intro hi,
        obtain ⟨x, xc, rfl⟩ := (set.mem_image _ _ _).1 hi,
        exact (hc1 xc).2.1 },
      { rw directed_on_image,
        refine hc2.directed_on.mono (λ s t, Sup_le_Sup) } },
    { rcases set.mem_sUnion.1 ha with ⟨s, sc, as⟩,
      exact (hc1 sc).2.2 a as } }
end⟩

/-- See Theorem 6.6, Călugăreanu -/
theorem is_complemented_of_is_atomistic [is_atomistic α] : is_complemented α :=
is_complemented_of_Sup_atoms_eq_top Sup_atoms_eq_top

theorem is_complemented_iff_is_atomistic : is_complemented α ↔ is_atomistic α :=
begin
  split; introsI,
  { exact is_atomistic_of_is_complemented },
  { exact is_complemented_of_is_atomistic }
end

end


/-
Copyright (c) 2021 Yaël Dillies, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Bhavik Mehta
-/
import analysis.convex.hull

/-!
# Extreme sets

This file defines extreme sets and extreme points for sets in a module.

An extreme set of `A` is a subset of `A` that is as far as it can get in any outward direction: If
point `x` is in it and point `y ∈ A`, then the line passing through `x` and `y` leaves `A` at `x`.
This is an analytic notion of "being on the side of". It is weaker than being exposed (see
`is_exposed.is_extreme`).

## Main declarations

* `is_extreme 𝕜 A B`: States that `B` is an extreme set of `A` (in the literature, `A` is often
  implicit).
* `set.extreme_points 𝕜 A`: Set of extreme points of `A` (corresponding to extreme singletons).
* `convex.mem_extreme_points_iff_convex_diff`: A useful equivalent condition to being an extreme
  point: `x` is an extreme point iff `A \ {x}` is convex.

## Implementation notes

The exact definition of extremeness has been carefully chosen so as to make as many lemmas
unconditional (in particular, the Krein-Milman theorem doesn't need the set to be convex!).
In practice, `A` is often assumed to be a convex set.

## References

See chapter 8 of [Barry Simon, *Convexity*][simon2011]

## TODO

Define intrinsic frontier and prove lemmas related to extreme sets and points.

More not-yet-PRed stuff is available on the branch `sperner_again`.
-/

open_locale classical affine
open set

variables (𝕜 : Type*) {E : Type*}

section has_scalar
variables [ordered_semiring 𝕜] [add_comm_monoid E] [has_scalar 𝕜 E]

/-- A set `B` is an extreme subset of `A` if `B ⊆ A` and all points of `B` only belong to open
segments whose ends are in `B`. -/
def is_extreme (A B : set E) : Prop :=
B ⊆ A ∧ ∀ ⦃x₁⦄, x₁ ∈ A → ∀ ⦃x₂⦄, x₂ ∈ A → ∀ ⦃x⦄, x ∈ B → x ∈ open_segment 𝕜 x₁ x₂ → x₁ ∈ B ∧ x₂ ∈ B

/-- A point `x` is an extreme point of a set `A` if `x` belongs to no open segment with ends in
`A`, except for the obvious `open_segment x x`. -/
def set.extreme_points (A : set E) : set E :=
{x ∈ A | ∀ ⦃x₁⦄, x₁ ∈ A → ∀ ⦃x₂⦄, x₂ ∈ A → x ∈ open_segment 𝕜 x₁ x₂ → x₁ = x ∧ x₂ = x}

@[refl] protected lemma is_extreme.refl (A : set E) :
  is_extreme 𝕜 A A :=
⟨subset.rfl, λ x₁ hx₁A x₂ hx₂A x hxA hx, ⟨hx₁A, hx₂A⟩⟩

variables {𝕜} {A B C : set E} {x : E}

protected lemma is_extreme.rfl :
  is_extreme 𝕜 A A :=
is_extreme.refl 𝕜 A

@[trans] protected lemma is_extreme.trans (hAB : is_extreme 𝕜 A B) (hBC : is_extreme 𝕜 B C) :
  is_extreme 𝕜 A C :=
begin
  refine ⟨subset.trans hBC.1 hAB.1, λ x₁ hx₁A x₂ hx₂A x hxC hx, _⟩,
  obtain ⟨hx₁B, hx₂B⟩ := hAB.2 hx₁A hx₂A (hBC.1 hxC) hx,
  exact hBC.2 hx₁B hx₂B hxC hx,
end

protected lemma is_extreme.antisymm :
  anti_symmetric (is_extreme 𝕜 : set E → set E → Prop) :=
λ A B hAB hBA, subset.antisymm hBA.1 hAB.1

instance : is_partial_order (set E) (is_extreme 𝕜) :=
{ refl := is_extreme.refl 𝕜,
  trans := λ A B C, is_extreme.trans,
  antisymm := is_extreme.antisymm }

lemma is_extreme.inter (hAB : is_extreme 𝕜 A B) (hAC : is_extreme 𝕜 A C) :
  is_extreme 𝕜 A (B ∩ C) :=
begin
  use subset.trans (inter_subset_left _ _) hAB.1,
  rintro x₁ hx₁A x₂ hx₂A x ⟨hxB, hxC⟩ hx,
  obtain ⟨hx₁B, hx₂B⟩ := hAB.2 hx₁A hx₂A hxB hx,
  obtain ⟨hx₁C, hx₂C⟩ := hAC.2 hx₁A hx₂A hxC hx,
  exact ⟨⟨hx₁B, hx₁C⟩, hx₂B, hx₂C⟩,
end

protected lemma is_extreme.mono (hAC : is_extreme 𝕜 A C) (hBA : B ⊆ A) (hCB : C ⊆ B) :
  is_extreme 𝕜 B C :=
⟨hCB, λ x₁ hx₁B x₂ hx₂B x hxC hx, hAC.2 (hBA hx₁B) (hBA hx₂B) hxC hx⟩

lemma is_extreme_Inter {ι : Type*} [nonempty ι] {F : ι → set E}
  (hAF : ∀ i : ι, is_extreme 𝕜 A (F i)) :
  is_extreme 𝕜 A (⋂ i : ι, F i) :=
begin
  obtain i := classical.arbitrary ι,
  refine ⟨Inter_subset_of_subset i (hAF i).1, λ x₁ hx₁A x₂ hx₂A x hxF hx, _⟩,
  simp_rw mem_Inter at ⊢ hxF,
  have h := λ i, (hAF i).2 hx₁A hx₂A (hxF i) hx,
  exact ⟨λ i, (h i).1, λ i, (h i).2⟩,
end

lemma is_extreme_bInter {F : set (set E)} (hF : F.nonempty)
  (hAF : ∀ B ∈ F, is_extreme 𝕜 A B) :
  is_extreme 𝕜 A (⋂ B ∈ F, B) :=
begin
  obtain ⟨B, hB⟩ := hF,
  refine ⟨(bInter_subset_of_mem hB).trans (hAF B hB).1, λ x₁ hx₁A x₂ hx₂A x hxF hx, _⟩,
  simp_rw mem_Inter₂ at ⊢ hxF,
  have h := λ B hB, (hAF B hB).2 hx₁A hx₂A (hxF B hB) hx,
  exact ⟨λ B hB, (h B hB).1, λ B hB, (h B hB).2⟩,
end

lemma is_extreme_sInter {F : set (set E)} (hF : F.nonempty)
  (hAF : ∀ B ∈ F, is_extreme 𝕜 A B) :
  is_extreme 𝕜 A (⋂₀ F) :=
begin
  obtain ⟨B, hB⟩ := hF,
  refine ⟨(sInter_subset_of_mem hB).trans (hAF B hB).1, λ x₁ hx₁A x₂ hx₂A x hxF hx, _⟩,
  simp_rw mem_sInter at ⊢ hxF,
  have h := λ B hB, (hAF B hB).2 hx₁A hx₂A (hxF B hB) hx,
  exact ⟨λ B hB, (h B hB).1, λ B hB, (h B hB).2⟩,
end

lemma extreme_points_def :
  x ∈ A.extreme_points 𝕜 ↔ x ∈ A ∧ ∀ (x₁ x₂ ∈ A), x ∈ open_segment 𝕜 x₁ x₂ → x₁ = x ∧ x₂ = x :=
iff.rfl

/-- x is an extreme point to A iff {x} is an extreme set of A. -/
lemma mem_extreme_points_iff_extreme_singleton :
  x ∈ A.extreme_points 𝕜 ↔ is_extreme 𝕜 A {x} :=
begin
  refine ⟨_, λ hx, ⟨singleton_subset_iff.1 hx.1, λ x₁ hx₁ x₂ hx₂, hx.2 hx₁ hx₂ rfl⟩⟩,
  rintro ⟨hxA, hAx⟩,
  use singleton_subset_iff.2 hxA,
  rintro x₁ hx₁A x₂ hx₂A y (rfl : y = x),
  exact hAx hx₁A hx₂A,
end

lemma extreme_points_subset : A.extreme_points 𝕜 ⊆ A := λ x hx, hx.1

@[simp] lemma extreme_points_empty :
  (∅ : set E).extreme_points 𝕜 = ∅ :=
subset_empty_iff.1 extreme_points_subset

@[simp] lemma extreme_points_singleton :
  ({x} : set E).extreme_points 𝕜 = {x} :=
extreme_points_subset.antisymm $ singleton_subset_iff.2
  ⟨mem_singleton x, λ x₁ hx₁ x₂ hx₂ _, ⟨hx₁, hx₂⟩⟩

lemma inter_extreme_points_subset_extreme_points_of_subset (hBA : B ⊆ A) :
  B ∩ A.extreme_points 𝕜 ⊆ B.extreme_points 𝕜 :=
λ x ⟨hxB, hxA⟩, ⟨hxB, λ x₁ hx₁ x₂ hx₂ hx, hxA.2 (hBA hx₁) (hBA hx₂) hx⟩

lemma is_extreme.extreme_points_subset_extreme_points (hAB : is_extreme 𝕜 A B) :
  B.extreme_points 𝕜 ⊆ A.extreme_points 𝕜 :=
λ x hx, mem_extreme_points_iff_extreme_singleton.2 (hAB.trans
  (mem_extreme_points_iff_extreme_singleton.1 hx))

lemma is_extreme.extreme_points_eq (hAB : is_extreme 𝕜 A B) :
  B.extreme_points 𝕜 = B ∩ A.extreme_points 𝕜 :=
subset.antisymm (λ x hx, ⟨hx.1, hAB.extreme_points_subset_extreme_points hx⟩)
  (inter_extreme_points_subset_extreme_points_of_subset hAB.1)

end has_scalar

section ordered_semiring
variables {𝕜} [ordered_semiring 𝕜] [add_comm_group E] [module 𝕜 E] {A B : set E} {x : E}

lemma is_extreme.convex_diff (hA : convex 𝕜 A) (hAB : is_extreme 𝕜 A B) :
  convex 𝕜 (A \ B) :=
convex_iff_open_segment_subset.2 (λ x₁ x₂ ⟨hx₁A, hx₁B⟩ ⟨hx₂A, hx₂B⟩ x hx,
    ⟨hA.open_segment_subset hx₁A hx₂A hx, λ hxB, hx₁B (hAB.2 hx₁A hx₂A hxB hx).1⟩)

end ordered_semiring

section linear_ordered_ring
variables {𝕜} [linear_ordered_ring 𝕜] [add_comm_group E] [module 𝕜 E]
variables [densely_ordered 𝕜] [no_zero_smul_divisors 𝕜 E] {A B : set E} {x : E}

/-- A useful restatement using `segment`: `x` is an extreme point iff the only (closed) segments
that contain it are those with `x` as one of their endpoints. -/
lemma mem_extreme_points_iff_forall_segment :
  x ∈ A.extreme_points 𝕜 ↔ x ∈ A ∧ ∀ (x₁ x₂ ∈ A), x ∈ segment 𝕜 x₁ x₂ → x₁ = x ∨ x₂ = x :=
begin
  refine and_congr_right (λ hxA, forall₄_congr $ λ x₁ h₁ x₂ h₂, _),
  split,
  { rw ← insert_endpoints_open_segment,
    rintro H (rfl|rfl|hx),
    exacts [or.inl rfl, or.inr rfl, or.inl $ (H hx).1] },
  { intros H hx,
    rcases H (open_segment_subset_segment _ _ _ hx) with rfl | rfl,
    exacts [⟨rfl, (left_mem_open_segment_iff.1 hx).symm⟩, ⟨right_mem_open_segment_iff.1 hx, rfl⟩] }
end

lemma convex.mem_extreme_points_iff_convex_diff (hA : convex 𝕜 A) :
  x ∈ A.extreme_points 𝕜 ↔ x ∈ A ∧ convex 𝕜 (A \ {x}) :=
begin
  use λ hx, ⟨hx.1, (mem_extreme_points_iff_extreme_singleton.1 hx).convex_diff hA⟩,
  rintro ⟨hxA, hAx⟩,
  refine mem_extreme_points_iff_forall_segment.2 ⟨hxA, λ x₁ hx₁ x₂ hx₂ hx, _⟩,
  rw convex_iff_segment_subset at hAx,
  by_contra' h,
  exact (hAx ⟨hx₁, λ hx₁, h.1 (mem_singleton_iff.2 hx₁)⟩
    ⟨hx₂, λ hx₂, h.2 (mem_singleton_iff.2 hx₂)⟩ hx).2 rfl,
end

lemma convex.mem_extreme_points_iff_mem_diff_convex_hull_diff (hA : convex 𝕜 A) :
  x ∈ A.extreme_points 𝕜 ↔ x ∈ A \ convex_hull 𝕜 (A \ {x}) :=
by rw [hA.mem_extreme_points_iff_convex_diff, hA.convex_remove_iff_not_mem_convex_hull_remove,
  mem_diff]

lemma extreme_points_convex_hull_subset :
  (convex_hull 𝕜 A).extreme_points 𝕜 ⊆ A :=
begin
  rintro x hx,
  rw (convex_convex_hull 𝕜 _).mem_extreme_points_iff_convex_diff at hx,
  by_contra,
  exact (convex_hull_min (subset_diff.2 ⟨subset_convex_hull 𝕜 _, disjoint_singleton_right.2 h⟩) hx.2
    hx.1).2 rfl,
  apply_instance
end

end linear_ordered_ring


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

! This file was ported from Lean 3 source module analysis.normed_space.indicator_function
! leanprover-community/mathlib commit 69c6a5a12d8a2b159f20933e60115a4f2de62b58
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.Normed.Group.Basic
import Mathbin.Algebra.IndicatorFunction

/-!
# Indicator function and norm

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

This file contains a few simple lemmas about `set.indicator` and `norm`.

## Tags
indicator, norm
-/

variable {α E : Type _} [SeminormedAddCommGroup E] {s t : Set α} (f : α → E) (a : α)

open Set

/- warning: norm_indicator_eq_indicator_norm -> norm_indicator_eq_indicator_norm is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {E : Type.{u2}} [_inst_1 : SeminormedAddCommGroup.{u2} E] {s : Set.{u1} α} (f : α -> E) (a : α), Eq.{1} Real (Norm.norm.{u2} E (SeminormedAddCommGroup.toHasNorm.{u2} E _inst_1) (Set.indicator.{u1, u2} α E (AddZeroClass.toHasZero.{u2} E (AddMonoid.toAddZeroClass.{u2} E (SubNegMonoid.toAddMonoid.{u2} E (AddGroup.toSubNegMonoid.{u2} E (SeminormedAddGroup.toAddGroup.{u2} E (SeminormedAddCommGroup.toSeminormedAddGroup.{u2} E _inst_1)))))) s f a)) (Set.indicator.{u1, 0} α Real Real.hasZero s (fun (a : α) => Norm.norm.{u2} E (SeminormedAddCommGroup.toHasNorm.{u2} E _inst_1) (f a)) a)
but is expected to have type
  forall {α : Type.{u1}} {E : Type.{u2}} [_inst_1 : SeminormedAddCommGroup.{u2} E] {s : Set.{u1} α} (f : α -> E) (a : α), Eq.{1} Real (Norm.norm.{u2} E (SeminormedAddCommGroup.toNorm.{u2} E _inst_1) (Set.indicator.{u1, u2} α E (NegZeroClass.toZero.{u2} E (SubNegZeroMonoid.toNegZeroClass.{u2} E (SubtractionMonoid.toSubNegZeroMonoid.{u2} E (SubtractionCommMonoid.toSubtractionMonoid.{u2} E (AddCommGroup.toDivisionAddCommMonoid.{u2} E (SeminormedAddCommGroup.toAddCommGroup.{u2} E _inst_1)))))) s f a)) (Set.indicator.{u1, 0} α Real Real.instZeroReal s (fun (a : α) => Norm.norm.{u2} E (SeminormedAddCommGroup.toNorm.{u2} E _inst_1) (f a)) a)
Case conversion may be inaccurate. Consider using '#align norm_indicator_eq_indicator_norm norm_indicator_eq_indicator_normₓ'. -/
theorem norm_indicator_eq_indicator_norm : ‖indicator s f a‖ = indicator s (fun a => ‖f a‖) a :=
  flip congr_fun a (indicator_comp_of_zero norm_zero).symm
#align norm_indicator_eq_indicator_norm norm_indicator_eq_indicator_norm

/- warning: nnnorm_indicator_eq_indicator_nnnorm -> nnnorm_indicator_eq_indicator_nnnorm is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {E : Type.{u2}} [_inst_1 : SeminormedAddCommGroup.{u2} E] {s : Set.{u1} α} (f : α -> E) (a : α), Eq.{1} NNReal (NNNorm.nnnorm.{u2} E (SeminormedAddGroup.toNNNorm.{u2} E (SeminormedAddCommGroup.toSeminormedAddGroup.{u2} E _inst_1)) (Set.indicator.{u1, u2} α E (AddZeroClass.toHasZero.{u2} E (AddMonoid.toAddZeroClass.{u2} E (SubNegMonoid.toAddMonoid.{u2} E (AddGroup.toSubNegMonoid.{u2} E (SeminormedAddGroup.toAddGroup.{u2} E (SeminormedAddCommGroup.toSeminormedAddGroup.{u2} E _inst_1)))))) s f a)) (Set.indicator.{u1, 0} α NNReal (MulZeroClass.toHasZero.{0} NNReal (NonUnitalNonAssocSemiring.toMulZeroClass.{0} NNReal (NonAssocSemiring.toNonUnitalNonAssocSemiring.{0} NNReal (Semiring.toNonAssocSemiring.{0} NNReal NNReal.semiring)))) s (fun (a : α) => NNNorm.nnnorm.{u2} E (SeminormedAddGroup.toNNNorm.{u2} E (SeminormedAddCommGroup.toSeminormedAddGroup.{u2} E _inst_1)) (f a)) a)
but is expected to have type
  forall {α : Type.{u1}} {E : Type.{u2}} [_inst_1 : SeminormedAddCommGroup.{u2} E] {s : Set.{u1} α} (f : α -> E) (a : α), Eq.{1} NNReal (NNNorm.nnnorm.{u2} E (SeminormedAddGroup.toNNNorm.{u2} E (SeminormedAddCommGroup.toSeminormedAddGroup.{u2} E _inst_1)) (Set.indicator.{u1, u2} α E (NegZeroClass.toZero.{u2} E (SubNegZeroMonoid.toNegZeroClass.{u2} E (SubtractionMonoid.toSubNegZeroMonoid.{u2} E (SubtractionCommMonoid.toSubtractionMonoid.{u2} E (AddCommGroup.toDivisionAddCommMonoid.{u2} E (SeminormedAddCommGroup.toAddCommGroup.{u2} E _inst_1)))))) s f a)) (Set.indicator.{u1, 0} α NNReal instNNRealZero s (fun (a : α) => NNNorm.nnnorm.{u2} E (SeminormedAddGroup.toNNNorm.{u2} E (SeminormedAddCommGroup.toSeminormedAddGroup.{u2} E _inst_1)) (f a)) a)
Case conversion may be inaccurate. Consider using '#align nnnorm_indicator_eq_indicator_nnnorm nnnorm_indicator_eq_indicator_nnnormₓ'. -/
theorem nnnorm_indicator_eq_indicator_nnnorm :
    ‖indicator s f a‖₊ = indicator s (fun a => ‖f a‖₊) a :=
  flip congr_fun a (indicator_comp_of_zero nnnorm_zero).symm
#align nnnorm_indicator_eq_indicator_nnnorm nnnorm_indicator_eq_indicator_nnnorm

/- warning: norm_indicator_le_of_subset -> norm_indicator_le_of_subset is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {E : Type.{u2}} [_inst_1 : SeminormedAddCommGroup.{u2} E] {s : Set.{u1} α} {t : Set.{u1} α}, (HasSubset.Subset.{u1} (Set.{u1} α) (Set.hasSubset.{u1} α) s t) -> (forall (f : α -> E) (a : α), LE.le.{0} Real Real.hasLe (Norm.norm.{u2} E (SeminormedAddCommGroup.toHasNorm.{u2} E _inst_1) (Set.indicator.{u1, u2} α E (AddZeroClass.toHasZero.{u2} E (AddMonoid.toAddZeroClass.{u2} E (SubNegMonoid.toAddMonoid.{u2} E (AddGroup.toSubNegMonoid.{u2} E (SeminormedAddGroup.toAddGroup.{u2} E (SeminormedAddCommGroup.toSeminormedAddGroup.{u2} E _inst_1)))))) s f a)) (Norm.norm.{u2} E (SeminormedAddCommGroup.toHasNorm.{u2} E _inst_1) (Set.indicator.{u1, u2} α E (AddZeroClass.toHasZero.{u2} E (AddMonoid.toAddZeroClass.{u2} E (SubNegMonoid.toAddMonoid.{u2} E (AddGroup.toSubNegMonoid.{u2} E (SeminormedAddGroup.toAddGroup.{u2} E (SeminormedAddCommGroup.toSeminormedAddGroup.{u2} E _inst_1)))))) t f a)))
but is expected to have type
  forall {α : Type.{u2}} {E : Type.{u1}} [_inst_1 : SeminormedAddCommGroup.{u1} E] {s : Set.{u2} α} {t : Set.{u2} α}, (HasSubset.Subset.{u2} (Set.{u2} α) (Set.instHasSubsetSet.{u2} α) s t) -> (forall (f : α -> E) (a : α), LE.le.{0} Real Real.instLEReal (Norm.norm.{u1} E (SeminormedAddCommGroup.toNorm.{u1} E _inst_1) (Set.indicator.{u2, u1} α E (NegZeroClass.toZero.{u1} E (SubNegZeroMonoid.toNegZeroClass.{u1} E (SubtractionMonoid.toSubNegZeroMonoid.{u1} E (SubtractionCommMonoid.toSubtractionMonoid.{u1} E (AddCommGroup.toDivisionAddCommMonoid.{u1} E (SeminormedAddCommGroup.toAddCommGroup.{u1} E _inst_1)))))) s f a)) (Norm.norm.{u1} E (SeminormedAddCommGroup.toNorm.{u1} E _inst_1) (Set.indicator.{u2, u1} α E (NegZeroClass.toZero.{u1} E (SubNegZeroMonoid.toNegZeroClass.{u1} E (SubtractionMonoid.toSubNegZeroMonoid.{u1} E (SubtractionCommMonoid.toSubtractionMonoid.{u1} E (AddCommGroup.toDivisionAddCommMonoid.{u1} E (SeminormedAddCommGroup.toAddCommGroup.{u1} E _inst_1)))))) t f a)))
Case conversion may be inaccurate. Consider using '#align norm_indicator_le_of_subset norm_indicator_le_of_subsetₓ'. -/
theorem norm_indicator_le_of_subset (h : s ⊆ t) (f : α → E) (a : α) :
    ‖indicator s f a‖ ≤ ‖indicator t f a‖ :=
  by
  simp only [norm_indicator_eq_indicator_norm]
  exact indicator_le_indicator_of_subset ‹_› (fun _ => norm_nonneg _) _
#align norm_indicator_le_of_subset norm_indicator_le_of_subset

/- warning: indicator_norm_le_norm_self -> indicator_norm_le_norm_self is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {E : Type.{u2}} [_inst_1 : SeminormedAddCommGroup.{u2} E] {s : Set.{u1} α} (f : α -> E) (a : α), LE.le.{0} Real Real.hasLe (Set.indicator.{u1, 0} α Real Real.hasZero s (fun (a : α) => Norm.norm.{u2} E (SeminormedAddCommGroup.toHasNorm.{u2} E _inst_1) (f a)) a) (Norm.norm.{u2} E (SeminormedAddCommGroup.toHasNorm.{u2} E _inst_1) (f a))
but is expected to have type
  forall {α : Type.{u2}} {E : Type.{u1}} [_inst_1 : SeminormedAddCommGroup.{u1} E] {s : Set.{u2} α} (f : α -> E) (a : α), LE.le.{0} Real Real.instLEReal (Set.indicator.{u2, 0} α Real Real.instZeroReal s (fun (a : α) => Norm.norm.{u1} E (SeminormedAddCommGroup.toNorm.{u1} E _inst_1) (f a)) a) (Norm.norm.{u1} E (SeminormedAddCommGroup.toNorm.{u1} E _inst_1) (f a))
Case conversion may be inaccurate. Consider using '#align indicator_norm_le_norm_self indicator_norm_le_norm_selfₓ'. -/
theorem indicator_norm_le_norm_self : indicator s (fun a => ‖f a‖) a ≤ ‖f a‖ :=
  indicator_le_self' (fun _ _ => norm_nonneg _) a
#align indicator_norm_le_norm_self indicator_norm_le_norm_self

/- warning: norm_indicator_le_norm_self -> norm_indicator_le_norm_self is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {E : Type.{u2}} [_inst_1 : SeminormedAddCommGroup.{u2} E] {s : Set.{u1} α} (f : α -> E) (a : α), LE.le.{0} Real Real.hasLe (Norm.norm.{u2} E (SeminormedAddCommGroup.toHasNorm.{u2} E _inst_1) (Set.indicator.{u1, u2} α E (AddZeroClass.toHasZero.{u2} E (AddMonoid.toAddZeroClass.{u2} E (SubNegMonoid.toAddMonoid.{u2} E (AddGroup.toSubNegMonoid.{u2} E (SeminormedAddGroup.toAddGroup.{u2} E (SeminormedAddCommGroup.toSeminormedAddGroup.{u2} E _inst_1)))))) s f a)) (Norm.norm.{u2} E (SeminormedAddCommGroup.toHasNorm.{u2} E _inst_1) (f a))
but is expected to have type
  forall {α : Type.{u1}} {E : Type.{u2}} [_inst_1 : SeminormedAddCommGroup.{u2} E] {s : Set.{u1} α} (f : α -> E) (a : α), LE.le.{0} Real Real.instLEReal (Norm.norm.{u2} E (SeminormedAddCommGroup.toNorm.{u2} E _inst_1) (Set.indicator.{u1, u2} α E (NegZeroClass.toZero.{u2} E (SubNegZeroMonoid.toNegZeroClass.{u2} E (SubtractionMonoid.toSubNegZeroMonoid.{u2} E (SubtractionCommMonoid.toSubtractionMonoid.{u2} E (AddCommGroup.toDivisionAddCommMonoid.{u2} E (SeminormedAddCommGroup.toAddCommGroup.{u2} E _inst_1)))))) s f a)) (Norm.norm.{u2} E (SeminormedAddCommGroup.toNorm.{u2} E _inst_1) (f a))
Case conversion may be inaccurate. Consider using '#align norm_indicator_le_norm_self norm_indicator_le_norm_selfₓ'. -/
theorem norm_indicator_le_norm_self : ‖indicator s f a‖ ≤ ‖f a‖ :=
  by
  rw [norm_indicator_eq_indicator_norm]
  apply indicator_norm_le_norm_self
#align norm_indicator_le_norm_self norm_indicator_le_norm_self


/-
Copyright (c) 2020 Xi Wang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Xi Wang.
-/

import tactic.basic

/-!
# A compiler for arithmetic expressions

A formalization of the correctness of a compiler from arithmetic expressions to assembly code
described by McCarthy and Painter.

## Tags

compiler

## Main results

* `expr`                : the syntax of the source language.
* `value`               : the semantics of the source language.
* `instruction`         : the syntax of the target language.
* `step`                : the semantics of the target language.
* `compile`             : the compiler.
* `compiler_correctness`: the compiler correctness theorem.

## Notation

* `≃[t]/ac`: partial equality of two machine states excluding registers x ≥ t and the accumulator.
* `≃[t]`   : partial equality of two machine states excluding registers x ≥ t.

## References

* John McCarthy and James Painter. Correctness of a compiler for arithmetic expressions.
  In Mathematical Aspects of Computer Science, volume 19 of Proceedings of Symposia in
  Applied Mathematics, 1967. <http://jmc.stanford.edu/articles/mcpain/mcpain.pdf>
-/

namespace arithcc

section types

/-! ### Types -/

/-- Value type shared by both source and target languages.  -/
@[reducible]
def word := ℕ

/-- Variable identifier type in the source language. -/
@[reducible]
def identifier := string

/-- Register name type in the target language. -/
@[reducible]
def register := ℕ

lemma register.lt_succ_self :
  ∀ (r : register), r < r + 1 :=
nat.lt_succ_self

lemma register.le_of_lt_succ {r₁ r₂ : register} :
  r₁ < r₂ + 1 → r₁ ≤ r₂ :=
nat.le_of_succ_le_succ

end types

section source

/-! ### Source language -/

/-- An expression in the source language is formed by constants, variables, and sums. -/
@[derive inhabited]
inductive expr
| const (v : word) : expr
| var (x : identifier) : expr
| sum (s₁ s₂ : expr) : expr

/-- The semantics of the source language (2.1). -/
@[simp]
def value : expr → (identifier → word) → word
| (expr.const v)   _ := v
| (expr.var x)     ξ := ξ x
| (expr.sum s₁ s₂) ξ := (value s₁ ξ) + (value s₂ ξ)

end source

section target

/-! ### Target language -/

/-- Instructions of the target assembly language (3.1--3.7).  -/
@[derive inhabited]
inductive instruction
| li   : word → instruction
| load : register → instruction
| sto  : register → instruction
| add  : register → instruction

/-- Machine state consists of the accumulator ac and a vector of registers.

The paper uses two functions `c` and `a` for accessing both the accumulator and registers.
Instead, we make accessing the accumulator and registers explicit, using `read` and `write`
for accessing registers only.
-/
structure state :=
mk :: (ac : word) (rs : register → word)

instance : inhabited state :=
⟨{ac := 0, rs := λ x, 0}⟩

/-- It's similar to the `c` function (3.8), but accesses registers only.  -/
@[simp]
def read (r : register) (η : state) : word :=
η.rs r

/-- The resulting machine state of updating a register. -/
@[simp]
def write (r : register) (v : word) (η : state) : state :=
{rs := λ x, if x = r then v else η.rs x, ..η}

/-- The semantics of the target language (3.11). -/
def step : instruction → state → state
| (instruction.li   v) η := {ac := v, ..η}
| (instruction.load r) η := {ac := read r η, ..η}
| (instruction.sto  r) η := write r η.ac η
| (instruction.add  r) η := {ac := read r η + η.ac, ..η}

/-- The resulting machine state of running a target program from a given machine state (3.12). -/
@[simp]
def outcome : list instruction → state → state
| []        η := η
| (i :: is) η := outcome is (step i η)

/-- A lemma on the concatenation of two programs (3.13). -/
@[simp]
lemma outcome_append (p₁ p₂ : list instruction) (η : state) :
  outcome (p₁ ++ p₂) η = outcome p₂ (outcome p₁ η) :=
begin
  revert η,
  induction p₁; intros; simp,
  apply p₁_ih
end

end target

section compiler

open instruction

/-! ### Compiler -/

/-- Map a variable in the source expression to a machine register. -/
@[simp]
def loc (ν : identifier) (map : identifier → register) : register :=
map ν

/-- The implementation of the compiler (4.2).

This definition explicitly takes a map from variables to registers.
-/
@[simp]
def compile (map : identifier → register) : expr → register → (list instruction)
| (expr.const v)   _ := [li v]
| (expr.var x)     _ := [load (loc x map)]
| (expr.sum s₁ s₂) t := compile s₁ t ++ [sto t] ++ compile s₂ (t + 1) ++ [add t]

end compiler

section correctness

/-! ### Correctness -/

/-- Machine states ζ₁ and ζ₂ are equal except for the accumulator and registers {x | x ≥ t}. -/
def state_eq_rs (t : register) (ζ₁ ζ₂ : state) : Prop :=
∀ (r : register), r < t → ζ₁.rs r = ζ₂.rs r

notation ζ₁ ` ≃[`:50 t `]/ac ` ζ₂:50 := state_eq_rs t ζ₁ ζ₂

@[refl]
protected lemma state_eq_rs.refl (t : register) (ζ : state) :
  ζ ≃[t]/ac ζ :=
by simp [state_eq_rs]

@[symm]
protected lemma state_eq_rs.symm {t : register} (ζ₁ ζ₂ : state) :
  ζ₁ ≃[t]/ac ζ₂ →
  ζ₂ ≃[t]/ac ζ₁ :=
by finish [state_eq_rs]

@[trans]
protected lemma state_eq_rs.trans {t : register} (ζ₁ ζ₂ ζ₃ : state) :
  ζ₁ ≃[t]/ac ζ₂ →
  ζ₂ ≃[t]/ac ζ₃ →
  ζ₁ ≃[t]/ac ζ₃ :=
by finish [state_eq_rs]

/-- Machine states ζ₁ and ζ₂ are equal except for registers {x | x ≥ t}. -/
def state_eq (t : register) (ζ₁ ζ₂ : state) : Prop :=
ζ₁.ac = ζ₂.ac ∧ state_eq_rs t ζ₁ ζ₂

notation ζ₁ ` ≃[`:50 t `] ` ζ₂:50 := state_eq t ζ₁ ζ₂

@[refl]
protected lemma state_eq.refl (t : register) (ζ : state) :
  ζ ≃[t] ζ :=
by simp [state_eq]

@[symm]
protected lemma state_eq.symm {t : register} (ζ₁ ζ₂ : state) :
  ζ₁ ≃[t] ζ₂ →
  ζ₂ ≃[t] ζ₁ :=
begin
  simp [state_eq], intros,
  split; try { cc },
  symmetry,
  assumption
end

@[trans]
protected lemma state_eq.trans {t : register} (ζ₁ ζ₂ ζ₃ : state) :
  ζ₁ ≃[t] ζ₂ →
  ζ₂ ≃[t] ζ₃ →
  ζ₁ ≃[t] ζ₃ :=
begin
  simp [state_eq], intros,
  split; try { cc },
  transitivity ζ₂; assumption
end

/-- Transitivity of chaining `≃[t]` and `≃[t]/ac`. -/
@[trans]
protected theorem state_eq_state_eq_rs.trans (t : register) (ζ₁ ζ₂ ζ₃ : state) :
  ζ₁ ≃[t] ζ₂ →
  ζ₂ ≃[t]/ac ζ₃ →
  ζ₁ ≃[t]/ac ζ₃ :=
begin
  simp [state_eq], intros,
  transitivity ζ₂; assumption
end

/-- Writing the same value to register `t` gives `≃[t + 1]` from `≃[t]`. -/
lemma state_eq_implies_write_eq {t : register} {ζ₁ ζ₂ : state} (h : ζ₁ ≃[t] ζ₂) (v : word) :
  write t v ζ₁ ≃[t + 1] write t v ζ₂ :=
begin
  simp [state_eq, state_eq_rs] at *,
  split ; try { cc },
  intros _ hr,
  have hr : r ≤ t := register.le_of_lt_succ hr,
  cases lt_or_eq_of_le hr with hr hr,
  { cases h with _ h,
    specialize h r hr,
    cc },
  { cc }
end

/-- Writing the same value to any register preserves `≃[t]/ac`. -/
lemma state_eq_rs_implies_write_eq_rs {t : register} {ζ₁ ζ₂ : state} (h : ζ₁ ≃[t]/ac ζ₂)
                                      (r : register) (v : word) :
  write r v ζ₁ ≃[t]/ac write r v ζ₂ :=
begin
  simp [state_eq_rs] at *,
  intros r' hr',
  specialize h r' hr',
  cc
end

/-- `≃[t + 1]` with writing to register `t` implies `≃[t]`. -/
lemma write_eq_implies_state_eq {t : register} {v : word} {ζ₁ ζ₂ : state}
                                (h : ζ₁ ≃[t + 1] write t v ζ₂) :
  ζ₁ ≃[t] ζ₂ :=
begin
  simp [state_eq, state_eq_rs] at *,
  split; try { cc },
  intros r hr,
  cases h with _ h,
  specialize h r (lt_trans hr (register.lt_succ_self _)),
  rwa if_neg (ne_of_lt hr) at h
end

/-- The main theorem on compiler correctness.

Unlike Theorem 1 in the paper, both `map` and the assumption on `t` are explicit.
-/
theorem compiler_correctness :
  ∀ (map : identifier → register) (e : expr) (ξ : identifier → word) (η : state) (t : register),
    (∀ x, read (loc x map) η = ξ x) →
    (∀ x, loc x map < t) →
    outcome (compile map e t) η ≃[t] {ac := value e ξ, ..η} :=
begin
  intros _ _ _ _ _ hmap ht,
  revert η t,
  induction e; intros,

  -- 5.I
  case expr.const { simp [state_eq, step] },

  -- 5.II
  case expr.var   { finish [hmap, state_eq, step] },

  -- 5.III
  case expr.sum   { simp,
    generalize_hyp dν₁ : value e_s₁ ξ = ν₁ at e_ih_s₁ ⊢,
    generalize_hyp dν₂ : value e_s₂ ξ = ν₂ at e_ih_s₂ ⊢,
    generalize     dν  : ν₁ + ν₂ = ν,

    generalize dζ₁ : outcome (compile _ e_s₁ t) η        = ζ₁,
    generalize dζ₂ : step (instruction.sto t) ζ₁         = ζ₂,
    generalize dζ₃ : outcome (compile _ e_s₂ (t + 1)) ζ₂ = ζ₃,
    generalize dζ₄ : step (instruction.add t) ζ₃         = ζ₄,

    have hζ₁ : ζ₁ ≃[t] {ac := ν₁, ..η},
    calc ζ₁
        = outcome (compile map e_s₁ t) η : by cc
    ... ≃[t] {ac := ν₁, ..η}             : by apply e_ih_s₁; assumption,

    have hζ₁_ν₁ : ζ₁.ac = ν₁,
    { finish [state_eq] },

    have hζ₂ : ζ₂ ≃[t + 1]/ac write t ν₁ η,
    calc ζ₂
        = step (instruction.sto t) ζ₁       : by cc
    ... = write t ζ₁.ac ζ₁                  : by simp [step]
    ... = write t ν₁ ζ₁                     : by cc
    ... ≃[t + 1] write t ν₁ {ac := ν₁, ..η} : by apply state_eq_implies_write_eq hζ₁
    ... ≃[t + 1]/ac write t ν₁ η            : by { apply state_eq_rs_implies_write_eq_rs,
                                                   simp [state_eq_rs] },

    have hζ₂_ν₂ : read t ζ₂ = ν₁,
    { simp [state_eq_rs] at hζ₂ ⊢,
      specialize hζ₂ t (register.lt_succ_self _),
      cc },

    have ht' : ∀ x, loc x map < t + 1,
    { intros,
      apply lt_trans (ht _) (register.lt_succ_self _) },

    have hmap' : ∀ x, read (loc x map) ζ₂ = ξ x,
    { intros,
      calc read (loc x map) ζ₂
          = read (loc x map) (write t ν₁ η) : by { apply hζ₂, apply ht' }
      ... = read (loc x map) η              : by { simp, rw if_neg, apply ne_of_lt (ht _) }
      ... = ξ x                             : by apply hmap
    },

    have hζ₃ : ζ₃ ≃[t + 1] {ac := ν₂, ..(write t ν₁ η)},
    calc ζ₃
        = outcome (compile map e_s₂ (t + 1)) ζ₂ : by cc
    ... ≃[t + 1] {ac := ν₂, ..ζ₂}               : by apply e_ih_s₂; assumption
    ... ≃[t + 1] {ac := ν₂, ..(write t ν₁ η)}   : by { simp [state_eq], apply hζ₂ },

    have hζ₃_ν₂ : ζ₃.ac = ν₂,
    { finish [state_eq] },

    have hζ₃_ν₁ : read t ζ₃ = ν₁,
    { simp [state_eq, state_eq_rs] at hζ₃ ⊢,
      cases hζ₃ with _ hζ₃,
      specialize hζ₃ t (register.lt_succ_self _),
      cc },

    have hζ₄ : ζ₄ ≃[t + 1] {ac := ν, ..write t ν₁ η},
    calc ζ₄
        = step (instruction.add t) ζ₃      : by cc
    ... = {ac := read t ζ₃ + ζ₃.ac, ..ζ₃}  : by simp [step]
    ... = {ac := ν, ..ζ₃}                  : by cc
    ... ≃[t + 1] {ac := ν, ..{ac := ν₂, ..write t ν₁ η}}
                                           : by { simp [state_eq] at hζ₃ ⊢, cases hζ₃, assumption }
    ... ≃[t + 1] {ac := ν, ..write t ν₁ η} : by simp,

    apply write_eq_implies_state_eq; assumption }
end

end correctness

end arithcc


import algebra.category.Group
import algebra.category.Module.epi_mono

section

open category_theory

universe u

variables {A B : Type u} [add_comm_group A] [add_comm_group B]
variables (f : AddCommGroup.of A ⟶ AddCommGroup.of B)

lemma AddCommGroup.mono_iff_injective :
  category_theory.mono f ↔ function.injective f :=
begin
  set f' : (⟨A⟩ : Module ℤ) ⟶ (⟨B⟩ : Module ℤ) :=
  { to_fun := f,
    map_add' := λ x y, by simp only [map_add],
    map_smul' := λ z a, begin
      induction z using int.induction_on with n hn n hn,
      { simp only [ring_hom.id_apply, zero_smul, map_zero], },
      { simp only [add_smul, map_add, one_smul, hn, ring_hom.id_apply], },
      { simp only [sub_smul, map_sub, one_smul, hn, ring_hom.id_apply], },
    end } with f'_eq,
  have iff1 : mono f' ↔ function.injective f' := Module.mono_iff_injective _,
  have iff2 : function.injective f ↔ function.injective f',
  { split,
    { rintros hf a b (eq1 : f a = f b),
      exact hf eq1, },
    { rintros hf' a b (eq1 : f' a = f' b),
      exact hf' eq1, }, },
  have iff3 : mono f ↔ mono f',
  { split,
    { intros m,
      split,
      rintros Z g h eq1,
      set g' : AddCommGroup.of Z ⟶ AddCommGroup.of A := g.to_add_monoid_hom,
      set h' : AddCommGroup.of Z ⟶ AddCommGroup.of A := h.to_add_monoid_hom,
      have eq2 : g' ≫ f = h' ≫ f,
      { ext,
        have := fun_like.congr_fun eq1 x,
        exact this, },
      resetI,
      rw cancel_mono f at eq2,
      ext,
      convert fun_like.congr_fun eq2 x, },
    { intros m,
      split,
      intros Z g h eq1,
      set g' : (Module.mk Z : Module ℤ) ⟶ Module.mk A :=
      { to_fun := g, map_add' := λ _ _, by rw map_add, map_smul' := λ z a,
        begin
          induction z using int.induction_on with n hn n hn,
          { simp only [zero_smul, map_zero, ring_hom.id_apply], },
          { simp only [add_smul, map_add, hn, one_smul, ring_hom.id_apply], },
          { simp only [sub_smul, map_sub, hn, one_smul, ring_hom.id_apply], }
        end },
      set h' : (Module.mk Z : Module ℤ) ⟶ Module.mk A :=
      { to_fun := h, map_add' := λ _ _, by rw map_add, map_smul' := λ z a,
        begin
          induction z using int.induction_on with n hn n hn,
          { simp only [zero_smul, map_zero, ring_hom.id_apply], },
          { simp only [add_smul, map_add, hn, one_smul, ring_hom.id_apply], },
          { simp only [sub_smul, map_sub, hn, one_smul, ring_hom.id_apply], }
        end },
      have eq2 : g' ≫ f' = h' ≫ f',
      { ext,
        convert fun_like.congr_fun eq1 x, },
      resetI,
      rw cancel_mono at eq2,
      ext,
      convert fun_like.congr_fun eq2 x, }, },
  rw [iff3, iff2, iff1],
end

end


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Kenny Lau

! This file was ported from Lean 3 source module data.list.nodup
! leanprover-community/mathlib commit c227d107bbada5d0d9d20287e3282c0a7f1651a0
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.List.Lattice
import Mathlib.Data.List.Pairwise
import Mathlib.Data.List.Forall2
import Mathlib.Data.Set.Pairwise.Basic

/-!
# Lists with no duplicates

`List.Nodup` is defined in `Data/List/Basic`. In this file we prove various properties of this
predicate.
-/

universe u v

open Nat Function

variable {α : Type u} {β : Type v} {l l₁ l₂ : List α} {r : α → α → Prop} {a b : α}

namespace List

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

@[simp]
theorem nodup_nil : @Nodup α [] :=
  Pairwise.nil
#align list.nodup_nil List.nodup_nil

@[simp]
theorem nodup_cons {a : α} {l : List α} : Nodup (a :: l) ↔ a ∉ l ∧ Nodup l := by
  simp only [Nodup, pairwise_cons, forall_mem_ne]
#align list.nodup_cons List.nodup_cons

protected theorem Pairwise.nodup {l : List α} {r : α → α → Prop} [IsIrrefl α r] (h : Pairwise r l) :
    Nodup l :=
  h.imp ne_of_irrefl
#align list.pairwise.nodup List.Pairwise.nodup

theorem rel_nodup {r : α → β → Prop} (hr : Relator.BiUnique r) : (Forall₂ r ⇒ (· ↔ ·)) Nodup Nodup
  | _, _, Forall₂.nil => by simp only [nodup_nil]
  | _, _, Forall₂.cons hab h => by
    simpa only [nodup_cons] using
      Relator.rel_and (Relator.rel_not (rel_mem hr hab h)) (rel_nodup hr h)
#align list.rel_nodup List.rel_nodup

protected theorem Nodup.cons (ha : a ∉ l) (hl : Nodup l) : Nodup (a :: l) :=
  nodup_cons.2 ⟨ha, hl⟩
#align list.nodup.cons List.Nodup.cons

theorem nodup_singleton (a : α) : Nodup [a] :=
  pairwise_singleton _ _
#align list.nodup_singleton List.nodup_singleton

theorem Nodup.of_cons (h : Nodup (a :: l)) : Nodup l :=
  (nodup_cons.1 h).2
#align list.nodup.of_cons List.Nodup.of_cons

theorem Nodup.not_mem (h : (a :: l).Nodup) : a ∉ l :=
  (nodup_cons.1 h).1
#align list.nodup.not_mem List.Nodup.not_mem

theorem not_nodup_cons_of_mem : a ∈ l → ¬Nodup (a :: l) :=
  imp_not_comm.1 Nodup.not_mem
#align list.not_nodup_cons_of_mem List.not_nodup_cons_of_mem

protected theorem Nodup.sublist : l₁ <+ l₂ → Nodup l₂ → Nodup l₁ :=
  Pairwise.sublist
#align list.nodup.sublist List.Nodup.sublist

theorem not_nodup_pair (a : α) : ¬Nodup [a, a] :=
  not_nodup_cons_of_mem <| mem_singleton_self _
#align list.not_nodup_pair List.not_nodup_pair

theorem nodup_iff_sublist {l : List α} : Nodup l ↔ ∀ a, ¬[a, a] <+ l :=
  ⟨fun d a h => not_nodup_pair a (d.sublist h),
    by
    induction' l with a l IH <;> intro h; · exact nodup_nil
    exact
      (IH fun a s => h a <| sublist_cons_of_sublist _ s).cons fun al =>
        h a <| (singleton_sublist.2 al).cons_cons _⟩
#align list.nodup_iff_sublist List.nodup_iff_sublist

--Porting note: new theorem
theorem nodup_iff_injective_get {l : List α} :
    Nodup l ↔ Function.Injective l.get :=
  pairwise_iff_get.trans
    ⟨fun h i j hg => by
      cases' i with i hi; cases' j with j hj
      rcases lt_trichotomy i j with (hij | rfl | hji)
      . exact (h ⟨i, hi⟩ ⟨j, hj⟩ hij hg).elim
      . rfl
      . exact (h ⟨j, hj⟩ ⟨i, hi⟩ hji hg.symm).elim,
      fun hinj i j hij h => Nat.ne_of_lt hij (Fin.veq_of_eq (hinj h))⟩

set_option linter.deprecated false in
@[deprecated nodup_iff_injective_get]
theorem nodup_iff_nthLe_inj {l : List α} :
    Nodup l ↔ ∀ i j h₁ h₂, nthLe l i h₁ = nthLe l j h₂ → i = j :=
  nodup_iff_injective_get.trans
    ⟨fun hinj _ _ _ _ h => congr_arg Fin.val (hinj h),
     fun hinj i j h => Fin.eq_of_veq (hinj i j i.2 j.2 h)⟩
#align list.nodup_iff_nth_le_inj List.nodup_iff_nthLe_inj

theorem Nodup.get_inj_iff {l : List α} (h : Nodup l) {i j : Fin l.length} :
    l.get i = l.get j ↔ i = j :=
  (nodup_iff_injective_get.1 h).eq_iff

set_option linter.deprecated false in
@[deprecated Nodup.get_inj_iff]
theorem Nodup.nthLe_inj_iff {l : List α} (h : Nodup l) {i j : ℕ} (hi : i < l.length)
    (hj : j < l.length) : l.nthLe i hi = l.nthLe j hj ↔ i = j :=
  ⟨nodup_iff_nthLe_inj.mp h _ _ _ _, by simp (config := { contextual := true })⟩
#align list.nodup.nth_le_inj_iff List.Nodup.nthLe_inj_iff

theorem nodup_iff_get?_ne_get? {l : List α} :
    l.Nodup ↔ ∀ i j : ℕ, i < j → j < l.length → l.get? i ≠ l.get? j := by
  rw [Nodup, pairwise_iff_get]
  constructor
  . intro h i j hij hj
    rw [get?_eq_get (lt_trans hij hj), get?_eq_get hj, Ne.def, Option.some_inj]
    exact h _ _ hij
  . intro h i j hij
    rw [Ne.def, ← Option.some_inj, ← get?_eq_get, ← get?_eq_get]
    exact h i j hij j.2
#align list.nodup_iff_nth_ne_nth List.nodup_iff_get?_ne_get?

theorem Nodup.ne_singleton_iff {l : List α} (h : Nodup l) (x : α) :
    l ≠ [x] ↔ l = [] ∨ ∃ y ∈ l, y ≠ x := by
  induction' l with hd tl hl
  · simp
  · specialize hl h.of_cons
    by_cases hx : tl = [x]
    · simpa [hx, and_comm, and_or_left] using h
    · rw [← Ne.def, hl] at hx
      rcases hx with (rfl | ⟨y, hy, hx⟩)
      · simp
      · suffices ∃ (y : α) (_ : y ∈ hd :: tl), y ≠ x by simpa [ne_nil_of_mem hy]
        exact ⟨y, mem_cons_of_mem _ hy, hx⟩
#align list.nodup.ne_singleton_iff List.Nodup.ne_singleton_iff

theorem not_nodup_of_get_eq_of_ne (xs : List α) (n m : Fin xs.length)
    (h : xs.get n = xs.get m) (hne : n ≠ m) : ¬Nodup xs := by
  rw [nodup_iff_injective_get]
  exact fun hinj => hne (hinj h)

set_option linter.deprecated false in
@[deprecated not_nodup_of_get_eq_of_ne]
theorem nthLe_eq_of_ne_imp_not_nodup (xs : List α) (n m : ℕ) (hn : n < xs.length)
    (hm : m < xs.length) (h : xs.nthLe n hn = xs.nthLe m hm) (hne : n ≠ m) : ¬Nodup xs := by
  rw [nodup_iff_nthLe_inj]
  simp only [exists_prop, exists_and_right, not_forall]
  exact ⟨n, m, ⟨hn, hm, h⟩, hne⟩
#align list.nth_le_eq_of_ne_imp_not_nodup List.nthLe_eq_of_ne_imp_not_nodup

--Porting note: new theorem
theorem get_indexOf [DecidableEq α] {l : List α} (H : Nodup l) (i : Fin l.length) :
    indexOf (get l i) l = i :=
  suffices (⟨indexOf (get l i) l, indexOf_lt_length.2 (get_mem _ _ _)⟩ : Fin l.length) = i
    from Fin.veq_of_eq this
  nodup_iff_injective_get.1 H (by simp)

set_option linter.deprecated false in
@[simp, deprecated get_indexOf]
theorem nthLe_index_of [DecidableEq α] {l : List α} (H : Nodup l) (n h) :
    indexOf (nthLe l n h) l = n :=
  nodup_iff_nthLe_inj.1 H _ _ _ h <| indexOf_nthLe <| indexOf_lt_length.2 <| nthLe_mem _ _ _
#align list.nth_le_index_of List.nthLe_index_of

theorem nodup_iff_count_le_one [DecidableEq α] {l : List α} : Nodup l ↔ ∀ a, count a l ≤ 1 :=
  nodup_iff_sublist.trans <|
    forall_congr' fun a =>
      have : [a, a] <+ l ↔ 1 < count a l := (@le_count_iff_replicate_sublist _ _ _ 2 _).symm
      (not_congr this).trans not_lt
#align list.nodup_iff_count_le_one List.nodup_iff_count_le_one

theorem nodup_replicate (a : α) : ∀ {n : ℕ}, Nodup (replicate n a) ↔ n ≤ 1
  | 0 => by simp [Nat.zero_le]
  | 1 => by simp
  | n + 2 =>
    iff_of_false
      (fun H => nodup_iff_sublist.1 H a ((replicate_sublist_replicate _).2 (Nat.le_add_left 2 n)))
      (not_le_of_lt <| Nat.le_add_left 2 n)
#align list.nodup_replicate List.nodup_replicate

@[simp]
theorem count_eq_one_of_mem [DecidableEq α] {a : α} {l : List α} (d : Nodup l) (h : a ∈ l) :
    count a l = 1 :=
  _root_.le_antisymm (nodup_iff_count_le_one.1 d a) (Nat.succ_le_of_lt (count_pos.2 h))
#align list.count_eq_one_of_mem List.count_eq_one_of_mem

theorem count_eq_of_nodup [DecidableEq α] {a : α} {l : List α} (d : Nodup l) :
    count a l = if a ∈ l then 1 else 0 := by
  split_ifs with h
  · exact count_eq_one_of_mem d h
  · exact count_eq_zero_of_not_mem h
#align list.count_eq_of_nodup List.count_eq_of_nodup

theorem Nodup.of_append_left : Nodup (l₁ ++ l₂) → Nodup l₁ :=
  Nodup.sublist (sublist_append_left l₁ l₂)
#align list.nodup.of_append_left List.Nodup.of_append_left

theorem Nodup.of_append_right : Nodup (l₁ ++ l₂) → Nodup l₂ :=
  Nodup.sublist (sublist_append_right l₁ l₂)
#align list.nodup.of_append_right List.Nodup.of_append_right

theorem nodup_append {l₁ l₂ : List α} : Nodup (l₁ ++ l₂) ↔ Nodup l₁ ∧ Nodup l₂ ∧ Disjoint l₁ l₂ :=
  by simp only [Nodup, pairwise_append, disjoint_iff_ne]
#align list.nodup_append List.nodup_append

theorem disjoint_of_nodup_append {l₁ l₂ : List α} (d : Nodup (l₁ ++ l₂)) : Disjoint l₁ l₂ :=
  (nodup_append.1 d).2.2
#align list.disjoint_of_nodup_append List.disjoint_of_nodup_append

theorem Nodup.append (d₁ : Nodup l₁) (d₂ : Nodup l₂) (dj : Disjoint l₁ l₂) : Nodup (l₁ ++ l₂) :=
  nodup_append.2 ⟨d₁, d₂, dj⟩
#align list.nodup.append List.Nodup.append

theorem nodup_middle {a : α} {l₁ l₂ : List α} :
    Nodup (l₁ ++ a :: l₂) ↔ Nodup (a :: (l₁ ++ l₂)) := by
  simp only [nodup_append, not_or, and_left_comm, and_assoc, nodup_cons, mem_append,
    disjoint_cons_right]
#align list.nodup_middle List.nodup_middle

theorem Nodup.of_map (f : α → β) {l : List α} : Nodup (map f l) → Nodup l :=
  (Pairwise.of_map f) fun _ _ => mt <| congr_arg f
#align list.nodup.of_map List.Nodup.of_mapₓ -- Porting note: different universe order

theorem Nodup.map_on {f : α → β} (H : ∀ x ∈ l, ∀ y ∈ l, f x = f y → x = y) (d : Nodup l) :
    (map f l).Nodup :=
  Pairwise.map _ (fun a b ⟨ma, mb, n⟩ e => n (H a ma b mb e)) (Pairwise.and_mem.1 d)
#align list.nodup.map_on List.Nodup.map_onₓ -- Porting note: different universe order

theorem inj_on_of_nodup_map {f : α → β} {l : List α} (d : Nodup (map f l)) :
    ∀ ⦃x⦄, x ∈ l → ∀ ⦃y⦄, y ∈ l → f x = f y → x = y := by
  induction' l with hd tl ih
  · simp
  · simp only [map, nodup_cons, mem_map, not_exists, not_and, ← Ne.def] at d
    simp only [mem_cons]
    rintro _ (rfl | h₁) _ (rfl | h₂) h₃
    · rfl
    · apply (d.1 _ h₂ h₃.symm).elim
    · apply (d.1 _ h₁ h₃).elim
    · apply ih d.2 h₁ h₂ h₃
#align list.inj_on_of_nodup_map List.inj_on_of_nodup_map

theorem nodup_map_iff_inj_on {f : α → β} {l : List α} (d : Nodup l) :
    Nodup (map f l) ↔ ∀ x ∈ l, ∀ y ∈ l, f x = f y → x = y :=
  ⟨inj_on_of_nodup_map, fun h => d.map_on h⟩
#align list.nodup_map_iff_inj_on List.nodup_map_iff_inj_on

protected theorem Nodup.map {f : α → β} (hf : Injective f) : Nodup l → Nodup (map f l) :=
  Nodup.map_on fun _ _ _ _ h => hf h
#align list.nodup.map List.Nodup.map -- Porting note: different universe order

theorem nodup_map_iff {f : α → β} {l : List α} (hf : Injective f) : Nodup (map f l) ↔ Nodup l :=
  ⟨Nodup.of_map _, Nodup.map hf⟩
#align list.nodup_map_iff List.nodup_map_iff

@[simp]
theorem nodup_attach {l : List α} : Nodup (attach l) ↔ Nodup l :=
  ⟨fun h => attach_map_val l ▸ h.map fun _ _ => Subtype.eq, fun h =>
    Nodup.of_map Subtype.val ((attach_map_val l).symm ▸ h)⟩
#align list.nodup_attach List.nodup_attach

alias nodup_attach ↔ Nodup.of_attach Nodup.attach
#align list.nodup.attach List.Nodup.attach
#align list.nodup.of_attach List.Nodup.of_attach

--Porting note: commented out
--attribute [protected] nodup.attach

theorem Nodup.pmap {p : α → Prop} {f : ∀ a, p a → β} {l : List α} {H}
    (hf : ∀ a ha b hb, f a ha = f b hb → a = b) (h : Nodup l) : Nodup (pmap f l H) := by
  rw [pmap_eq_map_attach]
  exact h.attach.map fun ⟨a, ha⟩ ⟨b, hb⟩ h => by congr; exact hf a (H _ ha) b (H _ hb) h
#align list.nodup.pmap List.Nodup.pmap

theorem Nodup.filter (p : α → Bool) {l} : Nodup l → Nodup (filter p l) := by
  simpa using Pairwise.filter (fun a ↦ p a)
#align list.nodup.filter List.Nodup.filter

@[simp]
theorem nodup_reverse {l : List α} : Nodup (reverse l) ↔ Nodup l :=
  pairwise_reverse.trans <| by simp only [Nodup, Ne.def, eq_comm]
#align list.nodup_reverse List.nodup_reverse

theorem Nodup.erase_eq_filter [DecidableEq α] {l} (d : Nodup l) (a : α) :
    l.erase a = l.filter (· ≠ a) := by
  induction' d with b l m _ IH; · rfl
  by_cases h : b = a
  · subst h
    rw [erase_cons_head, filter_cons_of_neg _ (by simp)]
    symm
    rw [filter_eq_self]
    simpa [@eq_comm α] using m
  · rw [erase_cons_tail _ h, filter_cons_of_pos, IH]
    simp [h]
#align list.nodup.erase_eq_filter List.Nodup.erase_eq_filter

theorem Nodup.erase [DecidableEq α] (a : α) : Nodup l → Nodup (l.erase a) :=
  Nodup.sublist <| erase_sublist _ _
#align list.nodup.erase List.Nodup.erase

theorem Nodup.diff [DecidableEq α] : l₁.Nodup → (l₁.diff l₂).Nodup :=
  Nodup.sublist <| diff_sublist _ _
#align list.nodup.diff List.Nodup.diff

theorem Nodup.mem_erase_iff [DecidableEq α] (d : Nodup l) : a ∈ l.erase b ↔ a ≠ b ∧ a ∈ l := by
  rw [d.erase_eq_filter, mem_filter, and_comm, decide_eq_true_iff]
#align list.nodup.mem_erase_iff List.Nodup.mem_erase_iff

theorem Nodup.not_mem_erase [DecidableEq α] (h : Nodup l) : a ∉ l.erase a := fun H =>
  (h.mem_erase_iff.1 H).1 rfl
#align list.nodup.not_mem_erase List.Nodup.not_mem_erase

theorem nodup_join {L : List (List α)} :
    Nodup (join L) ↔ (∀ l ∈ L, Nodup l) ∧ Pairwise Disjoint L := by
  simp only [Nodup, pairwise_join, disjoint_left.symm, forall_mem_ne]
#align list.nodup_join List.nodup_join

theorem nodup_bind {l₁ : List α} {f : α → List β} :
    Nodup (l₁.bind f) ↔
      (∀ x ∈ l₁, Nodup (f x)) ∧ Pairwise (fun a b : α => Disjoint (f a) (f b)) l₁ := by
  simp only [List.bind, nodup_join, pairwise_map, and_comm, and_left_comm, mem_map, exists_imp,
      and_imp]
  rw [show (∀ (l : List β) (x : α), f x = l → x ∈ l₁ → Nodup l) ↔ ∀ x : α, x ∈ l₁ → Nodup (f x)
      from forall_swap.trans <| forall_congr' fun _ => forall_eq']
#align list.nodup_bind List.nodup_bind

protected theorem Nodup.product {l₂ : List β} (d₁ : l₁.Nodup) (d₂ : l₂.Nodup) :
    (l₁.product l₂).Nodup :=
  nodup_bind.2
    ⟨fun a _ => d₂.map <| LeftInverse.injective fun b => (rfl : (a, b).2 = b),
      d₁.imp fun {a₁ a₂} n x h₁ h₂ => by
        rcases mem_map.1 h₁ with ⟨b₁, _, rfl⟩
        rcases mem_map.1 h₂ with ⟨b₂, mb₂, ⟨⟩⟩
        exact n rfl⟩
#align list.nodup.product List.Nodup.product

theorem Nodup.sigma {σ : α → Type _} {l₂ : ∀ a , List (σ a)} (d₁ : Nodup l₁)
    (d₂ : ∀ a , Nodup (l₂ a)) : (l₁.sigma l₂).Nodup :=
  nodup_bind.2
    ⟨fun a _ => (d₂ a).map fun b b' h => by injection h with _ h,
      d₁.imp fun {a₁ a₂} n x h₁ h₂ => by
        rcases mem_map.1 h₁ with ⟨b₁, _, rfl⟩
        rcases mem_map.1 h₂ with ⟨b₂, mb₂, ⟨⟩⟩
        exact n rfl⟩
#align list.nodup.sigma List.Nodup.sigma

protected theorem Nodup.filterMap {f : α → Option β} (h : ∀ a a' b, b ∈ f a → b ∈ f a' → a = a') :
    Nodup l → Nodup (filterMap f l) :=
  (Pairwise.filter_map f) @fun a a' n b bm b' bm' e => n <| h a a' b' (by rw [← e]; exact bm) bm'
#align list.nodup.filter_map List.Nodup.filterMap

protected theorem Nodup.concat (h : a ∉ l) (h' : l.Nodup) : (l.concat a).Nodup := by
  rw [concat_eq_append]; exact h'.append (nodup_singleton _) (disjoint_singleton.2 h)
#align list.nodup.concat List.Nodup.concat

theorem Nodup.insert [DecidableEq α] (h : l.Nodup) : (l.insert a).Nodup :=
  if h' : a ∈ l then by rw [insert_of_mem h']; exact h
  else by rw [insert_of_not_mem h', nodup_cons]; constructor <;> assumption
#align list.nodup.insert List.Nodup.insert

theorem Nodup.union [DecidableEq α] (l₁ : List α) (h : Nodup l₂) : (l₁ ∪ l₂).Nodup := by
  induction' l₁ with a l₁ ih generalizing l₂
  · exact h
  · exact (ih h).insert
#align list.nodup.union List.Nodup.union

theorem Nodup.inter [DecidableEq α] (l₂ : List α) : Nodup l₁ → Nodup (l₁ ∩ l₂) :=
  Nodup.filter _
#align list.nodup.inter List.Nodup.inter

theorem Nodup.diff_eq_filter [DecidableEq α] :
    ∀ {l₁ l₂ : List α} (_ : l₁.Nodup), l₁.diff l₂ = l₁.filter (· ∉ l₂)
  | l₁, [], _ => by simp
  | l₁, a :: l₂, hl₁ => by
    rw [diff_cons, (hl₁.erase _).diff_eq_filter, hl₁.erase_eq_filter, filter_filter]
    simp only [decide_not, Bool.not_eq_true', decide_eq_false_iff_not, ne_eq, and_comm,
      Bool.decide_and, find?, mem_cons, not_or]
#align list.nodup.diff_eq_filter List.Nodup.diff_eq_filter

theorem Nodup.mem_diff_iff [DecidableEq α] (hl₁ : l₁.Nodup) : a ∈ l₁.diff l₂ ↔ a ∈ l₁ ∧ a ∉ l₂ := by
  rw [hl₁.diff_eq_filter, mem_filter, decide_eq_true_iff]
#align list.nodup.mem_diff_iff List.Nodup.mem_diff_iff

protected theorem Nodup.set :
    ∀ {l : List α} {n : ℕ} {a : α} (_ : l.Nodup) (_ : a ∉ l), (l.set n a).Nodup
  | [], _, _, _, _ => nodup_nil
  | _ :: _, 0, _, hl, ha => nodup_cons.2 ⟨mt (mem_cons_of_mem _) ha, (nodup_cons.1 hl).2⟩
  | _ :: _, _ + 1, _, hl, ha =>
    nodup_cons.2
      ⟨fun h =>
        (mem_or_eq_of_mem_set h).elim (nodup_cons.1 hl).1 fun hba => ha (hba ▸ mem_cons_self _ _),
        hl.of_cons.set (mt (mem_cons_of_mem _) ha)⟩
#align list.nodup.update_nth List.Nodup.set

theorem Nodup.map_update [DecidableEq α] {l : List α} (hl : l.Nodup) (f : α → β) (x : α) (y : β) :
    l.map (Function.update f x y) =
      if x ∈ l then (l.map f).set (l.indexOf x) y else l.map f := by
  induction' l with hd tl ihl; · simp
  rw [nodup_cons] at hl
  simp only [mem_cons, map, ihl hl.2]
  by_cases H : hd = x
  · subst hd
    simp [set, hl.1]
  · simp [Ne.symm H, H, set, ← apply_ite (cons (f hd))]
#align list.nodup.map_update List.Nodup.map_update

theorem Nodup.pairwise_of_forall_ne {l : List α} {r : α → α → Prop} (hl : l.Nodup)
    (h : ∀ a ∈ l, ∀ b ∈ l, a ≠ b → r a b) : l.Pairwise r := by
  classical
    refine' pairwise_of_reflexive_on_dupl_of_forall_ne _ h
    intro x hx
    rw [nodup_iff_count_le_one] at hl
    exact absurd (hl x) hx.not_le
#align list.nodup.pairwise_of_forall_ne List.Nodup.pairwise_of_forall_ne

theorem Nodup.pairwise_of_set_pairwise {l : List α} {r : α → α → Prop} (hl : l.Nodup)
    (h : { x | x ∈ l }.Pairwise r) : l.Pairwise r :=
  hl.pairwise_of_forall_ne h
#align list.nodup.pairwise_of_set_pairwise List.Nodup.pairwise_of_set_pairwise

@[simp]
theorem Nodup.pairwise_coe [IsSymm α r] (hl : l.Nodup)
    : { a | a ∈ l }.Pairwise r ↔ l.Pairwise r := by
  induction' l with a l ih
  · simp
  rw [List.nodup_cons] at hl
  have : ∀ b ∈ l, ¬a = b → r a b ↔ r a b := fun b hb =>
    imp_iff_right (ne_of_mem_of_not_mem hb hl.1).symm
  simp [Set.setOf_or, Set.pairwise_insert_of_symmetric (@symm_of _ r _), ih hl.2, and_comm,
    forall₂_congr this]
#align list.nodup.pairwise_coe List.Nodup.pairwise_coe

--Porting note: new theorem
theorem Nodup.take_eq_filter_mem [DecidableEq α] :
    ∀ {l : List α} {n : ℕ} (_ : l.Nodup), l.take n = l.filter (. ∈ l.take n)
  | [], n, _ => by simp
  | b::l, 0, _ => by simp
  | b::l, n+1, hl => by
    rw [take_cons, Nodup.take_eq_filter_mem (Nodup.of_cons hl), List.filter_cons_of_pos _ (by simp)]
    congr 1
    refine' List.filter_congr' _
    intro x hx
    have : x ≠ b := fun h => (nodup_cons.1 hl).1 (h ▸ hx)
    simp (config := {contextual := true}) [List.mem_filter, this, hx]
end List

theorem Option.toList_nodup {α} : ∀ o : Option α, o.toList.Nodup
  | none => List.nodup_nil
  | some x => List.nodup_singleton x
#align option.to_list_nodup Option.toList_nodup


-- 5.8 Exercises
-- #1
-- Go back to the exercises in Chapter 3 and Chapter 4 and redo as many as you can now with tactic proofs,
-- using also rw and simp as appropriate.

-- 4.6 Exercises
-- #5
-- Prove as many of the identities listed in Section 4.4 as you can.

open classical

variables (α : Type*) (p q : α → Prop)
variable r : Prop

example : (∃ x : α, r) → r :=
begin
  intro h,
  cases h with w hr,
  assumption,
end

example (a : α) : r → (∃ x : α, r) :=
begin
  intro hr,
  exact exists.intro a hr,
end

example : (∃ x, p x ∧ r) ↔ (∃ x, p x) ∧ r :=
begin
  apply iff.intro,
    intro h,
    cases h with w hw,
    cases hw with hpw hr,
    split,
      exact exists.intro w hpw,
    assumption,
  intro h,
  cases h with hep hr,
  cases hep with w hpw,
  exact exists.intro w ⟨hpw, hr⟩,
end

example : (∃ x, p x ∨ q x) ↔ (∃ x, p x) ∨ (∃ x, q x) :=
begin
  apply iff.intro,
    intro h,
    cases h with w hpq,
    cases hpq with hp hq,
      left,
      exact ⟨w, hp⟩,
    right,
    exact ⟨w, hq⟩,
  intro h,
  cases h with hp hq,
    cases hp with w hpw,
    existsi w,
    left,
    assumption,
  cases hq with w hqw,
  existsi w,
  right,
  assumption,
end

example : (∀ x, p x) ↔ ¬ (∃ x, ¬ p x) :=
begin
  split,
    intro h,
    intro henp,
    cases henp with w hnpw,
    have hpw : p w := h w,
    contradiction,
  intro h,
  assume a : α,
  cases (em (p a)) with hpa hnpa,
    assumption,
  exfalso,
  apply h,
  exact ⟨a, hnpa⟩,
end

example : (∃ x, p x) ↔ ¬ (∀ x, ¬ p x) :=
begin
  split,
    intro h,
    cases h with w hpw,
    intro hnpx,
    have hnpw : ¬ p w := hnpx w,
    contradiction,
  intro h,
  apply by_contradiction,
    intro hnepx,
    apply h,
    intro w,
    intro hpw,
    have hepx : ∃ x, p x := ⟨w, hpw⟩,
    contradiction,
end

example : (¬ ∃ x, p x) ↔ (∀ x, ¬ p x) :=
begin
  split,
    intro h,
    assume w,
    assume hpw,
    have hepx : ∃ x, p x := ⟨w,hpw⟩,
    contradiction,
  intro h,
  intro hepx,
  cases hepx with w hpw,
  have hnpw :=h w,
  contradiction,
end

example : (¬ ∀ x, p x) ↔ (∃ x, ¬ p x) :=
begin
  split,
    intro h,
    apply by_contradiction,
    intro hnenpx,
    apply h,
    intro w,
    apply by_contradiction,
    intro hnpw,
    have henpx : ∃ x, ¬ p x := ⟨w, hnpw⟩,
    contradiction,
  intro h,
  cases h with w hnpw,
  intro hapx,
  have hpw := hapx w,
  contradiction,
end

example : (∀ x, p x → r) ↔ (∃ x, p x) → r :=
begin
  split,
    intros h1 h2,
    cases h2 with w hpw,
    have hpwr := h1 w,
    exact hpwr hpw,
  intro h,
  intro w,
  intro hpw,
  exact h ⟨w, hpw⟩,
end

lemma not_forall_exists_not : ¬ (∀ x: α, p x) → ∃ x, ¬(p x) :=
begin
  intro h,
  apply by_contradiction,
  intro h1,
  have h2 : ∀ x, p x :=
  begin
    intro w,
    apply by_contradiction,
    intro hnpw,
    have henpx : ∃ x, ¬ p x := ⟨w, hnpw⟩,
    contradiction,
  end,
  apply h,
  assumption,
end

example (a : α) : (∃ x, p x → r) ↔ (∀ x, p x) → r :=
begin
  split,
    intros h1 h2,
    cases h1 with w hw,
    exact hw (h2 w),
  intro h,
  cases (em r) with hr hnr,
    have hpar : p a → r := λ _, hr,
    exact ⟨a, hpar⟩,
  cases (em (∀ x, p x)) with hapx hnapx,
    have hr : r := h hapx,
    contradiction,
  have henpx := not_forall_exists_not α p hnapx,
  cases henpx with w hnpw,
  existsi w,
  intro hpwr,
  contradiction,
end

example (a : α) : (∃ x, r → p x) ↔ (r → ∃ x, p x) :=
begin
  split,
    intros h hr,
    cases h with w hw,
    exact ⟨w, hw hr⟩,
  intro h,
  cases (em (p a)) with hpa hnpa,
    have hrpa : r → p a := λ hr : r, hpa,
    exact ⟨a, hrpa⟩,
  cases (em r) with hr hnr,
    have hepx := h hr,
    cases hepx with w hpw,
    have hrpw : r → p w := λ _, hpw,
    exact ⟨w, hrpw⟩,
    have hrpa : r → p a :=
    begin
      intro hr,
      contradiction,
    end,
  exact ⟨a, hrpa⟩,
end


import ring_theory.algebra

universes u v w u₁ v₁

namespace algebra

variables {R : Type u} {S : Type v} {A : Type w}
variables [comm_ring R] [comm_ring S] [ring A] [algebra R A]

lemma mul_sub_algebra_map_commutes (x : A) (r : R) :
  x * (x - algebra_map R A r) = (x - algebra_map R A r) * x :=
by rw [mul_sub, ←commutes, sub_mul]

lemma mul_sub_algebra_map_pow_commutes (x : A) (r : R) (n : ℕ) :
  x * (x - algebra_map R A r) ^ n = (x - algebra_map R A r) ^ n * x :=
begin
  induction n with n ih,
  { simp },
  { rw [pow_succ, ←mul_assoc, mul_sub_algebra_map_commutes,
      mul_assoc, ih, ←mul_assoc], }
end

end algebra