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

Finite sets.
-/
import data.set.lattice data.nat.basic logic.function
       data.fintype

open set lattice function

universes u v w
variables {α : Type u} {β : Type v} {ι : Sort w}

namespace set

/-- A set is finite if the subtype is a fintype, i.e. there is a
  list that enumerates its members. -/
def finite (s : set α) : Prop := nonempty (fintype s)

/-- A set is infinite if it is not finite. -/
def infinite (s : set α) : Prop := ¬ finite s

/-- Construct a fintype from a finset with the same elements. -/
def fintype_of_finset {p : set α} (s : finset α) (H : ∀ x, x ∈ s ↔ x ∈ p) : fintype p :=
fintype.subtype s H

@[simp] theorem card_fintype_of_finset {p : set α} (s : finset α) (H : ∀ x, x ∈ s ↔ x ∈ p) :
  @fintype.card p (fintype_of_finset s H) = s.card :=
fintype.subtype_card s H

theorem card_fintype_of_finset' {p : set α} (s : finset α)
  (H : ∀ x, x ∈ s ↔ x ∈ p) [fintype p] : fintype.card p = s.card :=
by rw ← card_fintype_of_finset s H; congr

/-- Construct a finset enumerating a set `s`, given a `fintype` instance.  -/
def to_finset (s : set α) [fintype s] : finset α :=
⟨(@finset.univ s _).1.map subtype.val,
 multiset.nodup_map (λ a b, subtype.eq) finset.univ.2⟩

@[simp] theorem mem_to_finset {s : set α} [fintype s] {a : α} : a ∈ s.to_finset ↔ a ∈ s :=
by simp [to_finset]

@[simp] theorem mem_to_finset_val {s : set α} [fintype s] {a : α} : a ∈ s.to_finset.1 ↔ a ∈ s :=
mem_to_finset

noncomputable instance finite.fintype {s : set α} (h : finite s) : fintype s :=
classical.choice h

/-- Get a finset from a finite set -/
noncomputable def finite.to_finset {s : set α} (h : finite s) : finset α :=
@set.to_finset _ _ (finite.fintype h)

@[simp] theorem finite.mem_to_finset {s : set α} {h : finite s} {a : α} : a ∈ h.to_finset ↔ a ∈ s :=
@mem_to_finset _ _ (finite.fintype h) _

theorem finite.exists_finset {s : set α} : finite s →
  ∃ s' : finset α, ∀ a : α, a ∈ s' ↔ a ∈ s
| ⟨h⟩ := by exactI ⟨to_finset s, λ _, mem_to_finset⟩

theorem finite.exists_finset_coe {s : set α} (hs : finite s) :
  ∃ s' : finset α, ↑s' = s :=
let ⟨s', h⟩ := hs.exists_finset in ⟨s', set.ext h⟩

theorem finite_mem_finset (s : finset α) : finite {a | a ∈ s} :=
⟨fintype_of_finset s (λ _, iff.rfl)⟩

instance decidable_mem_of_fintype [decidable_eq α] (s : set α) [fintype s] (a) : decidable (a ∈ s) :=
decidable_of_iff _ mem_to_finset

instance fintype_empty : fintype (∅ : set α) :=
fintype_of_finset ∅ $ by simp

theorem empty_card : fintype.card (∅ : set α) = 0 := rfl

@[simp] theorem empty_card' {h : fintype.{u} (∅ : set α)} :
  @fintype.card (∅ : set α) h = 0 :=
eq.trans (by congr) empty_card

@[simp] theorem finite_empty : @finite α ∅ := ⟨set.fintype_empty⟩

def fintype_insert' {a : α} (s : set α) [fintype s] (h : a ∉ s) : fintype (insert a s : set α) :=
fintype_of_finset ⟨a :: s.to_finset.1,
  multiset.nodup_cons_of_nodup (by simp [h]) s.to_finset.2⟩ $ by simp

theorem card_fintype_insert' {a : α} (s : set α) [fintype s] (h : a ∉ s) :
  @fintype.card _ (fintype_insert' s h) = fintype.card s + 1 :=
by rw [fintype_insert', card_fintype_of_finset];
   simp [finset.card, to_finset]; refl

@[simp] theorem card_insert {a : α} (s : set α)
  [fintype s] (h : a ∉ s) {d : fintype.{u} (insert a s : set α)} :
  @fintype.card _ d = fintype.card s + 1 :=
by rw ← card_fintype_insert' s h; congr

lemma card_image_of_inj_on {s : set α} [fintype s]
  {f : α → β} [fintype (f '' s)] (H : ∀x∈s, ∀y∈s, f x = f y → x = y) :
  fintype.card (f '' s) = fintype.card s :=
by haveI := classical.prop_decidable; exact
calc fintype.card (f '' s) = (s.to_finset.image f).card : card_fintype_of_finset' _ (by simp)
... = s.to_finset.card : finset.card_image_of_inj_on
    (λ x hx y hy hxy, H x (mem_to_finset.1 hx) y (mem_to_finset.1 hy) hxy)
... = fintype.card s : (card_fintype_of_finset' _ (λ a, mem_to_finset)).symm

lemma card_image_of_injective (s : set α) [fintype s]
  {f : α → β} [fintype (f '' s)] (H : function.injective f) :
  fintype.card (f '' s) = fintype.card s :=
card_image_of_inj_on $ λ _ _ _ _ h, H h

instance fintype_insert [decidable_eq α] (a : α) (s : set α) [fintype s] : fintype (insert a s : set α) :=
if h : a ∈ s then by rwa [insert_eq, union_eq_self_of_subset_left (singleton_subset_iff.2 h)]
else fintype_insert' _ h

@[simp] theorem finite_insert (a : α) {s : set α} : finite s → finite (insert a s)
| ⟨h⟩ := ⟨@set.fintype_insert _ (classical.dec_eq α) _ _ h⟩

lemma to_finset_insert [decidable_eq α] {a : α} {s : set α} (hs : finite s) :
  (finite_insert a hs).to_finset = insert a hs.to_finset :=
finset.ext.mpr $ by simp

@[elab_as_eliminator]
theorem finite.induction_on {C : set α → Prop} {s : set α} (h : finite s)
  (H0 : C ∅) (H1 : ∀ {a s}, a ∉ s → finite s → C s → C (insert a s)) : C s :=
let ⟨t⟩ := h in by exactI
match s.to_finset, @mem_to_finset _ s _ with
| ⟨l, nd⟩, al := begin
    change ∀ a, a ∈ l ↔ a ∈ s at al,
    clear _let_match _match t h, revert s nd al,
    refine multiset.induction_on l _ (λ a l IH, _); intros s nd al,
    { rw show s = ∅, from eq_empty_iff_forall_not_mem.2 (by simpa using al),
      exact H0 },
    { rw ← show insert a {x | x ∈ l} = s, from set.ext (by simpa using al),
      cases multiset.nodup_cons.1 nd with m nd',
      refine H1 _ ⟨finset.subtype.fintype ⟨l, nd'⟩⟩ (IH nd' (λ _, iff.rfl)),
      exact m }
  end
end

@[elab_as_eliminator]
theorem finite.dinduction_on {C : ∀s:set α, finite s → Prop} {s : set α} (h : finite s)
  (H0 : C ∅ finite_empty)
  (H1 : ∀ {a s}, a ∉ s → ∀h:finite s, C s h → C (insert a s) (finite_insert a h)) :
  C s h :=
have ∀h:finite s, C s h,
  from finite.induction_on h (assume h, H0) (assume a s has hs ih h, H1 has hs (ih _)),
this h

instance fintype_singleton (a : α) : fintype ({a} : set α) :=
fintype_insert' _ (not_mem_empty _)

@[simp] theorem card_singleton (a : α) :
  fintype.card ({a} : set α) = 1 :=
by rw [show fintype.card ({a} : set α) = _, from
    card_fintype_insert' ∅ (not_mem_empty a)]; refl

@[simp] theorem finite_singleton (a : α) : finite ({a} : set α) :=
⟨set.fintype_singleton _⟩

instance fintype_union [decidable_eq α] (s t : set α) [fintype s] [fintype t] : fintype (s ∪ t : set α) :=
fintype_of_finset (s.to_finset ∪ t.to_finset) $ by simp

theorem finite_union {s t : set α} : finite s → finite t → finite (s ∪ t)
| ⟨hs⟩ ⟨ht⟩ := ⟨@set.fintype_union _ (classical.dec_eq α) _ _ hs ht⟩

instance fintype_sep (s : set α) (p : α → Prop) [fintype s] [decidable_pred p] : fintype ({a ∈ s | p a} : set α) :=
fintype_of_finset (s.to_finset.filter p) $ by simp

instance fintype_inter (s t : set α) [fintype s] [decidable_pred t] : fintype (s ∩ t : set α) :=
set.fintype_sep s t

def fintype_subset (s : set α) {t : set α} [fintype s] [decidable_pred t] (h : t ⊆ s) : fintype t :=
by rw ← inter_eq_self_of_subset_right h; apply_instance

theorem finite_subset {s : set α} : finite s → ∀ {t : set α}, t ⊆ s → finite t
| ⟨hs⟩ t h := ⟨@set.fintype_subset _ _ _ hs (classical.dec_pred t) h⟩

instance fintype_image [decidable_eq β] (s : set α) (f : α → β) [fintype s] : fintype (f '' s) :=
fintype_of_finset (s.to_finset.image f) $ by simp

instance fintype_range [decidable_eq β] (f : α → β) [fintype α] : fintype (range f) :=
fintype_of_finset (finset.univ.image f) $ by simp [range]

theorem finite_range (f : α → β) [fintype α] : finite (range f) :=
by haveI := classical.dec_eq β; exact ⟨by apply_instance⟩

theorem finite_image {s : set α} (f : α → β) : finite s → finite (f '' s)
| ⟨h⟩ := ⟨@set.fintype_image _ _ (classical.dec_eq β) _ _ h⟩

def fintype_of_fintype_image [decidable_eq β] (s : set α)
  {f : α → β} {g} (I : is_partial_inv f g) [fintype (f '' s)] : fintype s :=
fintype_of_finset ⟨_, @multiset.nodup_filter_map β α g _
  (@injective_of_partial_inv_right _ _ f g I) (f '' s).to_finset.2⟩ $ λ a,
begin
  suffices : (∃ b x, f x = b ∧ g b = some a ∧ x ∈ s) ↔ a ∈ s,
  by simpa [exists_and_distrib_left.symm, and.comm, and.left_comm, and.assoc],
  rw exists_swap,
  suffices : (∃ x, x ∈ s ∧ g (f x) = some a) ↔ a ∈ s, {simpa [and.comm, and.left_comm, and.assoc]},
  simp [I _, (injective_of_partial_inv I).eq_iff]
end

theorem finite_of_finite_image {s : set α} {f : α → β}
  (I : injective f) : finite (f '' s) → finite s | ⟨hs⟩ :=
by haveI := classical.dec_eq β; exact
⟨fintype_of_fintype_image _ (partial_inv_of_injective I)⟩

theorem finite_preimage {s : set β} {f : α → β}
  (I : injective f) (h : finite s) : finite (f ⁻¹' s) :=
finite_of_finite_image I (finite_subset h (image_preimage_subset f s))

instance fintype_Union [decidable_eq α] {ι : Type*} [fintype ι]
  (f : ι → set α) [∀ i, fintype (f i)] : fintype (⋃ i, f i) :=
fintype_of_finset (finset.univ.bind (λ i, (f i).to_finset)) $ by simp

theorem finite_Union {ι : Type*} [fintype ι] {f : ι → set α} (H : ∀i, finite (f i)) : finite (⋃ i, f i) :=
⟨@set.fintype_Union _ (classical.dec_eq α) _ _ _ (λ i, finite.fintype (H i))⟩

theorem finite_sUnion {s : set (set α)} (h : finite s) (H : ∀t∈s, finite t) : finite (⋃₀ s) :=
by rw sUnion_eq_Union; haveI := finite.fintype h;
   apply finite_Union; simpa using H

instance fintype_lt_nat (n : ℕ) : fintype {i | i < n} :=
fintype_of_finset (finset.range n) $ by simp

instance fintype_le_nat (n : ℕ) : fintype {i | i ≤ n} :=
by simpa [nat.lt_succ_iff] using set.fintype_lt_nat (n+1)

lemma finite_le_nat (n : ℕ) : finite {i | i ≤ n} := ⟨set.fintype_le_nat _⟩

instance fintype_prod (s : set α) (t : set β) [fintype s] [fintype t] : fintype (set.prod s t) :=
fintype_of_finset (s.to_finset.product t.to_finset) $ by simp

lemma finite_prod {s : set α} {t : set β} : finite s → finite t → finite (set.prod s t)
| ⟨hs⟩ ⟨ht⟩ := by exactI ⟨set.fintype_prod s t⟩

end set

namespace finset
variables [decidable_eq β]
variables {s t u : finset α} {f : α → β} {a : α}

lemma finite_to_set (s : finset α) : set.finite (↑s : set α) :=
set.finite_mem_finset s

@[simp] lemma coe_bind {f : α → finset β} : ↑(s.bind f) = (⋃x ∈ (↑s : set α), ↑(f x) : set β) :=
by simp [set.ext_iff]

@[simp] lemma coe_to_finset {s : set α} {hs : set.finite s} : ↑(hs.to_finset) = s :=
by simp [set.ext_iff]

@[simp] lemma coe_to_finset' [decidable_eq α] (s : set α) [fintype s] : (↑s.to_finset : set α) = s :=
by ext; simp

end finset

namespace set

lemma finite_subset_Union {s : set α} (hs : finite s)
  {ι} {t : ι → set α} (h : s ⊆ ⋃ i, t i) : ∃ I : set ι, finite I ∧ s ⊆ ⋃ i ∈ I, t i :=
begin
  unfreezeI, cases hs,
  have : ∀ x : s, ∃ i, x.1 ∈ t i, {simpa [subset_def] using h},
  cases classical.axiom_of_choice this with f hf,
  refine ⟨range f, finite_range f, _⟩,
  rintro x hx, simp, exact ⟨_, ⟨_, hx, rfl⟩, hf ⟨x, hx⟩⟩
end

lemma infinite_univ_nat : infinite (univ : set ℕ) :=
assume (h : finite (univ : set ℕ)),
let ⟨n, hn⟩ := finset.exists_nat_subset_range h.to_finset in
have n ∈ finset.range n, from finset.subset_iff.mpr hn $ by simp,
by simp * at *

lemma not_injective_nat_fintype [fintype α] [decidable_eq α] {f : ℕ → α} : ¬ injective f :=
assume (h : injective f),
have finite (f '' univ),
  from finite_subset (finset.finite_to_set $ fintype.elems α) (assume a h, fintype.complete a),
have finite (univ : set ℕ), from finite_of_finite_image h this,
infinite_univ_nat this

lemma not_injective_int_fintype [fintype α] [decidable_eq α] {f : ℤ → α} : ¬ injective f :=
assume hf,
have injective (f ∘ (coe : ℕ → ℤ)), from injective_comp hf $ assume i j, int.of_nat_inj,
not_injective_nat_fintype this

lemma card_lt_card {s t : set α} [fintype s] [fintype t] (h : s ⊂ t) :
  fintype.card s < fintype.card t :=
begin
  haveI := classical.prop_decidable,
  rw [← finset.coe_to_finset' s, ← finset.coe_to_finset' t, finset.coe_ssubset] at h,
  rw [card_fintype_of_finset' _ (λ x, mem_to_finset),
      card_fintype_of_finset' _ (λ x, mem_to_finset)],
  exact finset.card_lt_card h,
end

end set


import tactic

/-
Tactics you may consider
-intro
-cases
-apply
-exact
-have
-clear
-/

variables P Q R :  Prop

example : (P → Q) ∧ (Q → R) → (P → R) :=
begin
    intros h,
    cases h with hpq hqr,
    intro hp,
    exact (hqr (hpq (hp))),
end

-- Alternatively
example : (P → Q) ∧ (Q → R) → (P → R) :=
begin
    intro h,
    cases h with hpq hqr,
    intro hp,
    apply hqr (hpq hp),
end

-- Alternatively
theorem basic_logic : (P → Q) ∧ (Q → R) → (P → R) :=
begin
    intros h,
    have hpq : P → Q,
    exact h.left,
    have hqr : Q → R,
    exact h.right,
    clear h,
    intro hp,
    have hq : Q,
    exact hpq hp,
    exact hqr hq,
end

-- Alternatively
example : (P → Q) ∧ (Q → R) → (P → R) :=
begin
    intros h,
    have hpq : P → Q := h.left,
    have hqr : Q → R := h.right,
    clear h,
    intro hp,
    have hq : Q,
    exact hpq hp,
    exact hqr hq,
end


/-
Copyright (c) 2019 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot
-/
import topology.algebra.uniform_ring
import topology.algebra.field

/-!
# Completion of topological fields

The goal of this file is to prove the main part of Proposition 7 of Bourbaki GT III 6.8 :

The completion `hat K` of a Hausdorff topological field is a field if the image under
the mapping `x ↦ x⁻¹` of every Cauchy filter (with respect to the additive uniform structure)
which does not have a cluster point at `0` is a Cauchy filter
(with respect to the additive uniform structure).

Bourbaki does not give any detail here, he refers to the general discussion of extending
functions defined on a dense subset with values in a complete Hausdorff space. In particular
the subtlety about clustering at zero is totally left to readers.

Note that the separated completion of a non-separated topological field is the zero ring, hence
the separation assumption is needed. Indeed the kernel of the completion map is the closure of
zero which is an ideal. Hence it's either zero (and the field is separated) or the full field,
which implies one is sent to zero and the completion ring is trivial.

The main definition is `completable_top_field` which packages the assumptions as a Prop-valued
type class and the main results are the instances `field_completion` and
`topological_division_ring_completion`.
-/

noncomputable theory

open_locale classical uniformity topological_space

open set uniform_space uniform_space.completion filter

variables (K : Type*) [field K]  [uniform_space K]

local notation `hat` := completion

@[priority 100]
instance [separated_space K] : nontrivial (hat K) :=
⟨⟨0, 1, λ h, zero_ne_one $ (uniform_embedding_coe K).inj h⟩⟩

/--
A topological field is completable if it is separated and the image under
the mapping x ↦ x⁻¹ of every Cauchy filter (with respect to the additive uniform structure)
which does not have a cluster point at 0 is a Cauchy filter
(with respect to the additive uniform structure). This ensures the completion is
a field.
-/
class completable_top_field extends separated_space K : Prop :=
(nice : ∀ F : filter K, cauchy F → 𝓝 0 ⊓ F = ⊥ → cauchy (map (λ x, x⁻¹) F))

variables {K}

/-- extension of inversion to the completion of a field. -/
def hat_inv : hat K → hat K := dense_inducing_coe.extend (λ x : K, (coe x⁻¹ : hat K))

lemma continuous_hat_inv [completable_top_field K] {x : hat K} (h : x ≠ 0) :
  continuous_at hat_inv x :=
begin
  haveI : regular_space (hat K) := completion.regular_space K,
  refine dense_inducing_coe.continuous_at_extend _,
  apply mem_of_superset (compl_singleton_mem_nhds h),
  intros y y_ne,
  rw mem_compl_singleton_iff at y_ne,
  apply complete_space.complete,
  rw ← filter.map_map,
  apply cauchy.map _ (completion.uniform_continuous_coe K),
  apply completable_top_field.nice,
  { haveI := dense_inducing_coe.comap_nhds_ne_bot y,
    apply cauchy_nhds.comap,
    { rw completion.comap_coe_eq_uniformity,
      exact le_rfl } },
  { have eq_bot : 𝓝 (0 : hat K) ⊓ 𝓝 y = ⊥,
    { by_contradiction h,
      exact y_ne (eq_of_nhds_ne_bot $ ne_bot_iff.mpr h).symm },
    erw [dense_inducing_coe.nhds_eq_comap (0 : K), ← comap_inf,  eq_bot],
    exact comap_bot },
end

/-
The value of `hat_inv` at zero is not really specified, although it's probably zero.
Here we explicitly enforce the `inv_zero` axiom.
-/
instance completion.has_inv : has_inv (hat K) := ⟨λ x, if x = 0 then 0 else hat_inv x⟩

variables [topological_division_ring K]

lemma hat_inv_extends {x : K} (h : x ≠ 0) : hat_inv (x : hat K) = coe (x⁻¹ : K) :=
dense_inducing_coe.extend_eq_at
    ((continuous_coe K).continuous_at.comp (topological_division_ring.continuous_inv x h))

variables [completable_top_field K]

@[norm_cast]
lemma coe_inv (x : K) : (x : hat K)⁻¹ = ((x⁻¹ : K) : hat K) :=
begin
  by_cases h : x = 0,
  { rw [h, inv_zero],
    dsimp [has_inv.inv],
    norm_cast,
    simp [if_pos] },
  { conv_lhs { dsimp [has_inv.inv] },
    norm_cast,
    rw if_neg,
    { exact hat_inv_extends h },
    { exact λ H, h (dense_embedding_coe.inj H) } }
end

variables [uniform_add_group K]

lemma mul_hat_inv_cancel {x : hat K} (x_ne : x ≠ 0) : x*hat_inv x = 1 :=
begin
  haveI : t1_space (hat K) := t2_space.t1_space,
  let f := λ x : hat K, x*hat_inv x,
  let c := (coe : K → hat K),
  change f x = 1,
  have cont : continuous_at f x,
  { letI : topological_space (hat K × hat K) := prod.topological_space,
    have : continuous_at (λ y : hat K, ((y, hat_inv y) : hat K × hat K)) x,
      from continuous_id.continuous_at.prod (continuous_hat_inv x_ne),
    exact (_root_.continuous_mul.continuous_at.comp this : _) },
  have clo : x ∈ closure (c '' {0}ᶜ),
  { have := dense_inducing_coe.dense x,
    rw [← image_univ, show (univ : set K) = {0} ∪ {0}ᶜ,
                      from (union_compl_self _).symm, image_union] at this,
    apply mem_closure_of_mem_closure_union this,
    rw image_singleton,
    exact compl_singleton_mem_nhds x_ne },
  have fxclo : f x ∈ closure (f '' (c '' {0}ᶜ)) := mem_closure_image cont clo,
  have : f '' (c '' {0}ᶜ) ⊆ {1},
  { rw image_image,
    rintros _ ⟨z, z_ne, rfl⟩,
    rw mem_singleton_iff,
    rw mem_compl_singleton_iff at z_ne,
    dsimp [c, f],
    rw hat_inv_extends z_ne,
    norm_cast,
    rw mul_inv_cancel z_ne,
    norm_cast },
  replace fxclo := closure_mono this fxclo,
  rwa [closure_singleton, mem_singleton_iff] at fxclo
end

instance field_completion : field (hat K) :=
{ exists_pair_ne := ⟨0, 1, λ h, zero_ne_one ((uniform_embedding_coe K).inj h)⟩,
  mul_inv_cancel := λ x x_ne, by { dsimp [has_inv.inv],
                                   simp [if_neg x_ne, mul_hat_inv_cancel x_ne], },
  inv_zero := show ((0 : K) : hat K)⁻¹ = ((0 : K) : hat K), by rw [coe_inv, inv_zero],
  ..completion.has_inv,
  ..(by apply_instance : comm_ring (hat K)) }

instance topological_division_ring_completion : topological_division_ring (hat K) :=
{ continuous_inv := begin
    intros x x_ne,
    have : {y | hat_inv y = y⁻¹ } ∈ 𝓝 x,
    { have : {(0 : hat K)}ᶜ ⊆ {y : hat K | hat_inv y = y⁻¹ },
      { intros y y_ne,
        rw mem_compl_singleton_iff at y_ne,
        dsimp [has_inv.inv],
        rw if_neg y_ne },
      exact mem_of_superset (compl_singleton_mem_nhds x_ne) this },
    exact continuous_at.congr (continuous_hat_inv x_ne) this
  end,
  ..completion.top_ring_compl }


import GMLInit.Data.Bool
import GMLInit.Data.Equiv
import GMLInit.Data.Nat.Basic
import GMLInit.Data.Nat.Order

namespace Nat

protected def recTwo {motive : Nat → Sort _} (zero : motive 0) (one : motive 1) (step : (n : Nat) → motive n → motive (n+2)) : (n : Nat) → motive n
| 0 => zero
| 1 => one
| n+2 => step n (Nat.recTwo zero one step n)

protected def recTwoOn {motive : Nat → Sort _} (n : Nat) (zero : motive 0) (one : motive 1) (step : (n : Nat) → motive n → motive (n+2)) : motive n :=
  Nat.recTwo zero one step n

protected def casesTwoOn {motive : Nat → Sort _} (n : Nat) (zero : motive 0) (one : motive 1) (step : (n : Nat) → motive (n+2)) : motive n :=
  Nat.recTwo zero one (λ n _ => step n) n

def isEven : Nat → Bool
| 0 => true
| 1 => false
| n + 2 => isEven n

abbrev isOdd (n : Nat) := !n.isEven

private abbrev isEvenImpl (n : Nat) : Bool := (n % 2) == 0

@[csimp] theorem isEven_eq_isEvenImpl : isEven = isEvenImpl := by
  funext n
  induction n using Nat.recTwo with
  | zero => rfl
  | one => rfl
  | step n ih =>
    clean unfold Nat.isEven Nat.add
    rw [isEvenImpl, Nat.add_mod_right, ih]

theorem isEven_or_isOdd (n : Nat) : n.isEven ∨ n.isOdd := by
  rw [←Bool.or_eq_true]
  exact Bool.or_not_self_right ..

theorem not_isOdd_eq_isEven (n : Nat) : (!n.isOdd) = n.isEven := by
  rw [Bool.not_not]

theorem not_isEven_eq_isOdd (n : Nat) : (!n.isEven) = n.isOdd := rfl

def half : Nat → Nat
| 0 | 1 => 0
| n + 2 => half n + 1

abbrev halfImpl (n : Nat) : Nat := n / 2

@[csimp] theorem half_eq_halfImpl : half = halfImpl := by
  funext n
  induction n using Nat.recTwo with
  | zero => rfl
  | one => rfl
  | step n ih =>
    clean unfold Nat.half Nat.add
    rw [halfImpl, Nat.add_div_right, ih]
    nat_is_pos

protected abbrev inl (n : Nat) := 2 * n

protected abbrev inr (n : Nat) := 2 * n + 1

theorem isEven_inl (n : Nat) : isEven n.inl := by
  induction n with
  | zero => rfl
  | succ n ih =>
    clean unfold Nat.inl at ih ⊢
    rw [Nat.mul_succ]
    exact ih

theorem isOdd_inr (n : Nat) : isOdd n.inr := by
  induction n with
  | zero => rfl
  | succ n ih =>
    clean unfold Nat.inr at ih ⊢
    rw [Nat.mul_succ]
    exact ih

theorem half_inl_eq (n : Nat) : half n.inl = n := by
  induction n with
  | zero => rfl
  | succ n ih =>
    clean unfold Nat.inl at ih ⊢
    rw [Nat.mul_succ, Nat.half, ih]

theorem half_inr_eq (n : Nat) : half n.inr = n := by
  induction n with
  | zero => rfl
  | succ n ih =>
    clean unfold Nat.inr at ih ⊢
    rw [Nat.mul_succ, Nat.half, ih]

theorem inl_half_eq_of_isEven {n : Nat} : isEven n → (half n).inl = n := by
  induction n using Nat.recTwo with
  | zero => intro; rfl
  | one => intro; contradiction
  | step n ih =>
    intro h
    unfold Nat.inl at ih ⊢
    clean unfold Nat.half Nat.add
    rw [Nat.mul_succ, ih h]

theorem inr_half_eq_of_isOdd {n : Nat} : isOdd n → (half n).inr = n := by
  induction n using Nat.recTwo with
  | zero => intro; contradiction
  | one => intro; rfl
  | step n ih =>
    intro h
    unfold Nat.inr at ih ⊢
    clean unfold Nat.half Nat.add
    rw [Nat.mul_succ, Nat.add_succ, Nat.add_succ, ih h]

theorem inl_half_eq_or_inr_half_eq (n : Nat) : (half n).inl = n ∨ (half n).inr = n := by
  match isEven_or_isOdd n with
  | .inl h => left; exact inl_half_eq_of_isEven h
  | .inr h => right; exact inr_half_eq_of_isOdd h

def encodeSum : Sum Nat Nat → Nat
| .inl n => n.inl
| .inr n => n.inr

def decodeSum (n : Nat) : Sum Nat Nat :=
  if n.isOdd
  then .inr (half n)
  else .inl (half n)

def equivSum : Equiv (Sum Nat Nat) Nat where
  fwd := encodeSum
  rev := decodeSum
  spec := by intro
    | .inl m, n =>
      clean unfold encodeSum decodeSum
      split
      next h =>
        cases h
        constr
        · intro
          | rfl =>
            rw [half_inl_eq]
            split
            next h =>
              rw [←not_isEven_eq_isOdd, isEven_inl] at h
              contradiction
            next h => rfl
        · intro hl
          split at hl
          next => contradiction
          next h =>
            cases hl
            rw [inl_half_eq_of_isEven]
            rw [Bool.not_eq_true] at h
            rw [←not_isOdd_eq_isEven, h]
            rfl
      next h => contradiction
    | .inr m, n =>
      clean unfold encodeSum decodeSum
      split
      next h => contradiction
      next h =>
        cases h
        constr
        · intro | rfl => rw [if_pos (isOdd_inr _), half_inr_eq]
        · intro h
          split at h
          next hodd => cases h; rw [inr_half_eq_of_isOdd hodd]
          next => contradiction

end Nat


-- My collaborator of this final project is Derek Johnson.
import .functor
import .applicative
import .monad
open function

universes u v

namespace hidden

/-
infix symbol for local test
-/
local infixr ` <$> `:100 := functor.map
local infixr ` <$ `:100  := functor.map_const
local infixr ` $> `:100  := functor.map_const_rev

/-
Functor const function for option
-/
def option_map_const
  {α β : Type u} :
  α → option β → option α
| a option.none := option.none
| a (option.some b) := option.some a

/-
Provide a proof for Functor Identity Law
-/
theorem option_map_law1 : ∀ (T : Type u), option.map (@id T) = (@id (option T)) :=
begin
assume T,
apply funext,
assume optionT,
rw [id],
induction optionT,
simp [option.map_id],
simp [option.map_id],
end

/-
Provide a proof for Functor Composition Law
-/
theorem option_map_law2:
  ∀ (α β γ: Type u) (f: α → β) (g: β → γ) ,
     option.map (g ∘ f) = option.map g ∘ (option.map f)   :=
begin
intros,
apply funext,
assume optionA,
simp [option.map],
induction optionA,
simp [option.bind],
simp [option.bind],
end

/-
Create an instance of functor option
-/
instance option_mapper : functor option := ⟨ @option.map, @option_map_const, option_map_law1, option_map_law2  ⟩

/-
Local test
-/
#reduce nat.succ <$> option.none
#reduce nat.succ <$> option.some 0
#reduce nat.add 3 <$> option.some 2
#reduce id <$>  option.some 3
#reduce id <$>  option.some 4

--APPLICATIVE FUNCTOR

/-
Applicative functions for option
-/
def pure_option {α : Type u} : α → option α
| a := some a

def seq_option : Π {α β : Type u}, option (α → β) → option α → option β
| α β none _ := none
| α β (some func) oa := functor.map func oa  -- Use's functor's option_map!

def seq_option_left : Π {α β : Type u}, option α → option β → option α
| α β none _ := none
| α β (some func) oa := functor.map_const func oa

def seq_option_right : Π {α β : Type u}, option α → option β → option  β
| α β _ none  := none
| α β oa (some func)  := functor.map_const_rev oa func

local infixl ` <*> `:60 := has_seq.seq
local infixl ` <* `:60  := has_seq_left.seq_left
local infixl ` *> `:60  := has_seq_right.seq_right

instance : has_pure option := ⟨ @pure_option ⟩
instance : has_seq option := ⟨ @seq_option ⟩
instance : has_seq_left option := ⟨ @seq_option_left ⟩
instance : has_seq_right option := ⟨ @seq_option_right ⟩

/-
Provide a proof for Applicative Identity Law
-/
theorem option_applicative_law1 : ∀ (T : Type u), seq_option (pure_option (@id T)) = @id (option T) :=
begin
assume T,
apply funext,
assume optionT,
rw [id],
induction optionT,
-- base
simp [pure_option],
simp [seq_option],
simp [functor.map],
simp [option.map_id],
--
simp [pure_option],
simp [seq_option],
simp [functor.map],
simp [option.map_id],
end

/-
Provide a proof for Applicative Composition Law
-/
theorem option_applicative_law2 :  ∀ (α β γ: Type u) (func_g:  (α → β) )(func_f: (β → γ) ) (w:  α ),
pure_option func_f <*> (pure_option func_g <*> pure_option w ) = (pure_option (func_f  ∘  func_g)) <*> pure_option w
:=
begin
intros,
simp [pure_option],
simp [has_seq.seq],
simp [seq_option],
simp [functor.map],
simp [function.comp],
simp [option.map],
simp [option.bind],
end

/-
Provide a proof for Applicative Homomorphism Law
-/
theorem option_applicative_law3 :
∀ (α β: Type u) (func_f: α → β) (x:α), (pure_option func_f)  <*> (pure_option x)
= pure_option (func_f x ) :=
begin
intros,
apply rfl,
end

/-
Provide a proof for Applicative Interchange Law
-/
theorem option_applicative_law4 :
∀ (α β: Type u) (y: α) (func_f:  α → β  ),  (pure_option func_f) <*> (pure_option y)
= (pure_option (λ an_F: (α → β) , an_F y )  ) <*> (pure_option func_f) :=
begin
intros,
simp [pure_option],
simp [has_seq.seq],
simp [seq_option],
simp [functor.map],
simp [option.map],
simp [option.bind],
end

/-
Create an instance of applicative option
-/
instance : applicative option := ⟨ option_applicative_law1, option_applicative_law2, option_applicative_law3, option_applicative_law4 ⟩

/-
Local test
-/
#reduce has_pure.pure (nat.mul) <*> some 3 <*> some 4
#reduce has_pure.pure (nat.mul) <*> none <*> some 4
#reduce has_pure.pure (nat.mul) <*> some 3 <*> none

#reduce (has_pure.pure id) <*> (some 1)

#reduce some tt <* none
#reduce some tt <* some 1
#reduce some tt *> none
#reduce some tt *> some 1

--Monad

def has_bind_option : Π {α β : Type u}, option α → (α → option β) → option β
| α β none _ := none
| α β (some x) func := func x

instance : has_bind option :=⟨ @has_bind_option⟩

local infixl ` >>= `:55 := has_bind.bind
local infixl ` >> `:55  := has_bind.and_then

/-
Provide a proof for Monad Left Identity Law
-/
theorem option_monad_law1 :
∀ (α β: Type u) (func_f:  α → option β ) ( x: α  ),
    (pure_option x) >>= func_f  = func_f x  :=
begin
intros,
simp [pure_option],
simp [has_bind.bind],
simp [has_bind_option],
end

/-
Provide a proof for Monad Right Identity Law
-/
theorem option_monad_law2 :
∀ (α β: Type u)  (x: option α ),
    x >>= pure_option = x  :=
begin
intros,
simp [has_bind.bind],
induction x,
-- base
simp [has_bind_option],
-- inductive step
simp [has_bind_option],
simp [pure_option],
end

/-
Provide a proof for Monad Right Associativity Law
-/
theorem option_monad_law3 :
∀ (α β γ: Type u) (x: option α ) (func_f:  (α → option β) ) (func_g:  (β → option γ) ),
    x >>= func_f >>= func_g  = x  >>= (λ y, func_f y>>= func_g   ):=
begin
intros,
simp [has_bind.bind],
induction x,
-- base
simp [has_bind_option],
-- inductive step
simp [has_bind_option],
end

/-
Create an instance of Monad option
-/
instance : monad option := ⟨ option_monad_law1,  option_monad_law2, option_monad_law3 ⟩

/-
Local test
-/
#reduce some 3 >>=  (λ x, has_pure.pure (x+1))
#reduce none >>=  (λ x, has_pure.pure (x+1))
#reduce some 3 >>=  (λ x, none)

#reduce some 3 >>  some 5
#reduce none >>  some 5

end hidden


import Mathlib
import Mathbin

#check Semiring
#lookup3 semiring
#check Semiringₓ

#lookup3 nat.exists_infinite_primes

example (n : Nat) : n + n = 2 * n := by ring


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

Natural homomorphism from the natural numbers into a monoid with one.
-/
import tactic.interactive algebra.order algebra.ordered_group algebra.ring

namespace nat
variables {α : Type*}

section
variables [has_zero α] [has_one α] [has_add α]

/-- Canonical homomorphism from `ℕ` to a type `α` with `0`, `1` and `+`. -/
protected def cast : ℕ → α
| 0     := 0
| (n+1) := cast n + 1

@[priority 0] instance cast_coe : has_coe ℕ α := ⟨nat.cast⟩

@[simp] theorem cast_zero : ((0 : ℕ) : α) = 0 := rfl

theorem cast_add_one (n : ℕ) : ((n + 1 : ℕ) : α) = n + 1 := rfl
@[simp] theorem cast_succ (n : ℕ) : ((succ n : ℕ) : α) = n + 1 := rfl
end

@[simp] theorem cast_one [add_monoid α] [has_one α] : ((1 : ℕ) : α) = 1 := zero_add _

@[simp] theorem cast_add [add_monoid α] [has_one α] (m) : ∀ n, ((m + n : ℕ) : α) = m + n
| 0     := (add_zero _).symm
| (n+1) := show ((m + n : ℕ) : α) + 1 = m + (n + 1), by rw [cast_add n, add_assoc]

instance [add_monoid α] [has_one α] : is_add_monoid_hom (coe : ℕ → α) :=
by refine_struct {..}; simp

@[simp] theorem cast_bit0 [add_monoid α] [has_one α] (n : ℕ) : ((bit0 n : ℕ) : α) = bit0 n := cast_add _ _

@[simp] theorem cast_bit1 [add_monoid α] [has_one α] (n : ℕ) : ((bit1 n : ℕ) : α) = bit1 n :=
by rw [bit1, cast_add_one, cast_bit0]; refl

lemma cast_two {α : Type*} [semiring α] : ((2 : ℕ) : α) = 2 := by simp

@[simp] theorem cast_pred [add_group α] [has_one α] : ∀ {n}, n > 0 → ((n - 1 : ℕ) : α) = n - 1
| (n+1) h := (add_sub_cancel (n:α) 1).symm

@[simp] theorem cast_sub [add_group α] [has_one α] {m n} (h : m ≤ n) : ((n - m : ℕ) : α) = n - m :=
eq_sub_of_add_eq $ by rw [← cast_add, nat.sub_add_cancel h]

@[simp] theorem cast_mul [semiring α] (m) : ∀ n, ((m * n : ℕ) : α) = m * n
| 0     := (mul_zero _).symm
| (n+1) := (cast_add _ _).trans $
show ((m * n : ℕ) : α) + m = m * (n + 1), by rw [cast_mul n, left_distrib, mul_one]

instance [semiring α] : is_semiring_hom (coe : ℕ → α) :=
by refine_struct {..}; simp

theorem mul_cast_comm [semiring α] (a : α) (n : ℕ) : a * n = n * a :=
by induction n; simp [left_distrib, right_distrib, *]

@[simp] theorem cast_nonneg [linear_ordered_semiring α] : ∀ n : ℕ, 0 ≤ (n : α)
| 0     := le_refl _
| (n+1) := add_nonneg (cast_nonneg n) zero_le_one

@[simp] theorem cast_le [linear_ordered_semiring α] : ∀ {m n : ℕ}, (m : α) ≤ n ↔ m ≤ n
| 0     n     := by simp [zero_le]
| (m+1) 0     := by simpa [not_succ_le_zero] using
  lt_add_of_lt_of_nonneg zero_lt_one (@cast_nonneg α _ m)
| (m+1) (n+1) := (add_le_add_iff_right 1).trans $
  (@cast_le m n).trans $ (add_le_add_iff_right 1).symm

@[simp] theorem cast_lt [linear_ordered_semiring α] {m n : ℕ} : (m : α) < n ↔ m < n :=
by simpa [-cast_le] using not_congr (@cast_le α _ n m)

@[simp] theorem cast_pos [linear_ordered_semiring α] {n : ℕ} : (0 : α) < n ↔ 0 < n :=
by rw [← cast_zero, cast_lt]

theorem eq_cast [add_monoid α] [has_one α] (f : ℕ → α)
  (H0 : f 0 = 0) (H1 : f 1 = 1)
  (Hadd : ∀ x y, f (x + y) = f x + f y) : ∀ n : ℕ, f n = n
| 0     := H0
| (n+1) := by rw [Hadd, H1, eq_cast]; refl

theorem eq_cast' [add_group α] [has_one α] (f : ℕ → α)
  (H1 : f 1 = 1) (Hadd : ∀ x y, f (x + y) = f x + f y) : ∀ n : ℕ, f n = n :=
eq_cast _ (by rw [← add_left_inj (f 0), add_zero, ← Hadd]) H1 Hadd

@[simp] theorem cast_id (n : ℕ) : ↑n = n :=
(eq_cast id rfl rfl (λ _ _, rfl) n).symm

@[simp] theorem cast_min [decidable_linear_ordered_semiring α] {a b : ℕ} : (↑(min a b) : α) = min a b :=
by by_cases a ≤ b; simp [h, min]

@[simp] theorem cast_max [decidable_linear_ordered_semiring α] {a b : ℕ} : (↑(max a b) : α) = max a b :=
by by_cases a ≤ b; simp [h, max]

@[simp] theorem abs_cast [decidable_linear_ordered_comm_ring α] (a : ℕ) : abs (a : α) = a :=
abs_of_nonneg (cast_nonneg a)

end nat


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.int.least_greatest
import data.rat.floor

/-!
# Archimedean groups and fields.

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

This file defines the archimedean property for ordered groups and proves several results connected
to this notion. Being archimedean means that for all elements `x` and `y>0` there exists a natural
number `n` such that `x ≤ n • y`.

## Main definitions

* `archimedean` is a typeclass for an ordered additive commutative monoid to have the archimedean
  property.
* `archimedean.floor_ring` defines a floor function on an archimedean linearly ordered ring making
  it into a `floor_ring`.

## Main statements

* `ℕ`, `ℤ`, and `ℚ` are archimedean.
-/

open int set

variables {α : Type*}

/-- An ordered additive commutative monoid is called `archimedean` if for any two elements `x`, `y`
such that `0 < y` there exists a natural number `n` such that `x ≤ n • y`. -/
class archimedean (α) [ordered_add_comm_monoid α] : Prop :=
(arch : ∀ (x : α) {y}, 0 < y → ∃ n : ℕ, x ≤ n • y)

instance order_dual.archimedean [ordered_add_comm_group α] [archimedean α] : archimedean αᵒᵈ :=
⟨λ x y hy, let ⟨n, hn⟩ := archimedean.arch (-x : α) (neg_pos.2 hy) in
  ⟨n, by rwa [neg_nsmul, neg_le_neg_iff] at hn⟩⟩

section linear_ordered_add_comm_group
variables [linear_ordered_add_comm_group α] [archimedean α]

/-- An archimedean decidable linearly ordered `add_comm_group` has a version of the floor: for
`a > 0`, any `g` in the group lies between some two consecutive multiples of `a`. -/
lemma exists_unique_zsmul_near_of_pos {a : α} (ha : 0 < a) (g : α) :
  ∃! k : ℤ, k • a ≤ g ∧ g < (k + 1) • a :=
begin
  let s : set ℤ := {n : ℤ | n • a ≤ g},
  obtain ⟨k, hk : -g ≤ k • a⟩ := archimedean.arch (-g) ha,
  have h_ne : s.nonempty := ⟨-k, by simpa using neg_le_neg hk⟩,
  obtain ⟨k, hk⟩ := archimedean.arch g ha,
  have h_bdd : ∀ n ∈ s, n ≤ (k : ℤ),
  { assume n hn,
    apply (zsmul_le_zsmul_iff ha).mp,
    rw ← coe_nat_zsmul at hk,
    exact le_trans hn hk },
  obtain ⟨m, hm, hm'⟩ := int.exists_greatest_of_bdd ⟨k, h_bdd⟩ h_ne,
  have hm'' : g < (m + 1) • a,
  { contrapose! hm', exact ⟨m + 1, hm', lt_add_one _⟩, },
  refine ⟨m, ⟨hm, hm''⟩, λ n hn, (hm' n hn.1).antisymm $ int.le_of_lt_add_one _⟩,
  rw ← zsmul_lt_zsmul_iff ha,
  exact lt_of_le_of_lt hm hn.2
end

lemma exists_unique_zsmul_near_of_pos' {a : α} (ha : 0 < a) (g : α) :
  ∃! k : ℤ, 0 ≤ g - k • a ∧ g - k • a < a :=
by simpa only [sub_nonneg, add_zsmul, one_zsmul, sub_lt_iff_lt_add']
  using exists_unique_zsmul_near_of_pos ha g

lemma exists_unique_sub_zsmul_mem_Ico {a : α} (ha : 0 < a) (b c : α) :
  ∃! m : ℤ, b - m • a ∈ set.Ico c (c + a) :=
by simpa only [mem_Ico, le_sub_iff_add_le, zero_add, add_comm c, sub_lt_iff_lt_add', add_assoc]
  using exists_unique_zsmul_near_of_pos' ha (b - c)

lemma exists_unique_add_zsmul_mem_Ico {a : α} (ha : 0 < a) (b c : α) :
  ∃! m : ℤ, b + m • a ∈ set.Ico c (c + a) :=
(equiv.neg ℤ).bijective.exists_unique_iff.2 $
  by simpa only [equiv.neg_apply, neg_zsmul, ← sub_eq_add_neg]
    using exists_unique_sub_zsmul_mem_Ico ha b c

lemma exists_unique_add_zsmul_mem_Ioc {a : α} (ha : 0 < a) (b c : α) :
  ∃! m : ℤ, b + m • a ∈ set.Ioc c (c + a) :=
(equiv.add_right (1 : ℤ)).bijective.exists_unique_iff.2 $
  by simpa only [add_one_zsmul, sub_lt_iff_lt_add', le_sub_iff_add_le', ← add_assoc, and.comm,
    mem_Ioc, equiv.coe_add_right, add_le_add_iff_right]
    using exists_unique_zsmul_near_of_pos ha (c - b)

lemma exists_unique_sub_zsmul_mem_Ioc {a : α} (ha : 0 < a) (b c : α) :
  ∃! m : ℤ, b - m • a ∈ set.Ioc c (c + a) :=
(equiv.neg ℤ).bijective.exists_unique_iff.2 $
  by simpa only [equiv.neg_apply, neg_zsmul, sub_neg_eq_add]
    using exists_unique_add_zsmul_mem_Ioc ha b c

end linear_ordered_add_comm_group

theorem exists_nat_gt [strict_ordered_semiring α] [archimedean α] (x : α) : ∃ n : ℕ, x < n :=
let ⟨n, h⟩ := archimedean.arch x zero_lt_one in
⟨n+1, lt_of_le_of_lt (by rwa ← nsmul_one)
  (nat.cast_lt.2 (nat.lt_succ_self _))⟩

theorem exists_nat_ge [strict_ordered_semiring α] [archimedean α] (x : α) :
  ∃ n : ℕ, x ≤ n :=
begin
  nontriviality α,
  exact (exists_nat_gt x).imp (λ n, le_of_lt)
end

lemma add_one_pow_unbounded_of_pos [strict_ordered_semiring α] [archimedean α] (x : α) {y : α}
  (hy : 0 < y) :
  ∃ n : ℕ, x < (y + 1) ^ n :=
have 0 ≤ 1 + y, from add_nonneg zero_le_one hy.le,
let ⟨n, h⟩ := archimedean.arch x hy in
⟨n, calc x ≤ n • y : h
       ... = n * y : nsmul_eq_mul _ _
       ... < 1 + n * y : lt_one_add _
       ... ≤ (1 + y) ^ n : one_add_mul_le_pow' (mul_nonneg hy.le hy.le) (mul_nonneg this this)
                             (add_nonneg zero_le_two hy.le) _
       ... = (y + 1) ^ n : by rw [add_comm]⟩

section strict_ordered_ring
variables [strict_ordered_ring α] [archimedean α]

lemma pow_unbounded_of_one_lt (x : α) {y : α} (hy1 : 1 < y) :
  ∃ n : ℕ, x < y ^ n :=
sub_add_cancel y 1 ▸ add_one_pow_unbounded_of_pos _ (sub_pos.2 hy1)

theorem exists_int_gt (x : α) : ∃ n : ℤ, x < n :=
let ⟨n, h⟩ := exists_nat_gt x in ⟨n, by rwa int.cast_coe_nat⟩

theorem exists_int_lt (x : α) : ∃ n : ℤ, (n : α) < x :=
let ⟨n, h⟩ := exists_int_gt (-x) in ⟨-n, by rw int.cast_neg; exact neg_lt.1 h⟩

theorem exists_floor (x : α) :
  ∃ (fl : ℤ), ∀ (z : ℤ), z ≤ fl ↔ (z : α) ≤ x :=
begin
  haveI := classical.prop_decidable,
  have : ∃ (ub : ℤ), (ub:α) ≤ x ∧ ∀ (z : ℤ), (z:α) ≤ x → z ≤ ub :=
  int.exists_greatest_of_bdd
    (let ⟨n, hn⟩ := exists_int_gt x in ⟨n, λ z h',
      int.cast_le.1 $ le_trans h' $ le_of_lt hn⟩)
    (let ⟨n, hn⟩ := exists_int_lt x in ⟨n, le_of_lt hn⟩),
  refine this.imp (λ fl h z, _),
  cases h with h₁ h₂,
  exact ⟨λ h, le_trans (int.cast_le.2 h) h₁, h₂ z⟩,
end

end strict_ordered_ring

section linear_ordered_ring
variables [linear_ordered_ring α] [archimedean α]

/-- Every x greater than or equal to 1 is between two successive
natural-number powers of every y greater than one. -/
lemma exists_nat_pow_near {x : α} {y : α} (hx : 1 ≤ x) (hy : 1 < y) :
  ∃ n : ℕ, y ^ n ≤ x ∧ x < y ^ (n + 1) :=
have h : ∃ n : ℕ, x < y ^ n, from pow_unbounded_of_one_lt _ hy,
by classical; exact let n := nat.find h in
  have hn  : x < y ^ n, from nat.find_spec h,
  have hnp : 0 < n,     from pos_iff_ne_zero.2 (λ hn0,
    by rw [hn0, pow_zero] at hn; exact (not_le_of_gt hn hx)),
  have hnsp : nat.pred n + 1 = n,     from nat.succ_pred_eq_of_pos hnp,
  have hltn : nat.pred n < n,         from nat.pred_lt (ne_of_gt hnp),
  ⟨nat.pred n, le_of_not_lt (nat.find_min h hltn), by rwa hnsp⟩

end linear_ordered_ring

section linear_ordered_field
variables [linear_ordered_field α] [archimedean α] {x y ε : α}

/-- Every positive `x` is between two successive integer powers of
another `y` greater than one. This is the same as `exists_mem_Ioc_zpow`,
but with ≤ and < the other way around. -/
lemma exists_mem_Ico_zpow (hx : 0 < x) (hy : 1 < y) : ∃ n : ℤ, x ∈ Ico (y ^ n) (y ^ (n + 1)) :=
by classical; exact
let ⟨N, hN⟩ := pow_unbounded_of_one_lt x⁻¹ hy in
  have he: ∃ m : ℤ, y ^ m ≤ x, from
    ⟨-N, le_of_lt (by { rw [zpow_neg y (↑N), zpow_coe_nat],
    exact (inv_lt hx (lt_trans (inv_pos.2 hx) hN)).1 hN })⟩,
let ⟨M, hM⟩ := pow_unbounded_of_one_lt x hy in
  have hb: ∃ b : ℤ, ∀ m, y ^ m ≤ x → m ≤ b, from
    ⟨M, λ m hm, le_of_not_lt (λ hlt, not_lt_of_ge
  (zpow_le_of_le hy.le hlt.le)
    (lt_of_le_of_lt hm (by rwa ← zpow_coe_nat at hM)))⟩,
let ⟨n, hn₁, hn₂⟩ := int.exists_greatest_of_bdd hb he in
  ⟨n, hn₁, lt_of_not_ge (λ hge, not_le_of_gt (int.lt_succ _) (hn₂ _ hge))⟩

/-- Every positive `x` is between two successive integer powers of
another `y` greater than one. This is the same as `exists_mem_Ico_zpow`,
but with ≤ and < the other way around. -/
lemma exists_mem_Ioc_zpow (hx : 0 < x) (hy : 1 < y) : ∃ n : ℤ, x ∈ Ioc (y ^ n) (y ^ (n + 1)) :=
let ⟨m, hle, hlt⟩ := exists_mem_Ico_zpow (inv_pos.2 hx) hy in
have hyp : 0 < y, from lt_trans zero_lt_one hy,
⟨-(m+1),
by rwa [zpow_neg, inv_lt (zpow_pos_of_pos hyp _) hx],
by rwa [neg_add, neg_add_cancel_right, zpow_neg,
        le_inv hx (zpow_pos_of_pos hyp _)]⟩

/-- For any `y < 1` and any positive `x`, there exists `n : ℕ` with `y ^ n < x`. -/
lemma exists_pow_lt_of_lt_one (hx : 0 < x) (hy : y < 1) : ∃ n : ℕ, y ^ n < x :=
begin
  by_cases y_pos : y ≤ 0,
  { use 1, simp only [pow_one], linarith, },
  rw [not_le] at y_pos,
  rcases pow_unbounded_of_one_lt (x⁻¹) (one_lt_inv y_pos hy) with ⟨q, hq⟩,
  exact ⟨q, by rwa [inv_pow, inv_lt_inv hx (pow_pos y_pos _)] at hq⟩
end

/-- Given `x` and `y` between `0` and `1`, `x` is between two successive powers of `y`.
This is the same as `exists_nat_pow_near`, but for elements between `0` and `1` -/
lemma exists_nat_pow_near_of_lt_one (xpos : 0 < x) (hx : x ≤ 1) (ypos : 0 < y) (hy : y < 1) :
  ∃ n : ℕ, y ^ (n + 1) < x ∧ x ≤ y ^ n :=
begin
  rcases exists_nat_pow_near (one_le_inv_iff.2 ⟨xpos, hx⟩) (one_lt_inv_iff.2 ⟨ypos, hy⟩)
    with ⟨n, hn, h'n⟩,
  refine ⟨n, _, _⟩,
  { rwa [inv_pow, inv_lt_inv xpos (pow_pos ypos _)] at h'n },
  { rwa [inv_pow, inv_le_inv (pow_pos ypos _) xpos] at hn }
end

lemma exists_rat_gt (x : α) : ∃ q : ℚ, x < q :=
let ⟨n, h⟩ := exists_nat_gt x in ⟨n, by rwa rat.cast_coe_nat⟩

theorem exists_rat_lt (x : α) : ∃ q : ℚ, (q : α) < x :=
let ⟨n, h⟩ := exists_int_lt x in ⟨n, by rwa rat.cast_coe_int⟩

theorem exists_rat_btwn {x y : α} (h : x < y) : ∃ q : ℚ, x < q ∧ (q:α) < y :=
begin
  cases exists_nat_gt (y - x)⁻¹ with n nh,
  cases exists_floor (x * n) with z zh,
  refine ⟨(z + 1 : ℤ) / n, _⟩,
  have n0' := (inv_pos.2 (sub_pos.2 h)).trans nh,
  have n0 := nat.cast_pos.1 n0',
  rw [rat.cast_div_of_ne_zero, rat.cast_coe_nat, rat.cast_coe_int, div_lt_iff n0'],
  refine ⟨(lt_div_iff n0').2 $
    (lt_iff_lt_of_le_iff_le (zh _)).1 (lt_add_one _), _⟩,
  rw [int.cast_add, int.cast_one],
  refine lt_of_le_of_lt (add_le_add_right ((zh _).1 le_rfl) _) _,
  rwa [← lt_sub_iff_add_lt', ← sub_mul,
       ← div_lt_iff' (sub_pos.2 h), one_div],
  { rw [rat.coe_int_denom, nat.cast_one], exact one_ne_zero },
  { intro H, rw [rat.coe_nat_num, int.cast_coe_nat, nat.cast_eq_zero] at H, subst H, cases n0 },
  { rw [rat.coe_nat_denom, nat.cast_one], exact one_ne_zero }
end

lemma le_of_forall_rat_lt_imp_le (h : ∀ q : ℚ, (q : α) < x → (q : α) ≤ y) : x ≤ y :=
le_of_not_lt $ λ hyx, let ⟨q, hy, hx⟩ := exists_rat_btwn hyx in hy.not_le $ h _ hx

lemma le_of_forall_lt_rat_imp_le (h : ∀ q : ℚ, y < q → x ≤ q) : x ≤ y :=
le_of_not_lt $ λ hyx, let ⟨q, hy, hx⟩ := exists_rat_btwn hyx in hx.not_le $ h _ hy

lemma eq_of_forall_rat_lt_iff_lt (h : ∀ q : ℚ, (q : α) < x ↔ (q : α) < y) : x = y :=
(le_of_forall_rat_lt_imp_le $ λ q hq, ((h q).1 hq).le).antisymm $ le_of_forall_rat_lt_imp_le $
  λ q hq, ((h q).2 hq).le

lemma eq_of_forall_lt_rat_iff_lt (h : ∀ q : ℚ, x < q ↔ y < q) : x = y :=
(le_of_forall_lt_rat_imp_le $ λ q hq, ((h q).2 hq).le).antisymm $ le_of_forall_lt_rat_imp_le $
  λ q hq, ((h q).1 hq).le

theorem exists_nat_one_div_lt {ε : α} (hε : 0 < ε) : ∃ n : ℕ, 1 / (n + 1: α) < ε :=
begin
  cases exists_nat_gt (1/ε) with n hn,
  use n,
  rw [div_lt_iff, ← div_lt_iff' hε],
  { apply hn.trans,
    simp [zero_lt_one] },
  { exact n.cast_add_one_pos }
end

theorem exists_pos_rat_lt {x : α} (x0 : 0 < x) : ∃ q : ℚ, 0 < q ∧ (q : α) < x :=
by simpa only [rat.cast_pos] using exists_rat_btwn x0

lemma exists_rat_near (x : α) (ε0 : 0 < ε) : ∃ q : ℚ, |x - q| < ε :=
let ⟨q, h₁, h₂⟩ := exists_rat_btwn $ ((sub_lt_self_iff x).2 ε0).trans ((lt_add_iff_pos_left x).2 ε0)
  in ⟨q, abs_sub_lt_iff.2 ⟨sub_lt_comm.1 h₁, sub_lt_iff_lt_add.2 h₂⟩⟩

end linear_ordered_field

section linear_ordered_field
variables [linear_ordered_field α]

lemma archimedean_iff_nat_lt : archimedean α ↔ ∀ x : α, ∃ n : ℕ, x < n :=
⟨@exists_nat_gt α _, λ H, ⟨λ x y y0,
  (H (x / y)).imp $ λ n h, le_of_lt $
  by rwa [div_lt_iff y0, ← nsmul_eq_mul] at h⟩⟩

lemma archimedean_iff_nat_le : archimedean α ↔ ∀ x : α, ∃ n : ℕ, x ≤ n :=
archimedean_iff_nat_lt.trans
⟨λ H x, (H x).imp $ λ _, le_of_lt,
 λ H x, let ⟨n, h⟩ := H x in ⟨n+1,
   lt_of_le_of_lt h (nat.cast_lt.2 (lt_add_one _))⟩⟩

lemma archimedean_iff_int_lt : archimedean α ↔ ∀ x : α, ∃ n : ℤ, x < n :=
⟨@exists_int_gt α _,
begin
  rw archimedean_iff_nat_lt,
  intros h x,
  obtain ⟨n, h⟩ := h x,
  refine ⟨n.to_nat, h.trans_le _⟩,
  exact_mod_cast int.le_to_nat _,
end⟩

lemma archimedean_iff_int_le : archimedean α ↔ ∀ x : α, ∃ n : ℤ, x ≤ n :=
archimedean_iff_int_lt.trans
⟨λ H x, (H x).imp $ λ _, le_of_lt,
 λ H x, let ⟨n, h⟩ := H x in ⟨n+1,
   lt_of_le_of_lt h (int.cast_lt.2 (lt_add_one _))⟩⟩

lemma archimedean_iff_rat_lt : archimedean α ↔ ∀ x : α, ∃ q : ℚ, x < q :=
⟨@exists_rat_gt α _,
  λ H, archimedean_iff_nat_lt.2 $ λ x,
  let ⟨q, h⟩ := H x in
  ⟨⌈q⌉₊, lt_of_lt_of_le h $
    by simpa only [rat.cast_coe_nat] using (@rat.cast_le α _ _ _).2 (nat.le_ceil _)⟩⟩

lemma archimedean_iff_rat_le : archimedean α ↔ ∀ x : α, ∃ q : ℚ, x ≤ q :=
archimedean_iff_rat_lt.trans
⟨λ H x, (H x).imp $ λ _, le_of_lt,
 λ H x, let ⟨n, h⟩ := H x in ⟨n+1,
   lt_of_le_of_lt h (rat.cast_lt.2 (lt_add_one _))⟩⟩

end linear_ordered_field

instance : archimedean ℕ :=
⟨λ n m m0, ⟨n, by simpa only [mul_one, nat.nsmul_eq_mul] using nat.mul_le_mul_left n m0⟩⟩

instance : archimedean ℤ :=
⟨λ n m m0, ⟨n.to_nat, le_trans (int.le_to_nat _) $
by simpa only [nsmul_eq_mul, zero_add, mul_one]
  using mul_le_mul_of_nonneg_left (int.add_one_le_iff.2 m0) (int.coe_zero_le n.to_nat)⟩⟩

instance : archimedean ℚ :=
archimedean_iff_rat_le.2 $ λ q, ⟨q, by rw rat.cast_id⟩

/-- A linear ordered archimedean ring is a floor ring. This is not an `instance` because in some
cases we have a computable `floor` function. -/
noncomputable def archimedean.floor_ring (α) [linear_ordered_ring α] [archimedean α] :
  floor_ring α :=
floor_ring.of_floor α (λ a, classical.some (exists_floor a))
  (λ z a, (classical.some_spec (exists_floor a) z).symm)

/-- A linear ordered field that is a floor ring is archimedean. -/
@[priority 100] -- see Note [lower instance priority]
instance floor_ring.archimedean (α) [linear_ordered_field α] [floor_ring α] : archimedean α :=
begin
  rw archimedean_iff_int_le,
  exact λ x, ⟨⌈x⌉, int.le_ceil x⟩
end


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import data.multiset.nodup

/-!
# Disjoint sum of multisets

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

This file defines the disjoint sum of two multisets as `multiset (α ⊕ β)`. Beware not to confuse
with the `multiset.sum` operation which computes the additive sum.

## Main declarations

* `multiset.disj_sum`: `s.disj_sum t` is the disjoint sum of `s` and `t`.
-/

open sum

namespace multiset
variables {α β : Type*} (s : multiset α) (t : multiset β)

/-- Disjoint sum of multisets. -/
def disj_sum : multiset (α ⊕ β) := s.map inl + t.map inr

@[simp] lemma zero_disj_sum : (0 : multiset α).disj_sum t = t.map inr := zero_add _
@[simp] lemma disj_sum_zero : s.disj_sum (0 : multiset β) = s.map inl := add_zero _

@[simp] lemma card_disj_sum : (s.disj_sum t).card = s.card + t.card :=
by rw [disj_sum, card_add, card_map, card_map]

variables {s t} {s₁ s₂ : multiset α} {t₁ t₂ : multiset β} {a : α} {b : β} {x : α ⊕ β}

lemma mem_disj_sum : x ∈ s.disj_sum t ↔ (∃ a, a ∈ s ∧ inl a = x) ∨ ∃ b, b ∈ t ∧ inr b = x :=
by simp_rw [disj_sum, mem_add, mem_map]

@[simp] lemma inl_mem_disj_sum : inl a ∈ s.disj_sum t ↔ a ∈ s :=
begin
  rw [mem_disj_sum, or_iff_left],
  simp only [exists_eq_right],
  rintro ⟨b, _, hb⟩,
  exact inr_ne_inl hb,
end

@[simp] lemma inr_mem_disj_sum : inr b ∈ s.disj_sum t ↔ b ∈ t :=
begin
  rw [mem_disj_sum, or_iff_right],
  simp only [exists_eq_right],
  rintro ⟨a, _, ha⟩,
  exact inl_ne_inr ha,
end

lemma disj_sum_mono (hs : s₁ ≤ s₂) (ht : t₁ ≤ t₂) : s₁.disj_sum t₁ ≤ s₂.disj_sum t₂ :=
add_le_add (map_le_map hs) (map_le_map ht)

lemma disj_sum_mono_left (t : multiset β) : monotone (λ s : multiset α, s.disj_sum t) :=
λ s₁ s₂ hs, add_le_add_right (map_le_map hs) _

lemma disj_sum_mono_right (s : multiset α) :
  monotone (s.disj_sum : multiset β → multiset (α ⊕ β)) :=
λ t₁ t₂ ht, add_le_add_left (map_le_map ht) _

lemma disj_sum_lt_disj_sum_of_lt_of_le (hs : s₁ < s₂) (ht : t₁ ≤ t₂) :
  s₁.disj_sum t₁ < s₂.disj_sum t₂ :=
add_lt_add_of_lt_of_le (map_lt_map hs) (map_le_map ht)

lemma disj_sum_lt_disj_sum_of_le_of_lt (hs : s₁ ≤ s₂) (ht : t₁ < t₂) :
  s₁.disj_sum t₁ < s₂.disj_sum t₂ :=
add_lt_add_of_le_of_lt (map_le_map hs) (map_lt_map ht)

lemma disj_sum_strict_mono_left (t : multiset β) : strict_mono (λ s : multiset α, s.disj_sum t) :=
λ s₁ s₂ hs, disj_sum_lt_disj_sum_of_lt_of_le hs le_rfl

lemma disj_sum_strict_mono_right (s : multiset α) :
  strict_mono (s.disj_sum : multiset β → multiset (α ⊕ β)) :=
λ s₁ s₂, disj_sum_lt_disj_sum_of_le_of_lt le_rfl

protected lemma nodup.disj_sum (hs : s.nodup) (ht : t.nodup) : (s.disj_sum t).nodup :=
begin
  refine ((hs.map inl_injective).add_iff $ ht.map inr_injective).2 (λ x hs ht, _),
  rw multiset.mem_map at hs ht,
  obtain ⟨a, _, rfl⟩ := hs,
  obtain ⟨b, _, h⟩ := ht,
  exact inr_ne_inl h,
end

end multiset


/-birkhoff.lean -- Birkhoff's HSP Theorem in Lean
  Author: William DeMeo <williamdemeo@gmail.com>
  Date: 26 Nov 2018

  References
  [1] Bergman, Clifford, "Universal algebra," CRC Press, 2012

  Copyright (c) 2018 William DeMeo
  See LICENSE file: https://github.com/UniversalAlgebra/lean-ualib/blob/master/LICENSE
-/

import basic
import subuniverse
import data.set
import data.quot
--import data.setoid

universe s -- where operation (s)ymbols live
universe u -- where structure (u)niverses (i.e. carriers) live
universe u' -- where structure (u)niverses (i.e. carriers) live
universe u'' -- where structure (u)niverses (i.e. carriers) live
universe a -- where (a)rities live

section

  parameter υ : Sort u  -- A carrier type
  parameter τ : Sort u  -- Another carrier type

  -- (defined in basic.lean)  def op (υ : Sort u) (α : Sort a) := (α → υ) → υ
  -- (defined in basic.lean) structure signature := mk :: (F : Sort s) (ρ : F → Sort a)

  parameters {S : signature}
  open set
  open subuniverse
  -- Elementary Facts ------------------------------------------

  /- Lemma (cf. Ex. 1.16.6 of [1])
     Let $f$ and $g$ be homomorphisms from $\mathbf A$ to $\mathbf B$.
     Let $E(f,g) = \{ a \in A : f(a) = g(a) \}$ (the **equalizer** of $f$ and $g$).
     1. $E(f,g)$ is a subuniverse of $\mathbf A$.
     2. If $X \subseteq A$, if $X$ generates $\mathbf A$, and if the restrictions of f and g
        to $X$ agree---i.e., $f |_X = g |_X$---then $f = g$.
     3. If $\mathbf A$, $\mathbf B$ are finite algebras and $X$ generates $\mathbf A$, then
        $|Hom(\mathbf A, \mathbf B)| \leq |B|^{|X|}$. -/

  -- equalizer for generic functions
 --(A : algebra_on S α) (B : algebra_on S β) (C : algebra_on S γ) -- {I ζ : Type} {R : I → set α}
  def equalizer {α : Type u} {β : Type u'}
  (h : α → β) (g : α → β) : set α := λ (x : α), h x = g x

  -- indicates whether h is a homomorphism
  def hom {A : algebra S} {B : algebra S} (h : A → B)
  : Prop := ∀ f a, h (A f a) = B f (h ∘ a)

  -- composition of homomorphisms is a homomorphism
  lemma hom_comp_hom_of_hom {A : algebra S} {B : algebra S} {C : algebra S}
  (h : A → B)  {h₁ : hom h} (g : B → C) {h₂ : hom g} :
  hom (g ∘ h) := assume f a, show (g ∘ h)(A f a) = C f (g ∘ h ∘ a), from
  have h₃ : (g ∘ h)(A f a) = g (h (A f a)), from  rfl,
  calc (g ∘ h)(A f a) = g ((B f) (h ∘ a)) : (h₁ f a) ▸ h₃
                  ... = (C f) (g ∘ h ∘ a) : h₂ f (h ∘ a)

  -- the set on which two homs agree
  def equalizer_of_homs {A : algebra S} {B : algebra S}
  (h : A → B) (g : A → B) {hh : hom h} {hg : hom g} : set A := λ a, h a = g a

  -- 1. The equalizer $E(f,g)$ is a subuniverse of $\mathbf A$.
  lemma sub_equalizer_of_homs {A : algebra S} {B : algebra S}
  (h : A → B) (g : A → B) (hh : hom h)  (hg : hom g) :
  Sub A (equalizer h g) :=
    assume f a (h₁: ∀ x, a x ∈ equalizer h g),
    show A f a ∈ (equalizer h g),  from
      have h₂ : h ∘ a = g ∘ a, from funext h₁,
      show h (A f a) = g (A f a), from
        calc h (A f a) = (B f) (h ∘ a): hh f a
                   ... = (B f) (g ∘ a): congr_arg (B f) h₂
                   ... = g (A f a) : eq.symm (hg f a)

  -- 2. If $X ⊆ A$, if $Sg(X) = \mathbf A$, and if $f x = g x$ for all $x ∈ X$, then $f = g$.

  lemma mem_of_eq {α : Type u} (s t : set α) : s = t →  ∀ x, x ∈ s → x ∈ t :=
  begin intros h x h', rw ←h, assumption end

  lemma hom_determined_on_gens {A : algebra S} {B : algebra S}
  (h : A → B) (g : A → B) (hh : hom h) (hg : hom g) (X : set A) :
  X ⊆ equalizer h g → Sg A X ⊆ equalizer h g :=
  -- Idea of the proof: we have
  --     1. X ⊆ equalizer h g,
  --     2. Sub (equalizer h g), i.e., equalizer h g is a subalgebra
  --     3. and Sg X is the smallest subalgebra containing X
  -- Therefore, Sg X ⊆ equalizer h g, which means h = g on Sg X.
  assume h₁ : X ⊆ equalizer h g, show Sg A X ⊆ equalizer h g, from
  assume a (h₂ : a ∈ Sg A X), show a ∈ equalizer h g, from
  have h₃ : Sub A (equalizer h g), from (sub_equalizer_of_homs h g hh hg),
      (sInter_mem A a) h₂ h₃ h₁

  -- Here's another proof of the last result using the recursor of Y.
  lemma hom_determined_on_gens_rec {A : algebra S} {B : algebra S}
  (h : A → B) (g : A → B)  (hh : hom h) (hg : hom g) (X : set A) :
  (∀ x, x ∈ X → h x = g x) → (∀ a, a ∈ Sg A X → h a = g a) :=
  assume (h₁ : ∀ x, x ∈ X → h x = g x),
  assume a (h₂ : a ∈ Sg A X), show h a = g a, from
    have h₃ : a ∈ Y A X, from mem_of_eq (Sg A X) (Y A X) (sg_inductive A X) a h₂,
    Y.rec
      --base step: assume a = x ∈ X
      h₁
      --inductive step: assume a = A f b for some b with ∀ i, b i ∈ Sg X
      ( assume f b (h₄ : ∀ i, b i ∈ Y A X)  (h₅ : ∀ i, h (b i) = g (b i)),
        show h (A f b) = g (A f b), from
        have h₆ : h ∘ b = g ∘ b, from funext h₅,
        calc h (A f b) = (B f) (h ∘ b) : hh f b
                   ... = (B f) (g ∘ b) : congr_arg (B f) h₆
                   ... = g (A f b)     : eq.symm (hg f b)) h₃

  -- def surjective {α : Type u} {β : Type u'} (f : α → β ) : Prop := ∀ y, ∃ x, f x = y
  -- def injective {α : Type u} {β : Type u'} (f : α → β) : Prop := ∀ ⦃x₁ x₂⦄, f x₁ = f x₂ → x₁ = x₂
  -- def bijective {α : Type u} {β : Type u'} (f : α → β) : Prop := injective f ∧ surjective f

  open classical function
  local attribute [instance] prop_decidable

  noncomputable def inverse' {α : Type u} {β : Type u'} (f : α → β) (default : α)  : β → α :=
  λ b, if h : ∃ a, f a = b then some h else default

  -- The right inverse of a surjective function.
  noncomputable def right_inv {α : Type u} {β : Type u'} (f : α → β)
  (h₁ : surjective f) : β → α := λ b, some (h₁ b)

  -- A surjective function has a right inverse.
  lemma right_inv_is_right_inverse {α : Type u} {β : Type u'} (f : α → β)
  (h₁ : surjective f) : ∀ b, b = f ((right_inv f h₁) b) :=
  assume b, have h₂ : (right_inv f h₁) b = some (h₁ b), from rfl,
  have h₃ : f (some (h₁ b)) = b, from some_spec (h₁ b),
  eq.subst (eq.symm h₂) (eq.symm h₃)

  -- Right inverse of epi is hom.
  lemma right_inv_of_epi_is_hom {A : algebra S} {B : algebra S} (g : A → B)
  (h₁ : surjective g) (h₂ : hom g) : hom (right_inv g h₁) :=
  let g_inv := (right_inv g h₁) in
  show hom g_inv, from
  assume f b, show g_inv (B f b) = A f (g_inv ∘ b), from  sorry
  -- B f b = B f (g ∘ g_inv ∘ b) = g (A f (g_inv ∘ b))
  -- g (g_inv (B f b)) = B f b
  -- This seems to show only that the pair
  -- (g_inv (B f b), A f (g_inv ∘ b)) belongs to the kernel of g.

  def ker {α : Type u} {β : Type u'} (f : α → β) : α → α → Prop := λ a b, f a = f b

  /-Lemma (Ex. 1.26.8.a. [1])
    If $f : A → B$ is epi
       $g : A → C$ is hom
       $ker f ⊆ ker g$
    Then $∃ h : B → C$ with $g = h ∘ f$ and $h$ is a homomorphism.
  -/
  lemma hom_facotor_down {A : algebra S} {B : algebra S} {C : algebra S}
  -- assumptions:
  (f : A → B) (hf : hom f) (hs : surjective f)    -- f is epi
  (g : A → C) (hg : hom g)                        -- g is hom
  (kk : ∀ a b, ker f a b → ker g a b) :           -- ker f ⊆ ker g
  -- conclusion:
  ∃ h : B → C, (g = h ∘ f) ∧ (hom h) :=
  -- proof:
  let h := g ∘ (right_inv f hs)  in
    have h₁ : hom h, from sorry,
    have h₃ : g = h ∘ f, from sorry,
    exists.intro h (and.intro h₃ h₁)
  /-
       A---f----> B
       |        /
       g       h
       |     /
       |   /
       V L
       C
  -/

  /-Lemma (Ex. 1.26.8.b) [1])
    If $f : A → B$ is hom
       $g : A → C$ is epi
       $ker g ⊆ ker f$
    Then $∃ h : B → C$ with $f = h ∘ g$ and $h$ is a homomorphism.
  -/
  lemma hom_facotor_up {A : algebra S} {B : algebra S} {C : algebra S}
  -- assumptions:
  (f : A → B) (hf : hom f)                        -- f is hom
  (g : A → C) (hg : hom g) (hs : surjective g)    -- g is epi
  (kk : ∀ a b, ker g a b → ker f a b) :           -- ker g ⊆ ker f
  -- conclusion:
  ∃ h : C → B,  (f = h ∘ g) ∧ (hom h)
  :=
  -- proof:
  let h := f ∘ (right_inv g hs)  in
    have h₁ : hom h, from sorry,
    have h₃ : f = h ∘ g, from sorry,
    exists.intro h (and.intro h₃ h₁)

  /-
       A----f----> B
       |         7
       g       /
       |     h
       |   /
       V /
       C
 -/

end

namespace H -- homomorphisms
section
  parameter S : signature
  variables {α : Type*} {β : Type*} {A : algebra S} {B : algebra S}
  open subuniverse
  --  def preorder (R : α → α → Prop) : Prop := reflexive R ∧ transitive R
  --  def partial_order (R : α → α → Prop) : Prop := preorder R ∧ anti_symmetric R

  -- kernel of a set map
  def ker (f : α → β) : α → α → Prop :=
  λ a a', f a = f a'

  -- kernel of an algebra map  (shouldn't need two separate defs for ker and kernel)
  def kernel (f : A → B) : A → A → Prop :=
  λ a a', f a = f a'

  lemma ker_is_equivalence (h : α → β) : equivalence (ker h) :=
  have hr : reflexive (ker h), from assume x, rfl,
  have hs : symmetric (ker h), from
    assume x y (hxy : h x = h y), eq.symm hxy,
  have ht : transitive (ker h), from
    assume x y z (h₁ : h x = h y) (h₂ : h y = h z), eq.trans h₁ h₂,
  ⟨hr, hs, ht⟩

  #check ker_is_equivalence

  lemma kernel_is_equivalence
  (h : A → B) (hh : homomorphic h) : equivalence (kernel h) :=
  have hr : reflexive (kernel h), from assume x, rfl,
  have hs : symmetric (kernel h), from
    assume x y (hxy : h x = h y), eq.symm hxy,
  have ht : transitive (kernel h), from
    assume x y z (h₁ : h x = h y) (h₂ : h y = h z), eq.trans h₁ h₂,
  ⟨hr, hs, ht⟩

  #check kernel_is_equivalence

  open quot
  def kernel.setoid (h : A → B) (hh : homomorphic h) : setoid A :=
  setoid.mk (kernel h) (kernel_is_equivalence h hh)

  -- A homomorphic image (i.e., a quotient modulo kernel of a hom).
  def quotient_by_hom_kernel (h: A → B) (hh: homomorphic h) :=
  quot (kernel.setoid h hh).r

  def hom_image (h: A → B) (hh: homomorphic h) : set B := λ b, ∃ a, h a = b

  open classical function
  local attribute [instance] prop_decidable

  -- A homomorphic image is a subalgebra.
  lemma hom_image_is_sub (h : A → B) (hh : homomorphic h) :
  Sub B (hom_image h hh) :=
  assume (f : S.F) (b : S.ρ f → B.fst) (h₁ : ∀ i, b i ∈ (hom_image h hh)),
  show (hom_image h hh) (B f b),  -- must show ∃ x ∈ A, h x = B f b
  from
    have h₂ : ∀ i, ∃ x, h x = b i, from h₁,
    have h₃ : ∀ i, h (some (h₂ i)) = b i, from assume i, some_spec (h₂ i),
    have h₆ : (λ i, h (some (h₂ i)))= b, from funext h₃,
    have h₄ : h (A f (λ i, some (h₂ i))) = B f b, by rw [hh, congr_arg (B f) h₆],
    exists.intro (A f (λ i, some (h₂ i))) h₄
  -- This is pretty ugly.  There's probably a better way.

end

end H

namespace S -- subalgebras
section
end
end S

namespace P -- products
section
end
end P

/- Miscellaneous Notes

Recall,
  - `Prop` is syntactic sugar for `Sort 0`, the bottom of the type hierarchy.
    Like the other type universes, it is closed under the arrow constructor
    (if `p q : Prop`, then `p → q : Prop`)
  -`Type u` is syntactic sugar for `Sort (u+1)`
    (`Prop = Type -1` and `Sort 1 = Type 0`)

-/
/-
Refereces:
[1] @book {MR2839398,
    AUTHOR = {Bergman, Clifford},
     TITLE = {Universal algebra},
    SERIES = {Pure and Applied Mathematics (Boca Raton)},
    VOLUME = {301},
      NOTE = {Fundamentals and selected topics},
 PUBLISHER = {CRC Press, Boca Raton, FL},
      YEAR = {2012},
     PAGES = {xii+308},
      ISBN = {978-1-4398-5129-6},
   MRCLASS = {08-02 (06-02 08A40 08B05 08B10 08B26)},
  MRNUMBER = {2839398 (2012k:08001)},
MRREVIEWER = {Konrad P. Pi{\'o}ro},
}
-/


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

! This file was ported from Lean 3 source module logic.small.basic
! leanprover-community/mathlib commit d012cd09a9b256d870751284dd6a29882b0be105
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Logic.Equiv.Set

/-!
# Small types

A type is `w`-small if there exists an equivalence to some `S : Type w`.

We provide a noncomputable model `Shrink α : Type w`, and `equivShrink α : α ≃ Shrink α`.

A subsingleton type is `w`-small for any `w`.

If `α ≃ β`, then `Small.{w} α ↔ Small.{w} β`.
-/

universe u w v

/-- A type is `Small.{w}` if there exists an equivalence to some `S : Type w`.
-/
class Small (α : Type v) : Prop where
/-- If a type is `Small.{w}`, then there exists an equivalence with some `S : Type w` -/
  equiv_small : ∃ S : Type w, Nonempty (α ≃ S)
#align small Small

/-- Constructor for `Small α` from an explicit witness type and equivalence.
-/
theorem Small.mk' {α : Type v} {S : Type w} (e : α ≃ S) : Small.{w} α :=
  ⟨⟨S, ⟨e⟩⟩⟩
#align small.mk' Small.mk'

/-- An arbitrarily chosen model in `Type w` for a `w`-small type.
-/
def Shrink (α : Type v) [Small.{w} α] : Type w :=
  Classical.choose (@Small.equiv_small α _)
#align shrink Shrink

/-- The noncomputable equivalence between a `w`-small type and a model.
-/
noncomputable def equivShrink (α : Type v) [Small.{w} α] : α ≃ Shrink α :=
  Nonempty.some (Classical.choose_spec (@Small.equiv_small α _))
#align equiv_shrink equivShrink

--Porting note: Priority changed to 101
instance (priority := 101) small_self (α : Type v) : Small.{v} α :=
  Small.mk' <| Equiv.refl α
#align small_self small_self

theorem small_map {α : Type _} {β : Type _} [hβ : Small.{w} β] (e : α ≃ β) : Small.{w} α :=
  let ⟨_, ⟨f⟩⟩ := hβ.equiv_small
  Small.mk' (e.trans f)
#align small_map small_map

theorem small_lift (α : Type u) [hα : Small.{v} α] : Small.{max v w} α :=
  let ⟨⟨_, ⟨f⟩⟩⟩ := hα
  Small.mk' <| f.trans (Equiv.ulift.{w}).symm
#align small_lift small_lift

instance (priority := 100) small_max (α : Type v) : Small.{max w v} α :=
  small_lift.{v, w} α
#align small_max small_max

instance small_ulift (α : Type u) [Small.{v} α] : Small.{v} (ULift.{w} α) :=
  small_map Equiv.ulift
#align small_ulift small_ulift

theorem small_type : Small.{max (u + 1) v} (Type u) :=
  small_max.{max (u + 1) v} _
#align small_type small_type

section

open Classical

theorem small_congr {α : Type _} {β : Type _} (e : α ≃ β) : Small.{w} α ↔ Small.{w} β :=
  ⟨fun h => @small_map _ _ h e.symm, fun h => @small_map _ _ h e⟩
#align small_congr small_congr

instance small_subtype (α : Type v) [Small.{w} α] (P : α → Prop) : Small.{w} { x // P x } :=
  small_map (equivShrink α).subtypeEquivOfSubtype'
#align small_subtype small_subtype

theorem small_of_injective {α : Type v} {β : Type w} [Small.{u} β] {f : α → β}
    (hf : Function.Injective f) : Small.{u} α :=
  small_map (Equiv.ofInjective f hf)
#align small_of_injective small_of_injective

theorem small_of_surjective {α : Type v} {β : Type w} [Small.{u} α] {f : α → β}
    (hf : Function.Surjective f) : Small.{u} β :=
  small_of_injective (Function.injective_surjInv hf)
#align small_of_surjective small_of_surjective

theorem small_subset {α : Type v} {s t : Set α} (hts : t ⊆ s) [Small.{u} s] : Small.{u} t :=
  let f : t → s := fun x => ⟨x, hts x.prop⟩
  @small_of_injective _ _ _ f fun _ _ hxy => Subtype.ext (Subtype.mk.inj hxy)
#align small_subset small_subset

instance (priority := 100) small_subsingleton (α : Type v) [Subsingleton α] : Small.{w} α := by
  rcases isEmpty_or_nonempty α with ⟨⟩ <;> skip
  · apply small_map (Equiv.equivPEmpty α)
  · apply small_map Equiv.punitOfNonemptyOfSubsingleton
#align small_subsingleton small_subsingleton

/-!
We don't define `small_of_fintype` or `small_of_countable` in this file,
to keep imports to `logic` to a minimum.
-/

instance small_Pi {α} (β : α → Type _) [Small.{w} α] [∀ a, Small.{w} (β a)] :
    Small.{w} (∀ a, β a) :=
  ⟨⟨∀ a' : Shrink α, Shrink (β ((equivShrink α).symm a')),
      ⟨Equiv.piCongr (equivShrink α) fun a => by simpa using equivShrink (β a)⟩⟩⟩
#align small_Pi small_Pi

instance small_sigma {α} (β : α → Type _) [Small.{w} α] [∀ a, Small.{w} (β a)] :
    Small.{w} (Σa, β a) :=
  ⟨⟨Σa' : Shrink α, Shrink (β ((equivShrink α).symm a')),
      ⟨Equiv.sigmaCongr (equivShrink α) fun a => by simpa using equivShrink (β a)⟩⟩⟩
#align small_sigma small_sigma

instance small_prod {α β} [Small.{w} α] [Small.{w} β] : Small.{w} (α × β) :=
  ⟨⟨Shrink α × Shrink β, ⟨Equiv.prodCongr (equivShrink α) (equivShrink β)⟩⟩⟩
#align small_prod small_prod

instance small_sum {α β} [Small.{w} α] [Small.{w} β] : Small.{w} (Sum α β) :=
  ⟨⟨Sum (Shrink α) (Shrink β), ⟨Equiv.sumCongr (equivShrink α) (equivShrink β)⟩⟩⟩
#align small_sum small_sum

instance small_set {α} [Small.{w} α] : Small.{w} (Set α) :=
  ⟨⟨Set (Shrink α), ⟨Equiv.Set.congr (equivShrink α)⟩⟩⟩
#align small_set small_set

instance small_range {α : Type v} {β : Type w} (f : α → β) [Small.{u} α] :
    Small.{u} (Set.range f) :=
  small_of_surjective Set.surjective_onto_range
#align small_range small_range

instance small_image {α : Type v} {β : Type w} (f : α → β) (S : Set α) [Small.{u} S] :
    Small.{u} (f '' S) :=
  small_of_surjective Set.surjective_onto_image
#align small_image small_image

theorem not_small_type : ¬Small.{u} (Type max u v)
  | ⟨⟨S, ⟨e⟩⟩⟩ =>
    @Function.cantor_injective (Σα, e.symm α) (fun a => ⟨_, cast (e.3 _).symm a⟩) fun a b e => by
      dsimp at e
      injection e with h₁ h₂
      simpa using h₂
#align not_small_type not_small_type

end


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

import field_theory.adjoin
import field_theory.tower
import group_theory.solvable
import ring_theory.power_basis

/-!
# Normal field extensions

In this file we define normal field extensions and prove that for a finite extension, being normal
is the same as being a splitting field (`normal.of_is_splitting_field` and
`normal.exists_is_splitting_field`).

## Main Definitions

- `normal F K` where `K` is a field extension of `F`.
-/

noncomputable theory

open_locale big_operators
open_locale classical polynomial

open polynomial is_scalar_tower

variables (F K : Type*) [field F] [field K] [algebra F K]

--TODO(Commelin): refactor normal to extend `is_algebraic`??

/-- Typeclass for normal field extension: `K` is a normal extension of `F` iff the minimal
polynomial of every element `x` in `K` splits in `K`, i.e. every conjugate of `x` is in `K`. -/
class normal : Prop :=
(is_integral' (x : K) : is_integral F x)
(splits' (x : K) : splits (algebra_map F K) (minpoly F x))

variables {F K}

theorem normal.is_integral (h : normal F K) (x : K) : is_integral F x := normal.is_integral' x

theorem normal.splits (h : normal F K) (x : K) :
  splits (algebra_map F K) (minpoly F x) := normal.splits' x

theorem normal_iff : normal F K ↔
  ∀ x : K, is_integral F x ∧ splits (algebra_map F K) (minpoly F x) :=
⟨λ h x, ⟨h.is_integral x, h.splits x⟩, λ h, ⟨λ x, (h x).1, λ x, (h x).2⟩⟩

theorem normal.out : normal F K →
  ∀ x : K, is_integral F x ∧ splits (algebra_map F K) (minpoly F x) := normal_iff.1

variables (F K)

instance normal_self : normal F F :=
⟨λ x, is_integral_algebra_map, λ x, by { rw minpoly.eq_X_sub_C', exact splits_X_sub_C _ }⟩

variables {K}

variables (K)

theorem normal.exists_is_splitting_field [h : normal F K] [finite_dimensional F K] :
  ∃ p : F[X], is_splitting_field F K p :=
begin
  let s := basis.of_vector_space F K,
  refine ⟨∏ x, minpoly F (s x),
    splits_prod _ $ λ x hx, h.splits (s x),
    subalgebra.to_submodule_injective _⟩,
  rw [algebra.top_to_submodule, eq_top_iff, ← s.span_eq, submodule.span_le, set.range_subset_iff],
  refine λ x, algebra.subset_adjoin (multiset.mem_to_finset.mpr $
    (mem_roots $ mt (map_eq_zero $ algebra_map F K).1 $
    finset.prod_ne_zero_iff.2 $ λ x hx, _).2 _),
  { exact minpoly.ne_zero (h.is_integral (s x)) },
  rw [is_root.def, eval_map, ← aeval_def, alg_hom.map_prod],
  exact finset.prod_eq_zero (finset.mem_univ _) (minpoly.aeval _ _)
end

section normal_tower

variables (E : Type*) [field E] [algebra F E] [algebra K E] [is_scalar_tower F K E]

lemma normal.tower_top_of_normal [h : normal F E] : normal K E :=
normal_iff.2 $ λ x, begin
  cases h.out x with hx hhx,
  rw algebra_map_eq F K E at hhx,
  exact ⟨is_integral_of_is_scalar_tower x hx, polynomial.splits_of_splits_of_dvd (algebra_map K E)
    (polynomial.map_ne_zero (minpoly.ne_zero hx))
    ((polynomial.splits_map_iff (algebra_map F K) (algebra_map K E)).mpr hhx)
    (minpoly.dvd_map_of_is_scalar_tower F K x)⟩,
end

lemma alg_hom.normal_bijective [h : normal F E] (ϕ : E →ₐ[F] K) : function.bijective ϕ :=
⟨ϕ.to_ring_hom.injective, λ x, by
{ letI : algebra E K := ϕ.to_ring_hom.to_algebra,
  obtain ⟨h1, h2⟩ := h.out (algebra_map K E x),
  cases minpoly.mem_range_of_degree_eq_one E x (or.resolve_left h2 (minpoly.ne_zero h1)
    (minpoly.irreducible (is_integral_of_is_scalar_tower x
      ((is_integral_algebra_map_iff (algebra_map K E).injective).mp h1)))
    (minpoly.dvd E x ((algebra_map K E).injective (by
    { rw [ring_hom.map_zero, aeval_map, ←is_scalar_tower.to_alg_hom_apply F K E,
          ←alg_hom.comp_apply, ←aeval_alg_hom],
      exact minpoly.aeval F (algebra_map K E x) })))) with y hy,
  exact ⟨y, hy⟩ }⟩

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

lemma normal.of_alg_equiv [h : normal F E] (f : E ≃ₐ[F] E') : normal F E' :=
normal_iff.2 $ λ x, begin
  cases h.out (f.symm x) with hx hhx,
  have H := is_integral_alg_hom f.to_alg_hom hx,
  rw [alg_equiv.to_alg_hom_eq_coe, alg_equiv.coe_alg_hom, alg_equiv.apply_symm_apply] at H,
  use H,
  apply polynomial.splits_of_splits_of_dvd (algebra_map F E') (minpoly.ne_zero hx),
  { rw ← alg_hom.comp_algebra_map f.to_alg_hom,
    exact polynomial.splits_comp_of_splits (algebra_map F E) f.to_alg_hom.to_ring_hom hhx },
  { apply minpoly.dvd _ _,
    rw ← add_equiv.map_eq_zero_iff f.symm.to_add_equiv,
    exact eq.trans (polynomial.aeval_alg_hom_apply f.symm.to_alg_hom x
      (minpoly F (f.symm x))).symm (minpoly.aeval _ _) },
end

lemma alg_equiv.transfer_normal (f : E ≃ₐ[F] E') : normal F E ↔ normal F E' :=
⟨λ h, by exactI normal.of_alg_equiv f, λ h, by exactI normal.of_alg_equiv f.symm⟩

lemma normal.of_is_splitting_field (p : F[X]) [hFEp : is_splitting_field F E p] :
  normal F E :=
begin
  by_cases hp : p = 0,
  { haveI : is_splitting_field F F p, { rw hp, exact ⟨splits_zero _, subsingleton.elim _ _⟩ },
    exactI (alg_equiv.transfer_normal ((is_splitting_field.alg_equiv F p).trans
      (is_splitting_field.alg_equiv E p).symm)).mp (normal_self F) },
  refine normal_iff.2 (λ x, _),
  haveI hFE : finite_dimensional F E := is_splitting_field.finite_dimensional E p,
  have Hx : is_integral F x := is_integral_of_noetherian (is_noetherian.iff_fg.2 hFE) x,
  refine ⟨Hx, or.inr _⟩,
  rintros q q_irred ⟨r, hr⟩,
  let D := adjoin_root q,
  let pbED := adjoin_root.power_basis q_irred.ne_zero,
  haveI : finite_dimensional E D := power_basis.finite_dimensional pbED,
  have finrankED : finite_dimensional.finrank E D = q.nat_degree := power_basis.finrank pbED,
  letI : algebra F D := ring_hom.to_algebra ((algebra_map E D).comp (algebra_map F E)),
  haveI : is_scalar_tower F E D := of_algebra_map_eq (λ _, rfl),
  haveI : finite_dimensional F D := finite_dimensional.trans F E D,
  suffices : nonempty (D →ₐ[F] E),
  { cases this with ϕ,
    rw [←with_bot.coe_one, degree_eq_iff_nat_degree_eq q_irred.ne_zero, ←finrankED],
    have nat_lemma : ∀ a b c : ℕ, a * b = c → c ≤ a → 0 < c → b = 1,
    { intros a b c h1 h2 h3, nlinarith },
    exact nat_lemma _ _ _ (finite_dimensional.finrank_mul_finrank F E D)
      (linear_map.finrank_le_finrank_of_injective (show function.injective ϕ.to_linear_map,
        from ϕ.to_ring_hom.injective)) finite_dimensional.finrank_pos, },
  let C := adjoin_root (minpoly F x),
  have Hx_irred := minpoly.irreducible Hx,
  letI : algebra C D := ring_hom.to_algebra (adjoin_root.lift
    (algebra_map F D) (adjoin_root.root q) (by rw [algebra_map_eq F E D, ←eval₂_map, hr,
      adjoin_root.algebra_map_eq, eval₂_mul, adjoin_root.eval₂_root, zero_mul])),
  letI : algebra C E := ring_hom.to_algebra (adjoin_root.lift
    (algebra_map F E) x (minpoly.aeval F x)),
  haveI : is_scalar_tower F C D := of_algebra_map_eq (λ x, (adjoin_root.lift_of _).symm),
  haveI : is_scalar_tower F C E := of_algebra_map_eq (λ x, (adjoin_root.lift_of _).symm),
  suffices : nonempty (D →ₐ[C] E),
  { exact nonempty.map (alg_hom.restrict_scalars F) this },
  let S : set D := ((p.map (algebra_map F E)).roots.map (algebra_map E D)).to_finset,
  suffices : ⊤ ≤ intermediate_field.adjoin C S,
  { refine intermediate_field.alg_hom_mk_adjoin_splits' (top_le_iff.mp this) (λ y hy, _),
    rcases multiset.mem_map.mp (multiset.mem_to_finset.mp hy) with ⟨z, hz1, hz2⟩,
    have Hz : is_integral F z := is_integral_of_noetherian (is_noetherian.iff_fg.2 hFE) z,
    use (show is_integral C y, from is_integral_of_noetherian
      (is_noetherian.iff_fg.2 (finite_dimensional.right F C D)) y),
    apply splits_of_splits_of_dvd (algebra_map C E) (map_ne_zero (minpoly.ne_zero Hz)),
    { rw [splits_map_iff, ←algebra_map_eq F C E],
      exact splits_of_splits_of_dvd _ hp hFEp.splits (minpoly.dvd F z
        (eq.trans (eval₂_eq_eval_map _) ((mem_roots (map_ne_zero hp)).mp hz1))) },
    { apply minpoly.dvd,
      rw [←hz2, aeval_def, eval₂_map, ←algebra_map_eq F C D, algebra_map_eq F E D, ←hom_eval₂,
          ←aeval_def, minpoly.aeval F z, ring_hom.map_zero] } },
  rw [←intermediate_field.to_subalgebra_le_to_subalgebra, intermediate_field.top_to_subalgebra],
  apply ge_trans (intermediate_field.algebra_adjoin_le_adjoin C S),
  suffices : (algebra.adjoin C S).restrict_scalars F
           = (algebra.adjoin E {adjoin_root.root q}).restrict_scalars F,
  { rw [adjoin_root.adjoin_root_eq_top, subalgebra.restrict_scalars_top,
      ←@subalgebra.restrict_scalars_top F C] at this,
    exact top_le_iff.mpr (subalgebra.restrict_scalars_injective F this) },
  dsimp only [S],
  rw [←finset.image_to_finset, finset.coe_image],
  apply eq.trans (algebra.adjoin_res_eq_adjoin_res F E C D
    hFEp.adjoin_roots adjoin_root.adjoin_root_eq_top),
  rw [set.image_singleton, ring_hom.algebra_map_to_algebra, adjoin_root.lift_root]
end

instance (p : F[X]) : normal F p.splitting_field := normal.of_is_splitting_field p

end normal_tower

variables {F} {K} (ϕ ψ : K →ₐ[F] K) (χ ω : K ≃ₐ[F] K)

section restrict

variables (E : Type*) [field E] [algebra F E] [algebra E K] [is_scalar_tower F E K]

/-- Restrict algebra homomorphism to image of normal subfield -/
def alg_hom.restrict_normal_aux [h : normal F E] :
  (to_alg_hom F E K).range →ₐ[F] (to_alg_hom F E K).range :=
{ to_fun := λ x, ⟨ϕ x, by
  { suffices : (to_alg_hom F E K).range.map ϕ ≤ _,
    { exact this ⟨x, subtype.mem x, rfl⟩ },
    rintros x ⟨y, ⟨z, hy⟩, hx⟩,
    rw [←hx, ←hy],
    apply minpoly.mem_range_of_degree_eq_one E,
    exact or.resolve_left (h.splits z) (minpoly.ne_zero (h.is_integral z))
      (minpoly.irreducible $ is_integral_of_is_scalar_tower _ $
        is_integral_alg_hom ϕ $ is_integral_alg_hom _ $ h.is_integral z)
      (minpoly.dvd E _ $ by rw [aeval_map, aeval_alg_hom, aeval_alg_hom, alg_hom.comp_apply,
        alg_hom.comp_apply, minpoly.aeval, alg_hom.map_zero, alg_hom.map_zero]) }⟩,
  map_zero' := subtype.ext ϕ.map_zero,
  map_one' := subtype.ext ϕ.map_one,
  map_add' := λ x y, subtype.ext (ϕ.map_add x y),
  map_mul' := λ x y, subtype.ext (ϕ.map_mul x y),
  commutes' := λ x, subtype.ext (ϕ.commutes x) }

/-- Restrict algebra homomorphism to normal subfield -/
def alg_hom.restrict_normal [normal F E] : E →ₐ[F] E :=
((alg_equiv.of_injective_field (is_scalar_tower.to_alg_hom F E K)).symm.to_alg_hom.comp
  (ϕ.restrict_normal_aux E)).comp
    (alg_equiv.of_injective_field (is_scalar_tower.to_alg_hom F E K)).to_alg_hom

@[simp] lemma alg_hom.restrict_normal_commutes [normal F E] (x : E) :
  algebra_map E K (ϕ.restrict_normal E x) = ϕ (algebra_map E K x) :=
subtype.ext_iff.mp (alg_equiv.apply_symm_apply (alg_equiv.of_injective_field
  (is_scalar_tower.to_alg_hom F E K)) (ϕ.restrict_normal_aux E
    ⟨is_scalar_tower.to_alg_hom F E K x, x, rfl⟩))

lemma alg_hom.restrict_normal_comp [normal F E] :
  (ϕ.restrict_normal E).comp (ψ.restrict_normal E) = (ϕ.comp ψ).restrict_normal E :=
alg_hom.ext (λ _, (algebra_map E K).injective
  (by simp only [alg_hom.comp_apply, alg_hom.restrict_normal_commutes]))

/-- Restrict algebra isomorphism to a normal subfield -/
def alg_equiv.restrict_normal [h : normal F E] : E ≃ₐ[F] E :=
alg_equiv.of_bijective (χ.to_alg_hom.restrict_normal E) (alg_hom.normal_bijective F E E _)

@[simp] lemma alg_equiv.restrict_normal_commutes [normal F E] (x : E) :
  algebra_map E K (χ.restrict_normal E x) = χ (algebra_map E K x) :=
χ.to_alg_hom.restrict_normal_commutes E x

lemma alg_equiv.restrict_normal_trans [normal F E] :
  (χ.trans ω).restrict_normal E = (χ.restrict_normal E).trans (ω.restrict_normal E) :=
alg_equiv.ext (λ _, (algebra_map E K).injective
(by simp only [alg_equiv.trans_apply, alg_equiv.restrict_normal_commutes]))

/-- Restriction to an normal subfield as a group homomorphism -/
def alg_equiv.restrict_normal_hom [normal F E] : (K ≃ₐ[F] K) →* (E ≃ₐ[F] E) :=
monoid_hom.mk' (λ χ, χ.restrict_normal E) (λ ω χ, (χ.restrict_normal_trans ω E))

end restrict

section lift

variables {F} {K} (E : Type*) [field E] [algebra F E] [algebra K E] [is_scalar_tower F K E]

/-- If `E/K/F` is a tower of fields with `E/F` normal then we can lift
  an algebra homomorphism `ϕ : K →ₐ[F] K` to `ϕ.lift_normal E : E →ₐ[F] E`. -/
noncomputable def alg_hom.lift_normal [h : normal F E] : E →ₐ[F] E :=
@alg_hom.restrict_scalars F K E E _ _ _ _ _ _
  ((is_scalar_tower.to_alg_hom F K E).comp ϕ).to_ring_hom.to_algebra _ _ _ _ $ nonempty.some $
  @intermediate_field.alg_hom_mk_adjoin_splits' _ _ _ _ _ _ _
  ((is_scalar_tower.to_alg_hom F K E).comp ϕ).to_ring_hom.to_algebra _
  (intermediate_field.adjoin_univ _ _)
  (λ x hx, ⟨is_integral_of_is_scalar_tower x (h.out x).1,
    splits_of_splits_of_dvd _ (map_ne_zero (minpoly.ne_zero (h.out x).1))
    (by { rw [splits_map_iff, ←is_scalar_tower.algebra_map_eq], exact (h.out x).2 })
    (minpoly.dvd_map_of_is_scalar_tower F K x)⟩)

@[simp] lemma alg_hom.lift_normal_commutes [normal F E] (x : K) :
  ϕ.lift_normal E (algebra_map K E x) = algebra_map K E (ϕ x) :=
@alg_hom.commutes K E E _ _ _ _
  ((is_scalar_tower.to_alg_hom F K E).comp ϕ).to_ring_hom.to_algebra _ x

@[simp] lemma alg_hom.restrict_lift_normal [normal F K] [normal F E] :
  (ϕ.lift_normal E).restrict_normal K = ϕ :=
alg_hom.ext (λ x, (algebra_map K E).injective
  (eq.trans (alg_hom.restrict_normal_commutes _ K x) (ϕ.lift_normal_commutes E x)))

/-- If `E/K/F` is a tower of fields with `E/F` normal then we can lift
  an algebra isomorphism `ϕ : K ≃ₐ[F] K` to `ϕ.lift_normal E : E ≃ₐ[F] E`. -/
noncomputable def alg_equiv.lift_normal [normal F E] : E ≃ₐ[F] E :=
alg_equiv.of_bijective (χ.to_alg_hom.lift_normal E) (alg_hom.normal_bijective F E E _)

@[simp] lemma alg_equiv.lift_normal_commutes [normal F E] (x : K) :
  χ.lift_normal E (algebra_map K E x) = algebra_map K E (χ x) :=
χ.to_alg_hom.lift_normal_commutes E x

@[simp] lemma alg_equiv.restrict_lift_normal [normal F K] [normal F E] :
  (χ.lift_normal E).restrict_normal K = χ :=
alg_equiv.ext (λ x, (algebra_map K E).injective
  (eq.trans (alg_equiv.restrict_normal_commutes _ K x) (χ.lift_normal_commutes E x)))

lemma alg_equiv.restrict_normal_hom_surjective [normal F K] [normal F E] :
  function.surjective (alg_equiv.restrict_normal_hom K : (E ≃ₐ[F] E) → (K ≃ₐ[F] K)) :=
λ χ, ⟨χ.lift_normal E, χ.restrict_lift_normal E⟩

variables (F) (K) (E)

lemma is_solvable_of_is_scalar_tower [normal F K] [h1 : is_solvable (K ≃ₐ[F] K)]
  [h2 : is_solvable (E ≃ₐ[K] E)] : is_solvable (E ≃ₐ[F] E) :=
begin
  let f : (E ≃ₐ[K] E) →* (E ≃ₐ[F] E) :=
  { to_fun := λ ϕ, alg_equiv.of_alg_hom (ϕ.to_alg_hom.restrict_scalars F)
      (ϕ.symm.to_alg_hom.restrict_scalars F)
      (alg_hom.ext (λ x, ϕ.apply_symm_apply x))
      (alg_hom.ext (λ x, ϕ.symm_apply_apply x)),
    map_one' := alg_equiv.ext (λ _, rfl),
    map_mul' := λ _ _, alg_equiv.ext (λ _, rfl) },
  refine solvable_of_ker_le_range f (alg_equiv.restrict_normal_hom K)
    (λ ϕ hϕ, ⟨{commutes' := λ x, _, .. ϕ}, alg_equiv.ext (λ _, rfl)⟩),
  exact (eq.trans (ϕ.restrict_normal_commutes K x).symm (congr_arg _ (alg_equiv.ext_iff.mp hϕ x))),
end

end lift