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

import field_theory.intermediate_field
import field_theory.separable
import ring_theory.tensor_product

/-!
# Adjoining Elements to Fields

In this file we introduce the notion of adjoining elements to fields.
This isn't quite the same as adjoining elements to rings.
For example, `algebra.adjoin K {x}` might not include `x⁻¹`.

## Main results

- `adjoin_adjoin_left`: adjoining S and then T is the same as adjoining `S ∪ T`.
- `bot_eq_top_of_dim_adjoin_eq_one`: if `F⟮x⟯` has dimension `1` over `F` for every `x`
  in `E` then `F = E`

## Notation

 - `F⟮α⟯`: adjoin a single element `α` to `F`.
-/

open finite_dimensional polynomial
open_locale classical polynomial

namespace intermediate_field

section adjoin_def
variables (F : Type*) [field F] {E : Type*} [field E] [algebra F E] (S : set E)

/-- `adjoin F S` extends a field `F` by adjoining a set `S ⊆ E`. -/
def adjoin : intermediate_field F E :=
{ algebra_map_mem' := λ x, subfield.subset_closure (or.inl (set.mem_range_self x)),
  ..subfield.closure (set.range (algebra_map F E) ∪ S) }

end adjoin_def

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

@[simp] lemma adjoin_le_iff {S : set E} {T : intermediate_field F E} : adjoin F S ≤ T ↔ S ≤ T :=
⟨λ H, le_trans (le_trans (set.subset_union_right _ _) subfield.subset_closure) H,
  λ H, (@subfield.closure_le E _ (set.range (algebra_map F E) ∪ S) T.to_subfield).mpr
  (set.union_subset (intermediate_field.set_range_subset T) H)⟩

lemma gc : galois_connection (adjoin F : set E → intermediate_field F E) coe := λ _ _, adjoin_le_iff

/-- Galois insertion between `adjoin` and `coe`. -/
def gi : galois_insertion (adjoin F : set E → intermediate_field F E) coe :=
{ choice := λ s hs, (adjoin F s).copy s $ le_antisymm (gc.le_u_l s) hs,
  gc := intermediate_field.gc,
  le_l_u := λ S, (intermediate_field.gc (S : set E) (adjoin F S)).1 $ le_rfl,
  choice_eq := λ _ _, copy_eq _ _ _ }

instance : complete_lattice (intermediate_field F E) :=
galois_insertion.lift_complete_lattice intermediate_field.gi

instance : inhabited (intermediate_field F E) := ⟨⊤⟩

lemma coe_bot : ↑(⊥ : intermediate_field F E) = set.range (algebra_map F E) :=
begin
  change ↑(subfield.closure (set.range (algebra_map F E) ∪ ∅)) = set.range (algebra_map F E),
  simp [←set.image_univ, ←ring_hom.map_field_closure]
end

lemma mem_bot {x : E} : x ∈ (⊥ : intermediate_field F E) ↔ x ∈ set.range (algebra_map F E) :=
set.ext_iff.mp coe_bot x

@[simp] lemma bot_to_subalgebra : (⊥ : intermediate_field F E).to_subalgebra = ⊥ :=
by { ext, rw [mem_to_subalgebra, algebra.mem_bot, mem_bot] }

@[simp] lemma coe_top : ↑(⊤ : intermediate_field F E) = (set.univ : set E) := rfl

@[simp] lemma mem_top {x : E} : x ∈ (⊤ : intermediate_field F E) :=
trivial

@[simp] lemma top_to_subalgebra : (⊤ : intermediate_field F E).to_subalgebra = ⊤ :=
rfl

@[simp] lemma top_to_subfield : (⊤ : intermediate_field F E).to_subfield = ⊤ :=
rfl

@[simp, norm_cast]
lemma coe_inf (S T : intermediate_field F E) : (↑(S ⊓ T) : set E) = S ∩ T := rfl

@[simp]
lemma mem_inf {S T : intermediate_field F E} {x : E} : x ∈ S ⊓ T ↔ x ∈ S ∧ x ∈ T := iff.rfl

@[simp] lemma inf_to_subalgebra (S T : intermediate_field F E) :
  (S ⊓ T).to_subalgebra = S.to_subalgebra ⊓ T.to_subalgebra :=
rfl

@[simp] lemma inf_to_subfield (S T : intermediate_field F E) :
  (S ⊓ T).to_subfield = S.to_subfield ⊓ T.to_subfield :=
rfl

@[simp, norm_cast]
lemma coe_Inf (S : set (intermediate_field F E)) : (↑(Inf S) : set E) = Inf (coe '' S) := rfl

@[simp] lemma Inf_to_subalgebra (S : set (intermediate_field F E)) :
  (Inf S).to_subalgebra = Inf (to_subalgebra '' S) :=
set_like.coe_injective $ by simp [set.sUnion_image]

@[simp] lemma Inf_to_subfield (S : set (intermediate_field F E)) :
  (Inf S).to_subfield = Inf (to_subfield '' S) :=
set_like.coe_injective $ by simp [set.sUnion_image]

@[simp, norm_cast]
lemma coe_infi {ι : Sort*} (S : ι → intermediate_field F E) : (↑(infi S) : set E) = ⋂ i, (S i) :=
by simp [infi]

@[simp] lemma infi_to_subalgebra {ι : Sort*} (S : ι → intermediate_field F E) :
  (infi S).to_subalgebra = ⨅ i, (S i).to_subalgebra :=
set_like.coe_injective $ by simp [infi]

@[simp] lemma infi_to_subfield {ι : Sort*} (S : ι → intermediate_field F E) :
  (infi S).to_subfield = ⨅ i, (S i).to_subfield :=
set_like.coe_injective $ by simp [infi]

/--  Construct an algebra isomorphism from an equality of intermediate fields -/
@[simps apply]
def equiv_of_eq {S T : intermediate_field F E} (h : S = T) : S ≃ₐ[F] T :=
by refine { to_fun := λ x, ⟨x, _⟩, inv_fun := λ x, ⟨x, _⟩, .. }; tidy

@[simp] lemma equiv_of_eq_symm {S T : intermediate_field F E} (h : S = T) :
  (equiv_of_eq h).symm = equiv_of_eq h.symm :=
rfl

@[simp] lemma equiv_of_eq_rfl (S : intermediate_field F E) :
  equiv_of_eq (rfl : S = S) = alg_equiv.refl :=
by { ext, refl }

@[simp] lemma equiv_of_eq_trans {S T U : intermediate_field F E} (hST : S = T) (hTU : T = U) :
  (equiv_of_eq hST).trans (equiv_of_eq hTU) = equiv_of_eq (trans hST hTU) :=
rfl

variables (F E)
/-- The bottom intermediate_field is isomorphic to the field. -/
noncomputable def bot_equiv : (⊥ : intermediate_field F E) ≃ₐ[F] F :=
(subalgebra.equiv_of_eq _ _ bot_to_subalgebra).trans (algebra.bot_equiv F E)
variables {F E}

@[simp] lemma bot_equiv_def (x : F) :
  bot_equiv F E (algebra_map F (⊥ : intermediate_field F E) x) = x :=
alg_equiv.commutes (bot_equiv F E) x

@[simp] lemma bot_equiv_symm (x : F) :
  (bot_equiv F E).symm x = algebra_map F _ x :=
rfl

noncomputable instance algebra_over_bot : algebra (⊥ : intermediate_field F E) F :=
(intermediate_field.bot_equiv F E).to_alg_hom.to_ring_hom.to_algebra

lemma coe_algebra_map_over_bot :
  (algebra_map (⊥ : intermediate_field F E) F : (⊥ : intermediate_field F E) → F) =
    (intermediate_field.bot_equiv F E) :=
rfl

instance is_scalar_tower_over_bot : is_scalar_tower (⊥ : intermediate_field F E) F E :=
is_scalar_tower.of_algebra_map_eq
begin
  intro x,
  obtain ⟨y, rfl⟩ := (bot_equiv F E).symm.surjective x,
  rw [coe_algebra_map_over_bot, (bot_equiv F E).apply_symm_apply, bot_equiv_symm,
      is_scalar_tower.algebra_map_apply F (⊥ : intermediate_field F E) E]
end

/-- The top intermediate_field is isomorphic to the field.

This is the intermediate field version of `subalgebra.top_equiv`. -/
@[simps apply] def top_equiv : (⊤ : intermediate_field F E) ≃ₐ[F] E :=
(subalgebra.equiv_of_eq _ _ top_to_subalgebra).trans subalgebra.top_equiv

@[simp] lemma top_equiv_symm_apply_coe (a : E) :
  ↑((top_equiv.symm) a : (⊤ : intermediate_field F E)) = a := rfl

@[simp] lemma coe_bot_eq_self (K : intermediate_field F E) : ↑(⊥ : intermediate_field K E) = K :=
by { ext, rw [mem_lift2, mem_bot], exact set.ext_iff.mp subtype.range_coe x }

@[simp] lemma coe_top_eq_top (K : intermediate_field F E) :
  ↑(⊤ : intermediate_field K E) = (⊤ : intermediate_field F E) :=
set_like.ext_iff.mpr $ λ _, mem_lift2.trans (iff_of_true mem_top mem_top)

end lattice

section adjoin_def
variables (F : Type*) [field F] {E : Type*} [field E] [algebra F E] (S : set E)

lemma adjoin_eq_range_algebra_map_adjoin :
  (adjoin F S : set E) = set.range (algebra_map (adjoin F S) E) := (subtype.range_coe).symm

lemma adjoin.algebra_map_mem (x : F) : algebra_map F E x ∈ adjoin F S :=
intermediate_field.algebra_map_mem (adjoin F S) x

lemma adjoin.range_algebra_map_subset : set.range (algebra_map F E) ⊆ adjoin F S :=
begin
  intros x hx,
  cases hx with f hf,
  rw ← hf,
  exact adjoin.algebra_map_mem F S f,
end

instance adjoin.field_coe : has_coe_t F (adjoin F S) :=
{coe := λ x, ⟨algebra_map F E x, adjoin.algebra_map_mem F S x⟩}

lemma subset_adjoin : S ⊆ adjoin F S :=
λ x hx, subfield.subset_closure (or.inr hx)

instance adjoin.set_coe : has_coe_t S (adjoin F S) :=
{coe := λ x, ⟨x,subset_adjoin F S (subtype.mem x)⟩}

@[mono] lemma adjoin.mono (T : set E) (h : S ⊆ T) : adjoin F S ≤ adjoin F T :=
galois_connection.monotone_l gc h

lemma adjoin_contains_field_as_subfield (F : subfield E) : (F : set E) ⊆ adjoin F S :=
λ x hx, adjoin.algebra_map_mem F S ⟨x, hx⟩

lemma subset_adjoin_of_subset_left {F : subfield E} {T : set E} (HT : T ⊆ F) : T ⊆ adjoin F S :=
λ x hx, (adjoin F S).algebra_map_mem ⟨x, HT hx⟩

lemma subset_adjoin_of_subset_right {T : set E} (H : T ⊆ S) : T ⊆ adjoin F S :=
λ x hx, subset_adjoin F S (H hx)

@[simp] lemma adjoin_empty (F E : Type*) [field F] [field E] [algebra F E] :
  adjoin F (∅ : set E) = ⊥ :=
eq_bot_iff.mpr (adjoin_le_iff.mpr (set.empty_subset _))

@[simp] lemma adjoin_univ (F E : Type*) [field F] [field E] [algebra F E] :
  adjoin F (set.univ : set E) = ⊤ :=
eq_top_iff.mpr $ subset_adjoin _ _

/-- If `K` is a field with `F ⊆ K` and `S ⊆ K` then `adjoin F S ≤ K`. -/
lemma adjoin_le_subfield {K : subfield E} (HF : set.range (algebra_map F E) ⊆ K)
  (HS : S ⊆ K) : (adjoin F S).to_subfield ≤ K :=
begin
  apply subfield.closure_le.mpr,
  rw set.union_subset_iff,
  exact ⟨HF, HS⟩,
end

lemma adjoin_subset_adjoin_iff {F' : Type*} [field F'] [algebra F' E]
  {S S' : set E} : (adjoin F S : set E) ⊆ adjoin F' S' ↔
  set.range (algebra_map F E) ⊆ adjoin F' S' ∧ S ⊆ adjoin F' S' :=
⟨λ h, ⟨trans (adjoin.range_algebra_map_subset _ _) h, trans (subset_adjoin _ _) h⟩,
  λ ⟨hF, hS⟩, subfield.closure_le.mpr (set.union_subset hF hS)⟩

/-- `F[S][T] = F[S ∪ T]` -/
lemma adjoin_adjoin_left (T : set E) : ↑(adjoin (adjoin F S) T) = adjoin F (S ∪ T) :=
begin
  rw set_like.ext'_iff,
  change ↑(adjoin (adjoin F S) T) = _,
  apply set.eq_of_subset_of_subset; rw adjoin_subset_adjoin_iff; split,
  { rintros _ ⟨⟨x, hx⟩, rfl⟩, exact adjoin.mono _ _ _ (set.subset_union_left _ _) hx },
  { exact subset_adjoin_of_subset_right _ _ (set.subset_union_right _ _) },
  { exact subset_adjoin_of_subset_left _ (adjoin.range_algebra_map_subset _ _) },
  { exact set.union_subset
            (subset_adjoin_of_subset_left _ (subset_adjoin _ _))
            (subset_adjoin _ _) },
end

@[simp] lemma adjoin_insert_adjoin (x : E) :
  adjoin F (insert x (adjoin F S : set E)) = adjoin F (insert x S) :=
le_antisymm
  (adjoin_le_iff.mpr (set.insert_subset.mpr ⟨subset_adjoin _ _ (set.mem_insert _ _),
   adjoin_le_iff.mpr (subset_adjoin_of_subset_right _ _ (set.subset_insert _ _))⟩))
  (adjoin.mono _ _ _ (set.insert_subset_insert (subset_adjoin _ _)))

/-- `F[S][T] = F[T][S]` -/
lemma adjoin_adjoin_comm (T : set E) :
  ↑(adjoin (adjoin F S) T) = (↑(adjoin (adjoin F T) S) : (intermediate_field F E)) :=
by rw [adjoin_adjoin_left, adjoin_adjoin_left, set.union_comm]

lemma adjoin_map {E' : Type*} [field E'] [algebra F E'] (f : E →ₐ[F] E') :
  (adjoin F S).map f = adjoin F (f '' S) :=
begin
  ext x,
  show x ∈ (subfield.closure (set.range (algebra_map F E) ∪ S)).map (f : E →+* E') ↔
       x ∈ subfield.closure (set.range (algebra_map F E') ∪ f '' S),
  rw [ring_hom.map_field_closure, set.image_union, ← set.range_comp, ← ring_hom.coe_comp,
      f.comp_algebra_map],
  refl,
end

lemma algebra_adjoin_le_adjoin : algebra.adjoin F S ≤ (adjoin F S).to_subalgebra :=
algebra.adjoin_le (subset_adjoin _ _)

lemma adjoin_eq_algebra_adjoin (inv_mem : ∀ x ∈ algebra.adjoin F S, x⁻¹ ∈ algebra.adjoin F S) :
  (adjoin F S).to_subalgebra = algebra.adjoin F S :=
le_antisymm
  (show adjoin F S ≤
      { neg_mem' := λ x, (algebra.adjoin F S).neg_mem, inv_mem' := inv_mem, .. algebra.adjoin F S},
    from adjoin_le_iff.mpr (algebra.subset_adjoin))
  (algebra_adjoin_le_adjoin _ _)

lemma eq_adjoin_of_eq_algebra_adjoin (K : intermediate_field F E)
  (h : K.to_subalgebra = algebra.adjoin F S) : K = adjoin F S :=
begin
  apply to_subalgebra_injective,
  rw h,
  refine (adjoin_eq_algebra_adjoin _ _ _).symm,
  intros x,
  convert K.inv_mem,
  rw ← h,
  refl
end

@[elab_as_eliminator]
lemma adjoin_induction {s : set E} {p : E → Prop} {x} (h : x ∈ adjoin F s)
  (Hs : ∀ x ∈ s, p x) (Hmap : ∀ x, p (algebra_map F E x))
  (Hadd : ∀ x y, p x → p y → p (x + y))
  (Hneg : ∀ x, p x → p (-x))
  (Hinv : ∀ x, p x → p x⁻¹)
  (Hmul : ∀ x y, p x → p y → p (x * y)) : p x :=
subfield.closure_induction h (λ x hx, or.cases_on hx (λ ⟨x, hx⟩, hx ▸ Hmap x) (Hs x))
  ((algebra_map F E).map_one ▸ Hmap 1)
  Hadd Hneg Hinv Hmul

/--
Variation on `set.insert` to enable good notation for adjoining elements to fields.
Used to preferentially use `singleton` rather than `insert` when adjoining one element.
-/
--this definition of notation is courtesy of Kyle Miller on zulip
class insert {α : Type*} (s : set α) :=
(insert : α → set α)

@[priority 1000]
instance insert_empty {α : Type*} : insert (∅ : set α) :=
{ insert := λ x, @singleton _ _ set.has_singleton x }

@[priority 900]
instance insert_nonempty {α : Type*} (s : set α) : insert s :=
{ insert := λ x, set.insert x s }

notation K`⟮`:std.prec.max_plus l:(foldr `, ` (h t, insert.insert t h) ∅) `⟯` := adjoin K l

section adjoin_simple
variables (α : E)

lemma mem_adjoin_simple_self : α ∈ F⟮α⟯ :=
subset_adjoin F {α} (set.mem_singleton α)

/-- generator of `F⟮α⟯` -/
def adjoin_simple.gen : F⟮α⟯ := ⟨α, mem_adjoin_simple_self F α⟩

@[simp] lemma adjoin_simple.algebra_map_gen : algebra_map F⟮α⟯ E (adjoin_simple.gen F α) = α := rfl

@[simp] lemma adjoin_simple.is_integral_gen :
  is_integral F (adjoin_simple.gen F α) ↔ is_integral F α :=
by { conv_rhs { rw ← adjoin_simple.algebra_map_gen F α },
     rw is_integral_algebra_map_iff (algebra_map F⟮α⟯ E).injective,
     apply_instance }

lemma adjoin_simple_adjoin_simple (β : E) : ↑F⟮α⟯⟮β⟯ = F⟮α, β⟯ :=
adjoin_adjoin_left _ _ _

lemma adjoin_simple_comm (β : E) : ↑F⟮α⟯⟮β⟯ = (↑F⟮β⟯⟮α⟯ : intermediate_field F E) :=
adjoin_adjoin_comm _ _ _

-- TODO: develop the API for `subalgebra.is_field_of_algebraic` so it can be used here
lemma adjoin_simple_to_subalgebra_of_integral (hα : is_integral F α) :
  (F⟮α⟯).to_subalgebra = algebra.adjoin F {α} :=
begin
  apply adjoin_eq_algebra_adjoin,
  intros x hx,
  by_cases x = 0,
  { rw [h, inv_zero], exact subalgebra.zero_mem (algebra.adjoin F {α}) },

  let ϕ := alg_equiv.adjoin_singleton_equiv_adjoin_root_minpoly F α,
  haveI := minpoly.irreducible hα,
  suffices : ϕ ⟨x, hx⟩ * (ϕ ⟨x, hx⟩)⁻¹ = 1,
  { convert subtype.mem (ϕ.symm (ϕ ⟨x, hx⟩)⁻¹),
    refine inv_eq_of_mul_eq_one_right _,
    apply_fun ϕ.symm at this,
    rw [alg_equiv.map_one, alg_equiv.map_mul, alg_equiv.symm_apply_apply] at this,
    rw [←subsemiring.coe_one, ←this, subsemiring.coe_mul, subtype.coe_mk] },

  rw mul_inv_cancel (mt (λ key, _) h),
  rw ← ϕ.map_zero at key,
  change ↑(⟨x, hx⟩ : algebra.adjoin F {α}) = _,
  rw [ϕ.injective key, subalgebra.coe_zero]
end

end adjoin_simple
end adjoin_def

section adjoin_intermediate_field_lattice
variables {F : Type*} [field F] {E : Type*} [field E] [algebra F E] {α : E} {S : set E}

@[simp] lemma adjoin_eq_bot_iff : adjoin F S = ⊥ ↔ S ⊆ (⊥ : intermediate_field F E) :=
by { rw [eq_bot_iff, adjoin_le_iff], refl, }

@[simp] lemma adjoin_simple_eq_bot_iff : F⟮α⟯ = ⊥ ↔ α ∈ (⊥ : intermediate_field F E) :=
by { rw adjoin_eq_bot_iff, exact set.singleton_subset_iff }

@[simp] lemma adjoin_zero : F⟮(0 : E)⟯ = ⊥ :=
adjoin_simple_eq_bot_iff.mpr (zero_mem ⊥)

@[simp] lemma adjoin_one : F⟮(1 : E)⟯ = ⊥ :=
adjoin_simple_eq_bot_iff.mpr (one_mem ⊥)

@[simp] lemma adjoin_int (n : ℤ) : F⟮(n : E)⟯ = ⊥ :=
adjoin_simple_eq_bot_iff.mpr (coe_int_mem ⊥ n)

@[simp] lemma adjoin_nat (n : ℕ) : F⟮(n : E)⟯ = ⊥ :=
adjoin_simple_eq_bot_iff.mpr (coe_int_mem ⊥ n)

section adjoin_dim
open finite_dimensional module

variables {K L : intermediate_field F E}

@[simp] lemma dim_eq_one_iff : module.rank F K = 1 ↔ K = ⊥ :=
by rw [← to_subalgebra_eq_iff, ← dim_eq_dim_subalgebra,
  subalgebra.dim_eq_one_iff, bot_to_subalgebra]

@[simp] lemma finrank_eq_one_iff : finrank F K = 1 ↔ K = ⊥ :=
by rw [← to_subalgebra_eq_iff, ← finrank_eq_finrank_subalgebra,
  subalgebra.finrank_eq_one_iff, bot_to_subalgebra]

@[simp] lemma dim_bot : module.rank F (⊥ : intermediate_field F E) = 1 :=
by rw dim_eq_one_iff

@[simp] lemma finrank_bot : finrank F (⊥ : intermediate_field F E) = 1 :=
by rw finrank_eq_one_iff

lemma dim_adjoin_eq_one_iff : module.rank F (adjoin F S) = 1 ↔ S ⊆ (⊥ : intermediate_field F E) :=
iff.trans dim_eq_one_iff adjoin_eq_bot_iff

lemma dim_adjoin_simple_eq_one_iff : module.rank F F⟮α⟯ = 1 ↔ α ∈ (⊥ : intermediate_field F E) :=
by { rw dim_adjoin_eq_one_iff, exact set.singleton_subset_iff }

lemma finrank_adjoin_eq_one_iff : finrank F (adjoin F S) = 1 ↔ S ⊆ (⊥ : intermediate_field F E) :=
iff.trans finrank_eq_one_iff adjoin_eq_bot_iff

lemma finrank_adjoin_simple_eq_one_iff : finrank F F⟮α⟯ = 1 ↔ α ∈ (⊥ : intermediate_field F E) :=
by { rw [finrank_adjoin_eq_one_iff], exact set.singleton_subset_iff }

/-- If `F⟮x⟯` has dimension `1` over `F` for every `x ∈ E` then `F = E`. -/
lemma bot_eq_top_of_dim_adjoin_eq_one (h : ∀ x : E, module.rank F F⟮x⟯ = 1) :
  (⊥ : intermediate_field F E) = ⊤ :=
begin
  ext,
  rw iff_true_right intermediate_field.mem_top,
  exact dim_adjoin_simple_eq_one_iff.mp (h x),
end

lemma bot_eq_top_of_finrank_adjoin_eq_one (h : ∀ x : E, finrank F F⟮x⟯ = 1) :
  (⊥ : intermediate_field F E) = ⊤ :=
begin
  ext,
  rw iff_true_right intermediate_field.mem_top,
  exact finrank_adjoin_simple_eq_one_iff.mp (h x),
end

lemma subsingleton_of_dim_adjoin_eq_one (h : ∀ x : E, module.rank F F⟮x⟯ = 1) :
  subsingleton (intermediate_field F E) :=
subsingleton_of_bot_eq_top (bot_eq_top_of_dim_adjoin_eq_one h)

lemma subsingleton_of_finrank_adjoin_eq_one (h : ∀ x : E, finrank F F⟮x⟯ = 1) :
  subsingleton (intermediate_field F E) :=
subsingleton_of_bot_eq_top (bot_eq_top_of_finrank_adjoin_eq_one h)

/-- If `F⟮x⟯` has dimension `≤1` over `F` for every `x ∈ E` then `F = E`. -/
lemma bot_eq_top_of_finrank_adjoin_le_one [finite_dimensional F E]
  (h : ∀ x : E, finrank F F⟮x⟯ ≤ 1) : (⊥ : intermediate_field F E) = ⊤ :=
begin
  apply bot_eq_top_of_finrank_adjoin_eq_one,
  exact λ x, by linarith [h x, show 0 < finrank F F⟮x⟯, from finrank_pos],
end

lemma subsingleton_of_finrank_adjoin_le_one [finite_dimensional F E]
  (h : ∀ x : E, finrank F F⟮x⟯ ≤ 1) : subsingleton (intermediate_field F E) :=
subsingleton_of_bot_eq_top (bot_eq_top_of_finrank_adjoin_le_one h)

end adjoin_dim
end adjoin_intermediate_field_lattice

section adjoin_integral_element

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

lemma minpoly_gen {α : E} (h : is_integral F α) :
  minpoly F (adjoin_simple.gen F α) = minpoly F α :=
begin
  rw ← adjoin_simple.algebra_map_gen F α at h,
  have inj := (algebra_map F⟮α⟯ E).injective,
  exact minpoly.eq_of_algebra_map_eq inj ((is_integral_algebra_map_iff inj).mp h)
    (adjoin_simple.algebra_map_gen _ _).symm
end

variables (F)
lemma aeval_gen_minpoly (α : E) :
  aeval (adjoin_simple.gen F α) (minpoly F α) = 0 :=
begin
  ext,
  convert minpoly.aeval F α,
  conv in (aeval α) { rw [← adjoin_simple.algebra_map_gen F α] },
  exact is_scalar_tower.algebra_map_aeval F F⟮α⟯ E _ _
end

/-- algebra isomorphism between `adjoin_root` and `F⟮α⟯` -/
noncomputable def adjoin_root_equiv_adjoin (h : is_integral F α) :
  adjoin_root (minpoly F α) ≃ₐ[F] F⟮α⟯ :=
alg_equiv.of_bijective
  (adjoin_root.lift_hom (minpoly F α) (adjoin_simple.gen F α) (aeval_gen_minpoly F α))
  (begin
    set f := adjoin_root.lift _ _ (aeval_gen_minpoly F α : _),
    haveI := minpoly.irreducible h,
    split,
    { exact ring_hom.injective f },
    { suffices : F⟮α⟯.to_subfield ≤ ring_hom.field_range ((F⟮α⟯.to_subfield.subtype).comp f),
      { exact λ x, Exists.cases_on (this (subtype.mem x)) (λ y hy, ⟨y, subtype.ext hy⟩) },
      exact subfield.closure_le.mpr (set.union_subset (λ x hx, Exists.cases_on hx (λ y hy,
        ⟨y, by { rw [ring_hom.comp_apply, adjoin_root.lift_of], exact hy }⟩))
        (set.singleton_subset_iff.mpr ⟨adjoin_root.root (minpoly F α),
        by { rw [ring_hom.comp_apply, adjoin_root.lift_root], refl }⟩)) } end)

lemma adjoin_root_equiv_adjoin_apply_root (h : is_integral F α) :
  adjoin_root_equiv_adjoin F h (adjoin_root.root (minpoly F α)) =
    adjoin_simple.gen F α :=
adjoin_root.lift_root (aeval_gen_minpoly F α)

section power_basis

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

/-- The elements `1, x, ..., x ^ (d - 1)` form a basis for `K⟮x⟯`,
where `d` is the degree of the minimal polynomial of `x`. -/
noncomputable def power_basis_aux {x : L} (hx : is_integral K x) :
  basis (fin (minpoly K x).nat_degree) K K⟮x⟯ :=
(adjoin_root.power_basis (minpoly.ne_zero hx)).basis.map
  (adjoin_root_equiv_adjoin K hx).to_linear_equiv

/-- The power basis `1, x, ..., x ^ (d - 1)` for `K⟮x⟯`,
where `d` is the degree of the minimal polynomial of `x`. -/
@[simps]
noncomputable def adjoin.power_basis {x : L} (hx : is_integral K x) :
  power_basis K K⟮x⟯ :=
{ gen := adjoin_simple.gen K x,
  dim := (minpoly K x).nat_degree,
  basis := power_basis_aux hx,
  basis_eq_pow := λ i,
    by rw [power_basis_aux, basis.map_apply, power_basis.basis_eq_pow,
           alg_equiv.to_linear_equiv_apply, alg_equiv.map_pow, adjoin_root.power_basis_gen,
           adjoin_root_equiv_adjoin_apply_root] }

lemma adjoin.finite_dimensional {x : L} (hx : is_integral K x) : finite_dimensional K K⟮x⟯ :=
power_basis.finite_dimensional (adjoin.power_basis hx)

lemma adjoin.finrank {x : L} (hx : is_integral K x) :
  finite_dimensional.finrank K K⟮x⟯ = (minpoly K x).nat_degree :=
begin
  rw power_basis.finrank (adjoin.power_basis hx : _),
  refl
end

end power_basis

/-- Algebra homomorphism `F⟮α⟯ →ₐ[F] K` are in bijection with the set of roots
of `minpoly α` in `K`. -/
noncomputable def alg_hom_adjoin_integral_equiv (h : is_integral F α) :
  (F⟮α⟯ →ₐ[F] K) ≃ {x // x ∈ ((minpoly F α).map (algebra_map F K)).roots} :=
(adjoin.power_basis h).lift_equiv'.trans ((equiv.refl _).subtype_equiv (λ x,
  by rw [adjoin.power_basis_gen, minpoly_gen h, equiv.refl_apply]))

/-- Fintype of algebra homomorphism `F⟮α⟯ →ₐ[F] K` -/
noncomputable def fintype_of_alg_hom_adjoin_integral (h : is_integral F α) :
  fintype (F⟮α⟯ →ₐ[F] K) :=
power_basis.alg_hom.fintype (adjoin.power_basis h)

lemma card_alg_hom_adjoin_integral (h : is_integral F α) (h_sep : (minpoly F α).separable)
  (h_splits : (minpoly F α).splits (algebra_map F K)) :
  @fintype.card (F⟮α⟯ →ₐ[F] K) (fintype_of_alg_hom_adjoin_integral F h) =
    (minpoly F α).nat_degree :=
begin
  rw alg_hom.card_of_power_basis;
    simp only [adjoin.power_basis_dim, adjoin.power_basis_gen, minpoly_gen h, h_sep, h_splits],
end

end adjoin_integral_element

section induction

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

/-- An intermediate field `S` is finitely generated if there exists `t : finset E` such that
`intermediate_field.adjoin F t = S`. -/
def fg (S : intermediate_field F E) : Prop := ∃ (t : finset E), adjoin F ↑t = S

lemma fg_adjoin_finset (t : finset E) : (adjoin F (↑t : set E)).fg :=
⟨t, rfl⟩

theorem fg_def {S : intermediate_field F E} : S.fg ↔ ∃ t : set E, set.finite t ∧ adjoin F t = S :=
⟨λ ⟨t, ht⟩, ⟨↑t, set.finite_mem_finset t, ht⟩,
 λ ⟨t, ht1, ht2⟩, ⟨ht1.to_finset, by rwa set.finite.coe_to_finset⟩⟩

theorem fg_bot : (⊥ : intermediate_field F E).fg :=
⟨∅, adjoin_empty F E⟩

lemma fg_of_fg_to_subalgebra (S : intermediate_field F E)
  (h : S.to_subalgebra.fg) : S.fg :=
begin
  cases h with t ht,
  exact ⟨t, (eq_adjoin_of_eq_algebra_adjoin _ _ _ ht.symm).symm⟩
end

lemma fg_of_noetherian (S : intermediate_field F E)
  [is_noetherian F E] : S.fg :=
S.fg_of_fg_to_subalgebra S.to_subalgebra.fg_of_noetherian

lemma induction_on_adjoin_finset (S : finset E) (P : intermediate_field F E → Prop) (base : P ⊥)
  (ih : ∀ (K : intermediate_field F E) (x ∈ S), P K → P ↑K⟮x⟯) : P (adjoin F ↑S) :=
begin
  apply finset.induction_on' S,
  { exact base },
  { intros a s h1 _ _ h4,
    rw [finset.coe_insert, set.insert_eq, set.union_comm, ←adjoin_adjoin_left],
    exact ih (adjoin F s) a h1 h4 }
end

lemma induction_on_adjoin_fg (P : intermediate_field F E → Prop)
  (base : P ⊥) (ih : ∀ (K : intermediate_field F E) (x : E), P K → P ↑K⟮x⟯)
  (K : intermediate_field F E) (hK : K.fg) : P K :=
begin
  obtain ⟨S, rfl⟩ := hK,
  exact induction_on_adjoin_finset S P base (λ K x _ hK, ih K x hK),
end

lemma induction_on_adjoin [fd : finite_dimensional F E] (P : intermediate_field F E → Prop)
  (base : P ⊥) (ih : ∀ (K : intermediate_field F E) (x : E), P K → P ↑K⟮x⟯)
  (K : intermediate_field F E) : P K :=
begin
  letI : is_noetherian F E := is_noetherian.iff_fg.2 infer_instance,
  exact induction_on_adjoin_fg P base ih K K.fg_of_noetherian
end

end induction

section alg_hom_mk_adjoin_splits

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

/-- Lifts `L → K` of `F → K` -/
def lifts := Σ (L : intermediate_field F E), (L →ₐ[F] K)

variables {F E K}

instance : partial_order (lifts F E K) :=
{ le := λ x y, x.1 ≤ y.1 ∧ (∀ (s : x.1) (t : y.1), (s : E) = t → x.2 s = y.2 t),
  le_refl := λ x, ⟨le_refl x.1, λ s t hst, congr_arg x.2 (subtype.ext hst)⟩,
  le_trans := λ x y z hxy hyz, ⟨le_trans hxy.1 hyz.1, λ s u hsu, eq.trans
    (hxy.2 s ⟨s, hxy.1 s.mem⟩ rfl) (hyz.2 ⟨s, hxy.1 s.mem⟩ u hsu)⟩,
  le_antisymm :=
  begin
    rintros ⟨x1, x2⟩ ⟨y1, y2⟩ ⟨hxy1, hxy2⟩ ⟨hyx1, hyx2⟩,
    obtain rfl : x1 = y1 := le_antisymm hxy1 hyx1,
    congr,
    exact alg_hom.ext (λ s, hxy2 s s rfl),
  end }

noncomputable instance : order_bot (lifts F E K) :=
{ bot := ⟨⊥, (algebra.of_id F K).comp (bot_equiv F E).to_alg_hom⟩,
  bot_le := λ x, ⟨bot_le, λ s t hst,
  begin
    cases intermediate_field.mem_bot.mp s.mem with u hu,
    rw [show s = (algebra_map F _) u, from subtype.ext hu.symm, alg_hom.commutes],
    rw [show t = (algebra_map F _) u, from subtype.ext (eq.trans hu hst).symm, alg_hom.commutes],
  end⟩ }

noncomputable instance : inhabited (lifts F E K) := ⟨⊥⟩

lemma lifts.eq_of_le {x y : lifts F E K} (hxy : x ≤ y) (s : x.1) :
  x.2 s = y.2 ⟨s, hxy.1 s.mem⟩ := hxy.2 s ⟨s, hxy.1 s.mem⟩ rfl

lemma lifts.exists_max_two {c : set (lifts F E K)} {x y : lifts F E K} (hc : is_chain (≤) c)
  (hx : x ∈ set.insert ⊥ c) (hy : y ∈ set.insert ⊥ c) :
  ∃ z : lifts F E K, z ∈ set.insert ⊥ c ∧ x ≤ z ∧ y ≤ z :=
begin
  cases (hc.insert $ λ _ _ _, or.inl bot_le).total hx hy with hxy hyx,
  { exact ⟨y, hy, hxy, le_refl y⟩ },
  { exact ⟨x, hx, le_refl x, hyx⟩ },
end

lemma lifts.exists_max_three {c : set (lifts F E K)} {x y z : lifts F E K} (hc : is_chain (≤) c)
  (hx : x ∈ set.insert ⊥ c) (hy : y ∈ set.insert ⊥ c) (hz : z ∈ set.insert ⊥ c) :
  ∃ w  : lifts F E K, w ∈ set.insert ⊥ c ∧ x ≤ w ∧ y ≤ w ∧ z ≤ w :=
begin
  obtain ⟨v, hv, hxv, hyv⟩ := lifts.exists_max_two hc hx hy,
  obtain ⟨w, hw, hzw, hvw⟩ := lifts.exists_max_two hc hz hv,
  exact ⟨w, hw, le_trans hxv hvw, le_trans hyv hvw, hzw⟩,
end

/-- An upper bound on a chain of lifts -/
def lifts.upper_bound_intermediate_field {c : set (lifts F E K)} (hc : is_chain (≤) c) :
  intermediate_field F E :=
{ carrier := λ s, ∃ x : (lifts F E K), x ∈ set.insert ⊥ c ∧ (s ∈ x.1 : Prop),
  zero_mem' := ⟨⊥, set.mem_insert ⊥ c, zero_mem ⊥⟩,
  one_mem' := ⟨⊥, set.mem_insert ⊥ c, one_mem ⊥⟩,
  neg_mem' := by { rintros _ ⟨x, y, h⟩, exact ⟨x, ⟨y, x.1.neg_mem h⟩⟩ },
  inv_mem' := by { rintros _ ⟨x, y, h⟩, exact ⟨x, ⟨y, x.1.inv_mem h⟩⟩ },
  add_mem' := by
  { rintros _ _ ⟨x, hx, ha⟩ ⟨y, hy, hb⟩,
    obtain ⟨z, hz, hxz, hyz⟩ := lifts.exists_max_two hc hx hy,
    exact ⟨z, hz, z.1.add_mem (hxz.1 ha) (hyz.1 hb)⟩ },
  mul_mem' := by
  { rintros _ _ ⟨x, hx, ha⟩ ⟨y, hy, hb⟩,
    obtain ⟨z, hz, hxz, hyz⟩ := lifts.exists_max_two hc hx hy,
    exact ⟨z, hz, z.1.mul_mem (hxz.1 ha) (hyz.1 hb)⟩ },
  algebra_map_mem' := λ s, ⟨⊥, set.mem_insert ⊥ c, algebra_map_mem ⊥ s⟩ }

/-- The lift on the upper bound on a chain of lifts -/
noncomputable def lifts.upper_bound_alg_hom {c : set (lifts F E K)} (hc : is_chain (≤) c) :
  lifts.upper_bound_intermediate_field hc →ₐ[F] K :=
{ to_fun := λ s, (classical.some s.mem).2 ⟨s, (classical.some_spec s.mem).2⟩,
  map_zero' := alg_hom.map_zero _,
  map_one' := alg_hom.map_one _,
  map_add' := λ s t, begin
    obtain ⟨w, hw, hxw, hyw, hzw⟩ := lifts.exists_max_three hc
      (classical.some_spec s.mem).1 (classical.some_spec t.mem).1
      (classical.some_spec (s + t).mem).1,
    rw [lifts.eq_of_le hxw, lifts.eq_of_le hyw, lifts.eq_of_le hzw, ←w.2.map_add],
    refl,
  end,
  map_mul' := λ s t, begin
    obtain ⟨w, hw, hxw, hyw, hzw⟩ := lifts.exists_max_three hc
      (classical.some_spec s.mem).1 (classical.some_spec t.mem).1
      (classical.some_spec (s * t).mem).1,
    rw [lifts.eq_of_le hxw, lifts.eq_of_le hyw, lifts.eq_of_le hzw, ←w.2.map_mul],
    refl,
  end,
  commutes' := λ _, alg_hom.commutes _ _ }

/-- An upper bound on a chain of lifts -/
noncomputable def lifts.upper_bound {c : set (lifts F E K)} (hc : is_chain (≤) c) :
  lifts F E K :=
⟨lifts.upper_bound_intermediate_field hc, lifts.upper_bound_alg_hom hc⟩

lemma lifts.exists_upper_bound (c : set (lifts F E K)) (hc : is_chain (≤) c) :
  ∃ ub, ∀ a ∈ c, a ≤ ub :=
⟨lifts.upper_bound hc,
begin
  intros x hx,
  split,
  { exact λ s hs, ⟨x, set.mem_insert_of_mem ⊥ hx, hs⟩ },
  { intros s t hst,
    change x.2 s = (classical.some t.mem).2 ⟨t, (classical.some_spec t.mem).2⟩,
    obtain ⟨z, hz, hxz, hyz⟩ := lifts.exists_max_two hc (set.mem_insert_of_mem ⊥ hx)
      (classical.some_spec t.mem).1,
    rw [lifts.eq_of_le hxz, lifts.eq_of_le hyz],
    exact congr_arg z.2 (subtype.ext hst) },
end⟩

/-- Extend a lift `x : lifts F E K` to an element `s : E` whose conjugates are all in `K` -/
noncomputable def lifts.lift_of_splits (x : lifts F E K) {s : E} (h1 : is_integral F s)
  (h2 : (minpoly F s).splits (algebra_map F K)) : lifts F E K :=
let h3 : is_integral x.1 s := is_integral_of_is_scalar_tower s h1 in
let key : (minpoly x.1 s).splits x.2.to_ring_hom :=
  splits_of_splits_of_dvd _ (map_ne_zero (minpoly.ne_zero h1))
  ((splits_map_iff _ _).mpr (by {convert h2, exact ring_hom.ext (λ y, x.2.commutes y)}))
  (minpoly.dvd_map_of_is_scalar_tower _ _ _) in
⟨↑x.1⟮s⟯, (@alg_hom_equiv_sigma F x.1 (↑x.1⟮s⟯ : intermediate_field F E) K _ _ _ _ _ _ _
  (intermediate_field.algebra x.1⟮s⟯) (is_scalar_tower.of_algebra_map_eq (λ _, rfl))).inv_fun
  ⟨x.2, (@alg_hom_adjoin_integral_equiv x.1 _ E _ _ s K _ x.2.to_ring_hom.to_algebra
  h3).inv_fun ⟨root_of_splits x.2.to_ring_hom key (ne_of_gt (minpoly.degree_pos h3)), by
{ simp_rw [mem_roots (map_ne_zero (minpoly.ne_zero h3)), is_root, ←eval₂_eq_eval_map],
  exact map_root_of_splits x.2.to_ring_hom key (ne_of_gt (minpoly.degree_pos h3)) }⟩⟩⟩

lemma lifts.le_lifts_of_splits (x : lifts F E K) {s : E} (h1 : is_integral F s)
  (h2 : (minpoly F s).splits (algebra_map F K)) : x ≤ x.lift_of_splits h1 h2 :=
⟨λ z hz, algebra_map_mem x.1⟮s⟯ ⟨z, hz⟩, λ t u htu, eq.symm begin
  rw [←(show algebra_map x.1 x.1⟮s⟯ t = u, from subtype.ext htu)],
  letI : algebra x.1 K := x.2.to_ring_hom.to_algebra,
  exact (alg_hom.commutes _ t),
end⟩

lemma lifts.mem_lifts_of_splits (x : lifts F E K) {s : E} (h1 : is_integral F s)
  (h2 : (minpoly F s).splits (algebra_map F K)) : s ∈ (x.lift_of_splits h1 h2).1 :=
mem_adjoin_simple_self x.1 s

lemma lifts.exists_lift_of_splits (x : lifts F E K) {s : E} (h1 : is_integral F s)
  (h2 : (minpoly F s).splits (algebra_map F K)) : ∃ y, x ≤ y ∧ s ∈ y.1 :=
⟨x.lift_of_splits h1 h2, x.le_lifts_of_splits h1 h2, x.mem_lifts_of_splits h1 h2⟩

lemma alg_hom_mk_adjoin_splits
  (hK : ∀ s ∈ S, is_integral F (s : E) ∧ (minpoly F s).splits (algebra_map F K)) :
  nonempty (adjoin F S →ₐ[F] K) :=
begin
  obtain ⟨x : lifts F E K, hx⟩ := zorn_partial_order lifts.exists_upper_bound,
  refine ⟨alg_hom.mk (λ s, x.2 ⟨s, adjoin_le_iff.mpr (λ s hs, _) s.mem⟩) x.2.map_one (λ s t,
    x.2.map_mul ⟨s, _⟩ ⟨t, _⟩) x.2.map_zero (λ s t, x.2.map_add ⟨s, _⟩ ⟨t, _⟩) x.2.commutes⟩,
  rcases (x.exists_lift_of_splits (hK s hs).1 (hK s hs).2) with ⟨y, h1, h2⟩,
  rwa hx y h1 at h2
end

lemma alg_hom_mk_adjoin_splits' (hS : adjoin F S = ⊤)
  (hK : ∀ x ∈ S, is_integral F (x : E) ∧ (minpoly F x).splits (algebra_map F K)) :
  nonempty (E →ₐ[F] K) :=
begin
  cases alg_hom_mk_adjoin_splits hK with ϕ,
  rw hS at ϕ,
  exact ⟨ϕ.comp top_equiv.symm.to_alg_hom⟩,
end

end alg_hom_mk_adjoin_splits

section supremum

lemma le_sup_to_subalgebra {K L : Type*} [field K] [field L] [algebra K L]
  (E1 E2 : intermediate_field K L) :
  E1.to_subalgebra ⊔ E2.to_subalgebra ≤ (E1 ⊔ E2).to_subalgebra :=
sup_le (show E1 ≤ E1 ⊔ E2, from le_sup_left) (show E2 ≤ E1 ⊔ E2, from le_sup_right)

lemma sup_to_subalgebra {K L : Type*} [field K] [field L] [algebra K L]
  (E1 E2 : intermediate_field K L) [h1 : finite_dimensional K E1] [h2 : finite_dimensional K E2] :
  (E1 ⊔ E2).to_subalgebra = E1.to_subalgebra ⊔ E2.to_subalgebra :=
begin
  let S1 := E1.to_subalgebra,
  let S2 := E2.to_subalgebra,
  refine le_antisymm (show _ ≤ (S1 ⊔ S2).to_intermediate_field _, from (sup_le (show S1 ≤ _,
    from le_sup_left) (show S2 ≤ _, from le_sup_right))) (le_sup_to_subalgebra E1 E2),
  suffices : is_field ↥(S1 ⊔ S2),
  { intros x hx,
    by_cases hx' : (⟨x, hx⟩ : S1 ⊔ S2) = 0,
    { rw [←subtype.coe_mk x hx, hx', subalgebra.coe_zero, inv_zero],
      exact (S1 ⊔ S2).zero_mem },
    { obtain ⟨y, h⟩ := this.mul_inv_cancel hx',
      exact (congr_arg (∈ S1 ⊔ S2) $ eq_inv_of_mul_eq_one_right $ subtype.ext_iff.mp h).mp y.2 } },
  exact is_field_of_is_integral_of_is_field'
    (is_integral_sup.mpr ⟨algebra.is_integral_of_finite K E1, algebra.is_integral_of_finite K E2⟩)
    (field.to_is_field K),
end

lemma finite_dimensional_sup {K L : Type*} [field K] [field L] [algebra K L]
  (E1 E2 : intermediate_field K L) [h1 : finite_dimensional K E1] [h2 : finite_dimensional K E2] :
  finite_dimensional K ↥(E1 ⊔ E2) :=
begin
  let g := algebra.tensor_product.product_map E1.val E2.val,
  suffices : g.range = (E1 ⊔ E2).to_subalgebra,
  { have h : finite_dimensional K g.range.to_submodule := g.to_linear_map.finite_dimensional_range,
    rwa this at h },
  rw [algebra.tensor_product.product_map_range, E1.range_val, E2.range_val, sup_to_subalgebra],
end

end supremum

end intermediate_field

section power_basis

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

namespace power_basis

open intermediate_field

/-- `pb.equiv_adjoin_simple` is the equivalence between `K⟮pb.gen⟯` and `L` itself. -/
noncomputable def equiv_adjoin_simple (pb : power_basis K L) :
  K⟮pb.gen⟯ ≃ₐ[K] L :=
(adjoin.power_basis pb.is_integral_gen).equiv_of_minpoly pb
  (minpoly.eq_of_algebra_map_eq (algebra_map K⟮pb.gen⟯ L).injective
    (adjoin.power_basis pb.is_integral_gen).is_integral_gen
    (by rw [adjoin.power_basis_gen, adjoin_simple.algebra_map_gen]))

@[simp]
lemma equiv_adjoin_simple_aeval (pb : power_basis K L) (f : K[X]) :
  pb.equiv_adjoin_simple (aeval (adjoin_simple.gen K pb.gen) f) = aeval pb.gen f :=
equiv_of_minpoly_aeval _ pb _ f

@[simp]
lemma equiv_adjoin_simple_gen (pb : power_basis K L) :
  pb.equiv_adjoin_simple (adjoin_simple.gen K pb.gen) = pb.gen :=
equiv_of_minpoly_gen _ pb _

@[simp]
lemma equiv_adjoin_simple_symm_aeval (pb : power_basis K L) (f : K[X]) :
  pb.equiv_adjoin_simple.symm (aeval pb.gen f) = aeval (adjoin_simple.gen K pb.gen) f :=
by rw [equiv_adjoin_simple, equiv_of_minpoly_symm, equiv_of_minpoly_aeval, adjoin.power_basis_gen]

@[simp]
lemma equiv_adjoin_simple_symm_gen (pb : power_basis K L) :
  pb.equiv_adjoin_simple.symm pb.gen = (adjoin_simple.gen K pb.gen) :=
by rw [equiv_adjoin_simple, equiv_of_minpoly_symm, equiv_of_minpoly_gen, adjoin.power_basis_gen]

end power_basis

end power_basis


/-
This file contains the definitions of formulas in conjunctive normal form.
CNF is implemented as a list of clauses (see clause.lean).
The variable type used in the formula is polymorphic.

Authors: Cayden Codel, Jeremy Avigad, Marijn Heule
Carnegie Mellon University
-/

import basic
import cnf.literal
import cnf.clause

import data.list.basic
import data.list.nodup
import data.list.perm
import init.data.nat
import data.nat.basic

universe u

-- Represents the parametric type of the variable stored in the literal
variables {V : Type*}

/- Conjunctive normal form is a list of clauses joined by logical ANDs -/
def cnf (V : Type*) := list (clause V)

-- Note that the above definition allows for duplication of clauses (and
-- permutations of clauses), whereas a set definition would not (assuming a
-- set definition of clauses as well). However, lists allow for computable
-- functions to be defined on them.

namespace cnf

open literal
open clause
open list
open function
open finset

/-! # Instance properties -/

instance [inhabited V] : inhabited (cnf V) := ⟨[arbitrary (clause V)]⟩
instance : has_mem (clause V) (cnf V) := ⟨list.mem⟩
instance : has_emptyc (cnf V) := ⟨list.nil⟩
instance [decidable_eq V] : has_union (cnf V) := ⟨list.union⟩
instance [decidable_eq V] : has_inter (cnf V) := ⟨list.inter⟩
instance : has_singleton (clause V) (cnf V) := ⟨λ c, [c]⟩
instance [decidable_eq V] : has_insert (clause V) (cnf V) := ⟨list.insert⟩
instance : has_append (cnf V) := ⟨list.append⟩
instance : has_subset (cnf V) := ⟨list.subset⟩
instance [has_repr V] : has_repr (cnf V) := ⟨list.repr⟩

instance [decidable_eq V] (c : clause V) (f : cnf V) : decidable (c ∈ f) :=
begin
  induction f with cl cls ih,
  { exact decidable.false },
  { cases ih,
    { by_cases h : c = cl,
      { rw h, exact decidable.is_true (mem_cons_self cl cls) },
      { exact decidable.is_false (not_mem_cons_of_ne_of_not_mem h ih) } },
    exact decidable.is_true (mem_cons_of_mem cl ih) }
end

/-! ### Evaluation under assignment -/
section eval

variables {τ : assignment V} {c : clause V} {f : cnf V}

protected def eval (τ : assignment V) (f : cnf V) : bool :=
  f.foldr (λ c b, b && (clause.eval τ c)) tt

@[simp] theorem eval_nil : cnf.eval τ [] = tt := rfl

@[simp] theorem eval_singleton : cnf.eval τ [c] = c.eval τ :=
by simp only [cnf.eval, foldr, tt_band]

@[simp] theorem eval_cons : cnf.eval τ (c :: f) = c.eval τ && f.eval τ :=
by simp only [cnf.eval, foldr, bool.band_comm]

theorem eval_ff_cons_of_eval_ff (c : clause V) : f.eval τ = ff → cnf.eval τ (c :: f) = ff :=
assume h, by rw [eval_cons, h, band_ff]

theorem eval_append (τ : assignment V) (f₁ f₂ : cnf V) :
  cnf.eval τ (f₁ ++ f₂) = f₁.eval τ && f₂.eval τ :=
begin
  unfold cnf.eval,
  rw foldr_append,
  cases foldr (λ c b, b && clause.eval τ c) tt f₂,
  { rw [band_ff, foldr_band_ff] },
  { rw band_tt }
end

theorem eval_tt_iff_forall_clause_eval_tt : f.eval τ = tt ↔ ∀ (c : clause V), c ∈ f → c.eval τ = tt :=
begin
  induction f with c cs ih,
  { simp only [eval_nil, eq_self_iff_true, not_mem_nil, is_empty.forall_iff, implies_true_iff] },
  { simp only [ih, eval_cons, band_eq_true_eq_eq_tt_and_eq_tt, mem_cons_iff, forall_eq_or_imp] }
end

theorem eval_ff_iff_exists_clause_eval_ff : f.eval τ = ff ↔ ∃ c, c ∈ f ∧ clause.eval τ c = ff :=
begin
  induction f with c cs ih,
  { simp only [eval_nil, not_mem_nil, false_and, exists_false] },
  { simp only [eval_cons, band_eq_false_eq_eq_ff_or_eq_ff, mem_cons_iff],
    split,
    { rintros (h | h),
      { use [c, or.inl rfl, h] },
      { rcases ih.mp h with ⟨c₂, hc, he⟩,
        use [c₂, mem_cons_of_mem c hc, he] } },
    { rintros ⟨c₂, (rfl | hc), he⟩,
      { exact or.inl he },
      { exact or.inr (ih.mpr ⟨c₂, hc, he⟩) } } }
end

end eval

def satisfiable (f : cnf V) := ∃ τ, f.eval τ = tt

theorem satisfiable_of_eval_tt (f : cnf V) (τ : assignment V) : f.eval τ = tt → satisfiable f :=
assume h, exists.intro τ h

/-! ### Counting -/
section counting

variables (τ : assignment V) (c : clause V) (f f₁ f₂ : cnf V)

protected def count_tt : nat := f.countp (λ c, clause.eval τ c = tt)
protected def count_ff : nat := f.countp (λ c, clause.eval τ c = ff)

@[simp] theorem count_tt_nil : cnf.count_tt τ [] = 0 := rfl
@[simp] theorem count_ff_nil : cnf.count_ff τ [] = 0 := rfl

@[simp] theorem count_tt_singleton : cnf.count_tt τ [c] = cond (c.eval τ) 1 0 :=
by cases h : (c.eval τ); simp [h, cnf.count_tt]

@[simp] theorem count_ff_singleton : cnf.count_ff τ [c] = cond (c.eval τ) 0 1 :=
by cases h : (c.eval τ); simp [h, cnf.count_ff]

@[simp] theorem count_tt_cons : cnf.count_tt τ (c :: f) = cond (c.eval τ) (1 + f.count_tt τ) (f.count_tt τ) :=
by cases h : (c.eval τ); simp [h, cnf.count_tt, add_comm]

@[simp] theorem count_ff_cons : cnf.count_ff τ (c :: f) = cond (c.eval τ) (f.count_ff τ) (1 + f.count_ff τ) :=
by cases h : (c.eval τ); simp [h, cnf.count_ff, add_comm]

theorem count_tt_append : cnf.count_tt τ (f₁ ++ f₂) = cnf.count_tt τ f₁ + cnf.count_tt τ f₂ :=
begin
  induction f₁ with c cs ih,
  { simp only [nil_append, count_tt_nil, zero_add] },
  { cases h : (c.eval τ); simp [h, ih, add_assoc] }
end

theorem count_ff_append : cnf.count_ff τ (f₁ ++ f₂) = cnf.count_ff τ f₁ + cnf.count_ff τ f₂ :=
begin
  induction f₁ with c cs ih,
  { simp only [nil_append, count_ff_nil, zero_add] },
  { cases h : (c.eval τ); simp [h, ih, add_assoc] }
end

end counting

/-! # vars -/
section vars

variables [decidable_eq V] {v : V} {c : clause V} {f f₁ f₂ : cnf V}

protected def vars : cnf V → finset V
| []        := ∅
| (c :: cs) := (c.vars) ∪ (vars cs)

@[simp] theorem vars_nil : cnf.vars ([] : cnf V) = ∅ := rfl

@[simp] theorem vars_singleton (c : clause V) : cnf.vars [c] = clause.vars c :=
by { unfold cnf.vars, rw finset.union_empty }

theorem mem_vars_cons_of_mem_vars (c : clause V) : v ∈ f.vars → v ∈ cnf.vars (c :: f) :=
assume h, finset.mem_union.mpr (or.inr h)

theorem vars_append (f₁ f₂ : cnf V) : cnf.vars (f₁ ++ f₂) = f₁.vars ∪ f₂.vars :=
begin
  induction f₁ with c cs ih,
  { simp only [empty_union, vars_nil, nil_append] },
  { simp only [cnf.vars, cons_append c cs f₂, ih, finset.union_assoc] }
end

theorem vars_perm : f₁ ~ f₂ → f₁.vars = f₂.vars :=
begin
  intro hp,
  induction hp with _ _ _ _ IH  x y _  _ _ _ _ _ IH₁ IH₂,
  { refl },
  { unfold cnf.vars, rw IH },
  { unfold cnf.vars,
    rw [← finset.union_assoc, ← finset.union_assoc, finset.union_comm y.vars x.vars] },
  { exact eq.trans IH₁ IH₂ }
end

--theorem vars_perm_strong :

theorem clause_vars_subset_of_vars_of_mem : c ∈ f → c.vars ⊆ f.vars :=
begin
  induction f with cl cls ih,
  { intro h, exact absurd h (not_mem_nil _) },
  { intros hc v hv,
    rcases eq_or_mem_of_mem_cons hc with rfl | hc,
    { unfold cnf.vars,
      rw finset.mem_union,
      exact or.inl hv },
    { exact mem_vars_cons_of_mem_vars cl (ih hc hv) } }
end

theorem mem_vars_iff_exists_mem_clause_and_mem : v ∈ f.vars ↔ ∃ (c : clause V), c ∈ f ∧ v ∈ c.vars :=
begin
  induction f with cl cls ih,
  { simp only [not_mem_empty, not_mem_nil, exists_false, vars_nil, false_and] },
  { split,
    { intro hv,
      by_cases h : (v ∈ cl.vars),
      { use [cl, and.intro (mem_cons_self _ _) h] },
      { rcases ih.mp (or.resolve_left (finset.mem_union.mp hv) h) with ⟨c, hc, hv⟩,
        use [c, and.intro (mem_cons_of_mem cl hc) hv] } },
    { rintros ⟨c, hc, hv⟩,
      rw cnf.vars,
      rcases eq_or_mem_of_mem_cons hc with (rfl | hc),
      { exact finset.mem_union_left _ hv },
      { exact finset.mem_union_right _ (ih.mpr ⟨c, hc, hv⟩) } } }
end

theorem vars_subset_of_subset : f₁ ⊆ f₂ → (cnf.vars f₁) ⊆ (cnf.vars f₂) :=
begin
  intros h v hv,
  rcases cnf.mem_vars_iff_exists_mem_clause_and_mem.mp hv with ⟨c, hf, hvc⟩,
  exact clause_vars_subset_of_vars_of_mem (h hf) hvc
end

end vars

/-! # Equisatisfiability -/

def eqsat (f₁ f₂ : cnf V) := satisfiable f₁ ↔ satisfiable f₂

--notation f₁ ` ≈ ` f₂ := equisatisfiable f₁ f₂

@[refl] theorem eqsat.refl (f : cnf V) : eqsat f f := ⟨id, id⟩

@[symm] theorem eqsat.symm (f₁ f₂ : cnf V) : eqsat f₁ f₂ → eqsat f₂ f₁ := λ h, ⟨h.2, h.1⟩

@[trans] theorem eqsat.trans {f₁ f₂ f₃ : cnf V} : eqsat f₁ f₂ → eqsat f₂ f₃ → eqsat f₁ f₃ :=
λ h₁ h₂, ⟨λ h, h₂.1 (h₁.1 h), λ h, h₁.2 (h₂.2 h)⟩

/-! # Equivalence on domain theorems -/

open assignment

theorem eval_eq_of_eqod [decidable_eq V] {τ₁ τ₂ : assignment V} {f : cnf V} :
  (eqod τ₁ τ₂ f.vars) → f.eval τ₁ = f.eval τ₂ :=
begin
  intro h,
  cases hev : (cnf.eval τ₂ f),
  { apply eval_ff_iff_exists_clause_eval_ff.mpr,
    rcases eval_ff_iff_exists_clause_eval_ff.mp hev with ⟨c, hc, hff⟩,
    use [c, hc],
    exact hff ▸ clause.eval_eq_of_eqod
      (eqod_subset (clause_vars_subset_of_vars_of_mem hc) h) },
  { apply eval_tt_iff_forall_clause_eval_tt.mpr,
    intros c hc,
    exact (eval_tt_iff_forall_clause_eval_tt.mp hev c hc) ▸ clause.eval_eq_of_eqod
      (eqod_subset (clause_vars_subset_of_vars_of_mem hc) h) }
end

end cnf


/-
Copyright (c) 2022 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 data.set.intervals.with_bot_top
! leanprover-community/mathlib commit d012cd09a9b256d870751284dd6a29882b0be105
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Set.Intervals.Basic

/-!
# Intervals in `WithTop α` and `WithBot α`

In this file we prove various lemmas about `Set.image`s and `Set.preimage`s of intervals under
`some : α → WithTop α` and `some : α → WithBot α`.
-/

open Set

/-! ### `WithTop` -/

namespace WithTop

@[simp]
theorem preimage_coe_top : (some : α → WithTop α) ⁻¹' {⊤} = (∅ : Set α) :=
  eq_empty_of_subset_empty fun _ => coe_ne_top
#align with_top.preimage_coe_top WithTop.preimage_coe_top

variable [PartialOrder α] {a b : α}

theorem range_coe : range (some : α → WithTop α) = Iio ⊤ := by
  ext x
  rw [mem_Iio, lt_top_iff_ne_top, mem_range, ← none_eq_top, Option.ne_none_iff_exists]
  rfl
#align with_top.range_coe WithTop.range_coe

@[simp]
theorem preimage_coe_Ioi : (some : α → WithTop α) ⁻¹' Ioi a = Ioi a :=
  ext fun _ => coe_lt_coe
#align with_top.preimage_coe_Ioi WithTop.preimage_coe_Ioi

@[simp]
theorem preimage_coe_Ici : (some : α → WithTop α) ⁻¹' Ici a = Ici a :=
  ext fun _ => coe_le_coe
#align with_top.preimage_coe_Ici WithTop.preimage_coe_Ici

@[simp]
theorem preimage_coe_Iio : (some : α → WithTop α) ⁻¹' Iio a = Iio a :=
  ext fun _ => coe_lt_coe
#align with_top.preimage_coe_Iio WithTop.preimage_coe_Iio

@[simp]
theorem preimage_coe_Iic : (some : α → WithTop α) ⁻¹' Iic a = Iic a :=
  ext fun _ => coe_le_coe
#align with_top.preimage_coe_Iic WithTop.preimage_coe_Iic

@[simp]
theorem preimage_coe_Icc : (some : α → WithTop α) ⁻¹' Icc a b = Icc a b := by simp [← Ici_inter_Iic]
#align with_top.preimage_coe_Icc WithTop.preimage_coe_Icc

@[simp]
theorem preimage_coe_Ico : (some : α → WithTop α) ⁻¹' Ico a b = Ico a b := by simp [← Ici_inter_Iio]
#align with_top.preimage_coe_Ico WithTop.preimage_coe_Ico

@[simp]
theorem preimage_coe_Ioc : (some : α → WithTop α) ⁻¹' Ioc a b = Ioc a b := by simp [← Ioi_inter_Iic]
#align with_top.preimage_coe_Ioc WithTop.preimage_coe_Ioc

@[simp]
theorem preimage_coe_Ioo : (some : α → WithTop α) ⁻¹' Ioo a b = Ioo a b := by simp [← Ioi_inter_Iio]
#align with_top.preimage_coe_Ioo WithTop.preimage_coe_Ioo

@[simp]
theorem preimage_coe_Iio_top : (some : α → WithTop α) ⁻¹' Iio ⊤ = univ := by
  rw [← range_coe, preimage_range]
#align with_top.preimage_coe_Iio_top WithTop.preimage_coe_Iio_top

@[simp]
theorem preimage_coe_Ico_top : (some : α → WithTop α) ⁻¹' Ico a ⊤ = Ici a := by
  simp [← Ici_inter_Iio]
#align with_top.preimage_coe_Ico_top WithTop.preimage_coe_Ico_top

@[simp]
theorem preimage_coe_Ioo_top : (some : α → WithTop α) ⁻¹' Ioo a ⊤ = Ioi a := by
  simp [← Ioi_inter_Iio]
#align with_top.preimage_coe_Ioo_top WithTop.preimage_coe_Ioo_top

theorem image_coe_Ioi : (some : α → WithTop α) '' Ioi a = Ioo (a : WithTop α) ⊤ := by
  rw [← preimage_coe_Ioi, image_preimage_eq_inter_range, range_coe, Ioi_inter_Iio]
#align with_top.image_coe_Ioi WithTop.image_coe_Ioi

theorem image_coe_Ici : (some : α → WithTop α) '' Ici a = Ico (a : WithTop α) ⊤ := by
  rw [← preimage_coe_Ici, image_preimage_eq_inter_range, range_coe, Ici_inter_Iio]
#align with_top.image_coe_Ici WithTop.image_coe_Ici

theorem image_coe_Iio : (some : α → WithTop α) '' Iio a = Iio (a : WithTop α) := by
  rw [← preimage_coe_Iio, image_preimage_eq_inter_range, range_coe,
    inter_eq_self_of_subset_left (Iio_subset_Iio le_top)]
#align with_top.image_coe_Iio WithTop.image_coe_Iio

theorem image_coe_Iic : (some : α → WithTop α) '' Iic a = Iic (a : WithTop α) := by
  rw [← preimage_coe_Iic, image_preimage_eq_inter_range, range_coe,
    inter_eq_self_of_subset_left (Iic_subset_Iio.2 <| coe_lt_top a)]
#align with_top.image_coe_Iic WithTop.image_coe_Iic

theorem image_coe_Icc : (some : α → WithTop α) '' Icc a b = Icc (a : WithTop α) b := by
  rw [← preimage_coe_Icc, image_preimage_eq_inter_range, range_coe,
    inter_eq_self_of_subset_left
      (Subset.trans Icc_subset_Iic_self <| Iic_subset_Iio.2 <| coe_lt_top b)]
#align with_top.image_coe_Icc WithTop.image_coe_Icc

theorem image_coe_Ico : (some : α → WithTop α) '' Ico a b = Ico (a : WithTop α) b := by
  rw [← preimage_coe_Ico, image_preimage_eq_inter_range, range_coe,
    inter_eq_self_of_subset_left (Subset.trans Ico_subset_Iio_self <| Iio_subset_Iio le_top)]
#align with_top.image_coe_Ico WithTop.image_coe_Ico

theorem image_coe_Ioc : (some : α → WithTop α) '' Ioc a b = Ioc (a : WithTop α) b := by
  rw [← preimage_coe_Ioc, image_preimage_eq_inter_range, range_coe,
    inter_eq_self_of_subset_left
      (Subset.trans Ioc_subset_Iic_self <| Iic_subset_Iio.2 <| coe_lt_top b)]
#align with_top.image_coe_Ioc WithTop.image_coe_Ioc

theorem image_coe_Ioo : (some : α → WithTop α) '' Ioo a b = Ioo (a : WithTop α) b := by
  rw [← preimage_coe_Ioo, image_preimage_eq_inter_range, range_coe,
    inter_eq_self_of_subset_left (Subset.trans Ioo_subset_Iio_self <| Iio_subset_Iio le_top)]
#align with_top.image_coe_Ioo WithTop.image_coe_Ioo

end WithTop

/-! ### `WithBot` -/

namespace WithBot

@[simp]
theorem preimage_coe_bot : (some : α → WithBot α) ⁻¹' {⊥} = (∅ : Set α) :=
  @WithTop.preimage_coe_top αᵒᵈ
#align with_bot.preimage_coe_bot WithBot.preimage_coe_bot

variable [PartialOrder α] {a b : α}

theorem range_coe : range (some : α → WithBot α) = Ioi ⊥ :=
  @WithTop.range_coe αᵒᵈ _
#align with_bot.range_coe WithBot.range_coe

@[simp]
theorem preimage_coe_Ioi : (some : α → WithBot α) ⁻¹' Ioi a = Ioi a :=
  ext fun _ => coe_lt_coe
#align with_bot.preimage_coe_Ioi WithBot.preimage_coe_Ioi

@[simp]
theorem preimage_coe_Ici : (some : α → WithBot α) ⁻¹' Ici a = Ici a :=
  ext fun _ => coe_le_coe
#align with_bot.preimage_coe_Ici WithBot.preimage_coe_Ici

@[simp]
theorem preimage_coe_Iio : (some : α → WithBot α) ⁻¹' Iio a = Iio a :=
  ext fun _ => coe_lt_coe
#align with_bot.preimage_coe_Iio WithBot.preimage_coe_Iio

@[simp]
theorem preimage_coe_Iic : (some : α → WithBot α) ⁻¹' Iic a = Iic a :=
  ext fun _ => coe_le_coe
#align with_bot.preimage_coe_Iic WithBot.preimage_coe_Iic

@[simp]
theorem preimage_coe_Icc : (some : α → WithBot α) ⁻¹' Icc a b = Icc a b := by simp [← Ici_inter_Iic]
#align with_bot.preimage_coe_Icc WithBot.preimage_coe_Icc

@[simp]
theorem preimage_coe_Ico : (some : α → WithBot α) ⁻¹' Ico a b = Ico a b := by simp [← Ici_inter_Iio]
#align with_bot.preimage_coe_Ico WithBot.preimage_coe_Ico

@[simp]
theorem preimage_coe_Ioc : (some : α → WithBot α) ⁻¹' Ioc a b = Ioc a b := by simp [← Ioi_inter_Iic]
#align with_bot.preimage_coe_Ioc WithBot.preimage_coe_Ioc

@[simp]
theorem preimage_coe_Ioo : (some : α → WithBot α) ⁻¹' Ioo a b = Ioo a b := by simp [← Ioi_inter_Iio]
#align with_bot.preimage_coe_Ioo WithBot.preimage_coe_Ioo

@[simp]
theorem preimage_coe_Ioi_bot : (some : α → WithBot α) ⁻¹' Ioi ⊥ = univ := by
  rw [← range_coe, preimage_range]
#align with_bot.preimage_coe_Ioi_bot WithBot.preimage_coe_Ioi_bot

@[simp]
theorem preimage_coe_Ioc_bot : (some : α → WithBot α) ⁻¹' Ioc ⊥ a = Iic a := by
  simp [← Ioi_inter_Iic]
#align with_bot.preimage_coe_Ioc_bot WithBot.preimage_coe_Ioc_bot

@[simp]
theorem preimage_coe_Ioo_bot : (some : α → WithBot α) ⁻¹' Ioo ⊥ a = Iio a := by
  simp [← Ioi_inter_Iio]
#align with_bot.preimage_coe_Ioo_bot WithBot.preimage_coe_Ioo_bot

theorem image_coe_Iio : (some : α → WithBot α) '' Iio a = Ioo (⊥ : WithBot α) a := by
  rw [← preimage_coe_Iio, image_preimage_eq_inter_range, range_coe, inter_comm, Ioi_inter_Iio]
#align with_bot.image_coe_Iio WithBot.image_coe_Iio

theorem image_coe_Iic : (some : α → WithBot α) '' Iic a = Ioc (⊥ : WithBot α) a := by
  rw [← preimage_coe_Iic, image_preimage_eq_inter_range, range_coe, inter_comm, Ioi_inter_Iic]
#align with_bot.image_coe_Iic WithBot.image_coe_Iic

theorem image_coe_Ioi : (some : α → WithBot α) '' Ioi a = Ioi (a : WithBot α) := by
  rw [← preimage_coe_Ioi, image_preimage_eq_inter_range, range_coe,
    inter_eq_self_of_subset_left (Ioi_subset_Ioi bot_le)]
#align with_bot.image_coe_Ioi WithBot.image_coe_Ioi

theorem image_coe_Ici : (some : α → WithBot α) '' Ici a = Ici (a : WithBot α) := by
  rw [← preimage_coe_Ici, image_preimage_eq_inter_range, range_coe,
    inter_eq_self_of_subset_left (Ici_subset_Ioi.2 <| bot_lt_coe a)]
#align with_bot.image_coe_Ici WithBot.image_coe_Ici

theorem image_coe_Icc : (some : α → WithBot α) '' Icc a b = Icc (a : WithBot α) b := by
  rw [← preimage_coe_Icc, image_preimage_eq_inter_range, range_coe,
    inter_eq_self_of_subset_left
      (Subset.trans Icc_subset_Ici_self <| Ici_subset_Ioi.2 <| bot_lt_coe a)]
#align with_bot.image_coe_Icc WithBot.image_coe_Icc

theorem image_coe_Ioc : (some : α → WithBot α) '' Ioc a b = Ioc (a : WithBot α) b := by
  rw [← preimage_coe_Ioc, image_preimage_eq_inter_range, range_coe,
    inter_eq_self_of_subset_left (Subset.trans Ioc_subset_Ioi_self <| Ioi_subset_Ioi bot_le)]
#align with_bot.image_coe_Ioc WithBot.image_coe_Ioc

theorem image_coe_Ico : (some : α → WithBot α) '' Ico a b = Ico (a : WithBot α) b := by
  rw [← preimage_coe_Ico, image_preimage_eq_inter_range, range_coe,
    inter_eq_self_of_subset_left
      (Subset.trans Ico_subset_Ici_self <| Ici_subset_Ioi.2 <| bot_lt_coe a)]
#align with_bot.image_coe_Ico WithBot.image_coe_Ico

theorem image_coe_Ioo : (some : α → WithBot α) '' Ioo a b = Ioo (a : WithBot α) b := by
  rw [← preimage_coe_Ioo, image_preimage_eq_inter_range, range_coe,
    inter_eq_self_of_subset_left (Subset.trans Ioo_subset_Ioi_self <| Ioi_subset_Ioi bot_le)]
#align with_bot.image_coe_Ioo WithBot.image_coe_Ioo

end WithBot


/-
Copyright (c) 2020 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import algebra.invertible
import data.matrix.basis
import data.matrix.dmatrix
import algebra.lie.abelian
import linear_algebra.matrix.trace
import algebra.lie.skew_adjoint
import linear_algebra.symplectic_group

/-!
# Classical Lie algebras

This file is the place to find definitions and basic properties of the classical Lie algebras:
  * Aₗ = sl(l+1)
  * Bₗ ≃ so(l+1, l) ≃ so(2l+1)
  * Cₗ = sp(l)
  * Dₗ ≃ so(l, l) ≃ so(2l)

## Main definitions

  * `lie_algebra.special_linear.sl`
  * `lie_algebra.symplectic.sp`
  * `lie_algebra.orthogonal.so`
  * `lie_algebra.orthogonal.so'`
  * `lie_algebra.orthogonal.so_indefinite_equiv`
  * `lie_algebra.orthogonal.type_D`
  * `lie_algebra.orthogonal.type_B`
  * `lie_algebra.orthogonal.type_D_equiv_so'`
  * `lie_algebra.orthogonal.type_B_equiv_so'`

## Implementation notes

### Matrices or endomorphisms

Given a finite type and a commutative ring, the corresponding square matrices are equivalent to the
endomorphisms of the corresponding finite-rank free module as Lie algebras, see `lie_equiv_matrix'`.
We can thus define the classical Lie algebras as Lie subalgebras either of matrices or of
endomorphisms. We have opted for the former. At the time of writing (August 2020) it is unclear
which approach should be preferred so the choice should be assumed to be somewhat arbitrary.

### Diagonal quadratic form or diagonal Cartan subalgebra

For the algebras of type `B` and `D`, there are two natural definitions. For example since the
the `2l × 2l` matrix:
$$
  J = \left[\begin{array}{cc}
              0_l & 1_l\\
              1_l & 0_l
            \end{array}\right]
$$
defines a symmetric bilinear form equivalent to that defined by the identity matrix `I`, we can
define the algebras of type `D` to be the Lie subalgebra of skew-adjoint matrices either for `J` or
for `I`. Both definitions have their advantages (in particular the `J`-skew-adjoint matrices define
a Lie algebra for which the diagonal matrices form a Cartan subalgebra) and so we provide both.
We thus also provide equivalences `type_D_equiv_so'`, `so_indefinite_equiv` which show the two
definitions are equivalent. Similarly for the algebras of type `B`.

## Tags

classical lie algebra, special linear, symplectic, orthogonal
-/

universes u₁ u₂

namespace lie_algebra
open matrix
open_locale matrix

variables (n p q l : Type*) (R : Type u₂)
variables [decidable_eq n] [decidable_eq p] [decidable_eq q] [decidable_eq l]
variables [comm_ring R]

@[simp] lemma matrix_trace_commutator_zero [fintype n] (X Y : matrix n n R) :
  matrix.trace ⁅X, Y⁆ = 0 :=
calc _ = matrix.trace (X ⬝ Y) - matrix.trace (Y ⬝ X) : trace_sub _ _
   ... = matrix.trace (X ⬝ Y) - matrix.trace (X ⬝ Y) :
     congr_arg (λ x, _ - x) (matrix.trace_mul_comm Y X)
   ... = 0 : sub_self _

namespace special_linear

/-- The special linear Lie algebra: square matrices of trace zero. -/
def sl [fintype n] : lie_subalgebra R (matrix n n R) :=
{ lie_mem' := λ X Y _ _, linear_map.mem_ker.2 $ matrix_trace_commutator_zero _ _ _ _,
  ..linear_map.ker (matrix.trace_linear_map n R R) }

lemma sl_bracket [fintype n] (A B : sl n R) : ⁅A, B⁆.val = A.val ⬝ B.val - B.val ⬝ A.val := rfl

section elementary_basis

variables {n} [fintype n] (i j : n)

/-- When j ≠ i, the elementary matrices are elements of sl n R, in fact they are part of a natural
basis of sl n R. -/
def Eb (h : j ≠ i) : sl n R :=
⟨matrix.std_basis_matrix i j (1 : R),
  show matrix.std_basis_matrix i j (1 : R) ∈ linear_map.ker (matrix.trace_linear_map n R R),
  from matrix.std_basis_matrix.trace_zero i j (1 : R) h⟩

@[simp] lemma Eb_val (h : j ≠ i) : (Eb R i j h).val = matrix.std_basis_matrix i j 1 := rfl

end elementary_basis

end special_linear

namespace symplectic

/-- The symplectic Lie algebra: skew-adjoint matrices with respect to the canonical skew-symmetric
bilinear form. -/
def sp [fintype l] : lie_subalgebra R (matrix (l ⊕ l) (l ⊕ l) R) :=
  skew_adjoint_matrices_lie_subalgebra (matrix.J l R)

end symplectic

namespace orthogonal

/-- The definite orthogonal Lie subalgebra: skew-adjoint matrices with respect to the symmetric
bilinear form defined by the identity matrix. -/
def so [fintype n] : lie_subalgebra R (matrix n n R) :=
  skew_adjoint_matrices_lie_subalgebra (1 : matrix n n R)

@[simp] lemma mem_so [fintype n] (A : matrix n n R) : A ∈ so n R ↔ Aᵀ = -A :=
begin
  erw mem_skew_adjoint_matrices_submodule,
  simp only [matrix.is_skew_adjoint, matrix.is_adjoint_pair, matrix.mul_one, matrix.one_mul],
end

/-- The indefinite diagonal matrix with `p` 1s and `q` -1s. -/
def indefinite_diagonal : matrix (p ⊕ q) (p ⊕ q) R :=
  matrix.diagonal $ sum.elim (λ _, 1) (λ _, -1)

/-- The indefinite orthogonal Lie subalgebra: skew-adjoint matrices with respect to the symmetric
bilinear form defined by the indefinite diagonal matrix. -/
def so' [fintype p] [fintype q] : lie_subalgebra R (matrix (p ⊕ q) (p ⊕ q) R) :=
  skew_adjoint_matrices_lie_subalgebra $ indefinite_diagonal p q R

/-- A matrix for transforming the indefinite diagonal bilinear form into the definite one, provided
the parameter `i` is a square root of -1. -/
def Pso (i : R) : matrix (p ⊕ q) (p ⊕ q) R :=
  matrix.diagonal $ sum.elim (λ _, 1) (λ _, i)

variables [fintype p] [fintype q]

lemma Pso_inv {i : R} (hi : i*i = -1) : (Pso p q R i) * (Pso p q R (-i)) = 1 :=
begin
  ext x y, rcases x; rcases y,
  { -- x y : p
    by_cases h : x = y; simp [Pso, indefinite_diagonal, h], },
  { -- x : p, y : q
    simp [Pso, indefinite_diagonal], },
  { -- x : q, y : p
    simp [Pso, indefinite_diagonal], },
  { -- x y : q
    by_cases h : x = y; simp [Pso, indefinite_diagonal, h, hi], },
end

/-- There is a constructive inverse of `Pso p q R i`. -/
def invertible_Pso {i : R} (hi : i*i = -1) : invertible (Pso p q R i) :=
invertible_of_right_inverse _ _ (Pso_inv p q R hi)

lemma indefinite_diagonal_transform {i : R} (hi : i*i = -1) :
  (Pso p q R i)ᵀ ⬝ (indefinite_diagonal p q R) ⬝ (Pso p q R i) = 1 :=
begin
  ext x y, rcases x; rcases y,
  { -- x y : p
    by_cases h : x = y; simp [Pso, indefinite_diagonal, h], },
  { -- x : p, y : q
    simp [Pso, indefinite_diagonal], },
  { -- x : q, y : p
    simp [Pso, indefinite_diagonal], },
  { -- x y : q
    by_cases h : x = y; simp [Pso, indefinite_diagonal, h, hi], },
end

/-- An equivalence between the indefinite and definite orthogonal Lie algebras, over a ring
containing a square root of -1. -/
def so_indefinite_equiv {i : R} (hi : i*i = -1) : so' p q R ≃ₗ⁅R⁆ so (p ⊕ q) R :=
begin
  apply (skew_adjoint_matrices_lie_subalgebra_equiv
    (indefinite_diagonal p q R) (Pso p q R i) (invertible_Pso p q R hi)).trans,
  apply lie_equiv.of_eq,
  ext A, rw indefinite_diagonal_transform p q R hi, refl,
end

lemma so_indefinite_equiv_apply {i : R} (hi : i*i = -1) (A : so' p q R) :
  (so_indefinite_equiv p q R hi A : matrix (p ⊕ q) (p ⊕ q) R) =
    (Pso p q R i)⁻¹ ⬝ (A : matrix (p ⊕ q) (p ⊕ q) R) ⬝ (Pso p q R i) :=
by erw [lie_equiv.trans_apply, lie_equiv.of_eq_apply,
        skew_adjoint_matrices_lie_subalgebra_equiv_apply]

/-- A matrix defining a canonical even-rank symmetric bilinear form.

It looks like this as a `2l x 2l` matrix of `l x l` blocks:

   [ 0 1 ]
   [ 1 0 ]
-/
def JD : matrix (l ⊕ l) (l ⊕ l) R := matrix.from_blocks 0 1 1 0

/-- The classical Lie algebra of type D as a Lie subalgebra of matrices associated to the matrix
`JD`. -/
def type_D [fintype l] := skew_adjoint_matrices_lie_subalgebra (JD l R)

/-- A matrix transforming the bilinear form defined by the matrix `JD` into a split-signature
diagonal matrix.

It looks like this as a `2l x 2l` matrix of `l x l` blocks:

   [ 1 -1 ]
   [ 1  1 ]
-/
def PD : matrix (l ⊕ l) (l ⊕ l) R := matrix.from_blocks 1 (-1) 1 1

/-- The split-signature diagonal matrix. -/
def S := indefinite_diagonal l l R

lemma S_as_blocks : S l R = matrix.from_blocks 1 0 0 (-1) :=
begin
  rw [← matrix.diagonal_one, matrix.diagonal_neg, matrix.from_blocks_diagonal],
  refl,
end

lemma JD_transform [fintype l] : (PD l R)ᵀ ⬝ (JD l R) ⬝ (PD l R) = (2 : R) • (S l R) :=
begin
  have h : (PD l R)ᵀ ⬝ (JD l R) = matrix.from_blocks 1 1 1 (-1) := by
  { simp [PD, JD, matrix.from_blocks_transpose, matrix.from_blocks_multiply], },
  erw [h, S_as_blocks, matrix.from_blocks_multiply, matrix.from_blocks_smul],
  congr; simp [two_smul],
end

lemma PD_inv [fintype l] [invertible (2 : R)] : (PD l R) * (⅟(2 : R) • (PD l R)ᵀ) = 1 :=
begin
  have h : ⅟(2 : R) • (1 : matrix l l R) + ⅟(2 : R) • 1 = 1 := by
    rw [← smul_add, ← (two_smul R _), smul_smul, inv_of_mul_self, one_smul],
  erw [matrix.from_blocks_transpose, matrix.from_blocks_smul, matrix.mul_eq_mul,
    matrix.from_blocks_multiply],
  simp [h],
end

instance invertible_PD [fintype l] [invertible (2 : R)] : invertible (PD l R) :=
invertible_of_right_inverse _ _ (PD_inv l R)

/-- An equivalence between two possible definitions of the classical Lie algebra of type D. -/
def type_D_equiv_so' [fintype l] [invertible (2 : R)] :
  type_D l R ≃ₗ⁅R⁆ so' l l R :=
begin
  apply (skew_adjoint_matrices_lie_subalgebra_equiv (JD l R) (PD l R) (by apply_instance)).trans,
  apply lie_equiv.of_eq,
  ext A,
  rw [JD_transform, ← coe_unit_of_invertible (2 : R), ←units.smul_def, lie_subalgebra.mem_coe,
      mem_skew_adjoint_matrices_lie_subalgebra_unit_smul],
  refl,
end

/-- A matrix defining a canonical odd-rank symmetric bilinear form.

It looks like this as a `(2l+1) x (2l+1)` matrix of blocks:

   [ 2 0 0 ]
   [ 0 0 1 ]
   [ 0 1 0 ]

where sizes of the blocks are:

   [`1 x 1` `1 x l` `1 x l`]
   [`l x 1` `l x l` `l x l`]
   [`l x 1` `l x l` `l x l`]
-/
def JB := matrix.from_blocks ((2 : R) • 1 : matrix unit unit R) 0 0 (JD l R)

/-- The classical Lie algebra of type B as a Lie subalgebra of matrices associated to the matrix
`JB`. -/
def type_B  [fintype l] := skew_adjoint_matrices_lie_subalgebra(JB l R)

/-- A matrix transforming the bilinear form defined by the matrix `JB` into an
almost-split-signature diagonal matrix.

It looks like this as a `(2l+1) x (2l+1)` matrix of blocks:

   [ 1 0  0 ]
   [ 0 1 -1 ]
   [ 0 1  1 ]

where sizes of the blocks are:

   [`1 x 1` `1 x l` `1 x l`]
   [`l x 1` `l x l` `l x l`]
   [`l x 1` `l x l` `l x l`]
-/
def PB := matrix.from_blocks (1 : matrix unit unit R) 0 0 (PD l R)

variable [fintype l]

lemma PB_inv [invertible (2 : R)] : PB l R * matrix.from_blocks 1 0 0 (⅟(PD l R)) = 1 :=
begin
  rw [PB, matrix.mul_eq_mul, matrix.from_blocks_multiply, matrix.mul_inv_of_self],
  simp only [matrix.mul_zero, matrix.mul_one, matrix.zero_mul, zero_add, add_zero,
    matrix.from_blocks_one]
end

instance invertible_PB [invertible (2 : R)] : invertible (PB l R) :=
invertible_of_right_inverse _ _ (PB_inv l R)

lemma JB_transform : (PB l R)ᵀ ⬝ (JB l R) ⬝ (PB l R) = (2 : R) • matrix.from_blocks 1 0 0 (S l R) :=
by simp [PB, JB, JD_transform, matrix.from_blocks_transpose, matrix.from_blocks_multiply,
         matrix.from_blocks_smul]

lemma indefinite_diagonal_assoc :
  indefinite_diagonal (unit ⊕ l) l R =
  matrix.reindex_lie_equiv (equiv.sum_assoc unit l l).symm
    (matrix.from_blocks 1 0 0 (indefinite_diagonal l l R)) :=
begin
  ext i j,
  rcases i with ⟨⟨i₁ | i₂⟩ | i₃⟩;
  rcases j with ⟨⟨j₁ | j₂⟩ | j₃⟩;
  simp only [indefinite_diagonal, matrix.diagonal_apply, equiv.sum_assoc_apply_inl_inl,
    matrix.reindex_lie_equiv_apply, matrix.submatrix_apply, equiv.symm_symm, matrix.reindex_apply,
    sum.elim_inl, if_true, eq_self_iff_true, matrix.one_apply_eq, matrix.from_blocks_apply₁₁,
    dmatrix.zero_apply, equiv.sum_assoc_apply_inl_inr, if_false, matrix.from_blocks_apply₁₂,
    matrix.from_blocks_apply₂₁, matrix.from_blocks_apply₂₂, equiv.sum_assoc_apply_inr,
    sum.elim_inr];
  congr,
end

/-- An equivalence between two possible definitions of the classical Lie algebra of type B. -/
def type_B_equiv_so' [invertible (2 : R)] :
  type_B l R ≃ₗ⁅R⁆ so' (unit ⊕ l) l R :=
begin
  apply (skew_adjoint_matrices_lie_subalgebra_equiv (JB l R) (PB l R) (by apply_instance)).trans,
  symmetry,
  apply (skew_adjoint_matrices_lie_subalgebra_equiv_transpose
    (indefinite_diagonal (unit ⊕ l) l R)
    (matrix.reindex_alg_equiv _ (equiv.sum_assoc punit l l)) (matrix.transpose_reindex _ _)).trans,
  apply lie_equiv.of_eq,
  ext A,
  rw [JB_transform, ← coe_unit_of_invertible (2 : R), ←units.smul_def, lie_subalgebra.mem_coe,
      lie_subalgebra.mem_coe, mem_skew_adjoint_matrices_lie_subalgebra_unit_smul],
  simpa [indefinite_diagonal_assoc],
end

end orthogonal

end lie_algebra


import field

inductive  item_plus_sqrt (f : Type) [myfld f] (rt : f) : Type
| ips : f -> f -> item_plus_sqrt

open item_plus_sqrt

def ips_zero (f : Type) [myfld f] (rt : f) : (item_plus_sqrt f rt) := ips myfld.zero myfld.zero

def ips_add (f : Type) [myfld f] (rt : f) : (item_plus_sqrt f rt) -> (item_plus_sqrt f rt) -> (item_plus_sqrt f rt)
| (ips a b) (ips c d) := (ips (myfld.add a c) (myfld.add b d))

def ips_negate (f : Type) [myfld f] (rt : f) : (item_plus_sqrt f rt) -> (item_plus_sqrt f rt)
| (ips a b) := (ips (myfld.negate a) (myfld.negate b))

def ips_mul (f : Type) [myfld f] (rt : f) : (item_plus_sqrt f rt) -> (item_plus_sqrt f rt) -> (item_plus_sqrt f rt)
| (ips a b) (ips c d) := (ips ((a .* c) .+ (b .* d .* rt)) ((a .* d) .+ (b .* c)))

def to_ips (f : Type) [myfld f] (rt : f) (x : f) : (item_plus_sqrt f rt) := (ips x myfld.zero)

lemma ips_add_comm (f : Type) [myfld f] (rt : f) (a b c d : f) :
  ips_add f rt (ips a b) (ips c d) = ips_add f rt (ips c d) (ips a b) :=
begin
  unfold ips_add, rw myfld.add_comm a c, rw myfld.add_comm b d,
end

lemma ips_add_assoc (f : Type) [myfld f] (rt : f) (a1 b1 a2 b2 a3 b3 : f) :
  ips_add f rt (ips a1 b1) (ips_add f rt (ips a2 b2) (ips a3 b3)) =
  ips_add f rt (ips_add f rt (ips a1 b1) (ips a2 b2)) (ips a3 b3) :=
begin
  unfold ips_add, repeat {rw myfld.add_assoc},
end

lemma ips_mul_comm (f : Type) [myfld f] (rt : f) (a b c d : f) :
  ips_mul f rt (ips a b) (ips c d) = ips_mul f rt (ips c d) (ips a b) :=
begin
  unfold ips_mul, rw myfld.mul_comm a c, rw myfld.mul_comm b d,
  rw myfld.mul_comm a d, rw myfld.mul_comm b c,
  rw myfld.add_comm (c .* b) (d .* a),
end

def quadratic_formula (f : Type) [myfld f] [fld_not_char_two f] (b c : f) :
      (item_plus_sqrt f ((b .* b) .+ ((four f) .* .- c))) :=
  ips (.- b) .* (myfld.reciprocal (two f) (fld_not_char_two.not_char_two))
      (myfld.reciprocal (two f) (fld_not_char_two.not_char_two))

def quadratic_subst_ips (f : Type) [myfld f] [fld_not_char_two f] (rt : f) (b c : f)
    (x : item_plus_sqrt f rt) : (item_plus_sqrt f rt) :=
  ips_add f rt (ips_mul f rt x x) (ips_add f rt (ips_mul f rt x (to_ips f rt b)) (to_ips f rt c))

lemma quadratic_formula_works (f : Type) [myfld f] [fld_not_char_two f] (b c : f) :
  (quadratic_subst_ips f ((b .* b) .+ ((four f) .* .- c)) b c
                        (quadratic_formula f b c))
                        =
  (ips myfld.zero myfld.zero) :=
begin
  unfold quadratic_formula, unfold quadratic_subst_ips,
  unfold to_ips, unfold ips_mul, unfold ips_add,
  repeat {rw zero_simp}, repeat {rw zero_mul}, repeat {rw mul_zero}, rw simp_zero, rw zero_simp,
  repeat {rw mul_negate, rw mul_negate_alt_simp}, rw mul_negate,
  rw double_negative,
  have tmp : ∀ (p q rt : f), (p = myfld.zero) -> (q = myfld.zero) ->
                ((ips p q) : (item_plus_sqrt f rt)) =
                ((ips myfld.zero myfld.zero) : (item_plus_sqrt f rt)),
    intros p q rt h1 h2, rw h1, rw h2,
  apply tmp, clear tmp,
  rw mul_two_reciprocals,
  rw [myfld.mul_comm b (myfld.reciprocal (two f) _)] {occs := occurrences.pos [2]},
  rw <- myfld.mul_assoc _ (myfld.reciprocal (two f) _) _,
  rw myfld.mul_assoc (myfld.reciprocal (two f) _) (myfld.reciprocal (two f) _) _,
  rw mul_two_reciprocals, rw myfld.mul_comm b ((myfld.reciprocal _ _) .* _),
  rw <- myfld.mul_assoc (myfld.reciprocal _ _) b b,
  rw <- distrib_simp_alt,
  have tmp : .- (b .* (myfld.reciprocal (two f) fld_not_char_two.not_char_two) .* b) =
              .- ((myfld.reciprocal ((two f) .* (two f)) (mul_nonzero f (two f) (two f) fld_not_char_two.not_char_two fld_not_char_two.not_char_two))
              .* ((b .* b) .+ (b .* b))),
    rw <- mul_two_reciprocals, have tmp_tmp : ((b .* b) .+ (b .* b)) = (two f) .* (b .* b),
      unfold two, rw distrib_simp, rw one_mul_simp,
    rw tmp_tmp, rw myfld.mul_assoc _ (two f) _,
    rw <- myfld.mul_assoc _ (myfld.reciprocal (two f) _) (two f),
    rw myfld.mul_comm (myfld.reciprocal (two f) _) (two f), rw myfld.mul_reciprocal,
    rw simp_mul_one, rw myfld.mul_comm b _, rw myfld.mul_assoc,
  rw tmp, clear tmp, rw mul_negate_alt f _ ((b .* b) .+ (b .* b)),
  rw myfld.add_assoc, rw <- distrib_simp_alt,
  rw myfld.add_assoc (b .* b) (b .* b), rw myfld.add_comm _ (.- ((four f) .* c)),
  rw <- myfld.add_assoc _ ((b .* b) .+ (b .* b)) _,
  rw myfld.add_negate, rw zero_simp,
  rw mul_negate_alt_simp, have tmp : (two f) .* (two f) = (four f), unfold four, rw two_plus_two,
  rw reciprocal_rewrite f _ (four f) tmp, rw myfld.mul_assoc, rw myfld.mul_comm _ (four f),
  rw myfld.mul_reciprocal, rw one_mul_simp, rw myfld.add_comm, rw myfld.add_negate,

  clear tmp,
  rw myfld.mul_comm _ (b .* (myfld.reciprocal (two f) fld_not_char_two.not_char_two)),
  rw <- add_negate, rw <- distrib_simp_alt, rw only_one_reciprocal f (two f) _ (two_ne_zero f),
  rw add_two_halves, rw simp_mul_one,
  rw myfld.add_comm, rw myfld.mul_comm b _, rw myfld.add_negate,
end


import S5.soundness

open Classical
open prf

def is_consistent (Γ : ctx) := Γ ⊬ₛ₅ ⊥

theorem consist_not_of_not_prf { Γ : ctx } { p : form } : (Γ ⊬ₛ₅ p) → is_consistent (Γ ∪ ¬p) :=
  fun hnp hc => hnp (mp dne (deduction hc))

theorem not_prf_of_consist_not { Γ : ctx } { p : form } : is_consistent (Γ ∪ ¬p) → (Γ ⊬ₛ₅ p) :=
  fun h c => h (conv_deduction (mp dni c))

-- Other notable properties of consistency

theorem consist_of_not_prf { Γ : ctx } { p : form } : (Γ ⊬ₛ₅ p) → is_consistent Γ := sorry
--  fun nhp nc => nhp (False.elim nc)

theorem inconsist_to_neg_consist { Γ : ctx } { p : form } :
  is_consistent Γ → (¬ is_consistent (Γ ∪ p)) → is_consistent (Γ ∪ ¬p) := by
  intros c nc hp
  apply c
  apply mp
  apply deduction
  apply byContradiction nc
  apply mp dne
  exact (deduction hp)

theorem inconsist_of_neg_to_consist { Γ : ctx } { p : form } :
  is_consistent Γ → (¬ is_consistent (Γ ∪ ¬p)) → is_consistent (Γ ∪ p) := by
  intros c nc hp
  apply c
  apply mp
  { apply deduction (byContradiction nc) }
  { exact deduction hp }

theorem consist_fst { Γ : ctx } { p : form } : is_consistent (Γ ∪ p) → is_consistent Γ :=
  fun hc hn => hc (weak hn)

-- Consistent context extensions
theorem consist_ext { Γ : ctx } { p : form } : is_consistent Γ → (Γ ⊬ₛ₅ ¬p) → is_consistent (Γ ∪ p) := by
  intros c np hn
  apply np (deduction hn)

theorem inconsist_ext_to_inconsist { Γ : ctx } { p : form } :
  (And (is_consistent (Γ ∪ p)) (¬is_consistent (Γ ∪ ¬p))) → (¬is_consistent Γ) := sorry
-- by
--   intros h nc
--   have h₁ : ((Γ ∪ p) ⊢ₛ₅ ⊥) := byContradiction (And.left h)
--   have h₂ : ((Γ ∪ ¬p) ⊢ₛ₅ ⊥) := byContradiction (And.right h)
--   apply nc
--   apply mp (deduction h₁)
--   apply mp dne (deduction h₂)

theorem consist_to_consist_ext { Γ : ctx } { p : form } :
  is_consistent Γ → (is_consistent (Γ ∪ p) ∨ is_consistent (Γ ∪ ¬p)) := sorry
  -- intro c
  -- apply byContradiction
  -- intro h
  -- apply absurd c
  -- apply inconsist_ext_to_inconsist
  -- apply (decidable.not_or_iff_and_not _ _).1
  -- apply h
  -- repeat apply (prop_decidable _)

theorem pos_inconsist_ext { Γ : ctx } { p : form } (c : is_consistent Γ) :
  (p ∈ Γ) → (is_consistent (Γ ∪ p)) → (¬p) ∈ Γ := sorry
-- by
--   intros hp hn
--   apply False.elim
--   apply c
--   apply mp
--   apply deduction (byContradiction hn)
--   apply ax hp

theorem neg_inconsist_ext { Γ : ctx } { p : form } (c : is_consistent Γ) :
  ((¬p) ∈ Γ) → (¬is_consistent (Γ ∪ p)) → p ∈ Γ := sorry

-- Context extensions of subcontexts
-- theorem sub_preserves_consist { Γ Δ : ctx } :
--   (is_consistent) Γ → (is_consistent Δ) → (Δ ⊆ Γ) → is_consistent (Γ ⊔ Δ) :=
-- by intros c1 c2 s nc; apply c1; exact (subctx_contr s nc)

-- Contradictions & interpretations

theorem tt_to_const { Γ : ctx } { M : model }:
  (w ∈ M.worlds) → ((M, w ⊩ Γ) = True) → (is_consistent Γ) := by
  intros w h hin
  cases (soundness hin)
  apply bot_is_insatisf
  apply Exists.intro
  sorry
  --rename_i
  -- refine (_ M w _ h)
  repeat assumption


import .Preloaded
import tactic

theorem expand : ∀ n : ℕ, (n + 1) ^ 2 = n ^ 2 + 2 * n + 1 :=
begin
  intro n,
  ring
end


import analysis.special_functions.trigonometric.arctan
import ring_theory.witt_vector.compare

noncomputable theory
local notation `ℤ/3ℤ` := zmod 3
open real
open_locale real

/-!

# Machine-Checked proofs in Lean

## Introduction

I'm Rob Lewis. Just joined the Brown CS department this fall.

My goal with this talk:
* Introduce you to the idea of proof assistants
* Show you (quickly!) what it's like to use a proof assistant
* Explain the structure and goals of Lean's library mathlib

## Following along

* Install Lean and its supporting tools:
  <https://leanprover-community.github.io/get_started.html>
* `leanproject get robertylewis/simons`
* Open the `simons` *directory* in VSCode (File -> Open Folder...)

## What is a proof assistant?

A proof assistant provides a language (or languages) to:
* define kinds of objects
* define particular objects
* state properties of those objects
* prove that these properties hold

It also provides a tool to mechanically check these proofs,
down to logical axioms.
Ideally, we want all of this to be human-readable.
-/

#check ℕ
#check 0
#check ∀ n : ℕ, 0 ≤ n

lemma my_first_lemma : ∀ n : ℕ, 0 ≤ n :=
begin
  intro n,
  apply nat.zero_le,
end

/-!

Historically these tools have been applied with "objects" = "programs".
But nothing inherently computational about them.
Depending on our choice of languages,
we can talk about totally abstract things.
-/

#check category_theory.category
#check differentiable
#check fderiv

/-!

### Why formalize mathematics?

* Verified proofs are very very likely to be correct
* Full specifications, no ambiguity
* Age of data: machine-readable proofs are machine-processable
* Applications in AI
* Applications in education
* It's incredibly addictive

Big leaf node projects may be exciting,
but all of this requires *libraries*.

## A demo: complex numbers
-/

namespace demo

structure complex :=
(re : ℝ)
(im : ℝ)

def i : complex :=
{ re := 0,
  im := 1 }

def add (c1 c2 : complex) : complex :=
{ re := c1.re + c2.re,
  im := c1.im + c2.im }

def neg (c : complex) : complex :=
{ re := -c.re,
  im := -c.im }

@[simp]
def mul (c1 c2 : complex) : complex :=
{ re := c1.re * c2.re - c1.im * c2.im,
  im := c1.re * c2.im + c1.im * c2.re }

def inv (c : complex) : complex :=
let norm := (c.re^2 + c.im^2) in
{ re := c.re / norm,
  im := - c.im / norm }

instance : field complex :=
{ add := add,
  mul := mul,
  zero := {re := 0, im := 0},
  one := {re := 1, im := 0},
  neg := neg,
  inv := inv,
  add_comm := sorry,
  add_assoc := sorry,
  zero_add := sorry,
  add_zero := sorry,
  add_left_neg := sorry,
  mul_assoc := sorry,
  one_mul := sorry,
  mul_one := sorry,
  left_distrib := sorry,
  right_distrib := sorry,
  mul_comm := sorry,
  exists_pair_ne := sorry,
  mul_inv_cancel := sorry,
  inv_zero := sorry }

/--
`to_polar c` returns a pair of real numbers `(angle, radius)`.
-/
def to_polar (c : complex) : ℝ × ℝ :=
(arctan (c.im / c.re), sqrt (c.re^2 + c.im^2))

def from_polar (angle radius : ℝ) : complex :=
{ re := radius * cos angle,
  im := radius * sin angle }

example (angle radius : ℝ) :
  to_polar (from_polar angle radius) = (angle, radius) :=
begin
  sorry
end

end demo

/-!

## Lean and mathlib

The Lean proof asssistant is relatively new,
relatively ergonomic,
and has a relatively large community of users interested in mathematics.

*mathlib* is the de facto standard library for Lean.

* <https://leanprover-community.github.io/>
* <https://github.com/leanprover-community/mathlib>
* <https://leanprover.zulipchat.com/>
* 700k lines of code, nearly 200 contributors
* Collaborative open-source project
* Lots of effort to make mathlib developments coherent, reusable

Overview of the library:
<https://leanprover-community.github.io/mathlib-overview.html>

Undergraduate math in mathlib:
<https://leanprover-community.github.io/undergrad.html>

People involved at all levels of mathematical maturity!
Formalization is a great way to get undergraduates involved.

### Noteworthy projects

A number of projects, some ongoing, have added to or built on the library.

#### Liquid tensor experiment

Peter Scholze, Dec 5, 2020:
    I want to propose a challenge:
    Formalize the proof of the following theorem.

    **Theorem 1.1** (Clausen-Scholze).
    Let 0 < p' < p ≤ 1 be real numbers,
    let S be a profinite set,
    and let V be a p-Banach space.
    Let ℳₚ'(S) be the space of p'-measures on S.

    Then Extⁱ_Cond(Ab)(ℳₚ'(S), V) = 0 for i ≥ 1.
    ...
    I think this may be my most important theorem to date....
    Better be sure it’s correct.

Peter Scholze, June 5, 2021:
    Exactly half a year ago I wrote the Liquid Tensor
    Experiment blog post...
    I am excited to announce that the Experiment has verified
    the entire part of the argument that I was unsure about.
    I find it absolutely insane that interactive proof assistants
    are now at the level that
    within a very reasonable time span
    they can formally verify difficult original research.

A collaborative effort led by Johan Commelin.
-/

/-!
#### Formalizing perfectoid spaces

A challenge in formalizing a very complex *definition*.

Kevin Buzzard, Johan Commelin, Patrick Massot (2020).

#### Formalizing the solution to the cap set problem

A *cap set* is a subset of ℤ₃ⁿ containing no arithmetic progression.

Theorem (Ellenberg and Gijswijt, 2017):
The largest possible size of a cap set is O(2.756^n).

Sander Dahmen, Johannes Hölzl, Robert Y. Lewis (2019):
-/
theorem cap_set_problem : ∃ B : ℝ,
  ∀ {n : ℕ} {A : finset (fin n → ℤ/3ℤ)},
    (∀ x y z : fin n → ℤ/3ℤ,
      x ∈ A → y ∈ A → z ∈ A → x + y + z = 0 → x = y ∧ x = z) →
    ↑A.card ≤
      B * ((((3 : ℝ) / 8)^3 * (207 + 33*real.sqrt 33))^(1/3 : ℝ))^n :=
sorry

/-!
#### Formalizing the ring of Witt vectors

Johan Commelin and Robert Y. Lewis (2021).

Abstract strategies for verifying Witt vector identities
are very hard to formalize.
With the right abstractions and some metaprogramming,
formal arguments can follow the same path as informal arguments.
-/

#check witt_vector
#check witt_vector.equiv

/-!

### Current status

Plenty of ongoing projects:
* LTE
* Sphere eversion
* Transition from Lean 3 to Lean 4
* 8- and 24-dim sphere packings?

CMU recently received a $20m donation to found
the Hoskinson Center for Formal Mathematics.

Various events planned in the medium-term future:
* Lorentz Center in Leiden, March 2022 (ask me for details!)
* ICERM, summer 2022
* Lean Together 2022, ???

## Resources and references

Learning: <https://leanprover-community.github.io/learn.html>
* Tutorials project: <https://github.com/leanprover-community/tutorials>
* Lean for the Curious Mathematician: <https://leanprover-community.github.io/lftcm2020/>
* Theorem Proving in Lean: <https://leanprover.github.io/theorem_proving_in_lean/>

Papers: <https://leanprover-community.github.io/papers.html>

* de Moura, Kong, Avigad, van Doorn, von Raumer (2015).
  *The Lean Theorem Prover (System Description)*.
  <https://doi.org/10.1007/978-3-319-21401-6_26>

* The mathlib Community (2020). *The Lean mathematical library*.
  <https://doi.org/10.1145/3372885.3373824>

* Lewis (2019). *A formal proof of Hensel's Lemma over the p-adic integers*.
  <https://doi.org/10.1145/3293880.3294089>

* Dahmen, Hölzl, Lewis (2019). *Formalizing the solution to the cap set problem*.
  <https://doi.org/10.4230/LIPIcs.ITP.2019.15>

* Buzzard, Commelin, Massot (2020). *Formalising perfectoid spaces*.
  <https://doi.org/10.1145/3372885.3373830>

* Commelin, Lewis (2021). *Formalizing the ring of Witt vectors*.
  <https://doi.org/10.1145/3437992.3439919>

-/


import linear_algebra.linear_independent
import algebra.category.Module.abelian
import algebra.category.Module.images
import algebra.homology.homology
import algebra.homology.Module
import algebra.homology.homotopy
import algebra.big_operators.finsupp

lemma submodule_restrict_app {R : Type*}
  {M₁ : Type*} {M₂ : Type*} {M₃ : Type*}
  [semiring R] [add_comm_monoid M₁] [add_comm_monoid M₂] [add_comm_monoid M₃]
  [module R M₁] [module R M₂] [module R M₃]
  (p : submodule R M₂) (q : submodule R M₃)
  (f : M₁ →ₗ[R] M₂) (g : M₂ →ₗ[R] M₃)
  (hf : ∀ (x : M₁), f x ∈ p)
  (hg : ∀ (y : p), g.dom_restrict p y ∈ q)
  (x : M₁)
  : linear_map.cod_restrict q (linear_map.dom_restrict g p)
      hg
      (linear_map.cod_restrict p f hf x)
  = linear_map.cod_restrict q (g.comp f) (λ x, hg ⟨f x, hf x⟩) x :=
begin
  ext, refl
end

lemma free_module_basis_linear_independent
    (R : Type*) [ring R] (X : Type*)
    : linear_independent R (λ x : X, finsupp.single x (1 : R)) :=
begin
  rw linear_independent_iff,
  intros y h,
  have h' : y.support.sum (λ a, finsupp.single a (y a)) = 0,
  { rw [← h, finsupp.total_apply], dsimp [finsupp.sum],
    congr, ext, simp },
  ext x,
  have h'' : y.support.sum (λ a, finsupp.single a (y a)) x = 0,
  { rw h', simp },
  rw [finset.sum_apply', finset.sum_eq_single x,
      finsupp.single_eq_same] at h'',
  exact h'',
  { intros, rw finsupp.single_apply_eq_zero,
    intro H, symmetry' at H, contradiction },
  { intro H, rw finsupp.not_mem_support_iff at H, rw H, simp }
end

lemma free_module_basis_spanning
    (R : Type*) [ring R] (X : Type*)
    : submodule.span R (set.range (λ x : X, finsupp.single x (1 : R))) = ⊤ :=
begin
  ext f, rw submodule.mem_span, simp,
  intros p hp,
  -- Should extract this as a common lemma
  have : f = (f.support).sum (λ x, finsupp.single x (f x)),
  { ext x, symmetry, rw [finset.sum_apply', finset.sum_eq_single x, finsupp.single_eq_same],
    { intros b hb h, rw finsupp.single_apply_eq_zero, intro, symmetry' at h, contradiction },
    { intro H, rw finsupp.not_mem_support_iff at H, rw H, simp } },
  rw this,
  apply submodule.sum_mem,
  intros x hx,
  rw ← mul_one (f x),
  generalize h : finsupp.single x (f x * 1) = c,
  have := eq.trans (finsupp.smul_single (f x) x 1) h,
  rw ← this,
  apply submodule.smul_mem,
  apply hp,
  existsi x, refl
end

local attribute [instance] classical.prop_decidable
universes u v w

lemma basis.mem_span_iff (R : Type u) [comm_ring R] {M : Type v}
  [add_comm_monoid M] [module R M] {ι : Type w}
  (b : basis ι R M) (S : set M) (hS : S ⊆ set.range b) (x : M)
  : x ∈ submodule.span R S ↔ (∀ i, b.repr x i ≠ 0 → b i ∈ S) :=
begin
  by_cases ax1 : nonempty ι, swap,
  { simp at ax1,
    have h1 : ∀ y, b.repr y = 0,
    { intro, rw ← finsupp.support_eq_empty, exact @finset.eq_empty_of_is_empty _ ax1 _ },
    have : ∀ y : M, y = 0,
    { intro y, refine eq.trans (b.total_repr y).symm _, rw h1, apply map_zero },
    rw [this x, h1],
    simp, },
  by_cases ax2 : nontrivial R, swap,
  { rw nontrivial_iff at ax2, simp_rw [not_exists, not_not] at ax2,
    have : x = 0 := eq.trans (one_smul R x).symm (eq.trans (congr_arg2 _ (ax2 1 0) (refl x)) (zero_smul _ _)),
    rw this, rw (_ : ∀ y, b.repr y = 0), simp,
    intro, ext, apply ax2 },
  split,
  { intros h i,
    apply submodule.span_induction h,
    { intros y hy1 hy2,
      have := @function.inv_fun_eq _ _ ax1 _ _ (hS hy1),
      dsimp at this,
      rw ← this at hy2, simp at hy2,
      rw finsupp.single_apply at hy2,
      split_ifs at hy2,
      { rw h_1 at this, rw this, exact hy1 },
      { exfalso, apply hy2, refl } },
    { intro hi, exfalso, apply hi, simp },
    { intros y z hy hz hsum,
      simp at hsum,
      by_cases b.repr y i = 0 ∧ b.repr z i = 0,
      { exfalso, rw [h.left, h.right] at hsum, simp at hsum, exact hsum },
      { rw decidable.not_and_iff_or_not at h, cases h with h,
        { exact hy h },
        { exact hz h_1 }, } },
    { intros r x hx hrx, apply hx,
      simp at hrx,
      intro h', rw h' at hrx, apply hrx, simp, } },
  { intro h,
    refine (finsupp.mem_span_iff_total R S x).mpr _,
    let l : S →₀ R := finsupp.comap_domain (@function.inv_fun ι M ax1 (b : ι → M) ∘ subtype.val)
                                           (b.repr x)
                                           _,
    swap,
    { rintros ⟨a, ha⟩ _ ⟨a', ha'⟩ _ haa', simp at ⊢ haa',
      exact eq.trans (@function.inv_fun_eq _ _ ax1 _ _ (hS ha)).symm
                     (eq.trans (congr_arg b haa') (@function.inv_fun_eq _ _ ax1 _ _ (hS ha'))) },
    existsi l,
    refine eq.trans _ (b.total_repr x),
    simp [finsupp.total, finsupp.sum],
    refine finset.sum_bij (λ s _, @function.inv_fun ι M ax1 (b : ι → M) s.val)
                          _ _ _ _,
    { intro, simp },
    { rintros ⟨s, hs⟩ hs', simp at ⊢ hs',
      symmetry, exact congr_arg2 _ rfl (@function.inv_fun_eq _ _ ax1 _ _ (hS hs)), },
    { rintros ⟨a, ha⟩ ⟨a', ha'⟩ _ _ haa', apply subtype.eq,
      exact eq.trans (@function.inv_fun_eq _ _ ax1 _ _ (hS ha)).symm
                     (eq.trans (congr_arg b haa') (@function.inv_fun_eq _ _ ax1 _ _ (hS ha'))) },
    { intros i hi, simp at hi,
      refine exists.intro ⟨b i, h i hi⟩ _,
      have : @function.inv_fun _ _ ax1 b (b i) = i,
      { refine (@basis.injective _ _ _ _ _ _ b ax2) _ _ _,
        exact (@function.inv_fun_eq _ _ ax1 _ _ (hS (h i hi))) },
      refine exists.intro _ _,
      { simp, convert hi },
      { symmetry, apply this } } }
end

lemma submodule.inf_spans_free (R : Type) [comm_ring R] {M : Type*}
  [add_comm_monoid M] [module R M] {ι : Type*}
  (b : basis ι R M)
  (S T : set M) (hS : S ⊆ set.range b) (hT : T ⊆ set.range b)
  : submodule.span R S ⊓ submodule.span R T = submodule.span R (S ∩ T) :=
begin
  ext x, split; intro h,
  { simp at h,
    rw [basis.mem_span_iff R b S hS, basis.mem_span_iff R b T hT] at h, cases h with h1 h2,
    rw basis.mem_span_iff R b (S ∩ T) (subset_trans (set.inter_subset_left S T) hS),
    intros i hi, exact ⟨h1 i hi, h2 i hi⟩ },
  { rw basis.mem_span_iff R b (S ∩ T) (subset_trans (set.inter_subset_left S T) hS) at h,
    simp, rw [basis.mem_span_iff R b S hS, basis.mem_span_iff R b T hT],
    split; intros i hi, { exact (h i hi).left }, { exact (h i hi).right } }
end

lemma submodule.sup_spans (R : Type) [comm_ring R] {M : Type*}
  [add_comm_monoid M] [module R M] (S T : set M)
  : submodule.span R S ⊔ submodule.span R T = submodule.span R (S ∪ T) :=
begin
  apply eq_of_forall_ge_iff, intro N,
  rw sup_le_iff,
  split; intro h,
  { rw submodule.span_le,
    intros x hx, cases hx,
    { exact h.left (submodule.subset_span hx) },
    { exact h.right (submodule.subset_span hx) } },
  { split; refine le_trans _ h; apply submodule.span_mono; simp }
end

lemma map_domain_inj_of_inj {α β : Type*} {M : Type*} [add_comm_monoid M]
  (f : α → β) (hf : function.injective f)
  : function.injective (@finsupp.map_domain α β M _ f) :=
begin
  intros p q h, ext a,
  convert congr_arg (λ g : β →₀ M, g (f a)) h;
  rw finsupp.map_domain_apply hf,
end.

/-
It might be better to prove this by looking at stuff as coequalizers and using left adjointness of
the free module functor.
-/

noncomputable
def basis.quotient_basis (ι : Type*) (R : Type*) (M : Type*) [ring R] [add_comm_group M]
  [module R M] (N : submodule R M) (b : basis ι R M) (s : setoid ι)
  (H : N = submodule.span R (set.image (λ p : ι × ι, b p.fst - b p.snd) { p | p.fst ≈ p.snd }))
  : basis (quotient s) R (M ⧸ N) :=
  let v : quotient s → M ⧸ N := quotient.lift (λ i, submodule.quotient.mk (b i))
                                              (by { intros i j hij,
                                                    refine (submodule.quotient.eq N).mpr _,
                                                    rw H,
                                                    refine submodule.subset_span _,
                                                    refine @set.mem_image_of_mem _ _ _ (i, j) _ _,
                                                    exact hij }) in
  have h1 : linear_independent R v,
  by { have hcoeffs' := b.linear_independent,
       rw linear_independent_iff at ⊢ hcoeffs',
       intros coeffs h,
       let support' := coeffs.support.image quotient.out,
       let coeffs' : ι →₀ R := ⟨support', (λ x, if x ∈ support' then coeffs (quotient.mk x) else 0), _⟩,
       swap, { intro, simp, simp_rw ← and_assoc, simp, intros x hx ha, subst ha, simp, exact hx },
       specialize hcoeffs' coeffs' _,
       { have h' : N.mkq (finsupp.total ι M R b coeffs')
                 = finsupp.total (quotient s) (M ⧸ N) R v coeffs,
         { dsimp [finsupp.total, finsupp.sum],
           rw ← submodule.mkq_apply N,
           rw map_sum,
           apply finset.sum_bij' (λ i _, quot.mk s.r i) _ _ (λ j _, quot.out j),
           { intros, simp,
             simp [support'] at ha,
             obtain ⟨b, _, hb⟩ := ha, subst hb,
             exact congr_arg quot.out b.out_eq },
           { intros, simp },
           { intros, simp [support'], simp at ha,
             refine ⟨a, ha, rfl⟩ },
           { intros, simp [support'] at ha,
             obtain ⟨b, hb, hb'⟩ := ha, subst hb',
             simp, convert hb,
             exact b.out_eq },
           { intros, rw ite_eq_left_iff.mpr _, swap, { intros, contradiction },
             simp [v],
             refl } },
         rw h at h',
         simp at h',
         have H' : N = submodule.span R ((λ i : ι, b (quot.mk s.r i).out - b i) '' { i | (quot.mk s.r i).out ≠ i }),
         { refine eq.trans H _,
           apply le_antisymm,
           { rw submodule.span_le,
             rw set.image_subset_iff,
             rintros ⟨i, j⟩ hij,
             simp,
             rw (_ : b i - b j = (b (quot.mk setoid.r j).out - b j) - (b (quot.mk setoid.r i).out - b i)),
             { refine submodule.sub_mem _ _ _,
               { by_cases hj : (quot.mk s.r j).out = j,
                 { rw hj, rw sub_self, exact submodule.zero_mem _ },
                 { refine submodule.subset_span _, exact set.mem_image_of_mem _ hj } },
               { by_cases hi : (quot.mk s.r i).out = i,
                 { rw hi, rw sub_self, exact submodule.zero_mem _ },
                 { refine submodule.subset_span _, exact set.mem_image_of_mem _ hi } } },
             { have hij' : quot.mk setoid.r i = quot.mk setoid.r j := quotient.sound hij,
               rw hij',
               simp } },
           { rw submodule.span_le,
             rw set.image_subset_iff,
             intros i hi,
             refine submodule.subset_span _,
             simp,
             refine ⟨(quot.mk setoid.r i).out, i, _, rfl⟩,
             exact quotient.mk_out i } },
         rw H' at h',
         rw finsupp.mem_span_image_iff_total at h',
         obtain ⟨l, Hl_supp, Hl⟩ := h',
         dsimp [finsupp.supported] at Hl_supp,
         rw (_ : finsupp.total ι M R (λ (i : ι), b (quot.mk setoid.r i).out - b i) l
               = finsupp.total ι M R (λ (i : ι), b (quot.mk setoid.r i).out) l
               - finsupp.total ι M R b l)
            at Hl,
         { rw sub_eq_iff_eq_add at Hl,
           rw ← map_add at Hl,
           suffices Hl' : l = 0,
           { rw Hl' at Hl,
             simp at Hl,
             exact Hl.symm },
           rw (_ : (finsupp.total ι M R (λ (i : ι), b (quot.mk setoid.r i).out)) l
                 = (finsupp.total ι M R b) (l.map_domain (λ i, (quot.mk setoid.r i).out))) at Hl,
           { rw ← sub_eq_zero at Hl,
             rw ← map_sub at Hl,
             have := linear_independent_iff.mp b.linear_independent _ Hl,
             rw ← finsupp.support_eq_empty,
             rw ← finset.subset_empty,
             intros i hi, change false,
             specialize Hl_supp hi,
             have hi' : (finsupp.map_domain (λ (i : ι), (quot.mk setoid.r i).out) l - (coeffs' + l)) i = 0,
             { rw this, refl },
             simp at hi',
            --  replace this := congr_fun (congr_arg finsupp.to_fun this) i,
             rw [← sub_sub, sub_eq_zero] at hi',
             simp at hi, apply hi,
             rw ← hi',
             convert zero_sub_zero,
             { apply finsupp.map_domain_notin_range,
               rintro ⟨j, hj⟩,
               dsimp at hj, subst hj,
               refine Hl_supp _,
               exact congr_arg quot.out (quot.out_eq _) },
             { rw ite_eq_right_iff,
               rintro ⟨j, _, hj⟩, subst hj,
               exfalso,
               refine Hl_supp _,
               exact congr_arg quot.out (quot.out_eq _) } },
           { simp [finsupp.total, finsupp.map_domain],
             rw finsupp.sum_sum_index,
             { congr, ext,
               rw [finsupp.sum_single_index],
               apply zero_smul },
             { intro, apply zero_smul },
             { intros, apply add_smul } } },
         { rw [finsupp.total_apply, finsupp.total_apply, finsupp.total_apply],
           simp [finsupp.sum],
           simp_rw [smul_sub],
           simp } },
       ext i,
       have : coeffs' i.out = 0,
       { rw hcoeffs', refl },
       simp [coeffs'] at this,
       exact this },
  have h2 : submodule.span R (set.range v) = ⊤,
  by { rw eq_top_iff,
       intros x hx,
       induction x,
       { have := b.mem_span x,
         simp [submodule.span] at this ⊢,
         intros p Hp,
         refine this (submodule.comap N.mkq p) _,
         rintros t ⟨i, hi⟩, subst hi,
         refine Hp _,
         existsi ⟦i⟧,
         refl },
       { refl } },
  basis.mk h1 h2.

lemma basis_constr_of_lin_indep_family_injective {ι : Type*} {R : Type*} {M : Type*} {M' : Type*}
  [comm_ring R] [nontrivial R] [add_comm_group M] [module R M] [add_comm_group M'] [module R M']
  (b : basis ι R M) (f : ι → M') (hf : linear_independent R f)
  : function.injective (basis.constr b R f) :=
begin
  rw [← linear_map.ker_eq_bot, linear_map.ker_eq_bot'],
  intros m hm,
  simp [basis.constr] at hm,
  rw finsupp.total_map_domain at hm, swap, { exact hf.injective },
  rw function.comp.left_id at hm,
  rw linear_independent_iff at hf,
  specialize hf _ hm,
  rw linear_equiv.map_eq_zero_iff at hf, exact hf
end


/-
Copyright (c) 2020 Anatole Dedecker. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anatole Dedecker
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.analysis.normed_space.basic
import Mathlib.algebra.ring.basic
import Mathlib.analysis.asymptotics
import Mathlib.PostPort

universes u_1 l

namespace Mathlib

/-!
# Ordered normed spaces

In this file, we define classes for fields and groups that are both normed and ordered.
These are mostly useful to avoid diamonds during type class inference.
-/

/-- A `normed_linear_ordered_group` is an additive group that is both a `normed_group` and
    a `linear_ordered_add_comm_group`. This class is necessary to avoid diamonds. -/
class normed_linear_ordered_group (α : Type u_1)
    extends has_norm α, linear_ordered_add_comm_group α, metric_space α where
  dist_eq : ∀ (x y : α), dist x y = norm (x - y)

protected instance normed_linear_ordered_group.to_normed_group (α : Type u_1)
    [normed_linear_ordered_group α] : normed_group α :=
  normed_group.mk normed_linear_ordered_group.dist_eq

/-- A `normed_linear_ordered_field` is a field that is both a `normed_field` and a
    `linear_ordered_field`. This class is necessary to avoid diamonds. -/
class normed_linear_ordered_field (α : Type u_1)
    extends linear_ordered_field α, metric_space α, has_norm α where
  dist_eq : ∀ (x y : α), dist x y = norm (x - y)
  norm_mul' : ∀ (a b : α), norm (a * b) = norm a * norm b

protected instance normed_linear_ordered_field.to_normed_field (α : Type u_1)
    [normed_linear_ordered_field α] : normed_field α :=
  normed_field.mk normed_linear_ordered_field.dist_eq normed_linear_ordered_field.norm_mul'

protected instance normed_linear_ordered_field.to_normed_linear_ordered_group (α : Type u_1)
    [normed_linear_ordered_field α] : normed_linear_ordered_group α :=
  normed_linear_ordered_group.mk normed_linear_ordered_field.dist_eq

theorem tendsto_pow_div_pow_at_top_of_lt {α : Type u_1} [normed_linear_ordered_field α]
    [order_topology α] {p : ℕ} {q : ℕ} (hpq : p < q) :
    filter.tendsto (fun (x : α) => x ^ p / x ^ q) filter.at_top (nhds 0) :=
  sorry

theorem is_o_pow_pow_at_top_of_lt {α : Type} [normed_linear_ordered_field α] [order_topology α]
    {p : ℕ} {q : ℕ} (hpq : p < q) :
    asymptotics.is_o (fun (x : α) => x ^ p) (fun (x : α) => x ^ q) filter.at_top :=
  sorry

end Mathlib