import field_theory.galois
import field_theory.krull_topology
import topology.category.CompHaus.default
import order.filter.ultrafilter
import topology.algebra.open_subgroup
import topology.category.Profinite.default

open_locale classical

/-!
# Krull topology profinite

Let `L/K` be a normal algebraic field extension. We show that the Krull topology on `L ≃ₐ[K] L` is
profinite, in the sense that it is a compact, Hausdorff, and totally disconnected topological space.

## Main definitions

- `krull_topology_t2 K L h_int`. For an integral field extension `L/K`,`krull_topology_t2 K L h_int`
  is a term of type `t2_space(L ≃ₐ[K] L)`. The existence of the such a term implies that the Krull topology is
  Hausdorff. Here `h_int` is a term of type `∀ (x : L), is_integral K x`. That is, `h_int` is
  a proof that the extension `L/K` is integral.

- `alg_hom_of_finite_dimensional_of_ultrafilter h_findim f`. Let `L/E/K` be a tower of fields and let
  `h_findim : finite_dimensional K L` be a proof that `E/K` is finite-dimensional. Let
  `f : ultrafilter(L ≃ₐ[K] L)`. The restriction map `(L ≃ₐ[K] L) → (E →ₐ[K] L)` pushes `f`
  forward to an ultrafilter `f*` on `(E →ₐ[K] L)`. Since `(E →ₐ[K] L)` is a finite set, any
  ultrafilter on it is principal. Therefore, `f*` is a principal ultrafilter, and
  `alg_hom_of_finite_dimensional_ultrafilter h_findim f` generates it.

- `function_of_ultrafilter h_int f`. Let `L/E/K` be a tower of fields, with `E/K` finite Let `f` be
  an ultrafilter on `L ≃ₐ[K] L`, and let `h_int : ∀ (x : L), is_integral K x`. Write
  `σ_E` for `alg_hom_of_finite_dimensional_of_ultrafilter h_findim f`, where
  `h_findim : finite_dimensional K E`. Each `σ_E` is a map `E → L`, and we would like to
  glue these maps together to obtain a map `L → L`. This glued map is
  `function_of_ultrafilter h_int f`.

- `alg_hom_of_ultrafilter h_int f`. Let `L/K` be an integral field extension and let
  `h_int : ∀ (x : L), is_integral K x`. Let `f` be an ultrafilter on `L ≃ₐ[K] L`. Then
  `alg_hom_of_ultrafilter h_int f` is a term of `L →ₐ[K] L` whose underlying map is
  `function_of_ultrafilter h_int f`.

- `equiv_of_ultrafilter h_int f`. Let `L/K` be an integral field extension and let
  `h_int : ∀ (x : L), is_integral K x`. Let `f` be an ultrafilter on `L ≃ₐ[K] L`. Then
  `equiv_of_ultrafilter h_int f`is a term of `L ≃ₐ[K] L` whose underlying map is
  `function_of_ultrafilter h_int f`.

- `krull_topology_comphaus h_int h_splits`. Let `L/K` be an integral, normal field extension. Let
  `h_int : ∀ (x : L), is_integral K x` and `h_splits : ∀ (x : L), polynomial.splits (algebra_map K L) (minpoly K x)`.
  That is, `h_int` is a proof that the extension is integral, and `h_splits` is a proof that it is normal. Then
  `krull_topology_comphaus h_int h_splits` is a term of type `CompHaus` whose underlying topology is the Krull topology
  on `L ≃ₐ[K] L`.

- `krull_topology_totally_disconnected h_int`. Let `L/K` be an integral field extension. Let
  `h_int : ∀ (x : L), is_integral K x`. Then `krull_topology_totally_disconnected h_int` is a term of type
  `totally_disconnected_space (L ≃ₐ[K] L)`, whose underlying topology is the Krull topology.

- `krull_topology_profinite h_int h_splits`. Let `L/K` be an integral, normal field extension. Let
  `h_int : ∀ (x : L), is_integral K x` and `h_splits : ∀ (x : L), polynomial.splits (algebra_map K L) (minpoly K x)`.
  That is, `h_int` is a proof that the extension is integral, and `h_splits` is a proof that it is normal. Then
  `krull_topology_profinite h_int h_splits` is a term of type `Profinite`, whose underlying topological space is the
  Krull topology on `L ≃ₐ[K] L`.

## Main results

- `krull_topology_compact h_int h_splits`. If `L/K` be an integral, normal field extension, then
  the Krull topology on `L ≃ₐ[K] L` is compact.

-/

/-- If `f,g : L → L` are distinct `K`-algebra equivalences, then there is some `x ∈ L` with
  `f(x) ≠ g(x)`. -/
lemma diff_equivs_have_diff_values {K L : Type*} [field K] [field L] [algebra K L]
{f g : L ≃ₐ[K] L} (h : f ≠ g) :
∃ (x : L), f x ≠ g x :=
begin
  contrapose! h,
  exact alg_equiv.ext h,
end

open_locale topological_space filter

/-- If a subgroup of a topological group has `1` in its interior, then it is open. -/
lemma open_subgroup_of_nonempty_interior {G : Type*} [group G] [topological_space G]
[topological_group G] {H : subgroup G} (h_1_int : (1 : G) ∈ interior (H : set G)) :
is_open (H : set G) :=
begin
  have h : 𝓝 1 ≤ 𝓟 (H : set G) :=
    nhds_le_of_le h_1_int (is_open_interior) (filter.principal_mono.2 interior_subset),
  rw is_open_iff_nhds,
  intros g hg,
  rw (show 𝓝 g = filter.map ⇑(homeomorph.mul_left g) (𝓝 1), by simp),
  convert filter.map_mono h,
  simp only [homeomorph.coe_mul_left, filter.map_principal, set.image_mul_left, filter.principal_eq_iff_eq],
  ext,
  simp [H.mul_mem_cancel_left (H.inv_mem hg)],
end

/-- Let `L/E/K` be a tower of fields with `E/K` finite. Then `Gal(L/E)` is an open subgroup of
  `L ≃ₐ[K] L`. -/
lemma fixing_subgroup_is_open {K L : Type*} [field K] [field L] [algebra K L]
(E : intermediate_field K L) [finite_dimensional K E] :
is_open (E.fixing_subgroup : set (L ≃ₐ[K] L)) :=
begin
  have h_basis : E.fixing_subgroup.carrier ∈ (gal_group_basis K L) :=
   ⟨E.fixing_subgroup, ⟨E, _inst_4, rfl⟩, rfl⟩,
  have h_nhd := group_filter_basis.mem_nhds_one (gal_group_basis K L) h_basis,
  rw mem_nhds_iff at h_nhd,
  rcases h_nhd with ⟨U, hU_le, hU_open, h1U⟩,
  exact open_subgroup_of_nonempty_interior ⟨U, ⟨hU_open, hU_le⟩, h1U⟩,
end

section a
variables (F α : Sort*) (β : α → Sort*)
variables {F α β} [i : fun_like F α β]
include i

lemma fun_like.exists_ne {f g : F} (h : f ≠ g) : ∃ x, f x ≠ g x :=
not_forall.mp $ mt (fun_like.ext _ _) h
end a

/-- If `L/K` is an algebraic extension, then the Krull topology on `L ≃ₐ[K] L` is Hausdorff. -/
lemma krull_topology_t2 (K L : Type*) [field K] [field L] [algebra K L] (h_int :
algebra.is_integral K L):
t2_space (L ≃ₐ[K] L)  :=
{ t2 :=
begin
  intros f g hfg,
  let φ := f⁻¹ * g,
  have h : ∃(x : L), f x ≠ g x,
  {
    apply fun_like.exists_ne,
    exact hfg,
  },
  cases (fun_like.exists_ne hfg) with x hx,
  have hφx : φ x ≠ x,
  {
    --change f⁻¹(g x) ≠ x,
    apply ne_of_apply_ne f,
    change f (f.symm (g x)) ≠ f x,
    rw [alg_equiv.apply_symm_apply f (g x), ne_comm],
    exact hx,
  },
  let E : intermediate_field K L := intermediate_field.adjoin K {x},
  let h_findim : finite_dimensional K E :=
  intermediate_field.adjoin.finite_dimensional (h_int x),
  let H := E.fixing_subgroup,
  have h_basis : (H : set(L ≃ₐ[K] L)) ∈ gal_group_basis K L := ⟨H, ⟨E, ⟨h_findim, rfl⟩⟩, rfl⟩,
  have h_nhd := group_filter_basis.mem_nhds_one (gal_group_basis K L) h_basis,
  rw mem_nhds_iff at h_nhd,
  rcases h_nhd with ⟨W, hWH, hW_open, hW_1⟩,
  refine ⟨left_coset f W, left_coset g W, ⟨is_open.left_coset hW_open f, is_open.left_coset hW_open g,
  ⟨1, hW_1, by apply mul_one⟩, ⟨1, hW_1, by apply mul_one⟩, _⟩⟩,
  by_contra h_nonempty,
  change left_coset f W ∩ left_coset g W ≠ ∅ at h_nonempty,
  rw set.ne_empty_iff_nonempty at h_nonempty,
  rcases h_nonempty with ⟨σ, ⟨⟨w1, hw1, hfw1⟩, ⟨w2, hw2, hgw2⟩⟩⟩,
  rw ← hgw2 at hfw1,
  rename hfw1 h,
  rw [eq_inv_mul_iff_mul_eq.symm, ← mul_assoc, mul_inv_eq_iff_eq_mul.symm] at h,
  have h_in_H : w1 * w2⁻¹ ∈ H := H.mul_mem' (hWH hw1) (H.inv_mem' (hWH hw2)),
  rw h at h_in_H,
  change φ ∈ E.fixing_subgroup at h_in_H,
  rw mem_fixing_subgroup_iff at h_in_H,
  specialize h_in_H x,
  have hxE : x ∈ E,
  {
    apply intermediate_field.subset_adjoin,
    apply set.mem_singleton,
  },
  exact hφx (h_in_H hxE),
end}

section totally_disconnected

/-- Let `X` be a topological space, and suppose that for all distinct `x,y ∈ X`, there
  is some clopen set `U` such that `x ∈ U` and `y ∉ U`. Then `X` is totally disconnected. -/
lemma is_totally_disconnected_of_clopen_set {X : Type*} [topological_space X]
(h_exists_clopen : ∀ {x y : X} (h_diff : x ≠ y), ∃ (U : set X) (h_clopen : is_clopen U), x ∈ U ∧ y ∉ U) :
is_totally_disconnected (set.univ : set X) :=
begin
  intros S _ hS,
  by_contra,
  unfold set.subsingleton at h,
  simp at h,
  rcases h with ⟨x, hx, y, hy, hxy⟩,
  specialize h_exists_clopen hxy,
  rcases h_exists_clopen with ⟨U, h_clopen, hxU, hyU⟩,
  let V := set.compl U,
  have hV_open : is_open V,
  {
    rw ← is_closed_compl_iff,
    change is_closed U.compl.compl,
    simp,
    exact h_clopen.2,
  },
  specialize hS U V h_clopen.1 hV_open (λ a ha, em (a ∈ U)) ⟨x, hx, hxU⟩ ⟨y, hy, hyU⟩,
  have hUV : U ∩ V = ∅,
  {
   change U ∩ U.compl = ∅,
   simp,
  },
  rw hUV at hS,
  simp at hS,
  exact hS,
end

/-- Given a tower of fields `L/E/K`, with `E/K` finite, the subgroup `Gal(L/E) ≤ L ≃ₐ[K] L` is
  closed. -/
lemma fixing_subgroup_is_closed {K L : Type*} [field K] [field L] [algebra K L]
{E : intermediate_field K L} (h_findim : finite_dimensional K E) :
is_closed (E.fixing_subgroup : set (L ≃ₐ[K] L)) :=
begin
  let h_open : open_subgroup (L ≃ₐ[K] L) :=
  { to_subgroup := E.fixing_subgroup,
    is_open' := fixing_subgroup_is_open E,
  },
  exact open_subgroup.is_closed h_open,
end

/-- If `L/K` is an algebraic field extension, then the Krull topology on `L ≃ₐ[K] L` is
  totally disconnected. -/
lemma krull_totally_disconnected {K L : Type*} [field K] [field L] [algebra K L]
(h_int : ∀ (x : L), is_integral K x) :
is_totally_disconnected (set.univ : set (L ≃ₐ[K] L)) :=
begin
  apply is_totally_disconnected_of_clopen_set,
  intros σ τ h_diff,
  have hστ : σ⁻¹ * τ ≠ 1,
  {
    simp [inv_mul_eq_one],
    exact h_diff,
  },
  cases (diff_equivs_have_diff_values hστ) with x hx,
  change (σ⁻¹ * τ) x ≠ x at hx,
  let E := intermediate_field.adjoin K ({x} : set L),
  refine ⟨left_coset σ E.fixing_subgroup,
  ⟨is_open.left_coset (fixing_subgroup_is_open (intermediate_field.adjoin.finite_dimensional (h_int x))) σ,
    is_closed.left_coset (fixing_subgroup_is_closed (intermediate_field.adjoin.finite_dimensional (h_int x))) σ⟩,
    ⟨1, E.fixing_subgroup.one_mem', by simp⟩,
    _⟩,
  rw mem_left_coset_iff,
  change ¬ σ⁻¹ * τ ∈ E.fixing_subgroup,
  rw mem_fixing_subgroup_iff E (σ⁻¹ * τ),
  simp,
  exact ⟨x, intermediate_field.mem_adjoin_simple_self K x, hx⟩,
end

end totally_disconnected

section finite_stuff

variables {K E L : Type*} [field K] [field E] [algebra K E] [field L] [algebra K L]
  [finite_dimensional K E]

noncomputable instance foo {E : Type*} {X : set E} (hX : X.finite) {L : Type*}
  (F : E → multiset L) : fintype (Π x : X, {l : L // l ∈ F x}) :=
by { classical, letI : fintype X := set.finite.fintype hX, exact pi.fintype}

variable (K)

noncomputable def aux_fun1 : E → multiset L :=
λ e, ((minpoly K e).map (algebra_map K L)).roots

lemma minpoly.ne_zero' (e : E) : minpoly K e ≠ 0 :=
minpoly.ne_zero $ is_integral_of_noetherian (is_noetherian.iff_fg.2 infer_instance) _

variable (E)

def basis_set: set E :=
set.range (finite_dimensional.fin_basis K E : _ → E)

variable (L)

-- function from Hom_K(E,L) to pi type Π (x : basis), roots of min poly of x
def aux_fun2 (φ : E →ₐ[K] L) (x : basis_set K E) :
  {l : L // l ∈ (aux_fun1 K x.1 : multiset L)} :=
⟨φ x, begin
  unfold aux_fun1,
  rw [polynomial.mem_roots_map (minpoly.ne_zero' K x.val),
    ← polynomial.alg_hom_eval₂_algebra_map, ← φ.map_zero],
  exact congr_arg φ (minpoly.aeval K (x : E)),
end⟩

lemma aux_inj : function.injective (aux_fun2 K E L) :=
begin
  intros f g h,
  suffices : (f : E →ₗ[K] L) = g,
  { rw linear_map.ext_iff at this,
    ext x, exact this x },
  rw function.funext_iff at h,
  apply linear_map.ext_on (finite_dimensional.fin_basis K E).span_eq,
  rintro e he,
  have := (h ⟨e, he⟩),
  apply_fun subtype.val at this,
  exact this,
end

noncomputable def its_finite : fintype (E →ₐ[K] L) :=
let n := finite_dimensional.finrank K E in
begin
  let B : basis (fin n) K E := finite_dimensional.fin_basis K E,
  let X := set.range (B : fin n → E),
  have hX : X.finite := set.finite_range ⇑B,
  refine @fintype.of_injective _ _
    (foo hX (λ e, ((minpoly K e).map (algebra_map K L)).roots)) _ (aux_inj K E L),
end

end finite_stuff

lemma preimage_univ (X Y : Type*) (f : X → Y) :
f⁻¹' (set.univ) = (set.univ) :=
begin
  ext,
  refine ⟨λ h, set.mem_univ x, _⟩,
  intro h,
  change f x ∈ set.univ,
  exact set.mem_univ (f x),
end

open set

lemma ultrafilter.eq_principal_of_fintype (X : Type*) [fintype X]
  (f : ultrafilter X) : ∃ x : X, (f : filter X) = pure x :=
let ⟨x, hx1, (hx2 : (f : filter X) = pure x)⟩ :=
  ultrafilter.eq_principal_of_finite_mem (finite_univ : (univ : set X).finite)
  (filter.univ_mem) in
⟨x, hx2⟩

universe u

-- here's a short def
noncomputable def alg_hom_of_finite_dimensional_of_ultrafilter
  {K : Type*} {L : Type u} [field K] [field L] [algebra K L]
  {E : intermediate_field K L} (h_findim : finite_dimensional K E)
  (f : ultrafilter (L ≃ₐ[K] L)) : E →ₐ[K] L :=
classical.some
  (@ultrafilter.eq_principal_of_fintype (E →ₐ[K] L) (its_finite K E L)
  (f.map (λ σ, σ.to_alg_hom.comp (intermediate_field.val E))))

-- f.map ((L ≃ₐ[K] L) → (E →ₐ[K] L)) is generated by
-- alg_hom_of_finite_dimensional_of_ultrafilter_spec h_findim f
lemma alg_hom_of_finite_dimensional_of_ultrafilter_spec {K L : Type*} [field K] [field L] [algebra K L]
  {E : intermediate_field K L} (h_findim : finite_dimensional K E)
  (f : ultrafilter (L ≃ₐ[K] L)) :

(f.map (λ σ : L ≃ₐ[K] L, σ.to_alg_hom.comp (intermediate_field.val E)) : filter (E →ₐ[K] L)) =
  pure (alg_hom_of_finite_dimensional_of_ultrafilter h_findim f) :=

classical.some_spec
  (@ultrafilter.eq_principal_of_fintype (E →ₐ[K] L) (its_finite K E L)
  (f.map (λ σ, σ.to_alg_hom.comp (intermediate_field.val E))))

def intermediate_field.inclusion {K L : Type*} [field K] [field L] [algebra K L]
  {E F : intermediate_field K L} (hEF : E ≤ F):
  E →ₐ[K] F :=
{ to_fun := set.inclusion hEF,
  map_one' := rfl,
  map_add' := λ _ _, rfl,
  map_mul' := λ _ _, rfl,
  map_zero' := rfl,
  commutes' := λ _, rfl }

lemma inclusion_eq_identity {K L : Type*} [field K] [field L] [algebra K L]
  {E F : intermediate_field K L} (hEF : E ≤ F) (x : E) :
  F.val ((intermediate_field.inclusion hEF) x) = E.val x :=
  begin
    refl,
  end

lemma inclusion_commutes_with_val {K L : Type*} [field K] [field L] [algebra K L]
  {E F : intermediate_field K L} (hEF : E ≤ F) :
  F.val ∘ (intermediate_field.inclusion hEF) = E.val :=
begin
  refl,
end

lemma val_inj {K L : Type*} [field K] [field L] [algebra K L]
  {E : intermediate_field K L} :
  function.injective E.val :=
begin
  intros x y hxy,
  exact subtype.ext hxy,
end

lemma inclusion_commutes_with_mk {K L : Type*} [field K] [field L] [algebra K L] {E F : intermediate_field K L}
(hEF : E ≤ F) {x : L} (hx : x ∈ E) :
(intermediate_field.inclusion hEF) ⟨x, hx⟩ = ⟨x, hEF hx⟩ :=
begin
  apply val_inj,
  rw inclusion_eq_identity,
  simp,
end

lemma ultrafilter.map_map {X Y Z: Type*} (m : X → Y) (n : Y → Z) (f : ultrafilter X) :
(f.map m).map n = f.map(n ∘ m) :=
begin
  ext,
  split,
  {
    intro hs,
    rw [ultrafilter.mem_map, set.preimage_comp, ← ultrafilter.mem_map, ← ultrafilter.mem_map],
    exact hs,
  },
  {
    intro hs,
    rw [ultrafilter.mem_map, ultrafilter.mem_map, ← set.preimage_comp, ← ultrafilter.mem_map],
    exact hs,
  },
end

lemma ultrafilter.map_pure {X Y : Type*} (x : X) (m : X → Y):
(pure x : ultrafilter X).map m = pure (m x)  :=
begin
  refl,
end

lemma alg_hom_of_finite_dimensional_of_ultrafilter_functor {K L : Type*} [field K] [field L] [algebra K L]
  {E : intermediate_field K L} (hE : finite_dimensional K E)
  (f : ultrafilter (L ≃ₐ[K] L)) {F : intermediate_field K L} (hF : finite_dimensional K F) (hEF : E ≤ F)
  :
  alg_hom_of_finite_dimensional_of_ultrafilter hE f =
  (alg_hom_of_finite_dimensional_of_ultrafilter hF f).comp (intermediate_field.inclusion hEF) :=
  begin
    set p_E :=  (λ σ : L ≃ₐ[K] L, σ.to_alg_hom.comp (intermediate_field.val E)) with p_E_def,
    set p_F :=  (λ σ : L ≃ₐ[K] L, σ.to_alg_hom.comp (intermediate_field.val F)) with p_F_def,
    set σ_E := alg_hom_of_finite_dimensional_of_ultrafilter hE f with σ_E_def,
    set σ_F := alg_hom_of_finite_dimensional_of_ultrafilter hF f with σ_F_def,
    have hσ_E := alg_hom_of_finite_dimensional_of_ultrafilter_spec hE f,
    rw [← p_E_def, ← σ_E_def] at hσ_E,
    have hσ_F := alg_hom_of_finite_dimensional_of_ultrafilter_spec hF f,
    rw [← p_F_def, ← σ_F_def] at hσ_F,
    set res : (F →ₐ[K] L) → (E →ₐ[K] L) := (λ ϕ, ϕ.comp (intermediate_field.inclusion hEF))
    with res_def,
    have h_pF_pE_res : res ∘ p_F = p_E := rfl,
    have h_maps_commute : ((f.map p_F).map res : filter (E →ₐ[K] L)) = f.map p_E,
    {
      rw [ultrafilter.map_map, h_pF_pE_res],
    },
    have hEf  := alg_hom_of_finite_dimensional_of_ultrafilter_spec hE f,
    rw [← σ_E_def, ← p_E_def] at hEf,
    have hFf := alg_hom_of_finite_dimensional_of_ultrafilter_spec hF f,
    rw [← σ_F_def, ← p_F_def] at hFf,
    have hFf' : (ultrafilter.map p_F f) = (pure σ_F : ultrafilter (F →ₐ[K] L)),
    {
      exact ultrafilter.coe_inj.mp hFf,
    },
    rw [hEf, hFf', ultrafilter.map_pure] at h_maps_commute,
    have h := filter.pure_injective h_maps_commute,
    rw res_def at h,
    dsimp at h,
    exact h.symm,
  end

noncomputable def function_of_ultrafilter {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (f : ultrafilter (L ≃ₐ[K] L)) :
(L → L) :=
λ x, (alg_hom_of_finite_dimensional_of_ultrafilter
(intermediate_field.adjoin.finite_dimensional (h_int x)) f)
(⟨x, intermediate_field.mem_adjoin_simple_self K x⟩)

lemma function_of_ultrafilter_spec {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (f : ultrafilter (L ≃ₐ[K] L)) {E : intermediate_field K L}
(hE : finite_dimensional K E) (x : E) :
(function_of_ultrafilter h_int f) x = (alg_hom_of_finite_dimensional_of_ultrafilter hE f) x :=
begin
   have h_le : intermediate_field.adjoin K {(x : L)} ≤ E,
   {
     apply intermediate_field.gc.l_le,
     simp only [set_like.coe_mem, set_like.mem_coe, set.singleton_subset_iff, set.le_eq_subset],
   },
   have h_Kx : finite_dimensional K (intermediate_field.adjoin K {(x : L)}) :=
   intermediate_field.adjoin.finite_dimensional (h_int x),
   let h_functor := alg_hom_of_finite_dimensional_of_ultrafilter_functor h_Kx f hE h_le,
   have h : (function_of_ultrafilter h_int f) x =
   (alg_hom_of_finite_dimensional_of_ultrafilter h_Kx f) ⟨x,
   intermediate_field.mem_adjoin_simple_self K x⟩ := rfl,
   rw [h, h_functor],
   let x_in_Kx : intermediate_field.adjoin K {(x : L)} := ⟨(x : L),
   intermediate_field.mem_adjoin_simple_self K (x : L)⟩,
   have h' : (intermediate_field.inclusion h_le) x_in_Kx = x := by
     simp [inclusion_commutes_with_mk h_le (intermediate_field.mem_adjoin_simple_self K (x : L))],
   simp [h'],
end

lemma adj_finset_finite_dimensional {K L : Type*} [field K] [field L] [algebra K L]
(S : finset L)
(h_int : ∀ (x : L), x ∈ S → is_integral K x) :
finite_dimensional K (intermediate_field.adjoin K (coe S : set L)) :=
begin
  refine intermediate_field.induction_on_adjoin_finset (S) (λ (E : intermediate_field K L),
  finite_dimensional K E) _ _,
  {
    have temp : (⊥ : intermediate_field K L) = (⊥ : intermediate_field K L) := rfl,
    rw ← intermediate_field.finrank_eq_one_iff at temp,
    refine finite_dimensional.finite_dimensional_of_finrank _,
    rw temp,
    exact zero_lt_one,
  },
  {
    intros E x hx,
    specialize h_int x hx,
    introI h,
    haveI h2 : finite_dimensional ↥E (↥E)⟮x⟯,
    {
      apply intermediate_field.adjoin.finite_dimensional,
      exact is_integral_of_is_scalar_tower x h_int,
    },
    change finite_dimensional K ↥(↥E)⟮x⟯,
    exact finite_dimensional.trans K ↥E ↥(↥E)⟮x⟯,
  },
end

noncomputable def alg_hom_of_ultrafilter {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (f : ultrafilter (L ≃ₐ[K] L)) :
(L →ₐ[K] L) :=
{ to_fun := function_of_ultrafilter h_int f,
  map_one' :=
  begin
    have h_findim_bot : finite_dimensional K (⊥ : intermediate_field K L) :=
    intermediate_field.finite_dimensional_bot K L,
    have h_one_bot : (1 : L) ∈ (⊥: intermediate_field K L) := (⊥ : intermediate_field K L).one_mem,
    have h := function_of_ultrafilter_spec h_int f h_findim_bot (1 : (⊥ : intermediate_field K L)),
    simp at h,
    exact h,
  end,
  map_mul' :=
  begin
    intros x y,
    let E := intermediate_field.adjoin K ({x, y} : set L),
    have h_sub : {x, y} ⊆ E.carrier := intermediate_field.gc.le_u_l {x, y},
    have hxE : x ∈ E := h_sub (mem_insert x {y}),
    have hyE : y ∈ E,
    {
      apply h_sub,
      simp only [set.mem_insert_iff, set.mem_singleton, or_true],
    },
    have hxyE : x * y ∈ E := E.mul_mem' hxE hyE,
    let S := ({x, y} : finset L),
    have h_S_int : ∀ (x : L), x ∈ S → is_integral K x :=
    λ a ha, h_int a,
    have hE := adj_finset_finite_dimensional S h_S_int,
    have h_S_coes : (S : set L) = {x, y},
    {
      simp only [finset.coe_insert, finset.coe_singleton, eq_self_iff_true],
    },
    rw h_S_coes at hE,
    change finite_dimensional K E at hE,
    have h : function_of_ultrafilter h_int f x = function_of_ultrafilter h_int f (⟨x, hxE⟩ : E) := rfl,
    change function_of_ultrafilter h_int f (⟨x * y, hxyE⟩ : E) =
    function_of_ultrafilter h_int f (⟨x, hxE⟩ : E) *
    function_of_ultrafilter h_int f (⟨y, hyE⟩ : E),
    rw [function_of_ultrafilter_spec h_int f hE ⟨x, hxE⟩,
    function_of_ultrafilter_spec h_int f hE ⟨y, hyE⟩,
    function_of_ultrafilter_spec h_int f hE ⟨x * y, hxyE⟩],
    have h2 : (alg_hom_of_finite_dimensional_of_ultrafilter hE f) ⟨x, hxE⟩ *
  (alg_hom_of_finite_dimensional_of_ultrafilter hE f) ⟨y, hyE⟩ =
  (alg_hom_of_finite_dimensional_of_ultrafilter hE f) (⟨x, hxE⟩ * ⟨y, hyE⟩),
    {
      simp only [mul_eq_mul_left_iff, true_or, eq_self_iff_true, map_mul],
    },
    rw h2,
    refl,
  end,
  map_zero' :=
  begin
    have h_findim_bot : finite_dimensional K (⊥ : intermediate_field K L) :=
    intermediate_field.finite_dimensional_bot K L,
    have h_zero_bot : (0 : L) ∈ (⊥: intermediate_field K L) := (⊥ : intermediate_field K L).zero_mem,
    have h := function_of_ultrafilter_spec h_int f h_findim_bot (0 : (⊥ : intermediate_field K L)),
    simp at h,
    exact h,
  end,
  map_add' :=
  begin
    intros x y,
    let E := intermediate_field.adjoin K ({x, y} : set L),
    have h_sub : {x, y} ⊆ E.carrier := intermediate_field.gc.le_u_l {x, y},
    have hxE : x ∈ E := h_sub (mem_insert x {y}),
    have hyE : y ∈ E,
    {
      apply h_sub,
      simp only [set.mem_insert_iff, set.mem_singleton, or_true],
    },
    have hxyE : x + y ∈ E := E.add_mem' hxE hyE,
    let S := ({x, y} : finset L),
    have h_S_int : ∀ (x : L), x ∈ S → is_integral K x :=
    λ a ha, h_int a,
    have hE := adj_finset_finite_dimensional S h_S_int,
    have h_S_coes : (S : set L) = {x, y},
    {
      simp only [finset.coe_insert, finset.coe_singleton, eq_self_iff_true],
    },
    rw h_S_coes at hE,
    change finite_dimensional K E at hE,
    have h : function_of_ultrafilter h_int f x = function_of_ultrafilter h_int f (⟨x, hxE⟩ : E) := rfl,
    change function_of_ultrafilter h_int f (⟨x + y, hxyE⟩ : E) =
    function_of_ultrafilter h_int f (⟨x, hxE⟩ : E) +
    function_of_ultrafilter h_int f (⟨y, hyE⟩ : E),
    rw [function_of_ultrafilter_spec h_int f hE ⟨x, hxE⟩,
    function_of_ultrafilter_spec h_int f hE ⟨y, hyE⟩,
    function_of_ultrafilter_spec h_int f hE ⟨x + y, hxyE⟩],
    have h2 : (alg_hom_of_finite_dimensional_of_ultrafilter hE f) ⟨x, hxE⟩ +
  (alg_hom_of_finite_dimensional_of_ultrafilter hE f) ⟨y, hyE⟩ =
  (alg_hom_of_finite_dimensional_of_ultrafilter hE f) (⟨x, hxE⟩ + ⟨y, hyE⟩),
    {
      simp,
    },
    rw h2,
    refl,
  end,
  commutes' :=
  begin
    intro r,
    let r' := (algebra_map K L) r,
    have h_findim_bot : finite_dimensional K (⊥ : intermediate_field K L) :=
    intermediate_field.finite_dimensional_bot K L,
    have h : r' ∈ (⊥ : intermediate_field K L) := (⊥ : intermediate_field K L).algebra_map_mem r,
    change function_of_ultrafilter h_int f (⟨r', h⟩ : (⊥ : intermediate_field K L)) =
    (⟨r', h⟩ : (⊥ : intermediate_field K L)),
    rw function_of_ultrafilter_spec h_int f h_findim_bot (⟨r', h⟩ : (⊥ : intermediate_field K L)),
    have h2 : (⟨r', h⟩ : (⊥ : intermediate_field K L)) = (algebra_map K (⊥ : intermediate_field K L)
    r) := rfl,
    rw h2,
    simp,
    refl,
  end,
  }

lemma alg_hom_of_ultrafilter_injective {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (f : ultrafilter (L ≃ₐ[K] L)) :
function.injective (alg_hom_of_ultrafilter h_int f) :=
begin
  intros x y hxy,
  let E := intermediate_field.adjoin K ({x, y} : set L),
  let S := ({x, y} : finset L),
  have h_S_int : ∀ (x : L), x ∈ S → is_integral K x :=
  λ a ha, h_int a,
  have hE := adj_finset_finite_dimensional S h_S_int,
  have h_S_coes : (S : set L) = {x, y},
  {
    simp only [finset.coe_insert, finset.coe_singleton, eq_self_iff_true],
  },
  rw h_S_coes at hE,
  change finite_dimensional K E at hE,
  have h_sub : {x, y} ⊆ E.carrier := intermediate_field.gc.le_u_l {x, y},
  have hxE : x ∈ E := h_sub (mem_insert x {y}),
  have hyE : y ∈ E,
  {
    apply h_sub,
    simp only [set.mem_insert_iff, set.mem_singleton, or_true],
  },
  change (alg_hom_of_ultrafilter h_int f) (⟨x, hxE⟩ : E) =
  (alg_hom_of_ultrafilter h_int f) (⟨y, hyE⟩ : E) at hxy,
  change (function_of_ultrafilter h_int f) (⟨x, hxE⟩ : E) =
  (function_of_ultrafilter h_int f) (⟨y, hyE⟩ : E) at hxy,
  rw [function_of_ultrafilter_spec h_int f hE (⟨x, hxE⟩ : E),
  function_of_ultrafilter_spec h_int f hE (⟨y, hyE⟩ : E)] at hxy,
  have h : (⟨x, hxE⟩ : E) = (⟨y, hyE⟩ : E),
  {
    exact ring_hom.injective (alg_hom_of_finite_dimensional_of_ultrafilter hE f).to_ring_hom hxy,
  },
  simp at h,
  exact h,
end

lemma eq_of_map_le {K L : Type*} [field K] [field L] [algebra K L] {E : intermediate_field K L}
{f : L →ₐ[K] L} (h_findim : finite_dimensional K E) (h_map_le : E.map f ≤ E) :
E.map f = E :=
begin
  have hf_inj : function.injective f := ring_hom.injective f.to_ring_hom,
  haveI hE_submod_fin : finite_dimensional K E.to_subalgebra.to_submodule,
  {
    exact h_findim,
  },
  have h_finrank_eq : finite_dimensional.finrank K (E.map f) =
  finite_dimensional.finrank K E,
  {
    exact (linear_equiv.finrank_eq (submodule.equiv_map_of_injective (f.to_linear_map)
    hf_inj E.to_subalgebra.to_submodule)).symm,
  },
  have h_submod_le : (E.map f).to_subalgebra.to_submodule ≤ E.to_subalgebra.to_submodule := h_map_le,
  exact intermediate_field.to_subalgebra_eq_iff.mp (subalgebra.to_submodule_injective
  (finite_dimensional.eq_of_le_of_finrank_eq h_map_le h_finrank_eq)),
end

lemma alg_hom_of_ultrafilter_surjective {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x)) (f : ultrafilter (L ≃ₐ[K] L)) :
function.surjective (alg_hom_of_ultrafilter h_int f) :=
begin
  intro y,
  specialize h_splits y,
  let p := minpoly K y,
  let S := (p.map (algebra_map K L)).roots.to_finset,
  let E := intermediate_field.adjoin K (S : set L),
  have hE_findim : finite_dimensional K E := adj_finset_finite_dimensional S (λ x hx, h_int x),
  let σ := alg_hom_of_ultrafilter h_int f,
  have hσSS : σ '' S ⊆ S,
  {
    rintros x ⟨a, ha, hax⟩,
    rw ← hax,
    simp,
    rw polynomial.mem_roots,
    {
      rw [polynomial.is_root.def, ← polynomial.eval₂_eq_eval_map, ← polynomial.alg_hom_eval₂_algebra_map],
      have hσ0 : σ 0 = 0 := by simp,
      rw ← hσ0,
      apply congr_arg σ,
      simp at ha,
      rw polynomial.mem_roots at ha,
      {
        rw [polynomial.is_root.def, ← polynomial.eval₂_eq_eval_map] at ha,
        exact ha,
      },
      {
        exact polynomial.map_monic_ne_zero (minpoly.monic (h_int y)),
      },
    },
    exact polynomial.map_monic_ne_zero (minpoly.monic (h_int y)),
  },
  have hSE : (S : set L) ⊆ E := intermediate_field.gc.le_u_l (S : set L),
  have hσSE : σ '' S ⊆ E := set.subset.trans hσSS hSE,
  have h1 : E.map σ = intermediate_field.adjoin K (σ '' S) := intermediate_field.adjoin_map K S σ,
  have h2 : intermediate_field.adjoin K (σ '' S) ≤ E,
  {
    apply intermediate_field.gc.l_le,
    exact hσSE,
  },
  change ∃ (a : L), σ a = y,
  rw ← h1 at h2,
  have h3 := eq_of_map_le hE_findim h2,
  have hyE : y ∈ E,
  {
    have hyS : y ∈ S,
    {
      simp,
      rw polynomial.mem_roots,
      {
        rw [polynomial.is_root.def,
         ← polynomial.eval₂_eq_eval_map,
         ← polynomial.aeval_def],
        exact minpoly.aeval K y,
      },
      {
        exact polynomial.map_monic_ne_zero (minpoly.monic (h_int y)),
      },
    },
    exact hSE hyS,
  },
  rw ← h3 at hyE,
  rcases hyE with ⟨a, ha, hay⟩,
  exact ⟨a, hay⟩,
end

lemma alg_hom_of_ultrafilter_bijection {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x)) (f : ultrafilter (L ≃ₐ[K] L)) :
function.bijective (alg_hom_of_ultrafilter h_int f) :=
begin
  exact ⟨alg_hom_of_ultrafilter_injective h_int f,
  alg_hom_of_ultrafilter_surjective h_int h_splits f⟩,
end

noncomputable def equiv_of_ultrafilter {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x)) (f : ultrafilter (L ≃ₐ[K] L)) :
(L ≃ₐ[K] L) :=
alg_equiv.of_bijective (alg_hom_of_ultrafilter h_int f) (alg_hom_of_ultrafilter_bijection h_int h_splits f)

lemma equiv_of_ultrafilter_to_fun {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x)) (f : ultrafilter (L ≃ₐ[K] L)) :
(equiv_of_ultrafilter h_int h_splits f).to_fun = function_of_ultrafilter h_int f :=
rfl

lemma equiv_of_ultrafilter_to_alg_hom {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x)) (f : ultrafilter (L ≃ₐ[K] L)) :
(equiv_of_ultrafilter h_int h_splits f).to_alg_hom = alg_hom_of_ultrafilter h_int f :=
rfl

lemma asdf {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x)) (f : ultrafilter (L ≃ₐ[K] L)) {E : intermediate_field K L}
(h_findim : finite_dimensional K E) :
((equiv_of_ultrafilter h_int h_splits f).to_alg_hom.comp E.val) =
alg_hom_of_finite_dimensional_of_ultrafilter h_findim f :=
begin
  ext,
  exact function_of_ultrafilter_spec h_int f h_findim x,
end

def res {K L : Type*} [field K] [field L] [algebra K L] (E : intermediate_field K L):
(L ≃ₐ[K] L) → (E →ₐ[K] L) :=
λ f, f.to_alg_hom.comp E.val

lemma res_eq_map {K L : Type*} [field K] [field L] [algebra K L] {E : intermediate_field K L}
(σ : L ≃ₐ[K] L) (x : E) :
σ x = (res E σ) x :=
begin
  unfold res,
  simp,
end

-- I know this is a terrible name
lemma inv_mul_alg_equiv_of_elem {K L : Type*} [field K] [field L] [algebra K L]
(x : L) (f g : L ≃ₐ[K] L)  :
(f⁻¹ * g) x = x ↔ g x = f x :=
begin
   rw alg_equiv.mul_apply,
   split,
   {
    intro h,
    have h' := congr_arg f h,
    rw [← alg_equiv.mul_apply, mul_right_inv] at h',
    exact h',
   },
   {
    intro h,
    have h' := congr_arg f.symm h,
    rw alg_equiv.symm_apply_apply at h',
    exact h',
   },
end

lemma top_group_map_nhds_eq {G : Type*} [group G] [topological_space G]
[topological_group G] (g x : G) :
filter.map (λ y, g * y) (nhds x) = nhds (g * x) :=
begin
  ext,
  split,
  {
    intro h,
    rw [filter.mem_map, mem_nhds_iff] at h,
    rcases h with ⟨U, h_subset, h_open, hxU⟩,
    rw mem_nhds_iff,
    use left_coset g U,
    split,
    {
      rw ← set.image_subset_iff at h_subset,
      exact h_subset,
    },
    refine ⟨_, ⟨x, ⟨hxU, rfl⟩⟩⟩,
    apply is_open_map_mul_left g,
    exact h_open,
  },
  {
    intro h,
    rw mem_nhds_iff at h,
    rcases h with ⟨U, h_subset, h_open, hgxU⟩,
    rw [filter.mem_map, mem_nhds_iff],
    use left_coset g⁻¹ U,
    split,
    {
      rw ← set.image_subset_iff,
      have h : (λ (y : G), g * y) '' left_coset g⁻¹ U = U,
      {
        ext a,
        refine ⟨_, λ ha, ⟨g⁻¹ * a, ⟨a, ha, rfl⟩, by simp⟩⟩,
        rintro ⟨b, ⟨c, hcU, hcb⟩, hba⟩,
        change g⁻¹ * c = b at hcb,
        change g * b = a at hba,
        rw [← hcb, ← mul_assoc, mul_right_inv, one_mul] at hba,
        rw ← hba,
        exact hcU,
      },
      rw h,
      exact h_subset,
    },
    refine ⟨_, ⟨g * x, hgxU, by simp⟩⟩,
    apply is_open_map_mul_left g⁻¹,
    exact h_open,

  },
end

lemma sigma_is_limit {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x))
(f : ultrafilter (L ≃ₐ[K] L))
(h_le_princ : ↑f ≤ filter.principal
 (set.univ : set (L ≃ₐ[K] L))) :
(f : filter (L ≃ₐ[K] L)) ≤ nhds (equiv_of_ultrafilter h_int h_splits f) :=
begin
  let σ := equiv_of_ultrafilter h_int h_splits f,
  intros A hA,
  have hA_coset : left_coset σ⁻¹ A ∈ nhds (1 : L ≃ₐ[K] L),
  {
    have h_sigma_1 : σ = σ * 1 := by simp,
    change A ∈ nhds σ at hA,
    rw [h_sigma_1, ← top_group_map_nhds_eq σ 1, filter.mem_map] at hA,
    have h : left_coset σ⁻¹ A = (λ y, σ * y)⁻¹' A,
    {
      ext,
      split,
      {
        rintro ⟨a, ha, hax⟩,
        simp [hax.symm, ha],
      },
      {
        intro hx,
        rw set.mem_preimage at hx,
        rw [mem_left_coset_iff, inv_inv],
        exact hx,
      },
    },
    rw h,
    exact hA,
  },
  have hA_coset_cont_H : ∃ (E : intermediate_field K L), finite_dimensional K E
  ∧ E.fixing_subgroup.carrier ⊆ left_coset σ⁻¹ A,
  {
    rw [group_filter_basis.nhds_one_eq, filter_basis.mem_filter_iff] at hA_coset,
    rcases hA_coset with ⟨H_set, hH, hA_coset⟩,
    change H_set ∈ gal_basis K L at hH,
    rw mem_gal_basis_iff at hH,
    rcases hH with ⟨H, ⟨E, hE, hHE⟩, hHH_set⟩,
    refine ⟨E, hE, _⟩,
    rw [hHE, hHH_set],
    exact hA_coset,
  },
  rcases hA_coset_cont_H with ⟨E, h_findim, hEA⟩,
  have hEA' : left_coset σ E.fixing_subgroup ⊆ A,
  {
    rintros x ⟨y, hy, hyx⟩,
    change σ * y = x at hyx,
    specialize hEA hy,
    rcases hEA with ⟨a, ha, hay⟩,
    change σ⁻¹ * a = y at hay,
    rw inv_mul_eq_iff_eq_mul at hay,
    rw [← hyx, ← hay],
    exact ha,
  },
  let p : (L ≃ₐ[K] L) → (E →ₐ[K] L) := λ σ, (σ.to_alg_hom.comp E.val),
  have h_principal : f.map p = pure (p σ),
  {
    have h : p σ = alg_hom_of_finite_dimensional_of_ultrafilter h_findim f :=
    asdf h_int h_splits f h_findim,
    rw h,
    have h2 : ↑(ultrafilter.map p f) = pure (alg_hom_of_finite_dimensional_of_ultrafilter h_findim f) :=
    alg_hom_of_finite_dimensional_of_ultrafilter_spec h_findim f,
    ext,
    split,
    {
      intro hs,
      rw [← ultrafilter.mem_coe, h2] at hs,
      exact hs,
    },
    {
      intro hs,
      rw ultrafilter.mem_pure at hs,
      have h3 : s ∈ (pure (alg_hom_of_finite_dimensional_of_ultrafilter h_findim f) : filter (↥E →ₐ[K] L)),
      {
        rw filter.mem_pure,
        exact hs,
      },

      rw ← h2 at h3,
      rw ultrafilter.mem_coe at h3,
      exact h3,
    },
  },

  have h_small_set : left_coset σ E.fixing_subgroup ∈ f,
  {
    have h : {p σ} ∈ (pure (p σ) : ultrafilter (E →ₐ[K] L)) := set.mem_singleton (p σ),
    rw [← h_principal, ultrafilter.mem_map] at h,
    have h_preim : p⁻¹' {p σ} = left_coset σ E.fixing_subgroup,
    {
      ext g,
      split,
      {
        intro hg,
        rw [set.mem_preimage, set.mem_singleton_iff] at hg,
        rw mem_left_coset_iff,
        intro x,
        have h_g_on_x : g x = (p g) x := res_eq_map g x,
        have h_σ_on_x : σ x = (p σ) x := res_eq_map σ x,
        change (σ⁻¹ * g) x = x,
        rw [inv_mul_alg_equiv_of_elem, h_g_on_x, h_σ_on_x, hg],
      },
      {
        intro hg,
        rw [set.mem_preimage, set.mem_singleton_iff],
        ext,
        have h_g_on_x : g x = (p g) x := res_eq_map g x,
        have h_σ_on_x : σ x = (p σ) x := res_eq_map σ x,
        rw [← h_g_on_x, ← h_σ_on_x, ← inv_mul_alg_equiv_of_elem],
        exact (mem_left_coset_iff σ).1 hg x,
      },
    },
    rw h_preim at h,
    exact h,
  },
  exact f.to_filter.sets_of_superset h_small_set hEA',
end

lemma krull_topology_compact {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x))  :
is_compact (set.univ : set (L ≃ₐ[K] L)) := is_compact_iff_ultrafilter_le_nhds.2
  (λ f hf,  ⟨equiv_of_ultrafilter h_int h_splits f,
  set.mem_univ (equiv_of_ultrafilter h_int h_splits f),
  sigma_is_limit h_int h_splits f hf⟩)

def krull_topology_comphaus {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x)):
CompHaus :=
{ to_Top := Top.of (L ≃ₐ[K] L),
  is_compact := {
    compact_univ := krull_topology_compact h_int h_splits},
  is_hausdorff := krull_topology_t2 K L h_int,
}

def krull_topology_totally_disconnected {K L : Type*} [field K] [field L] [algebra K L]
(h_int : ∀ (x : L), is_integral K x) :
totally_disconnected_space (L ≃ₐ[K] L) :=
{ is_totally_disconnected_univ := krull_totally_disconnected h_int}

def krull_topology_profinite {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x)) :
Profinite :=
{ to_CompHaus := krull_topology_comphaus h_int h_splits,
  is_totally_disconnected := krull_topology_totally_disconnected h_int}


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

import category_theory.limits.shapes.products
import category_theory.epi_mono

/-!

# Adjunctions involving evaluation

We show that evaluation of functors have adjoints, given the existence of (co)products.

-/

namespace category_theory

open category_theory.limits

universes v₁ v₂ u₁ u₂
variables {C : Type u₁} [category.{v₁} C] (D : Type u₂) [category.{v₂} D]

noncomputable theory

section

variables [∀ (a b : C), has_coproducts_of_shape (a ⟶ b) D]

/-- The left adjoint of evaluation. -/
@[simps]
def evaluation_left_adjoint (c : C) : D ⥤ C ⥤ D :=
{ obj := λ d,
  { obj := λ t, ∐ (λ i : c ⟶ t, d),
    map := λ u v f, sigma.desc $ λ g, sigma.ι (λ _, d) $ g ≫ f,
    map_id' := begin
      intros, ext ⟨j⟩, simp only [cofan.mk_ι_app, colimit.ι_desc, category.comp_id],
      congr' 1, rw category.comp_id,
    end,
    map_comp' := begin
      intros, ext, simp only [cofan.mk_ι_app, colimit.ι_desc_assoc, colimit.ι_desc],
      congr' 1, rw category.assoc,
    end },
  map := λ d₁ d₂ f,
  { app := λ e, sigma.desc $ λ h, f ≫ sigma.ι (λ _, d₂) h,
    naturality' := by { intros, ext, dsimp, simp } },
  map_id' := by { intros, ext x ⟨j⟩, dsimp, simp },
  map_comp' := by { intros, ext, dsimp, simp } }

/-- The adjunction showing that evaluation is a right adjoint. -/
@[simps unit_app counit_app_app]
def evaluation_adjunction_right (c : C) :
  evaluation_left_adjoint D c ⊣ (evaluation _ _).obj c :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ d F,
  { to_fun := λ f, sigma.ι (λ _, d) (𝟙 _) ≫ f.app c,
    inv_fun := λ f,
    { app := λ e, sigma.desc $ λ h, f ≫ F.map h,
      naturality' := by { intros, ext, dsimp, simp } },
    left_inv := begin
      intros f,
      ext x ⟨g⟩,
      dsimp,
      simp only [colimit.ι_desc, limits.cofan.mk_ι_app, category.assoc, ← f.naturality,
        evaluation_left_adjoint_obj_map, colimit.ι_desc_assoc, cofan.mk_ι_app],
      congr' 2,
      rw category.id_comp
    end,
    right_inv := λ f, by { dsimp, simp } },
  hom_equiv_naturality_left_symm' := by { intros, ext, dsimp, simp },
  hom_equiv_naturality_right' := by { intros, dsimp, simp } }

instance evaluation_is_right_adjoint (c : C) :
  is_right_adjoint ((evaluation _ D).obj c) :=
⟨_, evaluation_adjunction_right _ _⟩

lemma nat_trans.mono_iff_app_mono {F G : C ⥤ D} (η : F ⟶ G) :
  mono η ↔ (∀ c, mono (η.app c)) :=
begin
  split,
  { intros h c,
    exact right_adjoint_preserves_mono (evaluation_adjunction_right D c) h },
  { introsI _,
    apply nat_trans.mono_app_of_mono }
end

end

section

variables [∀ (a b : C), has_products_of_shape (a ⟶ b) D]

/-- The right adjoint of evaluation. -/
@[simps]
def evaluation_right_adjoint (c : C) : D ⥤ C ⥤ D :=
{ obj := λ d,
  { obj := λ t, ∏ (λ i : t ⟶ c, d),
    map := λ u v f, pi.lift $ λ g, pi.π _ $ f ≫ g,
    map_id' := begin
      intros, ext ⟨j⟩, dsimp,
      simp only [limit.lift_π, category.id_comp, fan.mk_π_app],
      congr, simp,
    end,
    map_comp' := begin
      intros, ext ⟨j⟩, dsimp,
      simp only [limit.lift_π, fan.mk_π_app, category.assoc],
      congr' 1, simp,
    end },
  map := λ d₁ d₂ f,
  { app := λ t, pi.lift $ λ g, pi.π _ g ≫ f,
    naturality' := by { intros, ext, dsimp, simp } },
  map_id' := by { intros, ext x ⟨j⟩, dsimp, simp },
  map_comp' := by { intros, ext, dsimp, simp } }

/-- The adjunction showing that evaluation is a left adjoint. -/
@[simps unit_app_app counit_app]
def evaluation_adjunction_left (c : C) :
  (evaluation _ _).obj c ⊣ evaluation_right_adjoint D c :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ F d,
  { to_fun := λ f,
    { app := λ t, pi.lift $ λ g, F.map g ≫ f,
      naturality' := by { intros, ext, dsimp, simp } },
    inv_fun := λ f, f.app _ ≫ pi.π _ (𝟙 _),
    left_inv := λ f, by { dsimp, simp },
    right_inv := begin
      intros f,
      ext x ⟨g⟩,
      dsimp,
      simp only [limit.lift_π, evaluation_right_adjoint_obj_map,
        nat_trans.naturality_assoc, fan.mk_π_app],
      congr,
      rw category.comp_id
    end },
  hom_equiv_naturality_left_symm' := by { intros, dsimp, simp },
  hom_equiv_naturality_right' := by { intros, ext, dsimp, simp } }

instance evaluation_is_left_adjoint (c : C) :
  is_left_adjoint ((evaluation _ D).obj c) :=
⟨_, evaluation_adjunction_left _ _⟩

lemma nat_trans.epi_iff_app_epi {F G : C ⥤ D} (η : F ⟶ G) :
  epi η ↔ (∀ c, epi (η.app c)) :=
begin
  split,
  { intros h c,
    exact left_adjoint_preserves_epi (evaluation_adjunction_left D c) h },
  { introsI,
    apply nat_trans.epi_app_of_epi }
end

end

end category_theory


structure Foo where
  (p : Nat → Prop)
  (q : String → Prop)
  [inst0 : DecidablePred p]
  [inst1 : DecidablePred q]

example : Foo := {
  p := fun n => n < 9
  q := fun s => s.length < 9
}

structure Bar where
  (p : Prop)
  (q : Prop)
  [inst0 : Decidable p]
  [inst1 : Decidable q]

example : Bar := {
  p := True
  q := False
}

structure Boo where
  x : Nat
  y : Nat  := x + 1
  p : Prop := x < y
  [i : Decidable p]

example : Boo := {
  x := 0
}


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

! This file was ported from Lean 3 source module topology.tietze_extension
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.SpecificLimits.Basic
import Mathbin.Data.Set.Intervals.IsoIoo
import Mathbin.Topology.Algebra.Order.MonotoneContinuity
import Mathbin.Topology.UrysohnsBounded

/-!
# Tietze extension theorem

In this file we prove a few version of the Tietze extension theorem. The theorem says that a
continuous function `s → ℝ` defined on a closed set in a normal topological space `Y` can be
extended to a continuous function on the whole space. Moreover, if all values of the original
function belong to some (finite or infinite, open or closed) interval, then the extension can be
chosen so that it takes values in the same interval. In particular, if the original function is a
bounded function, then there exists a bounded extension of the same norm.

The proof mostly follows <https://ncatlab.org/nlab/show/Tietze+extension+theorem>. We patch a small
gap in the proof for unbounded functions, see
`exists_extension_forall_exists_le_ge_of_closed_embedding`.

## Implementation notes

We first prove the theorems for a closed embedding `e : X → Y` of a topological space into a normal
topological space, then specialize them to the case `X = s : set Y`, `e = coe`.

## Tags

Tietze extension theorem, Urysohn's lemma, normal topological space
-/

variable {X Y : Type _} [TopologicalSpace X] [TopologicalSpace Y] [NormalSpace Y]

open Metric Set Filter

open BoundedContinuousFunction Topology

noncomputable section

namespace BoundedContinuousFunction

/-- One step in the proof of the Tietze extension theorem. If `e : C(X, Y)` is a closed embedding
of a topological space into a normal topological space and `f : X →ᵇ ℝ` is a bounded continuous
function, then there exists a bounded continuous function `g : Y →ᵇ ℝ` of the norm `‖g‖ ≤ ‖f‖ / 3`
such that the distance between `g ∘ e` and `f` is at most `(2 / 3) * ‖f‖`. -/
theorem tietze_extension_step (f : X →ᵇ ℝ) (e : C(X, Y)) (he : ClosedEmbedding e) :
    ∃ g : Y →ᵇ ℝ, ‖g‖ ≤ ‖f‖ / 3 ∧ dist (g.comp_continuous e) f ≤ 2 / 3 * ‖f‖ :=
  by
  have h3 : (0 : ℝ) < 3 := by norm_num1
  have h23 : 0 < (2 / 3 : ℝ) := by norm_num1
  -- In the trivial case `f = 0`, we take `g = 0`
  rcases eq_or_ne f 0 with (rfl | hf)
  · use 0
    simp
  replace hf : 0 < ‖f‖ := norm_pos_iff.2 hf
  /- Otherwise, the closed sets `e '' (f ⁻¹' (Iic (-‖f‖ / 3)))` and `e '' (f ⁻¹' (Ici (‖f‖ / 3)))`
    are disjoint, hence by Urysohn's lemma there exists a function `g` that is equal to `-‖f‖ / 3`
    on the former set and is equal to `‖f‖ / 3` on the latter set. This function `g` satisfies the
    assertions of the lemma. -/
  have hf3 : -‖f‖ / 3 < ‖f‖ / 3 := (div_lt_div_right h3).2 (Left.neg_lt_self hf)
  have hc₁ : IsClosed (e '' (f ⁻¹' Iic (-‖f‖ / 3))) :=
    he.is_closed_map _ (is_closed_Iic.preimage f.continuous)
  have hc₂ : IsClosed (e '' (f ⁻¹' Ici (‖f‖ / 3))) :=
    he.is_closed_map _ (is_closed_Ici.preimage f.continuous)
  have hd : Disjoint (e '' (f ⁻¹' Iic (-‖f‖ / 3))) (e '' (f ⁻¹' Ici (‖f‖ / 3))) :=
    by
    refine' disjoint_image_of_injective he.inj (Disjoint.preimage _ _)
    rwa [Iic_disjoint_Ici, not_le]
  rcases exists_bounded_mem_Icc_of_closed_of_le hc₁ hc₂ hd hf3.le with ⟨g, hg₁, hg₂, hgf⟩
  refine' ⟨g, _, _⟩
  · refine' (norm_le <| div_nonneg hf.le h3.le).mpr fun y => _
    simpa [abs_le, neg_div] using hgf y
  · refine' (dist_le <| mul_nonneg h23.le hf.le).mpr fun x => _
    have hfx : -‖f‖ ≤ f x ∧ f x ≤ ‖f‖ := by
      simpa only [Real.norm_eq_abs, abs_le] using f.norm_coe_le_norm x
    cases' le_total (f x) (-‖f‖ / 3) with hle₁ hle₁
    ·
      calc
        |g (e x) - f x| = -‖f‖ / 3 - f x := by
          rw [hg₁ (mem_image_of_mem _ hle₁), abs_of_nonneg (sub_nonneg.2 hle₁)]
        _ ≤ 2 / 3 * ‖f‖ := by linarith

    · cases' le_total (f x) (‖f‖ / 3) with hle₂ hle₂
      · simp only [neg_div] at *
        calc
          dist (g (e x)) (f x) ≤ |g (e x)| + |f x| := dist_le_norm_add_norm _ _
          _ ≤ ‖f‖ / 3 + ‖f‖ / 3 := (add_le_add (abs_le.2 <| hgf _) (abs_le.2 ⟨hle₁, hle₂⟩))
          _ = 2 / 3 * ‖f‖ := by linarith

      ·
        calc
          |g (e x) - f x| = f x - ‖f‖ / 3 := by
            rw [hg₂ (mem_image_of_mem _ hle₂), abs_sub_comm, abs_of_nonneg (sub_nonneg.2 hle₂)]
          _ ≤ 2 / 3 * ‖f‖ := by linarith

#align bounded_continuous_function.tietze_extension_step BoundedContinuousFunction.tietze_extension_step

/-- **Tietze extension theorem** for real-valued bounded continuous maps, a version with a closed
embedding and bundled composition. If `e : C(X, Y)` is a closed embedding of a topological space
into a normal topological space and `f : X →ᵇ ℝ` is a bounded continuous function, then there exists
a bounded continuous function `g : Y →ᵇ ℝ` of the same norm such that `g ∘ e = f`. -/
theorem exists_extension_norm_eq_of_closed_embedding' (f : X →ᵇ ℝ) (e : C(X, Y))
    (he : ClosedEmbedding e) : ∃ g : Y →ᵇ ℝ, ‖g‖ = ‖f‖ ∧ g.comp_continuous e = f :=
  by
  /- For the proof, we iterate `tietze_extension_step`. Each time we apply it to the difference
    between the previous approximation and `f`. -/
  choose F hF_norm hF_dist using fun f : X →ᵇ ℝ => tietze_extension_step f e he
  set g : ℕ → Y →ᵇ ℝ := fun n => ((fun g => g + F (f - g.comp_continuous e))^[n]) 0
  have g0 : g 0 = 0 := rfl
  have g_succ : ∀ n, g (n + 1) = g n + F (f - (g n).comp_continuous e) := fun n =>
    Function.iterate_succ_apply' _ _ _
  have hgf : ∀ n, dist ((g n).comp_continuous e) f ≤ (2 / 3) ^ n * ‖f‖ :=
    by
    intro n
    induction' n with n ihn
    · simp [g0]
    · rw [g_succ n, add_comp_continuous, ← dist_sub_right, add_sub_cancel', pow_succ, mul_assoc]
      refine' (hF_dist _).trans (mul_le_mul_of_nonneg_left _ (by norm_num1))
      rwa [← dist_eq_norm']
  have hg_dist : ∀ n, dist (g n) (g (n + 1)) ≤ 1 / 3 * ‖f‖ * (2 / 3) ^ n :=
    by
    intro n
    calc
      dist (g n) (g (n + 1)) = ‖F (f - (g n).comp_continuous e)‖ := by
        rw [g_succ, dist_eq_norm', add_sub_cancel']
      _ ≤ ‖f - (g n).comp_continuous e‖ / 3 := (hF_norm _)
      _ = 1 / 3 * dist ((g n).comp_continuous e) f := by rw [dist_eq_norm', one_div, div_eq_inv_mul]
      _ ≤ 1 / 3 * ((2 / 3) ^ n * ‖f‖) := (mul_le_mul_of_nonneg_left (hgf n) (by norm_num1))
      _ = 1 / 3 * ‖f‖ * (2 / 3) ^ n := by ac_rfl

  have hg_cau : CauchySeq g := cauchySeq_of_le_geometric _ _ (by norm_num1) hg_dist
  have :
    tendsto (fun n => (g n).comp_continuous e) at_top
      (𝓝 <| (limUnder at_top g).comp_continuous e) :=
    ((continuous_comp_continuous e).Tendsto _).comp hg_cau.tendsto_lim
  have hge : (limUnder at_top g).comp_continuous e = f :=
    by
    refine' tendsto_nhds_unique this (tendsto_iff_dist_tendsto_zero.2 _)
    refine' squeeze_zero (fun _ => dist_nonneg) hgf _
    rw [← MulZeroClass.zero_mul ‖f‖]
    refine' (tendsto_pow_atTop_nhds_0_of_lt_1 _ _).mul tendsto_const_nhds <;> norm_num1
  refine' ⟨limUnder at_top g, le_antisymm _ _, hge⟩
  · rw [← dist_zero_left, ← g0]
    refine'
      (dist_le_of_le_geometric_of_tendsto₀ _ _ (by norm_num1) hg_dist hg_cau.tendsto_lim).trans_eq _
    field_simp [show (3 - 2 : ℝ) = 1 by norm_num1]
  · rw [← hge]
    exact norm_comp_continuous_le _ _
#align bounded_continuous_function.exists_extension_norm_eq_of_closed_embedding' BoundedContinuousFunction.exists_extension_norm_eq_of_closed_embedding'

/-- **Tietze extension theorem** for real-valued bounded continuous maps, a version with a closed
embedding and unbundled composition. If `e : C(X, Y)` is a closed embedding of a topological space
into a normal topological space and `f : X →ᵇ ℝ` is a bounded continuous function, then there exists
a bounded continuous function `g : Y →ᵇ ℝ` of the same norm such that `g ∘ e = f`. -/
theorem exists_extension_norm_eq_of_closedEmbedding (f : X →ᵇ ℝ) {e : X → Y}
    (he : ClosedEmbedding e) : ∃ g : Y →ᵇ ℝ, ‖g‖ = ‖f‖ ∧ g ∘ e = f :=
  by
  rcases exists_extension_norm_eq_of_closed_embedding' f ⟨e, he.continuous⟩ he with ⟨g, hg, rfl⟩
  exact ⟨g, hg, rfl⟩
#align bounded_continuous_function.exists_extension_norm_eq_of_closed_embedding BoundedContinuousFunction.exists_extension_norm_eq_of_closedEmbedding

/-- **Tietze extension theorem** for real-valued bounded continuous maps, a version for a closed
set. If `f` is a bounded continuous real-valued function defined on a closed set in a normal
topological space, then it can be extended to a bounded continuous function of the same norm defined
on the whole space. -/
theorem exists_norm_eq_restrict_eq_of_closed {s : Set Y} (f : s →ᵇ ℝ) (hs : IsClosed s) :
    ∃ g : Y →ᵇ ℝ, ‖g‖ = ‖f‖ ∧ g.restrict s = f :=
  exists_extension_norm_eq_of_closed_embedding' f ((ContinuousMap.id _).restrict s)
    (closedEmbedding_subtype_val hs)
#align bounded_continuous_function.exists_norm_eq_restrict_eq_of_closed BoundedContinuousFunction.exists_norm_eq_restrict_eq_of_closed

/-- **Tietze extension theorem** for real-valued bounded continuous maps, a version for a closed
embedding and a bounded continuous function that takes values in a non-trivial closed interval.
See also `exists_extension_forall_mem_of_closed_embedding` for a more general statement that works
for any interval (finite or infinite, open or closed).

If `e : X → Y` is a closed embedding and `f : X →ᵇ ℝ` is a bounded continuous function such that
`f x ∈ [a, b]` for all `x`, where `a ≤ b`, then there exists a bounded continuous function
`g : Y →ᵇ ℝ` such that `g y ∈ [a, b]` for all `y` and `g ∘ e = f`. -/
theorem exists_extension_forall_mem_Icc_of_closedEmbedding (f : X →ᵇ ℝ) {a b : ℝ} {e : X → Y}
    (hf : ∀ x, f x ∈ Icc a b) (hle : a ≤ b) (he : ClosedEmbedding e) :
    ∃ g : Y →ᵇ ℝ, (∀ y, g y ∈ Icc a b) ∧ g ∘ e = f :=
  by
  rcases exists_extension_norm_eq_of_closed_embedding (f - const X ((a + b) / 2)) he with
    ⟨g, hgf, hge⟩
  refine' ⟨const Y ((a + b) / 2) + g, fun y => _, _⟩
  · suffices ‖f - const X ((a + b) / 2)‖ ≤ (b - a) / 2 by
      simpa [Real.Icc_eq_closedBall, add_mem_closedBall_iff_norm] using
        (norm_coe_le_norm g y).trans (hgf.trans_le this)
    refine' (norm_le <| div_nonneg (sub_nonneg.2 hle) zero_le_two).2 fun x => _
    simpa only [Real.Icc_eq_closedBall] using hf x
  · ext x
    have : g (e x) = f x - (a + b) / 2 := congr_fun hge x
    simp [this]
#align bounded_continuous_function.exists_extension_forall_mem_Icc_of_closed_embedding BoundedContinuousFunction.exists_extension_forall_mem_Icc_of_closedEmbedding

/-- **Tietze extension theorem** for real-valued bounded continuous maps, a version for a closed
embedding. Let `e` be a closed embedding of a nonempty topological space `X` into a normal
topological space `Y`. Let `f` be a bounded continuous real-valued function on `X`. Then there
exists a bounded continuous function `g : Y →ᵇ ℝ` such that `g ∘ e = f` and each value `g y` belongs
to a closed interval `[f x₁, f x₂]` for some `x₁` and `x₂`.  -/
theorem exists_extension_forall_exists_le_ge_of_closedEmbedding [Nonempty X] (f : X →ᵇ ℝ)
    {e : X → Y} (he : ClosedEmbedding e) :
    ∃ g : Y →ᵇ ℝ, (∀ y, ∃ x₁ x₂, g y ∈ Icc (f x₁) (f x₂)) ∧ g ∘ e = f :=
  by
  inhabit X
  -- Put `a = ⨅ x, f x` and `b = ⨆ x, f x`
  obtain ⟨a, ha⟩ : ∃ a, IsGLB (range f) a
  exact ⟨_, isGLB_cinfᵢ (Real.bounded_iff_bddBelow_bddAbove.1 f.bounded_range).1⟩
  obtain ⟨b, hb⟩ : ∃ b, IsLUB (range f) b
  exact ⟨_, isLUB_csupᵢ (Real.bounded_iff_bddBelow_bddAbove.1 f.bounded_range).2⟩
  -- Then `f x ∈ [a, b]` for all `x`
  have hmem : ∀ x, f x ∈ Icc a b := fun x => ⟨ha.1 ⟨x, rfl⟩, hb.1 ⟨x, rfl⟩⟩
  -- Rule out the trivial case `a = b`
  have hle : a ≤ b := (hmem default).1.trans (hmem default).2
  rcases hle.eq_or_lt with (rfl | hlt)
  · have : ∀ x, f x = a := by simpa using hmem
    use const Y a
    simp [this, Function.funext_iff]
  -- Put `c = (a + b) / 2`. Then `a < c < b` and `c - a = b - c`.
  set c := (a + b) / 2
  have hac : a < c := left_lt_add_div_two.2 hlt
  have hcb : c < b := add_div_two_lt_right.2 hlt
  have hsub : c - a = b - c := by
    simp only [c]
    field_simp
    ring
  /- Due to `exists_extension_forall_mem_Icc_of_closed_embedding`, there exists an extension `g`
    such that `g y ∈ [a, b]` for all `y`. However, if `a` and/or `b` do not belong to the range of
    `f`, then we need to ensure that these points do not belong to the range of `g`. This is done
    in two almost identical steps. First we deal with the case `∀ x, f x ≠ a`. -/
  obtain ⟨g, hg_mem, hgf⟩ : ∃ g : Y →ᵇ ℝ, (∀ y, ∃ x, g y ∈ Icc (f x) b) ∧ g ∘ e = f :=
    by
    rcases exists_extension_forall_mem_Icc_of_closed_embedding f hmem hle he with ⟨g, hg_mem, hgf⟩
    -- If `a ∈ range f`, then we are done.
    rcases em (∃ x, f x = a) with (⟨x, rfl⟩ | ha')
    · exact ⟨g, fun y => ⟨x, hg_mem _⟩, hgf⟩
    /- Otherwise, `g ⁻¹' {a}` is disjoint with `range e ∪ g ⁻¹' (Ici c)`, hence there exists a
        function `dg : Y → ℝ` such that `dg ∘ e = 0`, `dg y = 0` whenever `c ≤ g y`, `dg y = c - a`
        whenever `g y = a`, and `0 ≤ dg y ≤ c - a` for all `y`.  -/
    have hd : Disjoint (range e ∪ g ⁻¹' Ici c) (g ⁻¹' {a}) :=
      by
      refine' disjoint_union_left.2 ⟨_, Disjoint.preimage _ _⟩
      · rw [Set.disjoint_left]
        rintro _ ⟨x, rfl⟩ (rfl : g (e x) = a)
        exact ha' ⟨x, (congr_fun hgf x).symm⟩
      · exact Set.disjoint_singleton_right.2 hac.not_le
    rcases exists_bounded_mem_Icc_of_closed_of_le
        (he.closed_range.union <| is_closed_Ici.preimage g.continuous)
        (is_closed_singleton.preimage g.continuous) hd (sub_nonneg.2 hac.le) with
      ⟨dg, dg0, dga, dgmem⟩
    replace hgf : ∀ x, (g + dg) (e x) = f x
    · intro x
      simp [dg0 (Or.inl <| mem_range_self _), ← hgf]
    refine' ⟨g + dg, fun y => _, funext hgf⟩
    · have hay : a < (g + dg) y :=
        by
        rcases(hg_mem y).1.eq_or_lt with (rfl | hlt)
        · refine' (lt_add_iff_pos_right _).2 _
          calc
            0 < c - g y := sub_pos.2 hac
            _ = dg y := (dga rfl).symm

        · exact hlt.trans_le ((le_add_iff_nonneg_right _).2 <| (dgmem y).1)
      rcases ha.exists_between hay with ⟨_, ⟨x, rfl⟩, hax, hxy⟩
      refine' ⟨x, hxy.le, _⟩
      cases' le_total c (g y) with hc hc
      · simp [dg0 (Or.inr hc), (hg_mem y).2]
      ·
        calc
          g y + dg y ≤ c + (c - a) := add_le_add hc (dgmem _).2
          _ = b := by rw [hsub, add_sub_cancel'_right]

  /- Now we deal with the case `∀ x, f x ≠ b`. The proof is the same as in the first case, with
    minor modifications that make it hard to deduplicate code. -/
  choose xl hxl hgb using hg_mem
  rcases em (∃ x, f x = b) with (⟨x, rfl⟩ | hb')
  · exact ⟨g, fun y => ⟨xl y, x, hxl y, hgb y⟩, hgf⟩
  have hd : Disjoint (range e ∪ g ⁻¹' Iic c) (g ⁻¹' {b}) :=
    by
    refine' disjoint_union_left.2 ⟨_, Disjoint.preimage _ _⟩
    · rw [Set.disjoint_left]
      rintro _ ⟨x, rfl⟩ (rfl : g (e x) = b)
      exact hb' ⟨x, (congr_fun hgf x).symm⟩
    · exact Set.disjoint_singleton_right.2 hcb.not_le
  rcases exists_bounded_mem_Icc_of_closed_of_le
      (he.closed_range.union <| is_closed_Iic.preimage g.continuous)
      (is_closed_singleton.preimage g.continuous) hd (sub_nonneg.2 hcb.le) with
    ⟨dg, dg0, dgb, dgmem⟩
  replace hgf : ∀ x, (g - dg) (e x) = f x
  · intro x
    simp [dg0 (Or.inl <| mem_range_self _), ← hgf]
  refine' ⟨g - dg, fun y => _, funext hgf⟩
  · have hyb : (g - dg) y < b :=
      by
      rcases(hgb y).eq_or_lt with (rfl | hlt)
      · refine' (sub_lt_self_iff _).2 _
        calc
          0 < g y - c := sub_pos.2 hcb
          _ = dg y := (dgb rfl).symm

      · exact ((sub_le_self_iff _).2 (dgmem _).1).trans_lt hlt
    rcases hb.exists_between hyb with ⟨_, ⟨xu, rfl⟩, hyxu, hxub⟩
    cases' lt_or_le c (g y) with hc hc
    · rcases em (a ∈ range f) with (⟨x, rfl⟩ | ha')
      · refine' ⟨x, xu, _, hyxu.le⟩
        calc
          f x = c - (b - c) := by rw [← hsub, sub_sub_cancel]
          _ ≤ g y - dg y := sub_le_sub hc.le (dgmem _).2

      · have hay : a < (g - dg) y := by
          calc
            a = c - (b - c) := by rw [← hsub, sub_sub_cancel]
            _ < g y - (b - c) := (sub_lt_sub_right hc _)
            _ ≤ g y - dg y := sub_le_sub_left (dgmem _).2 _

        rcases ha.exists_between hay with ⟨_, ⟨x, rfl⟩, ha, hxy⟩
        exact ⟨x, xu, hxy.le, hyxu.le⟩
    · refine' ⟨xl y, xu, _, hyxu.le⟩
      simp [dg0 (Or.inr hc), hxl]
#align bounded_continuous_function.exists_extension_forall_exists_le_ge_of_closed_embedding BoundedContinuousFunction.exists_extension_forall_exists_le_ge_of_closedEmbedding

/-- **Tietze extension theorem** for real-valued bounded continuous maps, a version for a closed
embedding. Let `e` be a closed embedding of a nonempty topological space `X` into a normal
topological space `Y`. Let `f` be a bounded continuous real-valued function on `X`. Let `t` be
a nonempty convex set of real numbers (we use `ord_connected` instead of `convex` to automatically
deduce this argument by typeclass search) such that `f x ∈ t` for all `x`. Then there exists
a bounded continuous real-valued function `g : Y →ᵇ ℝ` such that `g y ∈ t` for all `y` and
`g ∘ e = f`. -/
theorem exists_extension_forall_mem_of_closedEmbedding (f : X →ᵇ ℝ) {t : Set ℝ} {e : X → Y}
    [hs : OrdConnected t] (hf : ∀ x, f x ∈ t) (hne : t.Nonempty) (he : ClosedEmbedding e) :
    ∃ g : Y →ᵇ ℝ, (∀ y, g y ∈ t) ∧ g ∘ e = f :=
  by
  cases isEmpty_or_nonempty X
  · rcases hne with ⟨c, hc⟩
    refine' ⟨const Y c, fun y => hc, funext fun x => isEmptyElim x⟩
  rcases exists_extension_forall_exists_le_ge_of_closed_embedding f he with ⟨g, hg, hgf⟩
  refine' ⟨g, fun y => _, hgf⟩
  rcases hg y with ⟨xl, xu, h⟩
  exact hs.out (hf _) (hf _) h
#align bounded_continuous_function.exists_extension_forall_mem_of_closed_embedding BoundedContinuousFunction.exists_extension_forall_mem_of_closedEmbedding

/-- **Tietze extension theorem** for real-valued bounded continuous maps, a version for a closed
set. Let `s` be a closed set in a normal topological space `Y`. Let `f` be a bounded continuous
real-valued function on `s`. Let `t` be a nonempty convex set of real numbers (we use
`ord_connected` instead of `convex` to automatically deduce this argument by typeclass search) such
that `f x ∈ t` for all `x : s`. Then there exists a bounded continuous real-valued function
`g : Y →ᵇ ℝ` such that `g y ∈ t` for all `y` and `g.restrict s = f`. -/
theorem exists_forall_mem_restrict_eq_of_closed {s : Set Y} (f : s →ᵇ ℝ) (hs : IsClosed s)
    {t : Set ℝ} [OrdConnected t] (hf : ∀ x, f x ∈ t) (hne : t.Nonempty) :
    ∃ g : Y →ᵇ ℝ, (∀ y, g y ∈ t) ∧ g.restrict s = f :=
  by
  rcases exists_extension_forall_mem_of_closed_embedding f hf hne
      (closedEmbedding_subtype_val hs) with
    ⟨g, hg, hgf⟩
  exact ⟨g, hg, FunLike.coe_injective hgf⟩
#align bounded_continuous_function.exists_forall_mem_restrict_eq_of_closed BoundedContinuousFunction.exists_forall_mem_restrict_eq_of_closed

end BoundedContinuousFunction

namespace ContinuousMap

/-- **Tietze extension theorem** for real-valued continuous maps, a version for a closed
embedding. Let `e` be a closed embedding of a nonempty topological space `X` into a normal
topological space `Y`. Let `f` be a continuous real-valued function on `X`. Let `t` be a nonempty
convex set of real numbers (we use `ord_connected` instead of `convex` to automatically deduce this
argument by typeclass search) such that `f x ∈ t` for all `x`. Then there exists a continuous
real-valued function `g : C(Y, ℝ)` such that `g y ∈ t` for all `y` and `g ∘ e = f`. -/
theorem exists_extension_forall_mem_of_closedEmbedding (f : C(X, ℝ)) {t : Set ℝ} {e : X → Y}
    [hs : OrdConnected t] (hf : ∀ x, f x ∈ t) (hne : t.Nonempty) (he : ClosedEmbedding e) :
    ∃ g : C(Y, ℝ), (∀ y, g y ∈ t) ∧ g ∘ e = f :=
  by
  have h : ℝ ≃o Ioo (-1 : ℝ) 1 := orderIsoIooNegOneOne ℝ
  set F : X →ᵇ ℝ :=
    { toFun := coe ∘ h ∘ f
      continuous_toFun := continuous_subtype_coe.comp (h.continuous.comp f.continuous)
      map_bounded' :=
        bounded_range_iff.1
          ((bounded_Ioo (-1 : ℝ) 1).mono <| forall_range_iff.2 fun x => (h (f x)).2) }
  set t' : Set ℝ := coe ∘ h '' t
  have ht_sub : t' ⊆ Ioo (-1 : ℝ) 1 := image_subset_iff.2 fun x hx => (h x).2
  have : ord_connected t' := by
    constructor
    rintro _ ⟨x, hx, rfl⟩ _ ⟨y, hy, rfl⟩ z hz
    lift z to Ioo (-1 : ℝ) 1 using Icc_subset_Ioo (h x).2.1 (h y).2.2 hz
    change z ∈ Icc (h x) (h y) at hz
    rw [← h.image_Icc] at hz
    rcases hz with ⟨z, hz, rfl⟩
    exact ⟨z, hs.out hx hy hz, rfl⟩
  have hFt : ∀ x, F x ∈ t' := fun x => mem_image_of_mem _ (hf x)
  rcases F.exists_extension_forall_mem_of_closed_embedding hFt (hne.image _) he with ⟨G, hG, hGF⟩
  set g : C(Y, ℝ) :=
    ⟨h.symm ∘ cod_restrict G _ fun y => ht_sub (hG y),
      h.symm.continuous.comp <| G.continuous.subtype_mk _⟩
  have hgG : ∀ {y a}, g y = a ↔ G y = h a := fun y a =>
    h.to_equiv.symm_apply_eq.trans Subtype.ext_iff
  refine' ⟨g, fun y => _, _⟩
  · rcases hG y with ⟨a, ha, hay⟩
    convert ha
    exact hgG.2 hay.symm
  · ext x
    exact hgG.2 (congr_fun hGF _)
#align continuous_map.exists_extension_forall_mem_of_closed_embedding ContinuousMap.exists_extension_forall_mem_of_closedEmbedding

/-- **Tietze extension theorem** for real-valued continuous maps, a version for a closed
embedding. Let `e` be a closed embedding of a nonempty topological space `X` into a normal
topological space `Y`. Let `f` be a continuous real-valued function on `X`. Then there exists a
continuous real-valued function `g : C(Y, ℝ)` such that `g ∘ e = f`. -/
theorem exists_extension_of_closedEmbedding (f : C(X, ℝ)) (e : X → Y) (he : ClosedEmbedding e) :
    ∃ g : C(Y, ℝ), g ∘ e = f :=
  (exists_extension_forall_mem_of_closedEmbedding f (fun x => mem_univ _) univ_nonempty he).imp
    fun g => And.right
#align continuous_map.exists_extension_of_closed_embedding ContinuousMap.exists_extension_of_closedEmbedding

/-- **Tietze extension theorem** for real-valued continuous maps, a version for a closed set. Let
`s` be a closed set in a normal topological space `Y`. Let `f` be a continuous real-valued function
on `s`. Let `t` be a nonempty convex set of real numbers (we use `ord_connected` instead of `convex`
to automatically deduce this argument by typeclass search) such that `f x ∈ t` for all `x : s`. Then
there exists a continuous real-valued function `g : C(Y, ℝ)` such that `g y ∈ t` for all `y` and
`g.restrict s = f`. -/
theorem exists_restrict_eq_forall_mem_of_closed {s : Set Y} (f : C(s, ℝ)) {t : Set ℝ}
    [OrdConnected t] (ht : ∀ x, f x ∈ t) (hne : t.Nonempty) (hs : IsClosed s) :
    ∃ g : C(Y, ℝ), (∀ y, g y ∈ t) ∧ g.restrict s = f :=
  let ⟨g, hgt, hgf⟩ :=
    exists_extension_forall_mem_of_closedEmbedding f ht hne (closedEmbedding_subtype_val hs)
  ⟨g, hgt, coe_injective hgf⟩
#align continuous_map.exists_restrict_eq_forall_mem_of_closed ContinuousMap.exists_restrict_eq_forall_mem_of_closed

/-- **Tietze extension theorem** for real-valued continuous maps, a version for a closed set. Let
`s` be a closed set in a normal topological space `Y`. Let `f` be a continuous real-valued function
on `s`. Then there exists a continuous real-valued function `g : C(Y, ℝ)` such that
`g.restrict s = f`. -/
theorem exists_restrict_eq_of_closed {s : Set Y} (f : C(s, ℝ)) (hs : IsClosed s) :
    ∃ g : C(Y, ℝ), g.restrict s = f :=
  let ⟨g, hg, hgf⟩ :=
    exists_restrict_eq_forall_mem_of_closed f (fun _ => mem_univ _) univ_nonempty hs
  ⟨g, hgf⟩
#align continuous_map.exists_restrict_eq_of_closed ContinuousMap.exists_restrict_eq_of_closed

end ContinuousMap


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import algebra.associated
import tactic.ring

/-! # ℤ[√d]

The ring of integers adjoined with a square root of `d : ℤ`.

After defining the norm, we show that it is a linearly ordered commutative ring,
as well as an integral domain.

We provide the universal property, that ring homomorphisms `ℤ√d →+* R` correspond
to choices of square roots of `d` in `R`.

-/

/-- The ring of integers adjoined with a square root of `d`.
  These have the form `a + b √d` where `a b : ℤ`. The components
  are called `re` and `im` by analogy to the negative `d` case. -/
structure zsqrtd (d : ℤ) :=
(re : ℤ)
(im : ℤ)

prefix `ℤ√`:100 := zsqrtd

namespace zsqrtd
section
parameters {d : ℤ}

instance : decidable_eq ℤ√d :=
by tactic.mk_dec_eq_instance

theorem ext : ∀ {z w : ℤ√d}, z = w ↔ z.re = w.re ∧ z.im = w.im
| ⟨x, y⟩ ⟨x', y'⟩ := ⟨λ h, by injection h; split; assumption,
                      λ ⟨h₁, h₂⟩, by congr; assumption⟩

/-- Convert an integer to a `ℤ√d` -/
def of_int (n : ℤ) : ℤ√d := ⟨n, 0⟩
theorem of_int_re (n : ℤ) : (of_int n).re = n := rfl
theorem of_int_im (n : ℤ) : (of_int n).im = 0 := rfl

/-- The zero of the ring -/
def zero : ℤ√d := of_int 0
instance : has_zero ℤ√d := ⟨zsqrtd.zero⟩
@[simp] theorem zero_re : (0 : ℤ√d).re = 0 := rfl
@[simp] theorem zero_im : (0 : ℤ√d).im = 0 := rfl

instance : inhabited ℤ√d := ⟨0⟩

/-- The one of the ring -/
def one : ℤ√d := of_int 1
instance : has_one ℤ√d := ⟨zsqrtd.one⟩
@[simp] theorem one_re : (1 : ℤ√d).re = 1 := rfl
@[simp] theorem one_im : (1 : ℤ√d).im = 0 := rfl

/-- The representative of `√d` in the ring -/
def sqrtd : ℤ√d := ⟨0, 1⟩
@[simp] theorem sqrtd_re : (sqrtd : ℤ√d).re = 0 := rfl
@[simp] theorem sqrtd_im : (sqrtd : ℤ√d).im = 1 := rfl

/-- Addition of elements of `ℤ√d` -/
def add : ℤ√d → ℤ√d → ℤ√d
| ⟨x, y⟩ ⟨x', y'⟩ := ⟨x + x', y + y'⟩
instance : has_add ℤ√d := ⟨zsqrtd.add⟩
@[simp] theorem add_def (x y x' y' : ℤ) :
  (⟨x, y⟩ + ⟨x', y'⟩ : ℤ√d) = ⟨x + x', y + y'⟩ := rfl
@[simp] theorem add_re : ∀ z w : ℤ√d, (z + w).re = z.re + w.re
| ⟨x, y⟩ ⟨x', y'⟩ := rfl
@[simp] theorem add_im : ∀ z w : ℤ√d, (z + w).im = z.im + w.im
| ⟨x, y⟩ ⟨x', y'⟩ := rfl

@[simp] theorem bit0_re (z) : (bit0 z : ℤ√d).re = bit0 z.re := add_re _ _
@[simp] theorem bit0_im (z) : (bit0 z : ℤ√d).im = bit0 z.im := add_im _ _

@[simp] theorem bit1_re (z) : (bit1 z : ℤ√d).re = bit1 z.re := by simp [bit1]
@[simp] theorem bit1_im (z) : (bit1 z : ℤ√d).im = bit0 z.im := by simp [bit1]

/-- Negation in `ℤ√d` -/
def neg : ℤ√d → ℤ√d
| ⟨x, y⟩ := ⟨-x, -y⟩
instance : has_neg ℤ√d := ⟨zsqrtd.neg⟩
@[simp] theorem neg_re : ∀ z : ℤ√d, (-z).re = -z.re
| ⟨x, y⟩ := rfl
@[simp] theorem neg_im : ∀ z : ℤ√d, (-z).im = -z.im
| ⟨x, y⟩ := rfl

/-- Multiplication in `ℤ√d` -/
def mul : ℤ√d → ℤ√d → ℤ√d
| ⟨x, y⟩ ⟨x', y'⟩ := ⟨x * x' + d * y * y', x * y' + y * x'⟩
instance : has_mul ℤ√d := ⟨zsqrtd.mul⟩
@[simp] theorem mul_re : ∀ z w : ℤ√d, (z * w).re = z.re * w.re + d * z.im * w.im
| ⟨x, y⟩ ⟨x', y'⟩ := rfl
@[simp] theorem mul_im : ∀ z w : ℤ√d, (z * w).im = z.re * w.im + z.im * w.re
| ⟨x, y⟩ ⟨x', y'⟩ := rfl

instance : comm_ring ℤ√d :=
by refine_struct
{ add            := (+),
  zero           := (0 : ℤ√d),
  neg            := has_neg.neg,
  mul            := (*),
  sub            := λ a b, a + -b,
  one            := 1,
  npow           := @npow_rec (ℤ√d) ⟨1⟩ ⟨(*)⟩,
  nsmul          := @nsmul_rec (ℤ√d) ⟨0⟩ ⟨(+)⟩,
  zsmul          := @zsmul_rec (ℤ√d) ⟨0⟩ ⟨(+)⟩ ⟨zsqrtd.neg⟩ };
intros; try { refl }; simp [ext, add_mul, mul_add, add_comm, add_left_comm, mul_comm, mul_left_comm]

instance : add_comm_monoid ℤ√d    := by apply_instance
instance : add_monoid ℤ√d         := by apply_instance
instance : monoid ℤ√d             := by apply_instance
instance : comm_monoid ℤ√d        := by apply_instance
instance : comm_semigroup ℤ√d     := by apply_instance
instance : semigroup ℤ√d          := by apply_instance
instance : add_comm_semigroup ℤ√d := by apply_instance
instance : add_semigroup ℤ√d      := by apply_instance
instance : comm_semiring ℤ√d      := by apply_instance
instance : semiring ℤ√d           := by apply_instance
instance : ring ℤ√d               := by apply_instance
instance : distrib ℤ√d            := by apply_instance

/-- Conjugation in `ℤ√d`. The conjugate of `a + b √d` is `a - b √d`. -/
def conj : ℤ√d → ℤ√d
| ⟨x, y⟩ := ⟨x, -y⟩
@[simp] theorem conj_re : ∀ z : ℤ√d, (conj z).re = z.re
| ⟨x, y⟩ := rfl
@[simp] theorem conj_im : ∀ z : ℤ√d, (conj z).im = -z.im
| ⟨x, y⟩ := rfl

/-- `conj` as an `add_monoid_hom`. -/
def conj_hom : ℤ√d →+ ℤ√d :=
{ to_fun := conj,
  map_add' := λ ⟨a, ai⟩ ⟨b, bi⟩, ext.mpr ⟨rfl, neg_add _ _⟩,
  map_zero' := ext.mpr ⟨rfl, neg_zero⟩ }

@[simp] lemma conj_zero : conj (0 : ℤ√d) = 0 :=
conj_hom.map_zero

@[simp] lemma conj_one : conj (1 : ℤ√d) = 1 :=
by simp only [zsqrtd.ext, zsqrtd.conj_re, zsqrtd.conj_im, zsqrtd.one_im, neg_zero, eq_self_iff_true,
  and_self]

@[simp] lemma conj_neg (x : ℤ√d) : (-x).conj = -x.conj :=
conj_hom.map_neg x

@[simp] lemma conj_add (x y : ℤ√d) : (x + y).conj = x.conj + y.conj :=
conj_hom.map_add x y

@[simp] lemma conj_sub (x y : ℤ√d) : (x - y).conj = x.conj - y.conj :=
conj_hom.map_sub x y

@[simp] lemma conj_conj {d : ℤ} (x : ℤ√d) : x.conj.conj = x :=
by simp only [ext, true_and, conj_re, eq_self_iff_true, neg_neg, conj_im]

instance : nontrivial ℤ√d :=
⟨⟨0, 1, dec_trivial⟩⟩

@[simp] theorem coe_nat_re (n : ℕ) : (n : ℤ√d).re = n :=
by induction n; simp *
@[simp] theorem coe_nat_im (n : ℕ) : (n : ℤ√d).im = 0 :=
by induction n; simp *
theorem coe_nat_val (n : ℕ) : (n : ℤ√d) = ⟨n, 0⟩ :=
by simp [ext]

@[simp] theorem coe_int_re (n : ℤ) : (n : ℤ√d).re = n :=
by cases n; simp [*, int.of_nat_eq_coe, int.neg_succ_of_nat_eq]
@[simp] theorem coe_int_im (n : ℤ) : (n : ℤ√d).im = 0 :=
by cases n; simp *
theorem coe_int_val (n : ℤ) : (n : ℤ√d) = ⟨n, 0⟩ :=
by simp [ext]

instance : char_zero ℤ√d :=
{ cast_injective := λ m n, by simp [ext] }

@[simp] theorem of_int_eq_coe (n : ℤ) : (of_int n : ℤ√d) = n :=
by simp [ext, of_int_re, of_int_im]

@[simp] theorem smul_val (n x y : ℤ) : (n : ℤ√d) * ⟨x, y⟩ = ⟨n * x, n * y⟩ :=
by simp [ext]

@[simp] theorem muld_val (x y : ℤ) : sqrtd * ⟨x, y⟩ = ⟨d * y, x⟩ :=
by simp [ext]

@[simp] theorem dmuld : sqrtd * sqrtd = d :=
by simp [ext]

@[simp] theorem smuld_val (n x y : ℤ) : sqrtd * (n : ℤ√d) * ⟨x, y⟩ = ⟨d * n * y, n * x⟩ :=
by simp [ext]

theorem decompose {x y : ℤ} : (⟨x, y⟩ : ℤ√d) = x + sqrtd * y :=
by simp [ext]

theorem mul_conj {x y : ℤ} : (⟨x, y⟩ * conj ⟨x, y⟩ : ℤ√d) = x * x - d * y * y :=
by simp [ext, sub_eq_add_neg, mul_comm]

theorem conj_mul {a b : ℤ√d} : conj (a * b) = conj a * conj b :=
by { simp [ext], ring }

protected lemma coe_int_add (m n : ℤ) : (↑(m + n) : ℤ√d) = ↑m + ↑n :=
(int.cast_ring_hom _).map_add _ _
protected lemma coe_int_sub (m n : ℤ) : (↑(m - n) : ℤ√d) = ↑m - ↑n :=
(int.cast_ring_hom _).map_sub _ _
protected lemma coe_int_mul (m n : ℤ) : (↑(m * n) : ℤ√d) = ↑m * ↑n :=
(int.cast_ring_hom _).map_mul _ _
protected lemma coe_int_inj {m n : ℤ} (h : (↑m : ℤ√d) = ↑n) : m = n :=
by simpa using congr_arg re h

/-- Read `sq_le a c b d` as `a √c ≤ b √d` -/
def sq_le (a c b d : ℕ) : Prop := c*a*a ≤ d*b*b

theorem sq_le_of_le {c d x y z w : ℕ} (xz : z ≤ x) (yw : y ≤ w) (xy : sq_le x c y d) :
  sq_le z c w d :=
le_trans (mul_le_mul (nat.mul_le_mul_left _ xz) xz (nat.zero_le _) (nat.zero_le _)) $
  le_trans xy (mul_le_mul (nat.mul_le_mul_left _ yw) yw (nat.zero_le _) (nat.zero_le _))

theorem sq_le_add_mixed {c d x y z w : ℕ} (xy : sq_le x c y d) (zw : sq_le z c w d) :
  c * (x * z) ≤ d * (y * w) :=
nat.mul_self_le_mul_self_iff.2 $
by simpa [mul_comm, mul_left_comm] using
   mul_le_mul xy zw (nat.zero_le _) (nat.zero_le _)

theorem sq_le_add {c d x y z w : ℕ} (xy : sq_le x c y d) (zw : sq_le z c w d) :
  sq_le (x + z) c (y + w) d :=
begin
  have xz := sq_le_add_mixed xy zw,
  simp [sq_le, mul_assoc] at xy zw,
  simp [sq_le, mul_add, mul_comm, mul_left_comm, add_le_add, *]
end

theorem sq_le_cancel {c d x y z w : ℕ} (zw : sq_le y d x c) (h : sq_le (x + z) c (y + w) d) :
  sq_le z c w d :=
begin
  apply le_of_not_gt,
  intro l,
  refine not_le_of_gt _ h,
  simp [sq_le, mul_add, mul_comm, mul_left_comm, add_assoc],
  have hm := sq_le_add_mixed zw (le_of_lt l),
  simp [sq_le, mul_assoc] at l zw,
  exact lt_of_le_of_lt (add_le_add_right zw _)
    (add_lt_add_left (add_lt_add_of_le_of_lt hm (add_lt_add_of_le_of_lt hm l)) _)
end

theorem sq_le_smul {c d x y : ℕ} (n : ℕ) (xy : sq_le x c y d) : sq_le (n * x) c (n * y) d :=
by simpa [sq_le, mul_left_comm, mul_assoc] using
   nat.mul_le_mul_left (n * n) xy

theorem sq_le_mul {d x y z w : ℕ} :
  (sq_le x 1 y d → sq_le z 1 w d → sq_le (x * w + y * z) d (x * z + d * y * w) 1) ∧
  (sq_le x 1 y d → sq_le w d z 1 → sq_le (x * z + d * y * w) 1 (x * w + y * z) d) ∧
  (sq_le y d x 1 → sq_le z 1 w d → sq_le (x * z + d * y * w) 1 (x * w + y * z) d) ∧
  (sq_le y d x 1 → sq_le w d z 1 → sq_le (x * w + y * z) d (x * z + d * y * w) 1) :=
by refine ⟨_, _, _, _⟩;
{ intros xy zw,
  have := int.mul_nonneg (sub_nonneg_of_le (int.coe_nat_le_coe_nat_of_le xy))
                         (sub_nonneg_of_le (int.coe_nat_le_coe_nat_of_le zw)),
  refine int.le_of_coe_nat_le_coe_nat (le_of_sub_nonneg _),
  convert this,
  simp only [one_mul, int.coe_nat_add, int.coe_nat_mul],
  ring }

/-- "Generalized" `nonneg`. `nonnegg c d x y` means `a √c + b √d ≥ 0`;
  we are interested in the case `c = 1` but this is more symmetric -/
def nonnegg (c d : ℕ) : ℤ → ℤ → Prop
| (a : ℕ) (b : ℕ) := true
| (a : ℕ) -[1+ b] := sq_le (b+1) c a d
| -[1+ a] (b : ℕ) := sq_le (a+1) d b c
| -[1+ a] -[1+ b] := false

theorem nonnegg_comm {c d : ℕ} {x y : ℤ} : nonnegg c d x y = nonnegg d c y x :=
by induction x; induction y; refl

theorem nonnegg_neg_pos {c d} : Π {a b : ℕ}, nonnegg c d (-a) b ↔ sq_le a d b c
| 0     b := ⟨by simp [sq_le, nat.zero_le], λa, trivial⟩
| (a+1) b := by rw ← int.neg_succ_of_nat_coe; refl

theorem nonnegg_pos_neg {c d} {a b : ℕ} : nonnegg c d a (-b) ↔ sq_le b c a d :=
by rw nonnegg_comm; exact nonnegg_neg_pos

theorem nonnegg_cases_right {c d} {a : ℕ} :
  Π {b : ℤ}, (Π x : ℕ, b = -x → sq_le x c a d) → nonnegg c d a b
| (b:nat) h := trivial
| -[1+ b] h := h (b+1) rfl

theorem nonnegg_cases_left {c d} {b : ℕ} {a : ℤ} (h : Π x : ℕ, a = -x → sq_le x d b c) :
  nonnegg c d a b :=
cast nonnegg_comm (nonnegg_cases_right h)

section norm

def norm (n : ℤ√d) : ℤ := n.re * n.re - d * n.im * n.im
lemma norm_def (n : ℤ√d) : n.norm = n.re * n.re - d * n.im * n.im := rfl

@[simp] lemma norm_zero : norm 0 = 0 := by simp [norm]

@[simp] lemma norm_one : norm 1 = 1 := by simp [norm]

@[simp] lemma norm_int_cast (n : ℤ) : norm n = n * n := by simp [norm]

@[simp] lemma norm_nat_cast (n : ℕ) : norm n = n * n := norm_int_cast n

@[simp] lemma norm_mul (n m : ℤ√d) : norm (n * m) = norm n * norm m :=
by { simp only [norm, mul_im, mul_re], ring }

/-- `norm` as a `monoid_hom`. -/
def norm_monoid_hom : ℤ√d →* ℤ :=
{ to_fun := norm,
  map_mul' := norm_mul,
  map_one' := norm_one }

lemma norm_eq_mul_conj (n : ℤ√d) : (norm n : ℤ√d) = n * n.conj :=
by cases n; simp [norm, conj, zsqrtd.ext, mul_comm, sub_eq_add_neg]

@[simp] lemma norm_neg (x : ℤ√d) : (-x).norm = x.norm :=
coe_int_inj $ by simp only [norm_eq_mul_conj, conj_neg, neg_mul_eq_neg_mul_symm,
  mul_neg_eq_neg_mul_symm, neg_neg]

@[simp] lemma norm_conj (x : ℤ√d) : x.conj.norm = x.norm :=
coe_int_inj $ by simp only [norm_eq_mul_conj, conj_conj, mul_comm]

lemma norm_nonneg (hd : d ≤ 0) (n : ℤ√d) : 0 ≤ n.norm :=
add_nonneg (mul_self_nonneg _)
  (by rw [mul_assoc, neg_mul_eq_neg_mul];
    exact (mul_nonneg (neg_nonneg.2 hd) (mul_self_nonneg _)))

lemma norm_eq_one_iff {x : ℤ√d} : x.norm.nat_abs = 1 ↔ is_unit x :=
⟨λ h, is_unit_iff_dvd_one.2 $
  (le_total 0 (norm x)).cases_on
    (λ hx, show x ∣ 1, from ⟨x.conj,
      by rwa [← int.coe_nat_inj', int.nat_abs_of_nonneg hx,
        ← @int.cast_inj (ℤ√d) _ _, norm_eq_mul_conj, eq_comm] at h⟩)
    (λ hx, show x ∣ 1, from ⟨- x.conj,
      by rwa [← int.coe_nat_inj', int.of_nat_nat_abs_of_nonpos hx,
        ← @int.cast_inj (ℤ√d) _ _, int.cast_neg, norm_eq_mul_conj, neg_mul_eq_mul_neg,
        eq_comm] at h⟩),
λ h, let ⟨y, hy⟩ := is_unit_iff_dvd_one.1 h in begin
  have := congr_arg (int.nat_abs ∘ norm) hy,
  rw [function.comp_app, function.comp_app, norm_mul, int.nat_abs_mul,
    norm_one, int.nat_abs_one, eq_comm, nat.mul_eq_one_iff] at this,
  exact this.1
end⟩

lemma is_unit_iff_norm_is_unit {d : ℤ} (z : ℤ√d) : is_unit z ↔ is_unit z.norm :=
by rw [int.is_unit_iff_nat_abs_eq, norm_eq_one_iff]

lemma norm_eq_one_iff' {d : ℤ} (hd : d ≤ 0) (z : ℤ√d) : z.norm = 1 ↔ is_unit z :=
by rw [←norm_eq_one_iff, ←int.coe_nat_inj', int.nat_abs_of_nonneg (norm_nonneg hd z),
  int.coe_nat_one]

lemma norm_eq_zero_iff {d : ℤ} (hd : d < 0) (z : ℤ√d) : z.norm = 0 ↔ z = 0 :=
begin
  split,
  { intro h,
    rw [ext, zero_re, zero_im],
    rw [norm_def, sub_eq_add_neg, mul_assoc] at h,
    have left := mul_self_nonneg z.re,
    have right := neg_nonneg.mpr (mul_nonpos_of_nonpos_of_nonneg hd.le (mul_self_nonneg z.im)),
    obtain ⟨ha, hb⟩ := (add_eq_zero_iff' left right).mp h,
    split; apply eq_zero_of_mul_self_eq_zero,
    { exact ha },
    { rw [neg_eq_zero, mul_eq_zero] at hb,
      exact hb.resolve_left hd.ne } },
  { rintro rfl, exact norm_zero }
end

lemma norm_eq_of_associated {d : ℤ} (hd : d ≤ 0) {x y : ℤ√d} (h : associated x y) :
  x.norm = y.norm :=
begin
  obtain ⟨u, rfl⟩ := h,
  rw [norm_mul, (norm_eq_one_iff' hd _).mpr u.is_unit, mul_one],
end

end norm

end

section
parameter {d : ℕ}

/-- Nonnegativity of an element of `ℤ√d`. -/
def nonneg : ℤ√d → Prop | ⟨a, b⟩ := nonnegg d 1 a b

protected def le (a b : ℤ√d) : Prop := nonneg (b - a)

instance : has_le ℤ√d := ⟨zsqrtd.le⟩

protected def lt (a b : ℤ√d) : Prop := ¬(b ≤ a)

instance : has_lt ℤ√d := ⟨zsqrtd.lt⟩

instance decidable_nonnegg (c d a b) : decidable (nonnegg c d a b) :=
by cases a; cases b; repeat {rw int.of_nat_eq_coe}; unfold nonnegg sq_le; apply_instance

instance decidable_nonneg : Π (a : ℤ√d), decidable (nonneg a)
| ⟨a, b⟩ := zsqrtd.decidable_nonnegg _ _ _ _

instance decidable_le (a b : ℤ√d) : decidable (a ≤ b) := decidable_nonneg _

theorem nonneg_cases : Π {a : ℤ√d}, nonneg a → ∃ x y : ℕ, a = ⟨x, y⟩ ∨ a = ⟨x, -y⟩ ∨ a = ⟨-x, y⟩
| ⟨(x : ℕ), (y : ℕ)⟩ h := ⟨x, y, or.inl rfl⟩
| ⟨(x : ℕ), -[1+ y]⟩ h := ⟨x, y+1, or.inr $ or.inl rfl⟩
| ⟨-[1+ x], (y : ℕ)⟩ h := ⟨x+1, y, or.inr $ or.inr rfl⟩
| ⟨-[1+ x], -[1+ y]⟩ h := false.elim h

lemma nonneg_add_lem {x y z w : ℕ} (xy : nonneg ⟨x, -y⟩) (zw : nonneg ⟨-z, w⟩) :
  nonneg (⟨x, -y⟩ + ⟨-z, w⟩) :=
have nonneg ⟨int.sub_nat_nat x z, int.sub_nat_nat w y⟩, from int.sub_nat_nat_elim x z
  (λm n i, sq_le y d m 1 → sq_le n 1 w d → nonneg ⟨i, int.sub_nat_nat w y⟩)
  (λj k, int.sub_nat_nat_elim w y
    (λm n i, sq_le n d (k + j) 1 → sq_le k 1 m d → nonneg ⟨int.of_nat j, i⟩)
    (λm n xy zw, trivial)
    (λm n xy zw, sq_le_cancel zw xy))
  (λj k, int.sub_nat_nat_elim w y
    (λm n i, sq_le n d k 1 → sq_le (k + j + 1) 1 m d → nonneg ⟨-[1+ j], i⟩)
    (λm n xy zw, sq_le_cancel xy zw)
    (λm n xy zw, let t := nat.le_trans zw (sq_le_of_le (nat.le_add_right n (m+1)) (le_refl _) xy) in
      have k + j + 1 ≤ k, from nat.mul_self_le_mul_self_iff.2 (by repeat{rw one_mul at t}; exact t),
      absurd this (not_le_of_gt $ nat.succ_le_succ $ nat.le_add_right _ _))) (nonnegg_pos_neg.1 xy)
        (nonnegg_neg_pos.1 zw),
show nonneg ⟨_, _⟩, by rw [neg_add_eq_sub];
  rwa [int.sub_nat_nat_eq_coe,int.sub_nat_nat_eq_coe] at this

theorem nonneg_add {a b : ℤ√d} (ha : nonneg a) (hb : nonneg b) : nonneg (a + b) :=
begin
  rcases nonneg_cases ha with ⟨x, y, rfl|rfl|rfl⟩;
  rcases nonneg_cases hb with ⟨z, w, rfl|rfl|rfl⟩; dsimp [add, nonneg] at ha hb ⊢,
  { trivial },
  { refine nonnegg_cases_right (λi h, sq_le_of_le _ _ (nonnegg_pos_neg.1 hb)),
    { exact int.coe_nat_le.1 (le_of_neg_le_neg (@int.le.intro _ _ y (by simp [add_comm, *]))) },
    { apply nat.le_add_left } },
  { refine nonnegg_cases_left (λi h, sq_le_of_le _ _ (nonnegg_neg_pos.1 hb)),
    { exact int.coe_nat_le.1 (le_of_neg_le_neg (@int.le.intro _ _ x (by simp [add_comm, *]))) },
    { apply nat.le_add_left } },
  { refine nonnegg_cases_right (λi h, sq_le_of_le _ _ (nonnegg_pos_neg.1 ha)),
    { exact int.coe_nat_le.1 (le_of_neg_le_neg (@int.le.intro _ _ w (by simp *))) },
    { apply nat.le_add_right } },
  { simpa [add_comm] using
      nonnegg_pos_neg.2 (sq_le_add (nonnegg_pos_neg.1 ha) (nonnegg_pos_neg.1 hb)) },
  { exact nonneg_add_lem ha hb },
  { refine nonnegg_cases_left (λi h, sq_le_of_le _ _ (nonnegg_neg_pos.1 ha)),
    { exact int.coe_nat_le.1 (le_of_neg_le_neg (int.le.intro h)) },
    { apply nat.le_add_right } },
  { rw [add_comm, add_comm ↑y], exact nonneg_add_lem hb ha },
  { simpa [add_comm] using
      nonnegg_neg_pos.2 (sq_le_add (nonnegg_neg_pos.1 ha) (nonnegg_neg_pos.1 hb)) },
end

theorem le_refl (a : ℤ√d) : a ≤ a := show nonneg (a - a), by simp

protected theorem le_trans {a b c : ℤ√d} (ab : a ≤ b) (bc : b ≤ c) : a ≤ c :=
have nonneg (b - a + (c - b)), from nonneg_add ab bc,
by simpa [sub_add_sub_cancel']

theorem nonneg_iff_zero_le {a : ℤ√d} : nonneg a ↔ 0 ≤ a := show _ ↔ nonneg _, by simp

theorem le_of_le_le {x y z w : ℤ} (xz : x ≤ z) (yw : y ≤ w) : (⟨x, y⟩ : ℤ√d) ≤ ⟨z, w⟩ :=
show nonneg ⟨z - x, w - y⟩, from
match z - x, w - y, int.le.dest_sub xz, int.le.dest_sub yw with ._, ._, ⟨a, rfl⟩, ⟨b, rfl⟩ :=
  trivial end

theorem le_arch (a : ℤ√d) : ∃n : ℕ, a ≤ n :=
let ⟨x, y, (h : a ≤ ⟨x, y⟩)⟩ := show ∃x y : ℕ, nonneg (⟨x, y⟩ + -a), from match -a with
| ⟨int.of_nat x, int.of_nat y⟩ := ⟨0, 0, trivial⟩
| ⟨int.of_nat x, -[1+ y]⟩      := ⟨0, y+1, by simp [int.neg_succ_of_nat_coe, add_assoc]⟩
| ⟨-[1+ x],      int.of_nat y⟩ := ⟨x+1, 0, by simp [int.neg_succ_of_nat_coe, add_assoc]⟩
| ⟨-[1+ x],      -[1+ y]⟩      := ⟨x+1, y+1, by simp [int.neg_succ_of_nat_coe, add_assoc]⟩
end in begin
  refine ⟨x + d*y, zsqrtd.le_trans h _⟩,
  rw [← int.cast_coe_nat, ← of_int_eq_coe],
  change nonneg ⟨(↑x + d*y) - ↑x, 0-↑y⟩,
  cases y with y,
  { simp },
  have h : ∀y, sq_le y d (d * y) 1 := λ y,
    by simpa [sq_le, mul_comm, mul_left_comm] using
       nat.mul_le_mul_right (y * y) (nat.le_mul_self d),
  rw [show (x:ℤ) + d * nat.succ y - x = d * nat.succ y, by simp],
  exact h (y+1)
end

protected theorem nonneg_total : Π (a : ℤ√d), nonneg a ∨ nonneg (-a)
| ⟨(x : ℕ), (y : ℕ)⟩ := or.inl trivial
| ⟨-[1+ x], -[1+ y]⟩ := or.inr trivial
| ⟨0,       -[1+ y]⟩ := or.inr trivial
| ⟨-[1+ x], 0⟩       := or.inr trivial
| ⟨(x+1:ℕ), -[1+ y]⟩ := nat.le_total
| ⟨-[1+ x], (y+1:ℕ)⟩ := nat.le_total

protected theorem le_total (a b : ℤ√d) : a ≤ b ∨ b ≤ a :=
let t := nonneg_total (b - a) in by rw [show -(b-a) = a-b, from neg_sub b a] at t; exact t

instance : preorder ℤ√d :=
{ le               := zsqrtd.le,
  le_refl          := zsqrtd.le_refl,
  le_trans         := @zsqrtd.le_trans,
  lt               := zsqrtd.lt,
  lt_iff_le_not_le := λ a b,
    (and_iff_right_of_imp (zsqrtd.le_total _ _).resolve_left).symm }

protected theorem add_le_add_left (a b : ℤ√d) (ab : a ≤ b) (c : ℤ√d) : c + a ≤ c + b :=
show nonneg _, by rw add_sub_add_left_eq_sub; exact ab

protected theorem le_of_add_le_add_left (a b c : ℤ√d) (h : c + a ≤ c + b) : a ≤ b :=
by simpa using zsqrtd.add_le_add_left _ _ h (-c)

protected theorem add_lt_add_left (a b : ℤ√d) (h : a < b) (c) : c + a < c + b :=
λ h', h (zsqrtd.le_of_add_le_add_left _ _ _ h')

theorem nonneg_smul {a : ℤ√d} {n : ℕ} (ha : nonneg a) : nonneg (n * a) :=
by rw ← int.cast_coe_nat; exact match a, nonneg_cases ha, ha with
| ._, ⟨x, y, or.inl rfl⟩,          ha := by rw smul_val; trivial
| ._, ⟨x, y, or.inr $ or.inl rfl⟩, ha := by rw smul_val; simpa using
  nonnegg_pos_neg.2 (sq_le_smul n $ nonnegg_pos_neg.1 ha)
| ._, ⟨x, y, or.inr $ or.inr rfl⟩, ha := by rw smul_val; simpa using
  nonnegg_neg_pos.2 (sq_le_smul n $ nonnegg_neg_pos.1 ha)
end

theorem nonneg_muld {a : ℤ√d} (ha : nonneg a) : nonneg (sqrtd * a) :=
by refine match a, nonneg_cases ha, ha with
| ._, ⟨x, y, or.inl rfl⟩,          ha := trivial
| ._, ⟨x, y, or.inr $ or.inl rfl⟩, ha := by simp; apply nonnegg_neg_pos.2;
  simpa [sq_le, mul_comm, mul_left_comm] using
    nat.mul_le_mul_left d (nonnegg_pos_neg.1 ha)
| ._, ⟨x, y, or.inr $ or.inr rfl⟩, ha := by simp; apply nonnegg_pos_neg.2;
  simpa [sq_le, mul_comm, mul_left_comm] using
    nat.mul_le_mul_left d (nonnegg_neg_pos.1 ha)
end

theorem nonneg_mul_lem {x y : ℕ} {a : ℤ√d} (ha : nonneg a) : nonneg (⟨x, y⟩ * a) :=
have (⟨x, y⟩ * a : ℤ√d) = x * a + sqrtd * (y * a), by rw [decompose, right_distrib, mul_assoc];
  refl,
by rw this; exact nonneg_add (nonneg_smul ha) (nonneg_muld $ nonneg_smul ha)

theorem nonneg_mul {a b : ℤ√d} (ha : nonneg a) (hb : nonneg b) : nonneg (a * b) :=
match a, b, nonneg_cases ha, nonneg_cases hb, ha, hb with
| ._, ._, ⟨x, y, or.inl rfl⟩,          ⟨z, w, or.inl rfl⟩,          ha, hb := trivial
| ._, ._, ⟨x, y, or.inl rfl⟩,          ⟨z, w, or.inr $ or.inr rfl⟩, ha, hb := nonneg_mul_lem hb
| ._, ._, ⟨x, y, or.inl rfl⟩,          ⟨z, w, or.inr $ or.inl rfl⟩, ha, hb := nonneg_mul_lem hb
| ._, ._, ⟨x, y, or.inr $ or.inr rfl⟩, ⟨z, w, or.inl rfl⟩,          ha, hb :=
  by rw mul_comm; exact nonneg_mul_lem ha
| ._, ._, ⟨x, y, or.inr $ or.inl rfl⟩, ⟨z, w, or.inl rfl⟩,          ha, hb :=
  by rw mul_comm; exact nonneg_mul_lem ha
| ._, ._, ⟨x, y, or.inr $ or.inr rfl⟩, ⟨z, w, or.inr $ or.inr rfl⟩, ha, hb :=
  by rw [calc (⟨-x, y⟩ * ⟨-z, w⟩ : ℤ√d) = ⟨_, _⟩ : rfl
      ... = ⟨x * z + d * y * w, -(x * w + y * z)⟩ : by simp [add_comm]]; exact
  nonnegg_pos_neg.2 (sq_le_mul.left (nonnegg_neg_pos.1 ha) (nonnegg_neg_pos.1 hb))
| ._, ._, ⟨x, y, or.inr $ or.inr rfl⟩, ⟨z, w, or.inr $ or.inl rfl⟩, ha, hb :=
  by rw [calc (⟨-x, y⟩ * ⟨z, -w⟩ : ℤ√d) = ⟨_, _⟩ : rfl
      ... = ⟨-(x * z + d * y * w), x * w + y * z⟩ : by simp [add_comm]]; exact
  nonnegg_neg_pos.2 (sq_le_mul.right.left (nonnegg_neg_pos.1 ha) (nonnegg_pos_neg.1 hb))
| ._, ._, ⟨x, y, or.inr $ or.inl rfl⟩, ⟨z, w, or.inr $ or.inr rfl⟩, ha, hb :=
  by rw [calc (⟨x, -y⟩ * ⟨-z, w⟩ : ℤ√d) = ⟨_, _⟩ : rfl
      ... = ⟨-(x * z + d * y * w), x * w + y * z⟩ : by simp [add_comm]]; exact
  nonnegg_neg_pos.2 (sq_le_mul.right.right.left (nonnegg_pos_neg.1 ha) (nonnegg_neg_pos.1 hb))
| ._, ._, ⟨x, y, or.inr $ or.inl rfl⟩, ⟨z, w, or.inr $ or.inl rfl⟩, ha, hb :=
  by rw [calc (⟨x, -y⟩ * ⟨z, -w⟩ : ℤ√d) = ⟨_, _⟩ : rfl
      ... = ⟨x * z + d * y * w, -(x * w + y * z)⟩ : by simp [add_comm]]; exact
  nonnegg_pos_neg.2 (sq_le_mul.right.right.right (nonnegg_pos_neg.1 ha) (nonnegg_pos_neg.1 hb))
end

protected theorem mul_nonneg (a b : ℤ√d) : 0 ≤ a → 0 ≤ b → 0 ≤ a * b :=
by repeat {rw ← nonneg_iff_zero_le}; exact nonneg_mul

theorem not_sq_le_succ (c d y) (h : 0 < c) : ¬sq_le (y + 1) c 0 d :=
not_le_of_gt $ mul_pos (mul_pos h $ nat.succ_pos _) $ nat.succ_pos _

/-- A nonsquare is a natural number that is not equal to the square of an
  integer. This is implemented as a typeclass because it's a necessary condition
  for much of the Pell equation theory. -/
class nonsquare (x : ℕ) : Prop := (ns [] : ∀n : ℕ, x ≠ n*n)

parameter [dnsq : nonsquare d]
include dnsq

theorem d_pos : 0 < d := lt_of_le_of_ne (nat.zero_le _) $ ne.symm $ (nonsquare.ns d 0)

theorem divides_sq_eq_zero {x y} (h : x * x = d * y * y) : x = 0 ∧ y = 0 :=
let g := x.gcd y in or.elim g.eq_zero_or_pos
  (λH, ⟨nat.eq_zero_of_gcd_eq_zero_left H, nat.eq_zero_of_gcd_eq_zero_right H⟩)
  (λgpos, false.elim $
    let ⟨m, n, co, (hx : x = m * g), (hy : y = n * g)⟩ := nat.exists_coprime gpos in
    begin
      rw [hx, hy] at h,
      have : m * m = d * (n * n) := nat.eq_of_mul_eq_mul_left (mul_pos gpos gpos)
        (by simpa [mul_comm, mul_left_comm] using h),
      have co2 := let co1 := co.mul_right co in co1.mul co1,
      exact nonsquare.ns d m (nat.dvd_antisymm (by rw this; apply dvd_mul_right) $
        co2.dvd_of_dvd_mul_right $ by simp [this])
    end)

theorem divides_sq_eq_zero_z {x y : ℤ} (h : x * x = d * y * y) : x = 0 ∧ y = 0 :=
by rw [mul_assoc, ← int.nat_abs_mul_self, ← int.nat_abs_mul_self, ← int.coe_nat_mul, ← mul_assoc]
  at h;
exact let ⟨h1, h2⟩ := divides_sq_eq_zero (int.coe_nat_inj h) in
⟨int.eq_zero_of_nat_abs_eq_zero h1, int.eq_zero_of_nat_abs_eq_zero h2⟩

theorem not_divides_sq (x y) : (x + 1) * (x + 1) ≠ d * (y + 1) * (y + 1) :=
λe, by have t := (divides_sq_eq_zero e).left; contradiction

theorem nonneg_antisymm : Π {a : ℤ√d}, nonneg a → nonneg (-a) → a = 0
| ⟨0,         0⟩         xy yx := rfl
| ⟨-[1+ x],   -[1+ y]⟩   xy yx := false.elim xy
| ⟨(x+1:nat), (y+1:nat)⟩ xy yx := false.elim yx
| ⟨-[1+ x],   0⟩         xy yx := absurd xy (not_sq_le_succ _ _ _ dec_trivial)
| ⟨(x+1:nat), 0⟩         xy yx := absurd yx (not_sq_le_succ _ _ _ dec_trivial)
| ⟨0,         -[1+ y]⟩   xy yx := absurd xy (not_sq_le_succ _ _ _ d_pos)
| ⟨0,         (y+1:nat)⟩ _  yx := absurd yx (not_sq_le_succ _ _ _ d_pos)
| ⟨(x+1:nat), -[1+ y]⟩   (xy : sq_le _ _ _ _) (yx : sq_le _ _ _ _) :=
  let t := le_antisymm yx xy in by rw[one_mul] at t; exact absurd t (not_divides_sq _ _)
| ⟨-[1+ x],   (y+1:nat)⟩ (xy : sq_le _ _ _ _) (yx : sq_le _ _ _ _) :=
  let t := le_antisymm xy yx in by rw[one_mul] at t; exact absurd t (not_divides_sq _ _)

theorem le_antisymm {a b : ℤ√d} (ab : a ≤ b) (ba : b ≤ a) : a = b :=
eq_of_sub_eq_zero $ nonneg_antisymm ba (by rw neg_sub; exact ab)

instance : linear_order ℤ√d :=
{ le_antisymm     := @zsqrtd.le_antisymm,
  le_total        := zsqrtd.le_total,
  decidable_le    := zsqrtd.decidable_le,
  ..zsqrtd.preorder }

protected theorem eq_zero_or_eq_zero_of_mul_eq_zero : Π {a b : ℤ√d}, a * b = 0 → a = 0 ∨ b = 0
| ⟨x, y⟩ ⟨z, w⟩ h := by injection h with h1 h2; exact
  have h1 : x*z = -(d*y*w), from eq_neg_of_add_eq_zero h1,
  have h2 : x*w = -(y*z), from eq_neg_of_add_eq_zero h2,
  have fin : x*x = d*y*y → (⟨x, y⟩:ℤ√d) = 0, from
  λe, match x, y, divides_sq_eq_zero_z e with ._, ._, ⟨rfl, rfl⟩ := rfl end,
  if z0 : z = 0 then if w0 : w = 0 then
    or.inr (match z, w, z0, w0 with ._, ._, rfl, rfl := rfl end)
  else
     or.inl $ fin $ mul_right_cancel₀ w0 $ calc
       x * x * w = -y * (x * z) : by simp [h2, mul_assoc, mul_left_comm]
             ... = d * y * y * w : by simp [h1, mul_assoc, mul_left_comm]
  else
     or.inl $ fin $ mul_right_cancel₀ z0 $ calc
       x * x * z = d * -y * (x * w) : by simp [h1, mul_assoc, mul_left_comm]
             ... = d * y * y * z : by simp [h2, mul_assoc, mul_left_comm]

instance : is_domain ℤ√d :=
{ eq_zero_or_eq_zero_of_mul_eq_zero := @zsqrtd.eq_zero_or_eq_zero_of_mul_eq_zero,
  .. zsqrtd.comm_ring, .. zsqrtd.nontrivial }

protected theorem mul_pos (a b : ℤ√d) (a0 : 0 < a) (b0 : 0 < b) : 0 < a * b := λab,
or.elim (eq_zero_or_eq_zero_of_mul_eq_zero
         (le_antisymm ab (mul_nonneg _ _ (le_of_lt a0) (le_of_lt b0))))
  (λe, ne_of_gt a0 e)
  (λe, ne_of_gt b0 e)

instance : linear_ordered_comm_ring ℤ√d :=
{ add_le_add_left := @zsqrtd.add_le_add_left,
  mul_pos         := @zsqrtd.mul_pos,
  zero_le_one     := dec_trivial,
  .. zsqrtd.comm_ring, .. zsqrtd.linear_order, .. zsqrtd.nontrivial }

instance : linear_ordered_ring ℤ√d := by apply_instance
instance : ordered_ring ℤ√d        := by apply_instance

end

lemma norm_eq_zero {d : ℤ} (h_nonsquare : ∀ n : ℤ, d ≠ n*n) (a : ℤ√d) :
  norm a = 0 ↔ a = 0 :=
begin
  refine ⟨λ ha, ext.mpr _, λ h, by rw [h, norm_zero]⟩,
  delta norm at ha,
  rw sub_eq_zero at ha,
  by_cases h : 0 ≤ d,
  { obtain ⟨d', rfl⟩ := int.eq_coe_of_zero_le h,
    haveI : nonsquare d' := ⟨λ n h, h_nonsquare n $ by exact_mod_cast h⟩,
    exact divides_sq_eq_zero_z ha, },
  { push_neg at h,
    suffices : a.re * a.re = 0,
    { rw eq_zero_of_mul_self_eq_zero this at ha ⊢,
      simpa only [true_and, or_self_right, zero_re, zero_im, eq_self_iff_true,
        zero_eq_mul, mul_zero, mul_eq_zero, h.ne, false_or, or_self] using ha },
    apply _root_.le_antisymm _ (mul_self_nonneg _),
    rw [ha, mul_assoc],
    exact mul_nonpos_of_nonpos_of_nonneg h.le (mul_self_nonneg _) }
end

variables {R : Type} [comm_ring R]

@[ext] lemma hom_ext {d : ℤ} (f g : ℤ√d →+* R) (h : f sqrtd = g sqrtd) : f = g :=
begin
  ext ⟨x_re, x_im⟩,
  simp [decompose, h],
end

/-- The unique `ring_hom` from `ℤ√d` to a ring `R`, constructed by replacing `√d` with the provided
root. Conversely, this associates to every mapping `ℤ√d →+* R` a value of `√d` in `R`. -/
@[simps]
def lift {d : ℤ} : {r : R // r * r = ↑d} ≃ (ℤ√d →+* R) :=
{ to_fun := λ r,
  { to_fun := λ a, a.1 + a.2*(r : R),
    map_zero' := by simp,
    map_add' := λ a b, by { simp, ring, },
    map_one' := by simp,
    map_mul' := λ a b, by
    { have : (a.re + a.im * r : R) * (b.re + b.im * r) =
              a.re * b.re + (a.re * b.im + a.im * b.re) * r + a.im * b.im * (r * r) := by ring,
      simp [this, r.prop],
      ring, } },
  inv_fun := λ f, ⟨f sqrtd, by rw [←f.map_mul, dmuld, ring_hom.map_int_cast]⟩,
  left_inv := λ r, by { ext, simp },
  right_inv := λ f, by { ext, simp } }

/-- `lift r` is injective if `d` is non-square, and R has characteristic zero (that is, the map from
`ℤ` into `R` is injective). -/
lemma lift_injective [char_zero R] {d : ℤ} (r : {r : R // r * r = ↑d}) (hd : ∀ n : ℤ, d ≠ n*n) :
  function.injective (lift r) :=
(lift r).injective_iff.mpr $ λ a ha,
begin
  have h_inj : function.injective (coe : ℤ → R) := int.cast_injective,
  suffices : lift r a.norm = 0,
  { simp only [coe_int_re, add_zero, lift_apply_apply, coe_int_im, int.cast_zero, zero_mul] at this,
    rwa [← int.cast_zero, h_inj.eq_iff, norm_eq_zero hd] at this },
  rw [norm_eq_mul_conj, ring_hom.map_mul, ha, zero_mul]
end

end zsqrtd