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

/-!
# Cardinality of a finite set

This defines the cardinality of a `finset` and provides induction principles for finsets.

## Main declarations

* `finset.card`: `s.card : ℕ` returns the cardinality of `s : finset α`.

### Induction principles

* `finset.strong_induction`: Strong induction
* `finset.strong_induction_on`
* `finset.strong_downward_induction`
* `finset.strong_downward_induction_on`
* `finset.case_strong_induction_on`

## TODO

Should we add a noncomputable version?
-/

open function multiset nat

variables {α β : Type*}

namespace finset
variables {s t : finset α} {a b : α}

/-- `s.card` is the number of elements of `s`, aka its cardinality. -/
def card (s : finset α) : ℕ := s.1.card

lemma card_def (s : finset α) : s.card = s.1.card := rfl

@[simp] lemma card_mk {m nodup} : (⟨m, nodup⟩ : finset α).card = m.card := rfl

@[simp] lemma card_empty : card (∅ : finset α) = 0 := rfl

lemma card_le_of_subset : s ⊆ t → s.card ≤ t.card := multiset.card_le_of_le ∘ val_le_iff.mpr

@[mono] lemma card_mono : monotone (@card α) := by apply card_le_of_subset

@[simp] lemma card_eq_zero : s.card = 0 ↔ s = ∅ := card_eq_zero.trans val_eq_zero

lemma card_pos : 0 < s.card ↔ s.nonempty :=
pos_iff_ne_zero.trans $ (not_congr card_eq_zero).trans nonempty_iff_ne_empty.symm

alias finset.card_pos ↔ _ finset.nonempty.card_pos

lemma card_ne_zero_of_mem (h : a ∈ s) : s.card ≠ 0 := (not_congr card_eq_zero).2 $ ne_empty_of_mem h

@[simp] lemma card_singleton (a : α) : card ({a} : finset α) = 1 := card_singleton _

lemma card_singleton_inter [decidable_eq α] : ({a} ∩ s).card ≤ 1 :=
begin
  cases (finset.decidable_mem a s),
  { simp [finset.singleton_inter_of_not_mem h] },
  { simp [finset.singleton_inter_of_mem h] }
end

@[simp] lemma card_cons (h : a ∉ s) : (s.cons a h).card = s.card + 1 := card_cons _ _

section insert_erase
variables [decidable_eq α]

@[simp] lemma card_insert_of_not_mem (h : a ∉ s) : (insert a s).card = s.card + 1 :=
by rw [←cons_eq_insert _ _ h, card_cons]

lemma card_insert_of_mem (h : a ∈ s) : card (insert a s) = s.card := by rw insert_eq_of_mem h

lemma card_insert_le (a : α) (s : finset α) : card (insert a s) ≤ s.card + 1 :=
by by_cases a ∈ s; [{rw insert_eq_of_mem h, exact nat.le_succ _ }, rw card_insert_of_not_mem h]

/-- If `a ∈ s` is known, see also `finset.card_insert_of_mem` and `finset.card_insert_of_not_mem`.
-/
lemma card_insert_eq_ite : card (insert a s) = if a ∈ s then s.card else s.card + 1 :=
begin
  by_cases h : a ∈ s,
  { rw [card_insert_of_mem h, if_pos h] },
  { rw [card_insert_of_not_mem h, if_neg h] }
end

@[simp] lemma card_doubleton (h : a ≠ b) : ({a, b} : finset α).card = 2 :=
by rw [card_insert_of_not_mem (not_mem_singleton.2 h), card_singleton]

@[simp] lemma card_erase_of_mem : a ∈ s → (s.erase a).card = s.card - 1 := card_erase_of_mem
@[simp] lemma card_erase_add_one : a ∈ s → (s.erase a).card + 1 = s.card := card_erase_add_one

lemma card_erase_lt_of_mem : a ∈ s → (s.erase a).card < s.card := card_erase_lt_of_mem

lemma card_erase_le : (s.erase a).card ≤ s.card := card_erase_le

lemma pred_card_le_card_erase : s.card - 1 ≤ (s.erase a).card :=
begin
  by_cases h : a ∈ s,
  { exact (card_erase_of_mem h).ge },
  { rw erase_eq_of_not_mem h,
    exact nat.sub_le _ _ }
end

/-- If `a ∈ s` is known, see also `finset.card_erase_of_mem` and `finset.erase_eq_of_not_mem`. -/
lemma card_erase_eq_ite : (s.erase a).card = if a ∈ s then s.card - 1 else s.card :=
card_erase_eq_ite

end insert_erase

@[simp] lemma card_range (n : ℕ) : (range n).card = n := card_range n

@[simp] lemma card_attach : s.attach.card = s.card := multiset.card_attach

end finset

section to_list_multiset
variables [decidable_eq α] (m : multiset α) (l : list α)

lemma multiset.card_to_finset : m.to_finset.card = m.dedup.card := rfl

lemma multiset.to_finset_card_le : m.to_finset.card ≤ m.card := card_le_of_le $ dedup_le _

lemma multiset.to_finset_card_of_nodup {m : multiset α} (h : m.nodup) : m.to_finset.card = m.card :=
congr_arg card $ multiset.dedup_eq_self.mpr h

lemma list.card_to_finset : l.to_finset.card = l.dedup.length := rfl

lemma list.to_finset_card_le : l.to_finset.card ≤ l.length := multiset.to_finset_card_le ⟦l⟧

lemma list.to_finset_card_of_nodup {l : list α} (h : l.nodup) : l.to_finset.card = l.length :=
multiset.to_finset_card_of_nodup h

end to_list_multiset

namespace finset
variables {s t : finset α} {f : α → β} {n : ℕ}

@[simp] lemma length_to_list (s : finset α) : s.to_list.length = s.card :=
by { rw [to_list, ←multiset.coe_card, multiset.coe_to_list], refl }

lemma card_image_le [decidable_eq β] : (s.image f).card ≤ s.card :=
by simpa only [card_map] using (s.1.map f).to_finset_card_le

lemma card_image_of_inj_on [decidable_eq β] (H : set.inj_on f s) : (s.image f).card = s.card :=
by simp only [card, image_val_of_inj_on H, card_map]

lemma inj_on_of_card_image_eq [decidable_eq β] (H : (s.image f).card = s.card) : set.inj_on f s :=
begin
  change (s.1.map f).dedup.card = s.1.card at H,
  have : (s.1.map f).dedup = s.1.map f,
  { refine multiset.eq_of_le_of_card_le (multiset.dedup_le _) _,
    rw H,
    simp only [multiset.card_map] },
  rw multiset.dedup_eq_self at this,
  exact inj_on_of_nodup_map this,
end

lemma card_image_eq_iff_inj_on [decidable_eq β] : (s.image f).card = s.card ↔ set.inj_on f s :=
⟨inj_on_of_card_image_eq, card_image_of_inj_on⟩

lemma card_image_of_injective [decidable_eq β] (s : finset α) (H : injective f) :
  (s.image f).card = s.card :=
card_image_of_inj_on $ λ x _ y _ h, H h

@[simp] lemma card_map (f : α ↪ β) : (s.map f).card = s.card := multiset.card_map _ _

@[simp] lemma card_subtype (p : α → Prop) [decidable_pred p] (s : finset α) :
  (s.subtype p).card = (s.filter p).card :=
by simp [finset.subtype]

lemma card_filter_le (s : finset α) (p : α → Prop) [decidable_pred p] :
  (s.filter p).card ≤ s.card :=
card_le_of_subset $ filter_subset _ _

lemma eq_of_subset_of_card_le {s t : finset α} (h : s ⊆ t) (h₂ : t.card ≤ s.card) : s = t :=
eq_of_veq $ multiset.eq_of_le_of_card_le (val_le_iff.mpr h) h₂

lemma map_eq_of_subset {f : α ↪ α} (hs : s.map f ⊆ s) : s.map f = s :=
eq_of_subset_of_card_le hs (card_map _).ge

lemma filter_card_eq {p : α → Prop} [decidable_pred p] (h : (s.filter p).card = s.card) (x : α)
  (hx : x ∈ s) :
  p x :=
begin
  rw [←eq_of_subset_of_card_le (s.filter_subset p) h.ge, mem_filter] at hx,
  exact hx.2,
end

lemma card_lt_card (h : s ⊂ t) : s.card < t.card := card_lt_of_lt $ val_lt_iff.2 h

lemma card_eq_of_bijective (f : ∀ i, i < n → α) (hf : ∀ a ∈ s, ∃ i, ∃ h : i < n, f i h = a)
  (hf' : ∀ i (h : i < n), f i h ∈ s) (f_inj : ∀ i j (hi : i < n)
  (hj : j < n), f i hi = f j hj → i = j) :
  s.card = n :=
begin
  classical,
  have : ∀ (a : α), a ∈ s ↔ ∃ i (hi : i ∈ range n), f i (mem_range.1 hi) = a,
    from λ a, ⟨λ ha, let ⟨i, hi, eq⟩ := hf a ha in ⟨i, mem_range.2 hi, eq⟩,
      λ ⟨i, hi, eq⟩, eq ▸ hf' i (mem_range.1 hi)⟩,
  have : s = ((range n).attach.image $ λi, f i.1 (mem_range.1 i.2)),
    by simpa only [ext_iff, mem_image, exists_prop, subtype.exists, mem_attach, true_and],
  calc s.card = card ((range n).attach.image $ λ i, f i.1 (mem_range.1 i.2)) :
      by rw this
    ... = card ((range n).attach) :
      card_image_of_injective _ $ λ ⟨i, hi⟩ ⟨j, hj⟩ eq,
        subtype.eq $ f_inj i j (mem_range.1 hi) (mem_range.1 hj) eq
    ... = card (range n) : card_attach
    ... = n : card_range n
end

lemma card_congr {t : finset β} (f : Π a ∈ s, β) (h₁ : ∀ a ha, f a ha ∈ t)
  (h₂ : ∀ a b ha hb, f a ha = f b hb → a = b) (h₃ : ∀ b ∈ t, ∃ a ha, f a ha = b) :
  s.card = t.card :=
by classical;
calc s.card = s.attach.card : card_attach.symm
... = (s.attach.image (λ (a : {a // a ∈ s}), f a.1 a.2)).card
    : eq.symm (card_image_of_injective _ $ λ a b h, subtype.eq $ h₂ _ _ _ _ h)
... = t.card : congr_arg card (finset.ext $ λ b,
    ⟨λ h, let ⟨a, ha₁, ha₂⟩ := mem_image.1 h in ha₂ ▸ h₁ _ _,
      λ h, let ⟨a, ha₁, ha₂⟩ := h₃ b h in mem_image.2 ⟨⟨a, ha₁⟩, by simp [ha₂]⟩⟩)

lemma card_le_card_of_inj_on {t : finset β} (f : α → β) (hf : ∀ a ∈ s, f a ∈ t)
  (f_inj : ∀ a₁ ∈ s, ∀ a₂ ∈ s, f a₁ = f a₂ → a₁ = a₂) :
  s.card ≤ t.card :=
by classical;
  calc s.card = (s.image f).card : (card_image_of_inj_on f_inj).symm
    ... ≤ t.card : card_le_of_subset $ image_subset_iff.2 hf

/-- If there are more pigeons than pigeonholes, then there are two pigeons in the same pigeonhole.
-/
lemma exists_ne_map_eq_of_card_lt_of_maps_to {t : finset β} (hc : t.card < s.card)
  {f : α → β} (hf : ∀ a ∈ s, f a ∈ t) :
  ∃ (x ∈ s) (y ∈ s), x ≠ y ∧ f x = f y :=
begin
  classical,
  by_contra' hz,
  refine hc.not_le (card_le_card_of_inj_on f hf _),
  intros x hx y hy, contrapose, exact hz x hx y hy,
end

lemma le_card_of_inj_on_range (f : ℕ → α) (hf : ∀ i < n, f i ∈ s)
  (f_inj : ∀ (i < n) (j < n), f i = f j → i = j) :
  n ≤ s.card :=
calc n = card (range n) : (card_range n).symm
  ... ≤ s.card : card_le_card_of_inj_on f (by simpa only [mem_range]) (by simpa only [mem_range])

lemma surj_on_of_inj_on_of_card_le {t : finset β} (f : Π a ∈ s, β) (hf : ∀ a ha, f a ha ∈ t)
  (hinj : ∀ a₁ a₂ ha₁ ha₂, f a₁ ha₁ = f a₂ ha₂ → a₁ = a₂) (hst : t.card ≤ s.card) :
  ∀ b ∈ t, ∃ a ha, b = f a ha :=
begin
  classical,
  intros b hb,
  have h : (s.attach.image $ λ (a : {a // a ∈ s}), f a a.prop).card = s.card,
  { exact @card_attach _ s ▸ card_image_of_injective _
      (λ ⟨a₁, ha₁⟩ ⟨a₂, ha₂⟩ h, subtype.eq $ hinj _ _ _ _ h) },
  have h' : image (λ a : {a // a ∈ s}, f a a.prop) s.attach = t,
  { exact eq_of_subset_of_card_le (λ b h, let ⟨a, ha₁, ha₂⟩ := mem_image.1 h in
      ha₂ ▸ hf _ _) (by simp [hst, h]) },
  rw ←h' at hb,
  obtain ⟨a, ha₁, ha₂⟩ := mem_image.1 hb,
  exact ⟨a, a.2, ha₂.symm⟩,
end

lemma inj_on_of_surj_on_of_card_le {t : finset β} (f : Π a ∈ s, β) (hf : ∀ a ha, f a ha ∈ t)
  (hsurj : ∀ b ∈ t, ∃ a ha, b = f a ha) (hst : s.card ≤ t.card) ⦃a₁ a₂⦄ (ha₁ : a₁ ∈ s)
  (ha₂ : a₂ ∈ s) (ha₁a₂: f a₁ ha₁ = f a₂ ha₂) :
  a₁ = a₂ :=
by haveI : inhabited {x // x ∈ s} := ⟨⟨a₁, ha₁⟩⟩; exact
let f' : {x // x ∈ s} → {x // x ∈ t} := λ x, ⟨f x.1 x.2, hf x.1 x.2⟩ in
let g : {x // x ∈ t} → {x // x ∈ s} :=
  @surj_inv _ _ f'
    (λ x, let ⟨y, hy₁, hy₂⟩ := hsurj x.1 x.2 in ⟨⟨y, hy₁⟩, subtype.eq hy₂.symm⟩) in
have hg : injective g, from injective_surj_inv _,
have hsg : surjective g, from λ x,
  let ⟨y, hy⟩ := surj_on_of_inj_on_of_card_le (λ (x : {x // x ∈ t}) (hx : x ∈ t.attach), g x)
    (λ x _, show (g x) ∈ s.attach, from mem_attach _ _)
    (λ x y _ _ hxy, hg hxy) (by simpa) x (mem_attach _ _) in
  ⟨y, hy.snd.symm⟩,
have hif : injective f',
  from (left_inverse_of_surjective_of_right_inverse hsg
      (right_inverse_surj_inv _)).injective,
subtype.ext_iff_val.1 (@hif ⟨a₁, ha₁⟩ ⟨a₂, ha₂⟩ (subtype.eq ha₁a₂))

@[simp] lemma card_disj_union (s t : finset α) (h) : (s.disj_union t h).card = s.card + t.card :=
multiset.card_add _ _

/-! ### Lattice structure -/

section lattice
variables [decidable_eq α]

lemma card_union_add_card_inter (s t : finset α) : (s ∪ t).card + (s ∩ t).card = s.card + t.card :=
finset.induction_on t (by simp) $ λ a r har, by by_cases a ∈ s; simp *; cc

lemma card_union_le (s t : finset α) : (s ∪ t).card ≤ s.card + t.card :=
card_union_add_card_inter s t ▸ nat.le_add_right _ _

lemma card_union_eq (h : disjoint s t) : (s ∪ t).card = s.card + t.card :=
by rw [←disj_union_eq_union s t $ λ x, disjoint_left.mp h, card_disj_union _ _ _]

@[simp] lemma card_disjoint_union (h : disjoint s t) : card (s ∪ t) = s.card + t.card :=
card_union_eq h

lemma card_sdiff (h : s ⊆ t) : card (t \ s) = t.card - s.card :=
suffices card (t \ s) = card ((t \ s) ∪ s) - s.card, by rwa sdiff_union_of_subset h at this,
by rw [card_disjoint_union sdiff_disjoint, add_tsub_cancel_right]

lemma card_sdiff_add_card_eq_card {s t : finset α} (h : s ⊆ t) : card (t \ s) + card s = card t :=
((nat.sub_eq_iff_eq_add (card_le_of_subset h)).mp (card_sdiff h).symm).symm

lemma le_card_sdiff (s t : finset α) : t.card - s.card ≤ card (t \ s) :=
calc card t - card s
      ≤ card t - card (s ∩ t) : tsub_le_tsub_left (card_le_of_subset (inter_subset_left s t)) _
  ... = card (t \ (s ∩ t)) : (card_sdiff (inter_subset_right s t)).symm
  ... ≤ card (t \ s) : by rw sdiff_inter_self_right t s

lemma card_sdiff_add_card : (s \ t).card + t.card = (s ∪ t).card :=
by rw [←card_disjoint_union sdiff_disjoint, sdiff_union_self_eq_union]

end lattice

lemma filter_card_add_filter_neg_card_eq_card (p : α → Prop) [decidable_pred p] :
  (s.filter p).card + (s.filter (not ∘ p)).card = s.card :=
by { classical, simp [←card_union_eq, filter_union_filter_neg_eq, disjoint_filter] }

/-- Given a set `A` and a set `B` inside it, we can shrink `A` to any appropriate size, and keep `B`
inside it. -/
lemma exists_intermediate_set {A B : finset α} (i : ℕ) (h₁ : i + card B ≤ card A) (h₂ : B ⊆ A) :
  ∃ (C : finset α), B ⊆ C ∧ C ⊆ A ∧ card C = i + card B :=
begin
  classical,
  rcases nat.le.dest h₁ with ⟨k, _⟩,
  clear h₁,
  induction k with k ih generalizing A,
  { exact ⟨A, h₂, subset.refl _, h.symm⟩ },
  have : (A \ B).nonempty,
  { rw [←card_pos, card_sdiff h₂, ←h, nat.add_right_comm,
        add_tsub_cancel_right, nat.add_succ],
    apply nat.succ_pos },
  rcases this with ⟨a, ha⟩,
  have z : i + card B + k = card (erase A a),
  { rw [card_erase_of_mem (mem_sdiff.1 ha).1, ←h],
    refl },
  rcases ih _ z with ⟨B', hB', B'subA', cards⟩,
  { exact ⟨B', hB', trans B'subA' (erase_subset _ _), cards⟩ },
  { rintro t th,
    apply mem_erase_of_ne_of_mem _ (h₂ th),
    rintro rfl,
    exact not_mem_sdiff_of_mem_right th ha }
end

/-- We can shrink `A` to any smaller size. -/
lemma exists_smaller_set (A : finset α) (i : ℕ) (h₁ : i ≤ card A) :
  ∃ (B : finset α), B ⊆ A ∧ card B = i :=
let ⟨B, _, x₁, x₂⟩ := exists_intermediate_set i (by simpa) (empty_subset A) in ⟨B, x₁, x₂⟩

lemma exists_subset_or_subset_of_two_mul_lt_card [decidable_eq α] {X Y : finset α} {n : ℕ}
  (hXY : 2 * n < (X ∪ Y).card) :
  ∃ C : finset α, n < C.card ∧ (C ⊆ X ∨ C ⊆ Y) :=
begin
  have h₁ : (X ∩ (Y \ X)).card = 0 := finset.card_eq_zero.mpr (finset.inter_sdiff_self X Y),
  have h₂ : (X ∪ Y).card = X.card + (Y \ X).card,
  { rw [←card_union_add_card_inter X (Y \ X), finset.union_sdiff_self_eq_union, h₁, add_zero] },
  rw [h₂, two_mul] at hXY,
  rcases lt_or_lt_of_add_lt_add hXY with h|h,
  { exact ⟨X, h, or.inl (finset.subset.refl X)⟩ },
  { exact ⟨Y \ X, h, or.inr (finset.sdiff_subset Y X)⟩ }
end

/-! ### Explicit description of a finset from its card -/

lemma card_eq_one : s.card = 1 ↔ ∃ a, s = {a} :=
by cases s; simp only [multiset.card_eq_one, finset.card, ←val_inj, singleton_val]

lemma exists_eq_insert_iff [decidable_eq α] {s t : finset α} :
  (∃ a ∉ s, insert a s = t) ↔ s ⊆ t ∧ s.card + 1 = t.card :=
begin
  split,
  { rintro ⟨a, ha, rfl⟩,
    exact ⟨subset_insert _ _, (card_insert_of_not_mem ha).symm⟩ },
  { rintro ⟨hst, h⟩,
    obtain ⟨a, ha⟩ : ∃ a, t \ s = {a},
    { exact card_eq_one.1 (by rw [card_sdiff hst, ←h, add_tsub_cancel_left]) },
    refine ⟨a, λ hs, (_ : a ∉ {a}) $ mem_singleton_self _,
      by rw [insert_eq, ←ha, sdiff_union_of_subset hst]⟩,
    rw ←ha,
    exact not_mem_sdiff_of_mem_right hs }
end

lemma card_le_one : s.card ≤ 1 ↔ ∀ (a ∈ s) (b ∈ s), a = b :=
begin
  obtain rfl | ⟨x, hx⟩ := s.eq_empty_or_nonempty,
  { simp },
  refine (nat.succ_le_of_lt (card_pos.2 ⟨x, hx⟩)).le_iff_eq.trans (card_eq_one.trans ⟨_, _⟩),
  { rintro ⟨y, rfl⟩,
    simp },
  { exact λ h, ⟨x, eq_singleton_iff_unique_mem.2 ⟨hx, λ y hy, h _ hy _ hx⟩⟩ }
end

lemma card_le_one_iff : s.card ≤ 1 ↔ ∀ {a b}, a ∈ s → b ∈ s → a = b := by { rw card_le_one, tauto }

lemma card_le_one_iff_subset_singleton [nonempty α] : s.card ≤ 1 ↔ ∃ (x : α), s ⊆ {x} :=
begin
  refine ⟨λ H, _, _⟩,
  { obtain rfl | ⟨x, hx⟩ := s.eq_empty_or_nonempty,
    { exact ⟨classical.arbitrary α, empty_subset _⟩ },
    { exact ⟨x, λ y hy, by rw [card_le_one.1 H y hy x hx, mem_singleton]⟩ } },
  { rintro ⟨x, hx⟩,
    rw ←card_singleton x,
    exact card_le_of_subset hx }
end

/-- A `finset` of a subsingleton type has cardinality at most one. -/
lemma card_le_one_of_subsingleton [subsingleton α] (s : finset α) : s.card ≤ 1 :=
finset.card_le_one_iff.2 $ λ _ _ _ _, subsingleton.elim _ _

lemma one_lt_card : 1 < s.card ↔ ∃ (a ∈ s) (b ∈ s), a ≠ b :=
by { rw ←not_iff_not, push_neg, exact card_le_one }

lemma one_lt_card_iff : 1 < s.card ↔ ∃ a b, a ∈ s ∧ b ∈ s ∧ a ≠ b :=
by { rw one_lt_card, simp only [exists_prop, exists_and_distrib_left] }

lemma two_lt_card_iff : 2 < s.card ↔ ∃ a b c, a ∈ s ∧ b ∈ s ∧ c ∈ s ∧ a ≠ b ∧ a ≠ c ∧ b ≠ c :=
begin
  classical,
  refine ⟨λ h, _, _⟩,
  { obtain ⟨c, hc⟩ := card_pos.mp (zero_lt_two.trans h),
    have : 1 < (s.erase c).card := by rwa [←add_lt_add_iff_right 1, card_erase_add_one hc],
    obtain ⟨a, b, ha, hb, hab⟩ := one_lt_card_iff.mp this,
    exact ⟨a, b, c, mem_of_mem_erase ha, mem_of_mem_erase hb, hc,
      hab, ne_of_mem_erase ha, ne_of_mem_erase hb⟩ },
  { rintros ⟨a, b, c, ha, hb, hc, hab, hac, hbc⟩,
    rw [←card_erase_add_one hc, ←card_erase_add_one (mem_erase_of_ne_of_mem hbc hb),
        ←card_erase_add_one (mem_erase_of_ne_of_mem hab (mem_erase_of_ne_of_mem hac ha))],
    apply nat.le_add_left },
end

lemma two_lt_card : 2 < s.card ↔ ∃ (a ∈ s) (b ∈ s) (c ∈ s), a ≠ b ∧ a ≠ c ∧ b ≠ c :=
by simp_rw [two_lt_card_iff, exists_prop, exists_and_distrib_left]

lemma exists_ne_of_one_lt_card (hs : 1 < s.card) (a : α) : ∃ b, b ∈ s ∧ b ≠ a :=
begin
  obtain ⟨x, hx, y, hy, hxy⟩ := finset.one_lt_card.mp hs,
  by_cases ha : y = a,
  { exact ⟨x, hx, ne_of_ne_of_eq hxy ha⟩ },
  { exact ⟨y, hy, ha⟩ }
end

lemma card_eq_succ [decidable_eq α] : s.card = n + 1 ↔ ∃ a t, a ∉ t ∧ insert a t = s ∧ t.card = n :=
⟨λ h,
  let ⟨a, has⟩ := card_pos.mp (h.symm ▸ nat.zero_lt_succ _ : 0 < s.card) in
    ⟨a, s.erase a, s.not_mem_erase a, insert_erase has,
      by simp only [h, card_erase_of_mem has, add_tsub_cancel_right]⟩,
  λ ⟨a, t, hat, s_eq, n_eq⟩, s_eq ▸ n_eq ▸ card_insert_of_not_mem hat⟩

lemma card_eq_two [decidable_eq α] : s.card = 2 ↔ ∃ x y, x ≠ y ∧ s = {x, y} :=
begin
  split,
  { rw card_eq_succ,
    simp_rw [card_eq_one],
    rintro ⟨a, _, hab, rfl, b, rfl⟩,
    exact ⟨a, b, not_mem_singleton.1 hab, rfl⟩ },
  { rintro ⟨x, y, h, rfl⟩,
    exact card_doubleton h }
end

lemma card_eq_three [decidable_eq α] :
  s.card = 3 ↔ ∃ x y z, x ≠ y ∧ x ≠ z ∧ y ≠ z ∧ s = {x, y, z} :=
begin
  split,
  { rw card_eq_succ,
    simp_rw [card_eq_two],
    rintro ⟨a, _, abc, rfl, b, c, bc, rfl⟩,
    rw [mem_insert, mem_singleton, not_or_distrib] at abc,
    exact ⟨a, b, c, abc.1, abc.2, bc, rfl⟩ },
  { rintro ⟨x, y, z, xy, xz, yz, rfl⟩,
    simp only [xy, xz, yz, mem_insert, card_insert_of_not_mem, not_false_iff, mem_singleton,
      or_self, card_singleton] }
end

/-! ### Inductions -/

/-- Suppose that, given objects defined on all strict subsets of any finset `s`, one knows how to
define an object on `s`. Then one can inductively define an object on all finsets, starting from
the empty set and iterating. This can be used either to define data, or to prove properties. -/
def strong_induction {p : finset α → Sort*} (H : ∀ s, (∀ t ⊂ s, p t) → p s) :
  ∀ (s : finset α), p s
| s := H s (λ t h, have t.card < s.card, from card_lt_card h, strong_induction t)
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf card⟩]}

lemma strong_induction_eq {p : finset α → Sort*} (H : ∀ s, (∀ t ⊂ s, p t) → p s) (s : finset α) :
  strong_induction H s = H s (λ t h, strong_induction H t) :=
by rw strong_induction

/-- Analogue of `strong_induction` with order of arguments swapped. -/
@[elab_as_eliminator] def strong_induction_on {p : finset α → Sort*} (s : finset α) :
  (∀ s, (∀ t ⊂ s, p t) → p s) → p s :=
λ H, strong_induction H s

lemma strong_induction_on_eq {p : finset α → Sort*} (s : finset α) (H : ∀ s, (∀ t ⊂ s, p t) → p s) :
  s.strong_induction_on H = H s (λ t h, t.strong_induction_on H) :=
by { dunfold strong_induction_on, rw strong_induction }

@[elab_as_eliminator] lemma case_strong_induction_on [decidable_eq α] {p : finset α → Prop}
  (s : finset α) (h₀ : p ∅) (h₁ : ∀ a s, a ∉ s → (∀ t ⊆ s, p t) → p (insert a s)) :
  p s :=
finset.strong_induction_on s $ λ s,
finset.induction_on s (λ _, h₀) $ λ a s n _ ih, h₁ a s n $
λ t ss, ih _ (lt_of_le_of_lt ss (ssubset_insert n) : t < _)

/-- Suppose that, given that `p t` can be defined on all supersets of `s` of cardinality less than
`n`, one knows how to define `p s`. Then one can inductively define `p s` for all finsets `s` of
cardinality less than `n`, starting from finsets of card `n` and iterating. This
can be used either to define data, or to prove properties. -/
def strong_downward_induction {p : finset α → Sort*} {n : ℕ} (H : ∀ t₁, (∀ {t₂ : finset α},
  t₂.card ≤ n → t₁ ⊂ t₂ → p t₂) → t₁.card ≤ n → p t₁) :
  ∀ (s : finset α), s.card ≤ n → p s
| s := H s (λ t ht h, have n - t.card < n - s.card,
     from (tsub_lt_tsub_iff_left_of_le ht).2 (finset.card_lt_card h),
  strong_downward_induction t ht)
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf (λ (t : finset α), n - t.card)⟩]}

lemma strong_downward_induction_eq {p : finset α → Sort*}
  (H : ∀ t₁, (∀ {t₂ : finset α}, t₂.card ≤ n → t₁ ⊂ t₂ → p t₂) → t₁.card ≤ n → p t₁)
  (s : finset α) :
  strong_downward_induction H s = H s (λ t ht hst, strong_downward_induction H t ht) :=
by rw strong_downward_induction

/-- Analogue of `strong_downward_induction` with order of arguments swapped. -/
@[elab_as_eliminator] def strong_downward_induction_on {p : finset α → Sort*} (s : finset α)
  (H : ∀ t₁, (∀ {t₂ : finset α}, t₂.card ≤ n → t₁ ⊂ t₂ → p t₂) → t₁.card ≤ n → p t₁) :
  s.card ≤ n → p s :=
strong_downward_induction H s

lemma strong_downward_induction_on_eq {p : finset α → Sort*} (s : finset α) (H : ∀ t₁,
  (∀ {t₂ : finset α}, t₂.card ≤ n → t₁ ⊂ t₂ → p t₂) → t₁.card ≤ n → p t₁) :
  s.strong_downward_induction_on H = H s (λ t ht h, t.strong_downward_induction_on H ht) :=
by { dunfold strong_downward_induction_on, rw strong_downward_induction }

lemma lt_wf {α} : well_founded (@has_lt.lt (finset α) _) :=
have H : subrelation (@has_lt.lt (finset α) _)
    (inv_image ( < ) card),
  from λ x y hxy, card_lt_card hxy,
subrelation.wf H $ inv_image.wf _ $ nat.lt_wf

end finset


/-
Copyright (c) 2020 Thomas Browning and Patrick Lutz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Thomas Browning, Patrick Lutz
-/

import group_theory.solvable
import field_theory.polynomial_galois_group
import ring_theory.roots_of_unity

/-!
# The Abel-Ruffini Theorem

This file proves one direction of the Abel-Ruffini theorem, namely that if an element is solvable
by radicals, then its minimal polynomial has solvable Galois group.

## Main definitions

* `solvable_by_rad F E` : the intermediate field of solvable-by-radicals elements

## Main results

* the Abel-Ruffini Theorem `solvable_by_rad.is_solvable'` : An irreducible polynomial with a root
that is solvable by radicals has a solvable Galois group.
-/

noncomputable theory
open_locale classical

open polynomial intermediate_field

section abel_ruffini

variables {F : Type*} [field F] {E : Type*} [field E] [algebra F E]

lemma gal_zero_is_solvable : is_solvable (0 : polynomial F).gal :=
by apply_instance

lemma gal_one_is_solvable : is_solvable (1 : polynomial F).gal :=
by apply_instance

lemma gal_C_is_solvable (x : F) : is_solvable (C x).gal :=
by apply_instance

lemma gal_X_is_solvable : is_solvable (X : polynomial F).gal :=
by apply_instance

lemma gal_X_sub_C_is_solvable (x : F) : is_solvable (X - C x).gal :=
by apply_instance

lemma gal_X_pow_is_solvable (n : ℕ) : is_solvable (X ^ n : polynomial F).gal :=
by apply_instance

lemma gal_mul_is_solvable {p q : polynomial F}
  (hp : is_solvable p.gal) (hq : is_solvable q.gal) : is_solvable (p * q).gal :=
solvable_of_solvable_injective (gal.restrict_prod_injective p q)

lemma gal_prod_is_solvable {s : multiset (polynomial F)}
  (hs : ∀ p ∈ s, is_solvable (gal p)) : is_solvable s.prod.gal :=
begin
  apply multiset.induction_on' s,
  { exact gal_one_is_solvable },
  { intros p t hps hts ht,
    rw [multiset.insert_eq_cons, multiset.prod_cons],
    exact gal_mul_is_solvable (hs p hps) ht },
end

lemma gal_is_solvable_of_splits {p q : polynomial F}
  (hpq : fact (p.splits (algebra_map F q.splitting_field))) (hq : is_solvable q.gal) :
  is_solvable p.gal :=
begin
  haveI : is_solvable (q.splitting_field ≃ₐ[F] q.splitting_field) := hq,
  exact solvable_of_surjective (alg_equiv.restrict_normal_hom_surjective q.splitting_field),
end

lemma gal_is_solvable_tower (p q : polynomial F)
  (hpq : p.splits (algebra_map F q.splitting_field))
  (hp : is_solvable p.gal)
  (hq : is_solvable (q.map (algebra_map F p.splitting_field)).gal) :
  is_solvable q.gal :=
begin
  let K := p.splitting_field,
  let L := q.splitting_field,
  haveI : fact (p.splits (algebra_map F L)) := ⟨hpq⟩,
  let ϕ : (L ≃ₐ[K] L) ≃* (q.map (algebra_map F K)).gal :=
    (is_splitting_field.alg_equiv L (q.map (algebra_map F K))).aut_congr,
  have ϕ_inj : function.injective ϕ.to_monoid_hom := ϕ.injective,
  haveI : is_solvable (K ≃ₐ[F] K) := hp,
  haveI : is_solvable (L ≃ₐ[K] L) := solvable_of_solvable_injective ϕ_inj,
  exact is_solvable_of_is_scalar_tower F p.splitting_field q.splitting_field,
end

section gal_X_pow_sub_C

lemma gal_X_pow_sub_one_is_solvable (n : ℕ) : is_solvable (X ^ n - 1 : polynomial F).gal :=
begin
  by_cases hn : n = 0,
  { rw [hn, pow_zero, sub_self],
    exact gal_zero_is_solvable },
  have hn' : 0 < n := pos_iff_ne_zero.mpr hn,
  have hn'' : (X ^ n - 1 : polynomial F) ≠ 0 :=
    λ h, one_ne_zero ((leading_coeff_X_pow_sub_one hn').symm.trans (congr_arg leading_coeff h)),
  apply is_solvable_of_comm,
  intros σ τ,
  ext a ha,
  rw [mem_root_set hn'', alg_hom.map_sub, aeval_X_pow, aeval_one, sub_eq_zero] at ha,
  have key : ∀ σ : (X ^ n - 1 : polynomial F).gal, ∃ m : ℕ, σ a = a ^ m,
  { intro σ,
    obtain ⟨m, hm⟩ := σ.to_alg_hom.to_ring_hom.map_root_of_unity_eq_pow_self
      ⟨is_unit.unit (is_unit_of_pow_eq_one a n ha hn'),
      by { ext, rwa [units.coe_pow, is_unit.unit_spec, subtype.coe_mk n hn'] }⟩,
    use m,
    convert hm,
    all_goals { exact (is_unit.unit_spec _).symm } },
  obtain ⟨c, hc⟩ := key σ,
  obtain ⟨d, hd⟩ := key τ,
  rw [σ.mul_apply, τ.mul_apply, hc, τ.map_pow, hd, σ.map_pow, hc, ←pow_mul, pow_mul'],
end

lemma gal_X_pow_sub_C_is_solvable_aux (n : ℕ) (a : F)
  (h : (X ^ n - 1 : polynomial F).splits (ring_hom.id F)) : is_solvable (X ^ n - C a).gal :=
begin
  by_cases ha : a = 0,
  { rw [ha, C_0, sub_zero],
    exact gal_X_pow_is_solvable n },
  have ha' : algebra_map F (X ^ n - C a).splitting_field a ≠ 0 :=
    mt ((ring_hom.injective_iff _).mp (ring_hom.injective _) a) ha,
  by_cases hn : n = 0,
  { rw [hn, pow_zero, ←C_1, ←C_sub],
    exact gal_C_is_solvable (1 - a) },
  have hn' : 0 < n := pos_iff_ne_zero.mpr hn,
  have hn'' : X ^ n - C a ≠ 0 :=
    λ h, one_ne_zero ((leading_coeff_X_pow_sub_C hn').symm.trans (congr_arg leading_coeff h)),
  have hn''' : (X ^ n - 1 : polynomial F) ≠ 0 :=
    λ h, one_ne_zero ((leading_coeff_X_pow_sub_one hn').symm.trans (congr_arg leading_coeff h)),
  have mem_range : ∀ {c}, c ^ n = 1 → ∃ d, algebra_map F (X ^ n - C a).splitting_field d = c :=
    λ c hc, ring_hom.mem_range.mp (minpoly.mem_range_of_degree_eq_one F c (or.resolve_left h hn'''
      (minpoly.irreducible ((splitting_field.normal (X ^ n - C a)).is_integral c)) (minpoly.dvd F c
      (by rwa [map_id, alg_hom.map_sub, sub_eq_zero, aeval_X_pow, aeval_one])))),
  apply is_solvable_of_comm,
  intros σ τ,
  ext b hb,
  rw [mem_root_set hn'', alg_hom.map_sub, aeval_X_pow, aeval_C, sub_eq_zero] at hb,
  have hb' : b ≠ 0,
  { intro hb',
    rw [hb', zero_pow hn'] at hb,
    exact ha' hb.symm },
  have key : ∀ σ : (X ^ n - C a).gal, ∃ c, σ b = b * algebra_map F _ c,
  { intro σ,
    have key : (σ b / b) ^ n = 1 := by rw [div_pow, ←σ.map_pow, hb, σ.commutes, div_self ha'],
    obtain ⟨c, hc⟩ := mem_range key,
    use c,
    rw [hc, mul_div_cancel' (σ b) hb'] },
  obtain ⟨c, hc⟩ := key σ,
  obtain ⟨d, hd⟩ := key τ,
  rw [σ.mul_apply, τ.mul_apply, hc, τ.map_mul, τ.commutes, hd, σ.map_mul, σ.commutes, hc],
  rw [mul_assoc, mul_assoc, mul_right_inj' hb', mul_comm],
end

lemma splits_X_pow_sub_one_of_X_pow_sub_C {F : Type*} [field F] {E : Type*} [field E]
  (i : F →+* E) (n : ℕ) {a : F} (ha : a ≠ 0) (h : (X ^ n - C a).splits i) : (X ^ n - 1).splits i :=
begin
  have ha' : i a ≠ 0 := mt (i.injective_iff.mp (i.injective) a) ha,
  by_cases hn : n = 0,
  { rw [hn, pow_zero, sub_self],
    exact splits_zero i },
  have hn' : 0 < n := pos_iff_ne_zero.mpr hn,
  have hn'' : (X ^ n - C a).degree ≠ 0 :=
    ne_of_eq_of_ne (degree_X_pow_sub_C hn' a) (mt with_bot.coe_eq_coe.mp hn),
  obtain ⟨b, hb⟩ := exists_root_of_splits i h hn'',
  rw [eval₂_sub, eval₂_X_pow, eval₂_C, sub_eq_zero] at hb,
  have hb' : b ≠ 0,
  { intro hb',
    rw [hb', zero_pow hn'] at hb,
    exact ha' hb.symm },
  let s := ((X ^ n - C a).map i).roots,
  have hs : _ = _ * (s.map _).prod := eq_prod_roots_of_splits h,
  rw [leading_coeff_X_pow_sub_C hn', ring_hom.map_one, C_1, one_mul] at hs,
  have hs' : s.card = n := (nat_degree_eq_card_roots h).symm.trans nat_degree_X_pow_sub_C,
  apply @splits_of_exists_multiset F E _ _ i (X ^ n - 1) (s.map (λ c : E, c / b)),
  rw [leading_coeff_X_pow_sub_one hn', ring_hom.map_one, C_1, one_mul, multiset.map_map],
  have C_mul_C : (C (i a⁻¹)) * (C (i a)) = 1,
  { rw [←C_mul, ←i.map_mul, inv_mul_cancel ha, i.map_one, C_1] },
  have key1 : (X ^ n - 1).map i = C (i a⁻¹) * ((X ^ n - C a).map i).comp (C b * X),
  { rw [polynomial.map_sub, polynomial.map_sub, map_pow, map_X, map_C, polynomial.map_one, sub_comp,
        pow_comp, X_comp, C_comp, mul_pow, ←C_pow, hb, mul_sub, ←mul_assoc, C_mul_C, one_mul] },
  have key2 : (λ q : polynomial E, q.comp (C b * X)) ∘ (λ c : E, X - C c) =
    (λ c : E, C b * (X - C (c / b))),
  { ext1 c,
    change (X - C c).comp (C b * X) = C b * (X - C (c / b)),
    rw [sub_comp, X_comp, C_comp, mul_sub, ←C_mul, mul_div_cancel' c hb'] },
  rw [key1, hs, prod_comp, multiset.map_map, key2, multiset.prod_map_mul, multiset.map_const,
      multiset.prod_repeat, hs', ←C_pow, hb, ←mul_assoc, C_mul_C, one_mul],
  all_goals { exact field.to_nontrivial F },
end

lemma gal_X_pow_sub_C_is_solvable (n : ℕ) (x : F) : is_solvable (X ^ n - C x).gal :=
begin
  by_cases hx : x = 0,
  { rw [hx, C_0, sub_zero],
    exact gal_X_pow_is_solvable n },
  apply gal_is_solvable_tower (X ^ n - 1) (X ^ n - C x),
  { exact splits_X_pow_sub_one_of_X_pow_sub_C _ n hx (splitting_field.splits _) },
  { exact gal_X_pow_sub_one_is_solvable n },
  { rw [polynomial.map_sub, map_pow, map_X, map_C],
    apply gal_X_pow_sub_C_is_solvable_aux,
    have key := splitting_field.splits (X ^ n - 1 : polynomial F),
    rwa [←splits_id_iff_splits, polynomial.map_sub, map_pow, map_X, polynomial.map_one] at key }
end

end gal_X_pow_sub_C

variables (F)

/-- Inductive definition of solvable by radicals -/
inductive is_solvable_by_rad : E → Prop
| base (a : F) : is_solvable_by_rad (algebra_map F E a)
| add (a b : E) : is_solvable_by_rad a → is_solvable_by_rad b → is_solvable_by_rad (a + b)
| neg (α : E) : is_solvable_by_rad α → is_solvable_by_rad (-α)
| mul (α β : E) : is_solvable_by_rad α → is_solvable_by_rad β → is_solvable_by_rad (α * β)
| inv (α : E) : is_solvable_by_rad α → is_solvable_by_rad α⁻¹
| rad (α : E) (n : ℕ) (hn : n ≠ 0) : is_solvable_by_rad (α^n) → is_solvable_by_rad α

variables (E)

/-- The intermediate field of solvable-by-radicals elements -/
def solvable_by_rad : intermediate_field F E :=
{ carrier := is_solvable_by_rad F,
  zero_mem' := by { convert is_solvable_by_rad.base (0 : F), rw ring_hom.map_zero },
  add_mem' := is_solvable_by_rad.add,
  neg_mem' := is_solvable_by_rad.neg,
  one_mem' := by { convert is_solvable_by_rad.base (1 : F), rw ring_hom.map_one },
  mul_mem' := is_solvable_by_rad.mul,
  inv_mem' := is_solvable_by_rad.inv,
  algebra_map_mem' := is_solvable_by_rad.base }

namespace solvable_by_rad

variables {F} {E} {α : E}

lemma induction (P : solvable_by_rad F E → Prop)
(base : ∀ α : F, P (algebra_map F (solvable_by_rad F E) α))
(add : ∀ α β : solvable_by_rad F E, P α → P β → P (α + β))
(neg : ∀ α : solvable_by_rad F E, P α → P (-α))
(mul : ∀ α β : solvable_by_rad F E, P α → P β → P (α * β))
(inv : ∀ α : solvable_by_rad F E, P α → P α⁻¹)
(rad : ∀ α : solvable_by_rad F E, ∀ n : ℕ, n ≠ 0 → P (α^n) → P α)
(α : solvable_by_rad F E) : P α :=
begin
  revert α,
  suffices : ∀ (α : E), is_solvable_by_rad F α → (∃ β : solvable_by_rad F E, ↑β = α ∧ P β),
  { intro α,
    obtain ⟨α₀, hα₀, Pα⟩ := this α (subtype.mem α),
    convert Pα,
    exact subtype.ext hα₀.symm },
  apply is_solvable_by_rad.rec,
  { exact λ α, ⟨algebra_map F (solvable_by_rad F E) α, rfl, base α⟩ },
  { intros α β hα hβ Pα Pβ,
    obtain ⟨⟨α₀, hα₀, Pα⟩, β₀, hβ₀, Pβ⟩ := ⟨Pα, Pβ⟩,
    exact ⟨α₀ + β₀, by {rw [←hα₀, ←hβ₀], refl }, add α₀ β₀ Pα Pβ⟩ },
  { intros α hα Pα,
    obtain ⟨α₀, hα₀, Pα⟩ := Pα,
    exact ⟨-α₀, by {rw ←hα₀, refl }, neg α₀ Pα⟩ },
  { intros α β hα hβ Pα Pβ,
    obtain ⟨⟨α₀, hα₀, Pα⟩, β₀, hβ₀, Pβ⟩ := ⟨Pα, Pβ⟩,
    exact ⟨α₀ * β₀, by {rw [←hα₀, ←hβ₀], refl }, mul α₀ β₀ Pα Pβ⟩ },
  { intros α hα Pα,
    obtain ⟨α₀, hα₀, Pα⟩ := Pα,
    exact ⟨α₀⁻¹, by {rw ←hα₀, refl }, inv α₀ Pα⟩ },
  { intros α n hn hα Pα,
    obtain ⟨α₀, hα₀, Pα⟩ := Pα,
    refine ⟨⟨α, is_solvable_by_rad.rad α n hn hα⟩, rfl, rad _ n hn _⟩,
    convert Pα,
    exact subtype.ext (eq.trans ((solvable_by_rad F E).coe_pow _ n) hα₀.symm) }
end

theorem is_integral (α : solvable_by_rad F E) : is_integral F α :=
begin
  revert α,
  apply solvable_by_rad.induction,
  { exact λ _, is_integral_algebra_map },
  { exact λ _ _, is_integral_add },
  { exact λ _, is_integral_neg },
  { exact λ _ _, is_integral_mul },
  { exact λ α hα, subalgebra.inv_mem_of_algebraic (integral_closure F (solvable_by_rad F E))
      (show is_algebraic F ↑(⟨α, hα⟩ : integral_closure F (solvable_by_rad F E)),
        by exact (is_algebraic_iff_is_integral F).mpr hα) },
  { intros α n hn hα,
    obtain ⟨p, h1, h2⟩ := (is_algebraic_iff_is_integral F).mpr hα,
    refine (is_algebraic_iff_is_integral F).mp ⟨p.comp (X ^ n),
      ⟨λ h, h1 (leading_coeff_eq_zero.mp _), by rw [aeval_comp, aeval_X_pow, h2]⟩⟩,
    rwa [←leading_coeff_eq_zero, leading_coeff_comp, leading_coeff_X_pow, one_pow, mul_one] at h,
    rwa nat_degree_X_pow }
end

/-- The statement to be proved inductively -/
def P (α : solvable_by_rad F E) : Prop := is_solvable (minpoly F α).gal

/-- An auxiliary induction lemma, which is generalized by `solvable_by_rad.is_solvable`. -/
lemma induction3 {α : solvable_by_rad F E} {n : ℕ} (hn : n ≠ 0) (hα : P (α ^ n)) : P α :=
begin
  let p := minpoly F (α ^ n),
  have hp : p.comp (X ^ n) ≠ 0,
  { intro h,
    cases (comp_eq_zero_iff.mp h) with h' h',
    { exact minpoly.ne_zero (is_integral (α ^ n)) h' },
    { exact hn (by rw [←nat_degree_C _, ←h'.2, nat_degree_X_pow]) } },
  apply gal_is_solvable_of_splits,
  { exact ⟨splits_of_splits_of_dvd _ hp (splitting_field.splits (p.comp (X ^ n)))
      (minpoly.dvd F α (by rw [aeval_comp, aeval_X_pow, minpoly.aeval]))⟩ },
  { refine gal_is_solvable_tower p (p.comp (X ^ n)) _ hα _,
    { exact gal.splits_in_splitting_field_of_comp _ _ (by rwa [nat_degree_X_pow]) },
    { obtain ⟨s, hs⟩ := exists_multiset_of_splits _ (splitting_field.splits p),
      rw [map_comp, map_pow, map_X, hs, mul_comp, C_comp],
      apply gal_mul_is_solvable (gal_C_is_solvable _),
      rw prod_comp,
      apply gal_prod_is_solvable,
      intros q hq,
      rw multiset.mem_map at hq,
      obtain ⟨q, hq, rfl⟩ := hq,
      rw multiset.mem_map at hq,
      obtain ⟨q, hq, rfl⟩ := hq,
      rw [sub_comp, X_comp, C_comp],
      exact gal_X_pow_sub_C_is_solvable n q } },
end

/-- An auxiliary induction lemma, which is generalized by `solvable_by_rad.is_solvable`. -/
lemma induction2 {α β γ : solvable_by_rad F E} (hγ : γ ∈ F⟮α, β⟯) (hα : P α) (hβ : P β) : P γ :=
begin
  let p := (minpoly F α),
  let q := (minpoly F β),
  have hpq := polynomial.splits_of_splits_mul _ (mul_ne_zero (minpoly.ne_zero (is_integral α))
    (minpoly.ne_zero (is_integral β))) (splitting_field.splits (p * q)),
  let f : F⟮α, β⟯ →ₐ[F] (p * q).splitting_field := classical.choice (alg_hom_mk_adjoin_splits
  begin
    intros x hx,
    cases hx,
    rw hx,
    exact ⟨is_integral α, hpq.1⟩,
    cases hx,
    exact ⟨is_integral β, hpq.2⟩,
  end),
  have key : minpoly F γ = minpoly F (f ⟨γ, hγ⟩) := minpoly.eq_of_irreducible_of_monic
    (minpoly.irreducible (is_integral γ)) begin
      suffices : aeval (⟨γ, hγ⟩ : F ⟮α, β⟯) (minpoly F γ) = 0,
      { rw [aeval_alg_hom_apply, this, alg_hom.map_zero] },
      apply (algebra_map F⟮α, β⟯ (solvable_by_rad F E)).injective,
      rw [ring_hom.map_zero, is_scalar_tower.algebra_map_aeval],
      exact minpoly.aeval F γ,
    end (minpoly.monic (is_integral γ)),
  rw [P, key],
  exact gal_is_solvable_of_splits ⟨normal.splits (splitting_field.normal _) _⟩
    (gal_mul_is_solvable hα hβ),
end

/-- An auxiliary induction lemma, which is generalized by `solvable_by_rad.is_solvable`. -/

theorem is_solvable (α : solvable_by_rad F E) :
  is_solvable (minpoly F α).gal :=
begin
  revert α,
  apply solvable_by_rad.induction,
  { exact λ α, by { rw minpoly.eq_X_sub_C, exact gal_X_sub_C_is_solvable α } },
  { exact λ α β, induction2 (add_mem _ (subset_adjoin F _ (set.mem_insert α _))
      (subset_adjoin F _ (set.mem_insert_of_mem α (set.mem_singleton β)))) },
  { exact λ α, induction1 (neg_mem _ (mem_adjoin_simple_self F α)) },
  { exact λ α β, induction2 (mul_mem _ (subset_adjoin F _ (set.mem_insert α _))
      (subset_adjoin F _ (set.mem_insert_of_mem α (set.mem_singleton β)))) },
  { exact λ α, induction1 (inv_mem _ (mem_adjoin_simple_self F α)) },
  { exact λ α n, induction3 },
end

/-- **Abel-Ruffini Theorem** (one direction): An irreducible polynomial with an
`is_solvable_by_rad` root has solvable Galois group -/
lemma is_solvable' {α : E} {q : polynomial F} (q_irred : irreducible q)
  (q_aeval : aeval α q = 0) (hα : is_solvable_by_rad F α) :
  _root_.is_solvable q.gal :=
begin
  haveI : _root_.is_solvable (q * C q.leading_coeff⁻¹).gal,
  { rw [minpoly.eq_of_irreducible q_irred q_aeval,
        ←show minpoly F (⟨α, hα⟩ : solvable_by_rad F E) = minpoly F α,
        from minpoly.eq_of_algebra_map_eq (ring_hom.injective _) (is_integral ⟨α, hα⟩) rfl],
    exact is_solvable ⟨α, hα⟩ },
  refine solvable_of_surjective (gal.restrict_dvd_surjective ⟨C q.leading_coeff⁻¹, rfl⟩ _),
  rw [mul_ne_zero_iff, ne, ne, C_eq_zero, inv_eq_zero],
  exact ⟨q_irred.ne_zero, leading_coeff_ne_zero.mpr q_irred.ne_zero⟩,
end

end solvable_by_rad

end abel_ruffini


/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import topology.basic
import order.omega_complete_partial_order

/-!
# Scott Topological Spaces

A type of topological spaces whose notion
of continuity is equivalent to continuity in ωCPOs.

## Reference

 * https://ncatlab.org/nlab/show/Scott+topology

-/

open omega_complete_partial_order
open_locale classical

universes u
namespace Scott

/-- `x` is an `ω`-Sup of a chain `c` if it is the least upper bound of the range of `c`. -/
def is_ωSup {α : Type u} [preorder α] (c : chain α) (x : α) : Prop :=
(∀ i, c i ≤ x) ∧ (∀ y, (∀ i, c i ≤ y) → x ≤ y)

lemma is_ωSup_iff_is_lub {α : Type u} [preorder α] {c : chain α} {x : α} :
  is_ωSup c x ↔ is_lub (set.range c) x :=
by simp [is_ωSup, is_lub, is_least, upper_bounds, lower_bounds]

variables (α : Type u) [omega_complete_partial_order α]
local attribute [irreducible] set

/-- The characteristic function of open sets is monotone and preserves
the limits of chains. -/
def is_open (s : set α) : Prop :=
continuous' (λ x, x ∈ s)

theorem is_open_univ : is_open α set.univ :=
⟨λ x y h, by simp only [set.mem_univ]; refl',
  by convert @complete_lattice.top_continuous α Prop _ _; ext; simp ⟩

theorem is_open.inter (s t : set α) : is_open α s → is_open α t → is_open α (s ∩ t) :=
complete_lattice.inf_continuous'

theorem is_open_sUnion (s : set (set α)) (hs : ∀t∈s, is_open α t) : is_open α (⋃₀ s) :=
begin
  simp only [is_open] at hs ⊢,
  convert complete_lattice.Sup_continuous' (set_of ⁻¹' s) _,
  { ext1 x,
    simp only [Sup_apply, set.set_of_bijective.surjective.exists, exists_prop, set.mem_preimage,
      set_coe.exists, supr_Prop_eq, set.mem_set_of_eq, subtype.coe_mk] },
  { intros p hp,
    convert hs (set_of p) (set.mem_preimage.1 hp),
    simp only [set.mem_set_of_eq] },
end

end Scott

/-- A Scott topological space is defined on preorders
such that their open sets, seen as a function `α → Prop`,
preserves the joins of ω-chains  -/
@[reducible]
def Scott (α : Type u) := α

instance Scott.topological_space (α : Type u) [omega_complete_partial_order α] :
  topological_space (Scott α) :=
{ is_open := Scott.is_open α,
  is_open_univ := Scott.is_open_univ α,
  is_open_inter := Scott.is_open.inter α,
  is_open_sUnion := Scott.is_open_sUnion α }

section not_below
variables {α : Type*} [omega_complete_partial_order α] (y : Scott α)

/-- `not_below` is an open set in `Scott α` used
to prove the monotonicity of continuous functions -/
def not_below := { x | ¬ x ≤ y }

lemma not_below_is_open : is_open (not_below y) :=
begin
  have h : monotone (not_below y),
  { intros x y' h,
    simp only [not_below, set_of, le_Prop_eq],
    intros h₀ h₁, apply h₀ (le_trans h h₁) },
  existsi h, rintros c,
  apply eq_of_forall_ge_iff, intro z,
  rw ωSup_le_iff,
  simp only [ωSup_le_iff, not_below, set.mem_set_of_eq, le_Prop_eq, order_hom.coe_fun_mk,
             chain.map_coe, function.comp_app, exists_imp_distrib, not_forall],
end

end not_below

open Scott (hiding is_open)
open omega_complete_partial_order

lemma is_ωSup_ωSup {α} [omega_complete_partial_order α] (c : chain α) :
  is_ωSup c (ωSup c) :=
begin
  split,
  { apply le_ωSup, },
  { apply ωSup_le, },
end

lemma Scott_continuous_of_continuous {α β}
  [omega_complete_partial_order α]
  [omega_complete_partial_order β]
  (f : Scott α → Scott β) (hf : continuous f) :
  omega_complete_partial_order.continuous' f :=
begin
  simp only [continuous_def, (⁻¹')] at hf,
  have h : monotone f,
  { intros x y h,
    cases (hf {x | ¬ x ≤ f y} (not_below_is_open _)) with hf hf', clear hf',
    specialize hf h, simp only [set.preimage, set_of, (∈), set.mem, le_Prop_eq] at hf,
    by_contradiction H, apply hf H (le_refl (f y)) },
  existsi h, intro c,
  apply eq_of_forall_ge_iff, intro z,
  specialize (hf _ (not_below_is_open z)),
  cases hf, specialize hf_h c,
  simp only [not_below, order_hom.coe_fun_mk, eq_iff_iff, set.mem_set_of_eq] at hf_h,
  rw [← not_iff_not],
  simp only [ωSup_le_iff, hf_h, ωSup, supr, Sup, complete_lattice.Sup, complete_semilattice_Sup.Sup,
    exists_prop, set.mem_range, order_hom.coe_fun_mk, chain.map_coe, function.comp_app,
    eq_iff_iff, not_forall],
  tauto,
end

lemma continuous_of_Scott_continuous {α β}
  [omega_complete_partial_order α]
  [omega_complete_partial_order β]
  (f : Scott α → Scott β) (hf : omega_complete_partial_order.continuous' f) :
  continuous f :=
begin
  rw continuous_def,
  intros s hs,
  change continuous' (s ∘ f),
  cases hs with hs hs',
  cases hf with hf hf',
  apply continuous.of_bundled,
  apply continuous_comp _ _ hf' hs',
end