import data.fintype.basic
import data.finset data.set data.equiv.list tactic
--import topology.basic
-- import tactic.interactive
-- noncomputable theory

---open classical
--local attribute [instance] prop_decidable

-- variables {α : Type*} [decidable_eq α]
variables (E: Type*) [decidable_eq E] [fintype E]
variables (α : Type*) [decidable_eq α]

-- variables (F : Type*) [decidable_eq F] [fintype F]
-- variables

open finset
open fintype

namespace matroid

--def foo (X : set E) [decidable_pred X] : fintype (subtype X) := by apply_instance

--def size (X: set E) [decidable_pred X] : ℕ  := fintype.card (subtype X)
def size (X: set E) : ℕ := 0

--#check size

--example (F : set E) [decidable_pred F] : fintype (subtype F) := subtype.fintype F --finset.subtype.fintype F,,

structure matroid :=
(r : finset E → ℕ)
(R1 : ∀ (X : finset E), 0 ≤ r X ∧ r X ≤ card X )
(R2 : ∀ (X Y: finset E), X ⊆ Y → r X ≤ r Y)
(R3 : ∀ (X Y: finset  E), r (X ∪ Y) + r (X ∩ Y) ≤ r X + r Y)

def curry {α β γ : Type*} (f : α × β → γ) : α → β → γ := λ a, λ b, f (a,b)
def uncurry {α β γ : Type*} (f : α → β → γ) : α × β → γ := λ p, f p.1 p.2

def f: (ℕ × ℕ) → ℕ := λ p, p.1 + p.2

#check f
#check (curry f)
#eval ((curry f 3) 5)

/-def submatroid' (M : matroid E) (F : finset E) : matroid ( ??? ) :=
{ r := sorry,
R1 := sorry,
R2 := sorry,
R3 := sorry,
}-/

--def E_type (E: finset α) := (sorry) :()

--def sigma_matroid : Σ E : (finset α) , (r : finset E → ℕ)

/-
def submatroid (M : matroid E) (F : set E) [decidable_pred F] : matroid (subtype F) :=
{ r := λ X: set F , M.r ((coe : subtype F → E) '' X), --(λ (X : set F), M.r (coe '' X: set E)),
  R1 :=
  begin
      intros X X_decid,
      have dec : decidable_pred (coe '' X), refine dec_pred (coe '' X),
      have :=  M.R1 dec (coe '' X) ,  --(coe '' X) ,
  end,
  R2 :=
  begin
      intros X Y,
      have := M.R2 (coe '' X) (coe '' Y),
      intros hXY,
      have coe_something : coe '' X ⊆ coe '' Y := image_subset (coe : subtype F → E) hXY,
      exact this coe_something,
  end,
  R3 :=
  begin
      intros X Y,
      have coe_u := image_union (coe: subtype F → E) X Y,
      have inj : function.injective (coe: subtype F → E), exact subtype.coe_injective,
      have coe_i := image_inter inj,
      rw coe_u,
      rw ← coe_i,
      exact M.R3 (coe '' X) (coe '' Y),
  end
}

@[simp] lemma sdflkas (M : matroid E) (F : set E) [decidable_pred F] (s : set F) :
  (submatroid E M F).r s = M.r (coe '' s : set E) := rfl
-- begin

-- end

lemma easy (M : matroid E) (F: set E)[decidable_pred F] : (submatroid E M F).r (univ) ≤ M.r (univ) :=
begin
  -- convert M.R2 F univ (subset_univ F),
    -- sorry,
    -- calc (submatroid E M F).r univ = M.r F              : _
    --                     ...        ≤ M.r univ           : M.R2 F univ (subset_univ F),
    simp,
    exact M.R2 F univ (subset_univ F),

end

-- C ⊆ E   N = M / C           N.r (X) := M.r (X ∪ C) - M.r (C)

--def restriction (M: matroid E) (X: set E) : matroid (set_fintype X) := ⟨sorry,sorry,sorry,sorry,⟩

--variables {M: Type*} [matroid M]

/-lemma empty_rank_zero (M : matroid E) : M.r ∅ = 0 :=
begin

    cases (M.R1 ∅),

    have : size ∅ = 0, sorry,
    --unfold size at right,

    --rw (by library_search : size ∅ = 0) at right,
    linarith

end-/
-/

end matroid


/-
Copyright (c) 2022 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import Init.Data.Array.Basic
import Init.Classical

namespace Array

theorem eq_of_isEqvAux [DecidableEq α] (a b : Array α) (hsz : a.size = b.size) (i : Nat) (hi : i ≤ a.size) (heqv : Array.isEqvAux a b hsz (fun x y => x = y) i) (j : Nat) (low : i ≤ j) (high : j < a.size) : a[j] = b[j]'(hsz ▸ high) := by
  by_cases h : i < a.size
  · unfold Array.isEqvAux at heqv
    simp [h] at heqv
    have hind := eq_of_isEqvAux a b hsz (i+1) (Nat.succ_le_of_lt h) heqv.2
    by_cases heq : i = j
    · subst heq; exact heqv.1
    · exact hind j (Nat.succ_le_of_lt (Nat.lt_of_le_of_ne low heq)) high
  · have heq : i = a.size := Nat.le_antisymm hi (Nat.ge_of_not_lt h)
    subst heq
    exact absurd (Nat.lt_of_lt_of_le high low) (Nat.lt_irrefl j)
termination_by _ => a.size - i

theorem eq_of_isEqv [DecidableEq α] (a b : Array α) : Array.isEqv a b (fun x y => x = y) → a = b := by
  simp [Array.isEqv]
  split
  case inr => intro; contradiction
  case inl hsz =>
   intro h
   have aux := eq_of_isEqvAux a b hsz 0 (Nat.zero_le ..) h
   exact ext a b hsz fun i h _ => aux i (Nat.zero_le ..) _

theorem isEqvAux_self [DecidableEq α] (a : Array α) (i : Nat) : Array.isEqvAux a a rfl (fun x y => x = y) i = true := by
  unfold Array.isEqvAux
  split
  case inl h => simp [h, isEqvAux_self a (i+1)]
  case inr h => simp [h]
termination_by _ => a.size - i

theorem isEqv_self [DecidableEq α] (a : Array α) : Array.isEqv a a (fun x y => x = y) = true := by
  simp [isEqv, isEqvAux_self]

instance [DecidableEq α] : DecidableEq (Array α) :=
  fun a b =>
    match h:isEqv a b (fun a b => a = b) with
    | true  => isTrue (eq_of_isEqv a b h)
    | false => isFalse fun h' => by subst h'; rw [isEqv_self] at h; contradiction

end Array


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

! This file was ported from Lean 3 source module algebra.module.submodule.basic
! leanprover-community/mathlib commit feb99064803fd3108e37c18b0f77d0a8344677a3
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Module.LinearMap
import Mathlib.Algebra.Module.Equiv
import Mathlib.GroupTheory.GroupAction.SubMulAction
import Mathlib.GroupTheory.Submonoid.Membership

/-!

# Submodules of a module

In this file we define

* `Submodule R M` : a subset of a `Module` `M` that contains zero and is closed with respect to
  addition and scalar multiplication.

* `Subspace k M` : an abbreviation for `Submodule` assuming that `k` is a `Field`.

## Tags

submodule, subspace, linear map
-/

open Function

open BigOperators

universe u'' u' u v w

variable {G : Type u''} {S : Type u'} {R : Type u} {M : Type v} {ι : Type w}

/--
`SubmoduleClass S R M` says `S` is a type of submodules `s ≤ M`.

Note that only `R` is marked as `outParam` since `M` is already supplied by the `SetLike` class.
-/
class SubmoduleClass (S : Type _) (R : outParam <| Type _) (M : Type _) [AddZeroClass M] [SMul R M]
  [SetLike S M] [AddSubmonoidClass S M] extends SMulMemClass S R M
#align submodule_class SubmoduleClass

/-- A submodule of a module is one which is closed under vector operations.
  This is a sufficient condition for the subset of vectors in the submodule
  to themselves form a module. -/
structure Submodule (R : Type u) (M : Type v) [Semiring R] [AddCommMonoid M] [Module R M] extends
  AddSubmonoid M, SubMulAction R M : Type v
#align submodule Submodule

/-- Reinterpret a `Submodule` as an `AddSubmonoid`. -/
add_decl_doc Submodule.toAddSubmonoid
#align submodule.to_add_submonoid Submodule.toAddSubmonoid

/-- Reinterpret a `Submodule` as an `SubMulAction`. -/
add_decl_doc Submodule.toSubMulAction
#align submodule.to_sub_mul_action Submodule.toSubMulAction

namespace Submodule

variable [Semiring R] [AddCommMonoid M] [Module R M]

instance setLike : SetLike (Submodule R M) M where
  coe s := s.carrier
  coe_injective' p q h := by cases p; cases q; congr; exact SetLike.coe_injective' h
#align submodule.set_like Submodule.setLike

instance addSubmonoidClass : AddSubmonoidClass (Submodule R M) M where
  zero_mem _ := AddSubmonoid.zero_mem' _
  add_mem := AddSubsemigroup.add_mem' _
#align submodule.add_submonoid_class Submodule.addSubmonoidClass

instance submoduleClass : SubmoduleClass (Submodule R M) R M where
  smul_mem {s} c _ h := SubMulAction.smul_mem' s.toSubMulAction c h
#align submodule.submodule_class Submodule.submoduleClass

@[simp]
theorem mem_toAddSubmonoid (p : Submodule R M) (x : M) : x ∈ p.toAddSubmonoid ↔ x ∈ p :=
  Iff.rfl
#align submodule.mem_to_add_submonoid Submodule.mem_toAddSubmonoid

variable {p q : Submodule R M}

@[simp]
theorem mem_mk {S : AddSubmonoid M} {x : M} (h) : x ∈ (⟨S, h⟩ : Submodule R M) ↔ x ∈ S :=
  Iff.rfl
#align submodule.mem_mk Submodule.mem_mk

@[simp]
theorem coe_set_mk (S : AddSubmonoid M) (h) : ((⟨S, h⟩ : Submodule R M) : Set M) = S :=
  rfl
#align submodule.coe_set_mk Submodule.coe_set_mk

-- Porting note: replaced `S ⊆ S' : Set` with `S ≤ S'`
@[simp]
theorem mk_le_mk {S S' : AddSubmonoid M} (h h') :
    (⟨S, h⟩ : Submodule R M) ≤ (⟨S', h'⟩ : Submodule R M) ↔ S ≤ S' :=
  Iff.rfl
#align submodule.mk_le_mk Submodule.mk_le_mk

@[ext]
theorem ext (h : ∀ x, x ∈ p ↔ x ∈ q) : p = q :=
  SetLike.ext h
#align submodule.ext Submodule.ext

-- Porting note: adding this as the `simp`-normal form of `toSubMulAction_eq`
@[simp]
theorem carrier_inj : p.carrier = q.carrier ↔ p = q :=
  (SetLike.coe_injective (A := Submodule R M)).eq_iff

/-- Copy of a submodule with a new `carrier` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (p : Submodule R M) (s : Set M) (hs : s = ↑p) : Submodule R M where
  carrier := s
  zero_mem' := by simpa [hs] using p.zero_mem'
  add_mem' := hs.symm ▸ p.add_mem'
  smul_mem' := by simpa [hs] using p.smul_mem'
#align submodule.copy Submodule.copy

@[simp]
theorem coe_copy (S : Submodule R M) (s : Set M) (hs : s = ↑S) : (S.copy s hs : Set M) = s :=
  rfl
#align submodule.coe_copy Submodule.coe_copy

theorem copy_eq (S : Submodule R M) (s : Set M) (hs : s = ↑S) : S.copy s hs = S :=
  SetLike.coe_injective hs
#align submodule.copy_eq Submodule.copy_eq

theorem toAddSubmonoid_injective : Injective (toAddSubmonoid : Submodule R M → AddSubmonoid M) :=
  fun p q h => SetLike.ext'_iff.2 (show (p.toAddSubmonoid : Set M) = q from SetLike.ext'_iff.1 h)
#align submodule.to_add_submonoid_injective Submodule.toAddSubmonoid_injective

@[simp]
theorem toAddSubmonoid_eq : p.toAddSubmonoid = q.toAddSubmonoid ↔ p = q :=
  toAddSubmonoid_injective.eq_iff
#align submodule.to_add_submonoid_eq Submodule.toAddSubmonoid_eq

@[mono]
theorem toAddSubmonoid_strictMono : StrictMono (toAddSubmonoid : Submodule R M → AddSubmonoid M) :=
  fun _ _ => id
#align submodule.to_add_submonoid_strict_mono Submodule.toAddSubmonoid_strictMono

theorem toAddSubmonoid_le : p.toAddSubmonoid ≤ q.toAddSubmonoid ↔ p ≤ q :=
  Iff.rfl
#align submodule.to_add_submonoid_le Submodule.toAddSubmonoid_le

@[mono]
theorem toAddSubmonoid_mono : Monotone (toAddSubmonoid : Submodule R M → AddSubmonoid M) :=
  toAddSubmonoid_strictMono.monotone
#align submodule.to_add_submonoid_mono Submodule.toAddSubmonoid_mono

@[simp]
theorem coe_toAddSubmonoid (p : Submodule R M) : (p.toAddSubmonoid : Set M) = p :=
  rfl
#align submodule.coe_to_add_submonoid Submodule.coe_toAddSubmonoid

theorem toSubMulAction_injective : Injective (toSubMulAction : Submodule R M → SubMulAction R M) :=
  fun p q h => SetLike.ext'_iff.2 (show (p.toSubMulAction : Set M) = q from SetLike.ext'_iff.1 h)
#align submodule.to_sub_mul_action_injective Submodule.toSubMulAction_injective

theorem toSubMulAction_eq : p.toSubMulAction = q.toSubMulAction ↔ p = q :=
  toSubMulAction_injective.eq_iff
#align submodule.to_sub_mul_action_eq Submodule.toSubMulAction_eq

@[mono]
theorem toSubMulAction_strictMono :
    StrictMono (toSubMulAction : Submodule R M → SubMulAction R M) := fun _ _ => id
#align submodule.to_sub_mul_action_strict_mono Submodule.toSubMulAction_strictMono

@[mono]
theorem toSubMulAction_mono : Monotone (toSubMulAction : Submodule R M → SubMulAction R M) :=
  toSubMulAction_strictMono.monotone
#align submodule.to_sub_mul_action_mono Submodule.toSubMulAction_mono

@[simp]
theorem coe_toSubMulAction (p : Submodule R M) : (p.toSubMulAction : Set M) = p :=
  rfl
#align submodule.coe_to_sub_mul_action Submodule.coe_toSubMulAction

end Submodule

namespace SubmoduleClass

variable [Semiring R] [AddCommMonoid M] [Module R M] {A : Type _} [SetLike A M]
  [AddSubmonoidClass A M] [SubmoduleClass A R M] (S' : A)

-- Prefer subclasses of `Module` over `SubmoduleClass`.
/-- A submodule of a `Module` is a `Module`.  -/
instance (priority := 75) toModule : Module R S' :=
  Subtype.coe_injective.module R (AddSubmonoidClass.Subtype S') (SetLike.val_smul S')
#align submodule_class.to_module SubmoduleClass.toModule

/-- The natural `R`-linear map from a submodule of an `R`-module `M` to `M`. -/
protected def subtype : S' →ₗ[R] M where
  toFun := Subtype.val
  map_add' _ _ := rfl
  map_smul' _ _ := rfl
#align submodule_class.subtype SubmoduleClass.subtype

@[simp]
protected theorem coeSubtype : (SubmoduleClass.subtype S' : S' → M) = Subtype.val :=
  rfl
#align submodule_class.coe_subtype SubmoduleClass.coeSubtype

end SubmoduleClass

namespace Submodule

section AddCommMonoid

variable [Semiring R] [AddCommMonoid M]

-- We can infer the module structure implicitly from the bundled submodule,
-- rather than via typeclass resolution.
variable {module_M : Module R M}

variable {p q : Submodule R M}

variable {r : R} {x y : M}

variable (p)

-- Porting note: removing `@[simp]` since it can already be proven
theorem mem_carrier : x ∈ p.carrier ↔ x ∈ (p : Set M) :=
  Iff.rfl
#align submodule.mem_carrier Submodule.mem_carrier

@[simp]
protected theorem zero_mem : (0 : M) ∈ p :=
  zero_mem _
#align submodule.zero_mem Submodule.zero_mem

protected theorem add_mem (h₁ : x ∈ p) (h₂ : y ∈ p) : x + y ∈ p :=
  add_mem h₁ h₂
#align submodule.add_mem Submodule.add_mem

theorem smul_mem (r : R) (h : x ∈ p) : r • x ∈ p :=
  p.smul_mem' r h
#align submodule.smul_mem Submodule.smul_mem

theorem smul_of_tower_mem [SMul S R] [SMul S M] [IsScalarTower S R M] (r : S) (h : x ∈ p) :
    r • x ∈ p :=
  p.toSubMulAction.smul_of_tower_mem r h
#align submodule.smul_of_tower_mem Submodule.smul_of_tower_mem

protected theorem sum_mem {t : Finset ι} {f : ι → M} : (∀ c ∈ t, f c ∈ p) → (∑ i in t, f i) ∈ p :=
  sum_mem
#align submodule.sum_mem Submodule.sum_mem

theorem sum_smul_mem {t : Finset ι} {f : ι → M} (r : ι → R) (hyp : ∀ c ∈ t, f c ∈ p) :
    (∑ i in t, r i • f i) ∈ p :=
  sum_mem fun i hi => smul_mem _ _ (hyp i hi)
#align submodule.sum_smul_mem Submodule.sum_smul_mem

@[simp]
theorem smul_mem_iff' [Group G] [MulAction G M] [SMul G R] [IsScalarTower G R M] (g : G) :
    g • x ∈ p ↔ x ∈ p :=
  p.toSubMulAction.smul_mem_iff' g
#align submodule.smul_mem_iff' Submodule.smul_mem_iff'

instance add : Add p :=
  ⟨fun x y => ⟨x.1 + y.1, add_mem x.2 y.2⟩⟩
#align submodule.has_add Submodule.add

instance zero : Zero p :=
  ⟨⟨0, zero_mem _⟩⟩
#align submodule.has_zero Submodule.zero

instance inhabited : Inhabited p :=
  ⟨0⟩
#align submodule.inhabited Submodule.inhabited

instance smul [SMul S R] [SMul S M] [IsScalarTower S R M] : SMul S p :=
  ⟨fun c x => ⟨c • x.1, smul_of_tower_mem _ c x.2⟩⟩
#align submodule.has_smul Submodule.smul

instance isScalarTower [SMul S R] [SMul S M] [IsScalarTower S R M] : IsScalarTower S R p :=
  p.toSubMulAction.isScalarTower
#align submodule.is_scalar_tower Submodule.isScalarTower

instance isScalarTower' {S' : Type _} [SMul S R] [SMul S M] [SMul S' R] [SMul S' M] [SMul S S']
    [IsScalarTower S' R M] [IsScalarTower S S' M] [IsScalarTower S R M] : IsScalarTower S S' p :=
  p.toSubMulAction.isScalarTower'
#align submodule.is_scalar_tower' Submodule.isScalarTower'

instance isCentralScalar [SMul S R] [SMul S M] [IsScalarTower S R M] [SMul Sᵐᵒᵖ R] [SMul Sᵐᵒᵖ M]
    [IsScalarTower Sᵐᵒᵖ R M] [IsCentralScalar S M] : IsCentralScalar S p :=
  p.toSubMulAction.isCentralScalar
#align submodule.is_central_scalar Submodule.isCentralScalar

protected theorem nonempty : (p : Set M).Nonempty :=
  ⟨0, p.zero_mem⟩
#align submodule.nonempty Submodule.nonempty

@[simp]
theorem mk_eq_zero {x} (h : x ∈ p) : (⟨x, h⟩ : p) = 0 ↔ x = 0 :=
  Subtype.ext_iff_val
#align submodule.mk_eq_zero Submodule.mk_eq_zero

variable {p}

@[norm_cast] -- porting note: removed `@[simp]` because this follows from `ZeroMemClass.coe_zero`
theorem coe_eq_zero {x : p} : (x : M) = 0 ↔ x = 0 :=
  (SetLike.coe_eq_coe : (x : M) = (0 : p) ↔ x = 0)
#align submodule.coe_eq_zero Submodule.coe_eq_zero

@[simp, norm_cast]
theorem coe_add (x y : p) : (↑(x + y) : M) = ↑x + ↑y :=
  rfl
#align submodule.coe_add Submodule.coe_add

@[simp, norm_cast]
theorem coe_zero : ((0 : p) : M) = 0 :=
  rfl
#align submodule.coe_zero Submodule.coe_zero

@[norm_cast]
theorem coe_smul (r : R) (x : p) : ((r • x : p) : M) = r • (x : M) :=
  rfl
#align submodule.coe_smul Submodule.coe_smul

@[simp, norm_cast]
theorem coe_smul_of_tower [SMul S R] [SMul S M] [IsScalarTower S R M] (r : S) (x : p) :
    ((r • x : p) : M) = r • (x : M) :=
  rfl
#align submodule.coe_smul_of_tower Submodule.coe_smul_of_tower

@[norm_cast] -- porting note: removed `@[simp]` because this is now structure eta
theorem coe_mk (x : M) (hx : x ∈ p) : ((⟨x, hx⟩ : p) : M) = x :=
  rfl
#align submodule.coe_mk Submodule.coe_mk

-- porting note: removed `@[simp]` because this is exactly `SetLike.coe_mem`
theorem coe_mem (x : p) : (x : M) ∈ p :=
  x.2
#align submodule.coe_mem Submodule.coe_mem

variable (p)

instance addCommMonoid : AddCommMonoid p :=
  { p.toAddSubmonoid.toAddCommMonoid with
    add := (· + ·)
    zero := 0 }
#align submodule.add_comm_monoid Submodule.addCommMonoid

instance module' [Semiring S] [SMul S R] [Module S M] [IsScalarTower S R M] : Module S p :=
  { (show MulAction S p from p.toSubMulAction.mulAction') with
    smul := (· • ·)
    -- Porting note: this used to be `ext <;> simp [add_smul, smul_add]` but `simp` tries
    -- to prove it for the un-coerced version
    smul_zero := fun a => Subtype.ext (smul_zero a)
    zero_smul := fun a => Subtype.ext (zero_smul S (a : M))
    add_smul := fun a b x => Subtype.ext (add_smul a b (x : M))
    smul_add := fun a x y => Subtype.ext (smul_add a (x : M) (y : M)) }
#align submodule.module' Submodule.module'

instance module : Module R p :=
  p.module'
#align submodule.module Submodule.module

instance noZeroSMulDivisors [NoZeroSMulDivisors R M] : NoZeroSMulDivisors R p :=
  ⟨fun {c} {x : p} h =>
    have : c = 0 ∨ (x : M) = 0 := eq_zero_or_eq_zero_of_smul_eq_zero (congr_arg Subtype.val h)
    this.imp_right (@Subtype.ext_iff _ _ x 0).mpr⟩
#align submodule.no_zero_smul_divisors Submodule.noZeroSMulDivisors

/-- Embedding of a submodule `p` to the ambient space `M`. -/
protected def subtype : p →ₗ[R] M := by refine' { toFun := Subtype.val.. } <;> simp [coe_smul]
#align submodule.subtype Submodule.subtype

theorem subtype_apply (x : p) : p.subtype x = x :=
  rfl
#align submodule.subtype_apply Submodule.subtype_apply

@[simp]
theorem coeSubtype : (Submodule.subtype p : p → M) = Subtype.val :=
  rfl
#align submodule.coe_subtype Submodule.coeSubtype

theorem injective_subtype : Injective p.subtype :=
  Subtype.coe_injective
#align submodule.injective_subtype Submodule.injective_subtype

/-- Note the `AddSubmonoid` version of this lemma is called `AddSubmonoid.coe_finset_sum`. -/
-- porting note: removing the `@[simp]` attribute since it's lterally `AddSubmonoid.coe_finset_sum`
theorem coe_sum (x : ι → p) (s : Finset ι) : ↑(∑ i in s, x i) = ∑ i in s, (x i : M) :=
  map_sum p.subtype _ _
#align submodule.coe_sum Submodule.coe_sum

section RestrictScalars

variable (S) [Semiring S] [Module S M] [Module R M] [SMul S R] [IsScalarTower S R M]

/-- `V.restrict_scalars S` is the `S`-submodule of the `S`-module given by restriction of scalars,
corresponding to `V`, an `R`-submodule of the original `R`-module.
-/
def restrictScalars (V : Submodule R M) : Submodule S M where
  carrier := V
  zero_mem' := V.zero_mem
  smul_mem' c _ h := V.smul_of_tower_mem c h
  add_mem' hx hy := V.add_mem hx hy
#align submodule.restrict_scalars Submodule.restrictScalars

@[simp]
theorem coe_restrictScalars (V : Submodule R M) : (V.restrictScalars S : Set M) = V :=
  rfl
#align submodule.coe_restrict_scalars Submodule.coe_restrictScalars

@[simp]
theorem restrictScalars_mem (V : Submodule R M) (m : M) : m ∈ V.restrictScalars S ↔ m ∈ V :=
  Iff.refl _
#align submodule.restrict_scalars_mem Submodule.restrictScalars_mem

@[simp]
theorem restrictScalars_self (V : Submodule R M) : V.restrictScalars R = V :=
  SetLike.coe_injective rfl
#align submodule.restrict_scalars_self Submodule.restrictScalars_self

variable (R M)

theorem restrictScalars_injective :
    Function.Injective (restrictScalars S : Submodule R M → Submodule S M) := fun _ _ h =>
  ext <| Set.ext_iff.1 (SetLike.ext'_iff.1 h : _)
#align submodule.restrict_scalars_injective Submodule.restrictScalars_injective

@[simp]
theorem restrictScalars_inj {V₁ V₂ : Submodule R M} :
    restrictScalars S V₁ = restrictScalars S V₂ ↔ V₁ = V₂ :=
  (restrictScalars_injective S _ _).eq_iff
#align submodule.restrict_scalars_inj Submodule.restrictScalars_inj

/-- Even though `p.restrictScalars S` has type `Submodule S M`, it is still an `R`-module. -/
instance restrictScalars.origModule (p : Submodule R M) : Module R (p.restrictScalars S) :=
  (by infer_instance : Module R p)
#align submodule.restrict_scalars.orig_module Submodule.restrictScalars.origModule

instance restrictScalars.isScalarTower (p : Submodule R M) :
    IsScalarTower S R (p.restrictScalars S) where
  smul_assoc r s x := Subtype.ext <| smul_assoc r s (x : M)
#align submodule.restrict_scalars.is_scalar_tower Submodule.restrictScalars.isScalarTower

/-- `restrictScalars S` is an embedding of the lattice of `R`-submodules into
the lattice of `S`-submodules. -/
@[simps]
def restrictScalarsEmbedding : Submodule R M ↪o Submodule S M where
  toFun := restrictScalars S
  inj' := restrictScalars_injective S R M
  map_rel_iff' := by simp [SetLike.le_def]
#align submodule.restrict_scalars_embedding Submodule.restrictScalarsEmbedding
#align submodule.restrict_scalars_embedding_apply Submodule.restrictScalarsEmbedding_apply

/-- Turning `p : Submodule R M` into an `S`-submodule gives the same module structure
as turning it into a type and adding a module structure. -/
@[simps (config := { simpRhs := true })]
def restrictScalarsEquiv (p : Submodule R M) : p.restrictScalars S ≃ₗ[R] p :=
  { AddEquiv.refl p with
    toFun := id
    invFun := id
    map_smul' := fun _ _ => rfl }
#align submodule.restrict_scalars_equiv Submodule.restrictScalarsEquiv
#align submodule.restrict_scalars_equiv_symm_apply Submodule.restrictScalarsEquiv_symm_apply

end RestrictScalars

end AddCommMonoid

section AddCommGroup

variable [Ring R] [AddCommGroup M]

variable {module_M : Module R M}

variable (p p' : Submodule R M)

variable {r : R} {x y : M}

instance addSubgroupClass [Module R M] : AddSubgroupClass (Submodule R M) M :=
  { Submodule.addSubmonoidClass with neg_mem := fun p {_} => p.toSubMulAction.neg_mem }
#align submodule.add_subgroup_class Submodule.addSubgroupClass

protected theorem neg_mem (hx : x ∈ p) : -x ∈ p :=
  neg_mem hx
#align submodule.neg_mem Submodule.neg_mem

/-- Reinterpret a submodule as an additive subgroup. -/
def toAddSubgroup : AddSubgroup M :=
  { p.toAddSubmonoid with neg_mem' := fun {_} => p.neg_mem }
#align submodule.to_add_subgroup Submodule.toAddSubgroup

@[simp]
theorem coe_toAddSubgroup : (p.toAddSubgroup : Set M) = p :=
  rfl
#align submodule.coe_to_add_subgroup Submodule.coe_toAddSubgroup

@[simp]
theorem mem_toAddSubgroup : x ∈ p.toAddSubgroup ↔ x ∈ p :=
  Iff.rfl
#align submodule.mem_to_add_subgroup Submodule.mem_toAddSubgroup

theorem toAddSubgroup_injective : Injective (toAddSubgroup : Submodule R M → AddSubgroup M)
  | _, _, h => SetLike.ext (SetLike.ext_iff.1 h : _)
#align submodule.to_add_subgroup_injective Submodule.toAddSubgroup_injective

@[simp]
theorem toAddSubgroup_eq : p.toAddSubgroup = p'.toAddSubgroup ↔ p = p' :=
  toAddSubgroup_injective.eq_iff
#align submodule.to_add_subgroup_eq Submodule.toAddSubgroup_eq

@[mono]
theorem toAddSubgroup_strictMono : StrictMono (toAddSubgroup : Submodule R M → AddSubgroup M) :=
  fun _ _ => id
#align submodule.to_add_subgroup_strict_mono Submodule.toAddSubgroup_strictMono

theorem toAddSubgroup_le : p.toAddSubgroup ≤ p'.toAddSubgroup ↔ p ≤ p' :=
  Iff.rfl
#align submodule.to_add_subgroup_le Submodule.toAddSubgroup_le

@[mono]
theorem toAddSubgroup_mono : Monotone (toAddSubgroup : Submodule R M → AddSubgroup M) :=
  toAddSubgroup_strictMono.monotone
#align submodule.to_add_subgroup_mono Submodule.toAddSubgroup_mono

protected theorem sub_mem : x ∈ p → y ∈ p → x - y ∈ p :=
  sub_mem
#align submodule.sub_mem Submodule.sub_mem

protected theorem neg_mem_iff : -x ∈ p ↔ x ∈ p :=
  neg_mem_iff
#align submodule.neg_mem_iff Submodule.neg_mem_iff

protected theorem add_mem_iff_left : y ∈ p → (x + y ∈ p ↔ x ∈ p) :=
  add_mem_cancel_right
#align submodule.add_mem_iff_left Submodule.add_mem_iff_left

protected theorem add_mem_iff_right : x ∈ p → (x + y ∈ p ↔ y ∈ p) :=
  add_mem_cancel_left
#align submodule.add_mem_iff_right Submodule.add_mem_iff_right

protected theorem coe_neg (x : p) : ((-x : p) : M) = -x :=
  AddSubgroupClass.coe_neg _
#align submodule.coe_neg Submodule.coe_neg

protected theorem coe_sub (x y : p) : (↑(x - y) : M) = ↑x - ↑y :=
  AddSubgroupClass.coe_sub _ _
#align submodule.coe_sub Submodule.coe_sub

theorem sub_mem_iff_left (hy : y ∈ p) : x - y ∈ p ↔ x ∈ p := by
  rw [sub_eq_add_neg, p.add_mem_iff_left (p.neg_mem hy)]
#align submodule.sub_mem_iff_left Submodule.sub_mem_iff_left

theorem sub_mem_iff_right (hx : x ∈ p) : x - y ∈ p ↔ y ∈ p := by
  rw [sub_eq_add_neg, p.add_mem_iff_right hx, p.neg_mem_iff]
#align submodule.sub_mem_iff_right Submodule.sub_mem_iff_right

instance addCommGroup : AddCommGroup p :=
  { p.toAddSubgroup.toAddCommGroup with
    add := (· + ·)
    zero := 0
    neg := Neg.neg }
#align submodule.add_comm_group Submodule.addCommGroup

end AddCommGroup

section IsDomain

variable [Ring R] [IsDomain R]

variable [AddCommGroup M] [Module R M] {b : ι → M}

theorem not_mem_of_ortho {x : M} {N : Submodule R M}
    (ortho : ∀ (c : R), ∀ y ∈ N, c • x + y = (0 : M) → c = 0) : x ∉ N := by
  intro hx
  simpa using ortho (-1) x hx
#align submodule.not_mem_of_ortho Submodule.not_mem_of_ortho

theorem ne_zero_of_ortho {x : M} {N : Submodule R M}
    (ortho : ∀ (c : R), ∀ y ∈ N, c • x + y = (0 : M) → c = 0) : x ≠ 0 :=
  mt (fun h => show x ∈ N from h.symm ▸ N.zero_mem) (not_mem_of_ortho ortho)
#align submodule.ne_zero_of_ortho Submodule.ne_zero_of_ortho

end IsDomain

section OrderedMonoid

variable [Semiring R]

/-- A submodule of an `OrderedAddCommMonoid` is an `OrderedAddCommMonoid`. -/
instance toOrderedAddCommMonoid {M} [OrderedAddCommMonoid M] [Module R M] (S : Submodule R M) :
    OrderedAddCommMonoid S :=
  Subtype.coe_injective.orderedAddCommMonoid Subtype.val rfl (fun _ _ => rfl) fun _ _ => rfl
#align submodule.to_ordered_add_comm_monoid Submodule.toOrderedAddCommMonoid

/-- A submodule of a `LinearOrderedAddCommMonoid` is a `LinearOrderedAddCommMonoid`. -/
instance toLinearOrderedAddCommMonoid {M} [LinearOrderedAddCommMonoid M] [Module R M]
    (S : Submodule R M) : LinearOrderedAddCommMonoid S :=
  Subtype.coe_injective.linearOrderedAddCommMonoid Subtype.val rfl (fun _ _ => rfl) (fun _ _ => rfl)
    (fun _ _ => rfl) fun _ _ => rfl
#align submodule.to_linear_ordered_add_comm_monoid Submodule.toLinearOrderedAddCommMonoid

/-- A submodule of an `OrderedCancelAddCommMonoid` is an `OrderedCancelAddCommMonoid`. -/
instance toOrderedCancelAddCommMonoid {M} [OrderedCancelAddCommMonoid M] [Module R M]
    (S : Submodule R M) : OrderedCancelAddCommMonoid S :=
  Subtype.coe_injective.orderedCancelAddCommMonoid Subtype.val rfl (fun _ _ => rfl) fun _ _ => rfl
#align submodule.to_ordered_cancel_add_comm_monoid Submodule.toOrderedCancelAddCommMonoid

/-- A submodule of a `LinearOrderedCancelAddCommMonoid` is a
`LinearOrderedCancelAddCommMonoid`. -/
instance toLinearOrderedCancelAddCommMonoid {M} [LinearOrderedCancelAddCommMonoid M] [Module R M]
    (S : Submodule R M) : LinearOrderedCancelAddCommMonoid S :=
  Subtype.coe_injective.linearOrderedCancelAddCommMonoid Subtype.val rfl (fun _ _ => rfl)
    (fun _ _ => rfl) (fun _ _ => rfl) fun _ _ => rfl
#align submodule.to_linear_ordered_cancel_add_comm_monoid
  Submodule.toLinearOrderedCancelAddCommMonoid

end OrderedMonoid

section OrderedGroup

variable [Ring R]

/-- A submodule of an `OrderedAddCommGroup` is an `OrderedAddCommGroup`. -/
instance toOrderedAddCommGroup {M} [OrderedAddCommGroup M] [Module R M] (S : Submodule R M) :
    OrderedAddCommGroup S :=
  Subtype.coe_injective.orderedAddCommGroup Subtype.val rfl (fun _ _ => rfl) (fun _ => rfl)
    (fun _ _ => rfl) (fun _ _ => rfl) fun _ _ => rfl
#align submodule.to_ordered_add_comm_group Submodule.toOrderedAddCommGroup

/-- A submodule of a `LinearOrderedAddCommGroup` is a
`LinearOrderedAddCommGroup`. -/
instance toLinearOrderedAddCommGroup {M} [LinearOrderedAddCommGroup M] [Module R M]
    (S : Submodule R M) : LinearOrderedAddCommGroup S :=
  Subtype.coe_injective.linearOrderedAddCommGroup Subtype.val rfl (fun _ _ => rfl) (fun _ => rfl)
    (fun _ _ => rfl) (fun _ _ => rfl) (fun _ _ => rfl) (fun _ _ => rfl) fun _ _ => rfl
#align submodule.to_linear_ordered_add_comm_group Submodule.toLinearOrderedAddCommGroup

end OrderedGroup

end Submodule

namespace Submodule

variable [DivisionRing S] [Semiring R] [AddCommMonoid M] [Module R M]

variable [SMul S R] [Module S M] [IsScalarTower S R M]

variable (p : Submodule R M) {s : S} {x y : M}

end Submodule

/-- Subspace of a vector space. Defined to equal `Submodule`. -/
abbrev Subspace (R : Type u) (M : Type v) [DivisionRing R] [AddCommGroup M] [Module R M] :=
  Submodule R M
#align subspace Subspace


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import topology.sets.opens

/-!
# Properties of maps that are local at the target.

We show that the following properties of continuous maps are local at the target :
- `inducing`
- `embedding`
- `open_embedding`
- `closed_embedding`

-/

open topological_space set filter
open_locale topology filter

variables {α β : Type*} [topological_space α] [topological_space β] {f : α → β}
variables {s : set β} {ι : Type*} {U : ι → opens β} (hU : supr U = ⊤)

lemma set.restrict_preimage_inducing (s : set β) (h : inducing f) :
  inducing (s.restrict_preimage f) :=
begin
  simp_rw [inducing_coe.inducing_iff, inducing_iff_nhds, restrict_preimage, maps_to.coe_restrict,
    restrict_eq, ← @filter.comap_comap _ _ _ _ coe f] at h ⊢,
  intros a,
  rw [← h, ← inducing_coe.nhds_eq_comap],
end

alias set.restrict_preimage_inducing ← inducing.restrict_preimage

lemma set.restrict_preimage_embedding (s : set β) (h : embedding f) :
  embedding (s.restrict_preimage f) :=
⟨h.1.restrict_preimage s, h.2.restrict_preimage s⟩

alias set.restrict_preimage_embedding ← embedding.restrict_preimage

lemma set.restrict_preimage_open_embedding (s : set β) (h : open_embedding f) :
  open_embedding (s.restrict_preimage f) :=
⟨h.1.restrict_preimage s,
  (s.range_restrict_preimage f).symm ▸ continuous_subtype_coe.is_open_preimage _ h.2⟩

alias set.restrict_preimage_open_embedding ← open_embedding.restrict_preimage

lemma set.restrict_preimage_closed_embedding (s : set β) (h : closed_embedding f) :
  closed_embedding (s.restrict_preimage f) :=
⟨h.1.restrict_preimage s,
  (s.range_restrict_preimage f).symm ▸ inducing_coe.is_closed_preimage _ h.2⟩

alias set.restrict_preimage_closed_embedding ← closed_embedding.restrict_preimage

lemma set.restrict_preimage_is_closed_map (s : set β) (H : is_closed_map f)  :
  is_closed_map (s.restrict_preimage f) :=
begin
  rintros t ⟨u, hu, e⟩,
  refine ⟨⟨_, (H _ (is_open.is_closed_compl hu)).1, _⟩⟩,
  rw ← (congr_arg has_compl.compl e).trans (compl_compl t),
  simp only [set.preimage_compl, compl_inj_iff],
  ext ⟨x, hx⟩,
  suffices : (∃ y, y ∉ u ∧ f y = x) ↔ ∃ y, f y ∈ s ∧ y ∉ u ∧ f y = x,
  { simpa [set.restrict_preimage, ← subtype.coe_inj] },
  exact ⟨λ ⟨a, b, c⟩, ⟨a, c.symm ▸ hx, b, c⟩, λ ⟨a, _, b, c⟩, ⟨a, b, c⟩⟩
end

include hU

lemma is_open_iff_inter_of_supr_eq_top (s : set β) :
  is_open s ↔ ∀ i, is_open (s ∩ U i) :=
begin
  split,
  { exact λ H i, H.inter (U i).2 },
  { intro H,
    have : (⋃ i, (U i : set β)) = set.univ := by { convert (congr_arg coe hU), simp },
    rw [← s.inter_univ, ← this, set.inter_Union],
    exact is_open_Union H }
end

lemma is_open_iff_coe_preimage_of_supr_eq_top (s : set β) :
  is_open s ↔ ∀ i, is_open (coe ⁻¹' s : set (U i)) :=
begin
  simp_rw [(U _).2.open_embedding_subtype_coe.open_iff_image_open,
    set.image_preimage_eq_inter_range, subtype.range_coe],
  apply is_open_iff_inter_of_supr_eq_top,
  assumption
end

lemma is_closed_iff_coe_preimage_of_supr_eq_top (s : set β) :
  is_closed s ↔ ∀ i, is_closed (coe ⁻¹' s : set (U i)) :=
by simpa using is_open_iff_coe_preimage_of_supr_eq_top hU sᶜ

lemma is_closed_map_iff_is_closed_map_of_supr_eq_top :
  is_closed_map f ↔ ∀ i, is_closed_map ((U i).1.restrict_preimage f) :=
begin
  refine ⟨λ h i, set.restrict_preimage_is_closed_map _ h, _⟩,
  rintros H s hs,
  rw is_closed_iff_coe_preimage_of_supr_eq_top hU,
  intro i,
  convert H i _ ⟨⟨_, hs.1, eq_compl_comm.mpr rfl⟩⟩,
  ext ⟨x, hx⟩,
  suffices : (∃ y, y ∈ s ∧ f y = x) ↔ ∃ y, f y ∈ U i ∧ y ∈ s ∧ f y = x,
  { simpa [set.restrict_preimage, ← subtype.coe_inj] },
  exact ⟨λ ⟨a, b, c⟩, ⟨a, c.symm ▸ hx, b, c⟩, λ ⟨a, _, b, c⟩, ⟨a, b, c⟩⟩
end

lemma inducing_iff_inducing_of_supr_eq_top (h : continuous f) :
  inducing f ↔ ∀ i, inducing ((U i).1.restrict_preimage f) :=
begin
  simp_rw [inducing_coe.inducing_iff, inducing_iff_nhds, restrict_preimage, maps_to.coe_restrict,
    restrict_eq, ← @filter.comap_comap _ _ _ _ coe f],
  split,
  { intros H i x, rw [← H, ← inducing_coe.nhds_eq_comap] },
  { intros H x,
    obtain ⟨i, hi⟩ := opens.mem_supr.mp (show f x ∈ supr U, by { rw hU, triv }),
    erw ← open_embedding.map_nhds_eq (h.1 _ (U i).2).open_embedding_subtype_coe ⟨x, hi⟩,
    rw [(H i) ⟨x, hi⟩, filter.subtype_coe_map_comap, function.comp_apply, subtype.coe_mk,
      inf_eq_left, filter.le_principal_iff],
    exact filter.preimage_mem_comap ((U i).2.mem_nhds hi) }
end

lemma embedding_iff_embedding_of_supr_eq_top (h : continuous f) :
  embedding f ↔ ∀ i, embedding ((U i).1.restrict_preimage f) :=
begin
  simp_rw embedding_iff,
  rw forall_and_distrib,
  apply and_congr,
  { apply inducing_iff_inducing_of_supr_eq_top; assumption },
  { apply set.injective_iff_injective_of_Union_eq_univ, convert (congr_arg coe hU), simp }
end

lemma open_embedding_iff_open_embedding_of_supr_eq_top (h : continuous f) :
  open_embedding f ↔ ∀ i, open_embedding ((U i).1.restrict_preimage f) :=
begin
  simp_rw open_embedding_iff,
  rw forall_and_distrib,
  apply and_congr,
  { apply embedding_iff_embedding_of_supr_eq_top; assumption },
  { simp_rw set.range_restrict_preimage, apply is_open_iff_coe_preimage_of_supr_eq_top hU }
end

lemma closed_embedding_iff_closed_embedding_of_supr_eq_top (h : continuous f) :
  closed_embedding f ↔ ∀ i, closed_embedding ((U i).1.restrict_preimage f) :=
begin
  simp_rw closed_embedding_iff,
  rw forall_and_distrib,
  apply and_congr,
  { apply embedding_iff_embedding_of_supr_eq_top; assumption },
  { simp_rw set.range_restrict_preimage, apply is_closed_iff_coe_preimage_of_supr_eq_top hU }
end


/-
Copyright (c) 2022 Violeta Hernández Palacios. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Violeta Hernández Palacios

! This file was ported from Lean 3 source module set_theory.zfc.ordinal
! leanprover-community/mathlib commit 98bbc3526516bca903bff09ea10c4206bf079e6b
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.SetTheory.Zfc.Basic

/-!
# Von Neumann ordinals

This file works towards the development of von Neumann ordinals, i.e. transitive sets, well-ordered
under `∈`. We currently only have an initial development of transitive sets.

Further development can be found on the branch `von_neumann_v2`.

## Definitions

- `Set.is_transitive` means that every element of a set is a subset.

## Todo

- Define von Neumann ordinals.
- Define the basic arithmetic operations on ordinals from a purely set-theoretic perspective.
- Prove the equivalences between these definitions and those provided in
  `set_theory/ordinal/arithmetic.lean`.
-/

universe u

variable {x y z : SetCat.{u}}

namespace SetCat

/-- A transitive set is one where every element is a subset. -/
def IsTransitive (x : SetCat) : Prop :=
  ∀ y ∈ x, y ⊆ x
#align Set.is_transitive SetCat.IsTransitive

@[simp]
theorem empty_isTransitive : IsTransitive ∅ := fun y hy => (not_mem_empty y hy).elim
#align Set.empty_is_transitive SetCat.empty_isTransitive

theorem IsTransitive.subset_of_mem (h : x.IsTransitive) : y ∈ x → y ⊆ x :=
  h y
#align Set.is_transitive.subset_of_mem SetCat.IsTransitive.subset_of_mem

theorem isTransitive_iff_mem_trans : z.IsTransitive ↔ ∀ {x y : SetCat}, x ∈ y → y ∈ z → x ∈ z :=
  ⟨fun h x y hx hy => h.subset_of_mem hy hx, fun H x hx y hy => H hy hx⟩
#align Set.is_transitive_iff_mem_trans SetCat.isTransitive_iff_mem_trans

alias is_transitive_iff_mem_trans ↔ is_transitive.mem_trans _
#align Set.is_transitive.mem_trans SetCat.IsTransitive.mem_trans

protected theorem IsTransitive.inter (hx : x.IsTransitive) (hy : y.IsTransitive) :
    (x ∩ y).IsTransitive := fun z hz w hw =>
  by
  rw [mem_inter] at hz⊢
  exact ⟨hx.mem_trans hw hz.1, hy.mem_trans hw hz.2⟩
#align Set.is_transitive.inter SetCat.IsTransitive.inter

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
protected theorem IsTransitive.sUnion (h : x.IsTransitive) : (⋃₀ x).IsTransitive := fun y hy z hz =>
  by
  rcases mem_sUnion.1 hy with ⟨w, hw, hw'⟩
  exact mem_sUnion_of_mem hz (h.mem_trans hw' hw)
#align Set.is_transitive.sUnion SetCat.IsTransitive.sUnion

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem IsTransitive.sUnion' (H : ∀ y ∈ x, IsTransitive y) : (⋃₀ x).IsTransitive := fun y hy z hz =>
  by
  rcases mem_sUnion.1 hy with ⟨w, hw, hw'⟩
  exact mem_sUnion_of_mem ((H w hw).mem_trans hz hw') hw
#align Set.is_transitive.sUnion' SetCat.IsTransitive.sUnion'

protected theorem IsTransitive.union (hx : x.IsTransitive) (hy : y.IsTransitive) :
    (x ∪ y).IsTransitive := by
  rw [← sUnion_pair]
  apply is_transitive.sUnion' fun z => _
  rw [mem_pair]
  rintro (rfl | rfl)
  assumption'
#align Set.is_transitive.union SetCat.IsTransitive.union

protected theorem IsTransitive.powerset (h : x.IsTransitive) : (powerset x).IsTransitive :=
  fun y hy z hz => by
  rw [mem_powerset] at hy⊢
  exact h.subset_of_mem (hy hz)
#align Set.is_transitive.powerset SetCat.IsTransitive.powerset

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem isTransitive_iff_sUnion_subset : x.IsTransitive ↔ ⋃₀ x ⊆ x :=
  ⟨fun h y hy => by
    rcases mem_sUnion.1 hy with ⟨z, hz, hz'⟩
    exact h.mem_trans hz' hz, fun H y hy z hz => H <| mem_sUnion_of_mem hz hy⟩
#align Set.is_transitive_iff_sUnion_subset SetCat.isTransitive_iff_sUnion_subset

alias is_transitive_iff_sUnion_subset ↔ is_transitive.sUnion_subset _
#align Set.is_transitive.sUnion_subset SetCat.IsTransitive.sUnion_subset

theorem isTransitive_iff_subset_powerset : x.IsTransitive ↔ x ⊆ powerset x :=
  ⟨fun h y hy => mem_powerset.2 <| h.subset_of_mem hy, fun H y hy z hz => mem_powerset.1 (H hy) hz⟩
#align Set.is_transitive_iff_subset_powerset SetCat.isTransitive_iff_subset_powerset

alias is_transitive_iff_subset_powerset ↔ is_transitive.subset_powerset _
#align Set.is_transitive.subset_powerset SetCat.IsTransitive.subset_powerset

end SetCat


/-
Copyright (c) 2023 Wojciech Nawrocki. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Wojciech Nawrocki
-/

import Mathlib.Data.Finset.Basic
import Mathlib.Data.Set.Finite
import Mathlib.Tactic.ByContra

import ProofChecker.Model.PropTerm

/-! Definitions and theorems relating propositional formulas and functions to variables

## Main definitions

`PropForm.vars` - the set of syntactic variables of a formula
`PropTerm.semVars` - the set of semantic variables of a function
`PropTerm.equivalentOver X` - two functions are equivalent over a set `X` of variables
`PropTerm.hasUniqueExtension X Y` - the assignments to a function extend uniquely from a set `X` to
a set `Y` of variables

NOTE: Semantic notions are not generally defined on `PropForm`s. They are expected to be used on
`PropForm`s by composing with `⟦-⟧`.

NOTE: We try to delay talking about dependently-typed functions `{x // x ∈ X} → Bool` for as long as
possible by developing the theory in terms of total assignments `ν → Bool`. Assignments with finite
domain are eventually considered in `ModelCount.lean`. -/

namespace PropAssignment

-- TODO: is this defined in mathlib for functions in general?
def agreeOn (X : Set ν) (σ₁ σ₂ : PropAssignment ν) : Prop :=
  ∀ x ∈ X, σ₁ x = σ₂ x

theorem agreeOn_refl (X : Set ν) (σ : PropAssignment ν) : agreeOn X σ σ :=
  fun _ _ => rfl
theorem agreeOn.symm : agreeOn X σ₁ σ₂ → agreeOn X σ₂ σ₁ :=
  fun h x hX => Eq.symm (h x hX)
theorem agreeOn.trans : agreeOn X σ₁ σ₂ → agreeOn X σ₂ σ₃ → agreeOn X σ₁ σ₃ :=
  fun h₁ h₂ x hX => Eq.trans (h₁ x hX) (h₂ x hX)

theorem agreeOn.subset : X ⊆ Y → agreeOn Y σ₁ σ₂ → agreeOn X σ₁ σ₂ :=
  fun hSub h x hX => h x (hSub hX)

theorem agreeOn_empty (σ₁ σ₂ : PropAssignment ν) : agreeOn ∅ σ₁ σ₂ :=
  fun _ h => False.elim (Set.not_mem_empty _ h)

variable [DecidableEq ν]

theorem agreeOn_set_of_not_mem {x : ν} {X : Set ν} (σ : PropAssignment ν) (v : Bool) : x ∉ X →
    agreeOn X (σ.set x v) σ := by
  -- I ❤ Aesop
  aesop (add norm unfold agreeOn, norm unfold set)

end PropAssignment

namespace PropForm

variable [DecidableEq ν]

/-- Variables appearing in the formula. Sometimes called its "support set". -/
def vars : PropForm ν → Finset ν
  | var y => {y}
  | tr | fls => ∅
  | neg φ => vars φ
  | conj φ₁ φ₂ | disj φ₁ φ₂ | impl φ₁ φ₂ | biImpl φ₁ φ₂ => vars φ₁ ∪ vars φ₂

theorem eval_of_agreeOn_vars {φ : PropForm ν} {σ₁ σ₂ : PropAssignment ν} : σ₁.agreeOn φ.vars σ₂ →
    φ.eval σ₁ = φ.eval σ₂ := by
  intro h
  induction φ <;> simp_all [PropAssignment.agreeOn, eval, vars]

theorem eval_ext {φ : PropForm ν} {σ₁ σ₂ : PropAssignment ν} : (∀ x ∈ φ.vars, σ₁ x = σ₂ x) →
    φ.eval σ₁ = φ.eval σ₂ :=
  eval_of_agreeOn_vars

theorem eval_set_of_not_mem_vars {x : ν} {φ : PropForm ν} {τ : PropAssignment ν} :
    x ∉ φ.vars → φ.eval (τ.set x b) = φ.eval τ := by
  intro hNMem
  apply eval_of_agreeOn_vars
  intro y hY
  have : y ≠ x := fun h => hNMem (h ▸ hY)
  simp [PropAssignment.set, this]

theorem agreeOn_vars {φ : PropForm ν} {σ₁ σ₂ : PropAssignment ν} :
    σ₁.agreeOn φ.vars σ₂ → (σ₁ ⊨ φ ↔ σ₂ ⊨ φ) := by
  intro h
  simp [SemanticEntails.entails, satisfies, eval_of_agreeOn_vars h]

set_option push_neg.use_distrib true in
lemma mem_vars_of_flip {φ : PropForm ν} {τ : PropAssignment ν} (x : ν) : τ ⊨ φ →
    τ.set x (!τ x) ⊭ φ → x ∈ φ.vars := by
  intro hτ hτ'
  induction φ generalizing τ with
  | tr => exfalso; exact hτ' satisfies_tr
  | fls => exfalso; exact not_satisfies_fls hτ
  | var y =>
    simp_all only [vars, satisfies_var, Finset.mem_singleton]
    by_contra h
    exact hτ' (hτ ▸ τ.set_get_of_ne (!τ x) h)
  | _ =>
    simp_all only
      [satisfies_conj, satisfies_disj, satisfies_impl', satisfies_biImpl', vars, Finset.mem_union]
    push_neg at hτ'
    aesop

theorem exists_flip {φ : PropForm ν} {σ₁ σ₂ : PropAssignment ν} : σ₁ ⊨ φ → σ₂ ⊭ φ →
    ∃ (x : ν) (τ : PropAssignment ν), σ₁ x ≠ σ₂ x ∧ τ ⊨ φ ∧ τ.set x (!τ x) ⊭ φ :=
  fun h₁ h₂ =>
    let s := φ.vars.filter fun x => σ₁ x ≠ σ₂ x
    have hS : ∀ x ∈ s, σ₁ x ≠ σ₂ x := fun _ h => Finset.mem_filter.mp h |>.right
    have hSC : ∀ x ∈ φ.vars \ s, σ₁ x = σ₂ x := fun _ h => by simp_all
    have ⟨x, τ, hMem, hτ, hτ'⟩ := go h₁ h₂ s hS hSC rfl
    ⟨x, τ, hS _ hMem, hτ, hτ'⟩
-- NOTE(Jeremy): a proof using `Finset.induction` would likely be shorter
where go {σ₁ σ₂ : PropAssignment ν} (h₁ : σ₁ ⊨ φ) (h₂ : σ₂ ⊭ φ)
    (s : Finset ν) (hS : ∀ x ∈ s, σ₁ x ≠ σ₂ x) (hSC : ∀ x ∈ φ.vars \ s, σ₁ x = σ₂ x) :
    {n : Nat} → s.card = n →
    ∃ (x : ν) (τ : PropAssignment ν), x ∈ s ∧ τ ⊨ φ ∧ τ.set x (!τ x) ⊭ φ
  | 0,   hCard =>
    -- In the base case, σ₁ and σ₂ agree on all φ.vars, contradiction.
    have : s = ∅ := Finset.card_eq_zero.mp hCard
    have : σ₁.agreeOn φ.vars σ₂ := fun _ h => by simp_all
    have : σ₂ ⊨ φ := (agreeOn_vars this).mp h₁
    False.elim (h₂ this)
  | _+1, hCard => by
    -- In the inductive case, let σ₁' := σ₁[x₀ ↦ !(σ₁ x₀)] and see if σ₁' satisfies φ or not.
    have ⟨x₀, s', h₀, h', hCard'⟩ := Finset.card_eq_succ.mp hCard
    have h₀S : x₀ ∈ s := h' ▸ Finset.mem_insert_self x₀ s'
    let σ₁' := σ₁.set x₀ (!σ₁ x₀)
    by_cases h₁' : σ₁' ⊨ φ
    case neg =>
      -- If σ₁' no longer satisfies φ, we're done.
      use x₀, σ₁
      refine ⟨h' ▸ Finset.mem_insert_self x₀ s', h₁, h₁'⟩
    case pos =>
      -- If σ₁' still satisfies φ, proceed by induction.
      have hS' : ∀ x ∈ s', σ₁' x ≠ σ₂ x := fun x hMem => by
        have hX : x₀ ≠ x := fun h => h₀ (h ▸ hMem)
        simp only [σ₁.set_get_of_ne (!σ₁ x₀) hX]
        exact hS _ (h' ▸ Finset.mem_insert_of_mem hMem)
      have hSC' : ∀ x ∈ φ.vars \ s', σ₁' x = σ₂ x := fun x hMem => by
        by_cases hX : x₀ = x
        case pos =>
          simp only [← hX, σ₁.set_get, Bool.bnot_eq_to_not_eq]
          apply hS _ h₀S
        case neg =>
          simp only [σ₁.set_get_of_ne _ hX]
          apply hSC
          aesop
      have ⟨x, τ, hMem, H⟩ := go h₁' h₂ s' hS' hSC' hCard'
      refine ⟨x, τ, h' ▸ Finset.mem_insert_of_mem hMem, H⟩

end PropForm

namespace PropTerm

variable [DecidableEq ν]

/-- See `semVars`. -/
private def semVars' (φ : PropTerm ν) : Set ν :=
  { x | ∃ (τ : PropAssignment ν), τ ⊨ φ ∧ τ.set x (!τ x) ⊭ φ }

private theorem semVars'_subset_vars (φ : PropForm ν) : semVars' ⟦φ⟧ ⊆ φ.vars :=
  fun x ⟨_, hτ, hτ'⟩ => PropForm.mem_vars_of_flip x hτ hτ'

private instance semVars'_finite (φ : PropTerm ν) : Set.Finite φ.semVars' :=
  have ⟨φ', h⟩ := Quotient.exists_rep φ
  Set.Finite.subset (Finset.finite_toSet _) (h ▸ semVars'_subset_vars φ')

/-- The *semantic variables* of `φ` are those it is sensitive to as a Boolean function.
Unlike `vars`, this set is stable under equivalence of formulas. -/
noncomputable def semVars (φ : PropTerm ν) : Finset ν :=
  Set.Finite.toFinset φ.semVars'_finite

theorem mem_semVars (φ : PropTerm ν) (x : ν) :
    x ∈ φ.semVars ↔ ∃ (τ : PropAssignment ν), τ ⊨ φ ∧ τ.set x (!τ x) ⊭ φ := by
  simp [Set.Finite.mem_toFinset, semVars, semVars']

/-- Any two assignments with opposing evaluations on `φ` disagree on a semantic variable of `φ`. -/
theorem exists_semVar {φ : PropTerm ν} {σ₁ σ₂ : PropAssignment ν} : σ₁ ⊨ φ → σ₂ ⊭ φ →
    ∃ (x : ν), σ₁ x ≠ σ₂ x ∧ x ∈ φ.semVars := by
  have ⟨φ', hMk⟩ := Quotient.exists_rep φ
  dsimp
  rw [← hMk, satisfies_mk, satisfies_mk]
  intro h₁ h₂
  have ⟨x, τ, hNe, hτ, hτ'⟩ := PropForm.exists_flip h₁ h₂
  use x, hNe
  simp only [mem_semVars]
  use τ
  rw [satisfies_mk, satisfies_mk]
  exact ⟨hτ, hτ'⟩

theorem agreeOn_semVars {φ : PropTerm ν} {σ₁ σ₂ : PropAssignment ν} :
    σ₁.agreeOn φ.semVars σ₂ → (σ₁ ⊨ φ ↔ σ₂ ⊨ φ) := by
  suffices ∀ {σ₁ σ₂}, σ₁.agreeOn φ.semVars σ₂ → σ₁ ⊨ φ → σ₂ ⊨ φ from
    fun h => ⟨this h, this h.symm⟩
  intro σ₁ σ₂ h h₁
  by_contra h₂
  have ⟨x, hNe, hMem⟩ := exists_semVar h₁ h₂
  exact hNe (h x hMem)

theorem eval_of_agreeOn_semVars {φ : PropTerm ν} {σ₁ σ₂ : PropAssignment ν} :
    σ₁.agreeOn φ.semVars σ₂ → φ.eval σ₁ = φ.eval σ₂ := by
  intro h
  have := agreeOn_semVars h
  dsimp only [SemanticEntails.entails, satisfies] at this
  aesop

@[simp]
theorem semVars_var (x : ν) : (var x).semVars = {x} := by
  ext y
  simp only [Finset.mem_singleton, mem_semVars, satisfies_var]
  refine ⟨?mp, ?mpr⟩
  case mp =>
    intro ⟨τ, hτ, hτ'⟩
    by_contra h
    have := τ.set_get_of_ne (!τ y) h
    exact hτ' (hτ ▸ this)
  case mpr =>
    intro h; cases h
    use (fun _ => true)
    simp

@[simp]
theorem semVars_tr (ν) [DecidableEq ν] : (⊤ : PropTerm ν).semVars = ∅ := by
  ext
  simp [mem_semVars]

@[simp]
theorem semVars_fls (ν) [DecidableEq ν] : (⊥ : PropTerm ν).semVars = ∅ := by
  ext
  simp [mem_semVars]

@[simp]
theorem semVars_neg (φ : PropTerm ν) : φᶜ.semVars = φ.semVars := by
  ext x
  simp only [mem_semVars]
  constructor <;> {
    intro ⟨τ, hτ, hτ'⟩
    simp only [satisfies_neg, not_not] at hτ hτ' ⊢
    let τ' := τ.set x (!τ x)
    have : (!τ' x) = τ x := by
      simp only [τ.set_get x, Bool.not_not]
    refine ⟨τ', hτ', ?_⟩
    rw [τ.set_set, this, τ.set_same]
    exact hτ
  }

theorem semVars_conj (φ₁ φ₂ : PropTerm ν) : (φ₁ ⊓ φ₂).semVars ⊆ φ₁.semVars ∪ φ₂.semVars := by
  intro x
  simp only [Finset.mem_union, mem_semVars, satisfies_conj, not_and_or]
  aesop

theorem semVars_disj (φ₁ φ₂ : PropTerm ν) : (φ₁ ⊔ φ₂).semVars ⊆ φ₁.semVars ∪ φ₂.semVars := by
  intro x
  simp only [Finset.mem_union, mem_semVars]
  aesop

theorem semVars_impl (φ₁ φ₂ : PropTerm ν) : (φ₁ ⇨ φ₂).semVars ⊆ φ₁.semVars ∪ φ₂.semVars := by
  rw [himp_eq]
  have := semVars_disj (φ₁ᶜ) φ₂
  rw [sup_comm, semVars_neg] at this
  exact this

theorem semVars_biImpl (φ₁ φ₂ : PropTerm ν) :
    (PropTerm.biImpl φ₁ φ₂).semVars ⊆ φ₁.semVars ∪ φ₂.semVars := by
  rw [biImpl_eq_impls]
  apply subset_trans (semVars_conj _ _)
  apply Finset.union_subset
  . apply semVars_impl
  . rw [Finset.union_comm]
    apply semVars_impl

/-- Two functions φ₁ and φ₂ are equivalent over X when for every assignment τ, models of φ₁
extending τ over X are in bijection with models of φ₂ extending τ over X. -/
-- This is `sequiv` here: https://github.com/ccodel/verified-encodings/blob/master/src/cnf/encoding.lean
def equivalentOver (X : Set ν) (φ₁ φ₂ : PropTerm ν) :=
  ∀ τ, (∃ (σ₁ : PropAssignment ν), σ₁.agreeOn X τ ∧ σ₁ ⊨ φ₁) ↔
       (∃ (σ₂ : PropAssignment ν), σ₂.agreeOn X τ ∧ σ₂ ⊨ φ₂)

-- NOTE: This is a better definition than `equivalentOver`. It would be nice to clean the proofs up
-- to use it, but it's not essential.
def extendsOver (X : Set ν) (φ₁ φ₂ : PropTerm ν) :=
  ∀ (σ₁ : PropAssignment ν), σ₁ ⊨ φ₁ → ∃ (σ₂ : PropAssignment ν), σ₂.agreeOn X σ₁ ∧ σ₂ ⊨ φ₂

theorem equivalentOver_iff_extendsOver (X : Set ν) (φ₁ φ₂ : PropTerm ν) :
    equivalentOver X φ₁ φ₂ ↔ (extendsOver X φ₁ φ₂ ∧ extendsOver X φ₂ φ₁) := by
  constructor
  case mp =>
    intro h
    exact ⟨fun σ₁ h₁ => h σ₁ |>.mp ⟨σ₁, σ₁.agreeOn_refl X, h₁⟩,
      fun σ₂ h₂ => h σ₂ |>.mpr ⟨σ₂, σ₂.agreeOn_refl X, h₂⟩⟩
  case mpr =>
    intro ⟨h₁, h₂⟩
    intro τ
    constructor
    case mp =>
      intro ⟨σ₁, hAgree₁, hσ₁⟩
      have ⟨σ₂, hAgree₂, hσ₂⟩ := h₁ σ₁ hσ₁
      exact ⟨σ₂, hAgree₂.trans hAgree₁, hσ₂⟩
    case mpr =>
      intro ⟨σ₂, hAgree₂, hσ₂⟩
      have ⟨σ₁, hAgree₁, hσ₁⟩ := h₂ σ₂ hσ₂
      exact ⟨σ₁, hAgree₁.trans hAgree₂, hσ₁⟩

theorem equivalentOver_refl (φ : PropTerm ν) : equivalentOver X φ φ :=
  fun _ => ⟨id, id⟩
theorem equivalentOver.symm : equivalentOver X φ₁ φ₂ → equivalentOver X φ₂ φ₁ :=
  fun e τ => (e τ).symm
theorem equivalentOver.trans : equivalentOver X φ₁ φ₂ → equivalentOver X φ₂ φ₃ →
    equivalentOver X φ₁ φ₃ :=
  fun e₁ e₂ τ => (e₁ τ).trans (e₂ τ)

theorem equivalentOver.subset {X Y : Set ν} : X ⊆ Y → equivalentOver Y φ₁ φ₂ →
    equivalentOver X φ₁ φ₂ := by
  intro hSub
  suffices ∀ φ₁ φ₂ τ, equivalentOver Y φ₁ φ₂ →
      (∃ (σ₁ : PropAssignment ν), σ₁.agreeOn X τ ∧ σ₁ ⊨ φ₁) →
      ∃ (σ₂ : PropAssignment ν), σ₂.agreeOn X τ ∧ σ₂ ⊨ φ₂ from
    fun e τ => ⟨this φ₁ φ₂ τ e, this φ₂ φ₁ τ e.symm⟩
  intro φ₁ φ₂ τ e ⟨σ₁, hA, hS⟩
  have ⟨σ₃, hA', hS'⟩ := (e σ₁).mp ⟨σ₁, σ₁.agreeOn_refl _, hS⟩
  exact ⟨σ₃, hA'.subset hSub |>.trans hA, hS'⟩

theorem equivalentOver_semVars {X : Set ν} : φ₁.semVars ⊆ X → φ₂.semVars ⊆ X →
    equivalentOver X φ₁ φ₂ → φ₁ = φ₂ := by
  suffices ∀ {φ₁ φ₂} {τ : PropAssignment ν}, φ₂.semVars ⊆ X →
      equivalentOver X φ₁ φ₂ → τ ⊨ φ₁ → τ ⊨ φ₂ by
    intro h₁ h₂ e
    ext τ
    exact ⟨this h₂ e, this h₁ e.symm⟩
  intro φ₁ φ₂ τ h₂ e h
  have ⟨σ₁, hA, hS⟩ := (e τ).mp ⟨τ, τ.agreeOn_refl _, h⟩
  have : σ₁ ⊨ φ₂ ↔ τ ⊨ φ₂ := agreeOn_semVars (hA.subset h₂)
  exact this.mp hS

/-- A function has the unique extension property from `X` to `Y` (both sets of variables) when any
satisfying assignment, if it exists, is uniquely determined on `Y` by its values on `X`. Formally,
any two satisfying assignments which agree on `X` must also agree on `Y`. -/
/- TODO: Model equivalence is expected to follow from this. For example:
equivalentOver φ₁.vars ⟦φ₁⟧ ⟦φ₂⟧ ∧ hasUniqueExtension ⟦φ₂⟧ φ₁.vars φ₂.vars →
{ σ : { x // x ∈ φ₁.vars} → Bool | σ ⊨ φ₁ } ≃ { σ : { x // x ∈ φ₂.vars } → Bool | σ ⊨ φ₂ } -/
def hasUniqueExtension (X Y : Set ν) (φ : PropTerm ν) :=
  ∀ ⦃σ₁ σ₂ : PropAssignment ν⦄, σ₁ ⊨ φ → σ₂ ⊨ φ → σ₁.agreeOn X σ₂ → σ₁.agreeOn Y σ₂

theorem hasUniqueExtension_refl (X : Set ν) (φ : PropTerm ν) : hasUniqueExtension X X φ :=
  by simp [hasUniqueExtension]

theorem hasUniqueExtension.subset_left : X ⊆ X' → hasUniqueExtension X Y φ →
    hasUniqueExtension X' Y φ :=
  fun hSub h _ _ h₁ h₂ hAgree => h h₁ h₂ (hAgree.subset hSub)

theorem hasUniqueExtension.subset_right : Y' ⊆ Y → hasUniqueExtension X Y φ →
    hasUniqueExtension X Y' φ :=
  fun hSub h _ _ h₁ h₂ hAgree => (h h₁ h₂ hAgree).subset hSub

theorem hasUniqueExtension.trans : hasUniqueExtension X Y φ → hasUniqueExtension Y Z φ →
    hasUniqueExtension X Z φ :=
  fun hXY hYZ _ _ h₁ h₂ hAgree => hAgree |> hXY h₁ h₂ |> hYZ h₁ h₂

theorem hasUniqueExtension.conj_right (ψ : PropTerm ν) :
    hasUniqueExtension X Y φ → hasUniqueExtension X Y (φ ⊓ ψ) :=
  fun hXY _ _ h₁ h₂ hAgree => hXY (satisfies_conj.mp h₁).left (satisfies_conj.mp h₂).left hAgree

theorem hasUniqueExtension.conj_left (ψ : PropTerm ν) :
    hasUniqueExtension X Y φ → hasUniqueExtension X Y (ψ ⊓ φ) :=
  fun hXY _ _ h₁ h₂ hAgree => hXY (satisfies_conj.mp h₁).right (satisfies_conj.mp h₂).right hAgree

theorem hasUniqueExtension_to_empty (X : Set ν) (φ : PropTerm ν) : hasUniqueExtension X ∅ φ :=
  hasUniqueExtension_refl X φ |>.subset_right (Set.empty_subset X)

end PropTerm

namespace PropForm

variable [DecidableEq ν]

theorem equivalentOver_of_equivalent : equivalent φ₁ φ₂ → PropTerm.equivalentOver X ⟦φ₁⟧ ⟦φ₂⟧ :=
  fun h => Quotient.sound h ▸ PropTerm.equivalentOver_refl ⟦φ₁⟧

theorem semVars_eq_of_equivalent (φ₁ φ₂ : PropForm ν) : equivalent φ₁ φ₂ →
    PropTerm.semVars ⟦φ₁⟧ = PropTerm.semVars ⟦φ₂⟧ :=
  fun h => Quotient.sound h ▸ rfl

theorem semVars_subset_vars (φ : PropForm ν) : PropTerm.semVars ⟦φ⟧ ⊆ φ.vars := by
  simp only [PropTerm.semVars, Set.Finite.toFinset_subset]
  exact PropTerm.semVars'_subset_vars φ

theorem equivalentOver_vars {X : Set ν} : φ₁.vars ⊆ X → φ₂.vars ⊆ X →
    PropTerm.equivalentOver X ⟦φ₁⟧ ⟦φ₂⟧ → equivalent φ₁ φ₂ :=
  fun h₁ h₂ h => Quotient.exact
    (PropTerm.equivalentOver_semVars
      (subset_trans (semVars_subset_vars φ₁) h₁)
      (subset_trans (semVars_subset_vars φ₂) h₂)
      h)

end PropForm


import logic.basic  data.option

open tactic

variables {α β γ : Type} {p q r s : Prop}

lemma fun_mono_2 {p : α → β → γ} {a1 a2 : α} {b1 b2 : β} :
  a1 = a2 → b1 = b2 → (p a1 b1 = p a2 b2) :=
λ h1 h2, by rw [h1, h2]

lemma pred_mono_2 {p : α → β → Prop} {a1 a2 : α} {b1 b2 : β} :
  a1 = a2 → b1 = b2 → (p a1 b1 ↔ p a2 b2) :=
λ h1 h2, by rw [h1, h2]

lemma sub_eq_sub_of_eq_of_eq [has_sub α] {a b c d : α} :
  a = b → c = d → a - c = b - d :=
λ h1 h2, by rw [h1, h2]

lemma eq_iff_eq_of_eq_of_eq [has_sub α] {a b c d : α} :
  a = b → c = d → (a = c ↔ b = d) :=
λ h1 h2, by rw [h1, h2]

lemma imp_of_imp (p) {q} : (p → q) → (p → q) := id

lemma exists_of_exists {α : Type} {p q : α → Prop} :
  (∀ a, p a → q a) → (∃ a, p a) → (∃ a, q a) :=
begin
  intros h1 h2, cases h2 with w h2, refine ⟨w,_⟩,
  apply h1, assumption
end

lemma exists_iff_exists {α : Type} {p q : α → Prop} :
  (∀ a, p a ↔ q a) → ((∃ a, p a) ↔ ∃ a, q a) :=
begin
  intro h, constructor; intro h;
  cases h with a ha; existsi a;
  [{rw (h a).symm}, {rw h}]; assumption
end

lemma forall_iff_forall {α : Type} {p q : α → Prop} :
  (∀ a, p a ↔ q a) → ((∀ a, p a) ↔ (∀ a, q a)) :=
begin
  intro h1, constructor; intros h2 a;
  [{rw (h1 a).symm}, {rw h1}]; apply h2
end

lemma or_of_or : (p → q) → (r → s) → (p ∨ r) → (q ∨ s) :=
begin
  intros h1 h2 h3, cases h3;
  [{left, apply h1}, {right, apply h2}]; assumption
end

lemma and_of_and : (p → q) → (r → s) → (p ∧ r) → (q ∧ s) :=
begin
  intros h1 h2 h3, cases h3 with h3 h4,
  apply and.intro (h1 h3) (h2 h4)
end

lemma or_iff_or {p p' q q' : Prop} :
  (p ↔ p') → (q ↔ q') → ((p ∨ q) ↔ (p' ∨ q')) :=
begin
  intros hp hq, rewrite hp, rewrite hq
end

lemma and_iff_and {p p' q q' : Prop} :
  (p ↔ p') → (q ↔ q') → ((p ∧ q) ↔ (p' ∧ q')) :=
begin intros hp hq, rewrite hp, rewrite hq end

lemma ite.rec {p} [hd : decidable p] {f g : α} (q : α → Prop)
  (hf : p → q f) (hg : ¬ p → q g) : q (@ite p hd α f g) :=
begin
  unfold ite, tactic.unfreeze_local_instances,
  cases hd with h h, simp, apply hg h, simp, apply hf h
end

lemma of_ite_eq {p} [decidable p] {f g h : α} :
@ite p _ α f g = h → g ≠ h → p :=
begin
  intros h1 h2, by_cases h3 : p,
  assumption, rw if_neg h3 at h1,
  exfalso, apply h2 h1
end

lemma iff_of_left_of_right {p q : Prop} : p → q → (p ↔ q) :=
begin intros hp hq, constructor; intro h; assumption end

lemma iff_of_not_of_not {p q : Prop} :
  ¬p → ¬q → (p ↔ q) :=
begin intros hp hq, constructor; intro h; contradiction end

lemma not_of_imp_of_not : (p → q) → ¬q → ¬p :=
begin intros h1 h2 h3, apply h2 (h1 h3) end

namespace classical

local attribute [instance] classical.dec

lemma iff_iff {a b : Prop} : (a ↔ b) ↔ ((¬a ∨ b) ∧ (a ∨ ¬b)) :=
begin
  rw [iff_iff_implies_and_implies a b],
  simp only [imp_iff_not_or, or.comm]
end

lemma imp_iff_not_or {a b : Prop} : a → b ↔ ¬a ∨ b :=
_root_.imp_iff_not_or

lemma not_exists_not :
  ∀ {p : α → Prop}, (¬∃ (x : α), ¬p x) ↔ ∀ (x : α), p x :=
λ p, _root_.not_exists_not

lemma not_not : ¬¬p ↔ p := _root_.not_not

lemma not_and_distrib : ¬(p ∧ q) ↔ ¬p ∨ ¬q := not_and_distrib

end classical


/-
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

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

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

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,
  let ϕ := algebra.of_id F (⊥ : subalgebra F E),
  let ψ := alg_equiv.of_bijective ϕ ((algebra.bot_equiv F E).symm.bijective),
  change (↑x : E) = ↑(ψ (ψ.symm ⟨x, _⟩)),
  rw alg_equiv.apply_symm_apply ψ ⟨x, _⟩,
  refl
end

/-- The top intermediate_field is isomorphic to the field. -/
@[simps apply] def top_equiv : (⊤ : intermediate_field F E) ≃ₐ[F] E :=
(subalgebra.equiv_of_eq _ _ top_to_subalgebra).trans algebra.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 (eq_inv_of_mul_right_eq_one _).symm,
    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⟩,
    have : x1 = y1 := le_antisymm hxy1 hyx1,
    subst this,
    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 : zorn.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 (zorn.chain_insert hc (λ _ _ _, or.inl bot_le)).total_of_refl 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 : zorn.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 : zorn.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 : zorn.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 : zorn.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 : zorn.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.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_right_eq_one (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 : polynomial K) :
  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 : polynomial K) :
  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


import finite_dimensional_vector_spaces.ring_n_is_module

universes u

namespace fin_vector_space

variables (R : Type u) [h : field R] (n : ℕ)

-- structure fin_dim_ring extends module R (vector R n)

include h

def elemental_vector (i : fin n) : vector R n :=
match n, i with
| 0, _ := vector.nil
| (n+1), ⟨0, _⟩ := vector.cons 1 (vector.repeat 0 n)
| (n+1), ⟨i+1, l⟩ := vector.cons 0
    $ by exact _match _ ⟨_, (nat.lt_of_succ_lt_succ l)⟩
end

def basis : vector (vector R n) n :=
vector.of_fn (elemental_vector R n)

def basis_as_finset : finset (vector R n) :=
{
    val := (basis R n).to_list,
    nodup := by
        { rw [basis, vector.to_list_of_fn,
            multiset.coe_nodup, list.nodup_iff_nth_le_inj],
        intros i j h1 h2,
        rw [list.length_of_fn] at h1 h2,
        rw [list.nth_le_of_fn _ ⟨i, h1⟩, list.nth_le_of_fn _ ⟨j, h2⟩],
        intro a,
        induction n with n ih generalizing i j,
        exact (nat.le_lt_antisymm (i.zero_le) h1).elim,
        cases i; cases j; unfold elemental_vector at a,
            { replace a := @congr _ _ (vector.head) _ _ _ rfl a,
            rw [vector.head_cons, vector.head_cons] at a,
            exact (not_not_intro a h.zero_ne_one.symm).elim },
            { replace a := @congr _ _ (vector.head) _ _ _ rfl a,
            rw [vector.head_cons, vector.head_cons] at a,
            exact (not_not_intro a h.zero_ne_one).elim },
            { rw [list.length_of_fn] at ih,
            have hi := nat.lt_of_succ_lt_succ h1_1,
            have hj := nat.lt_of_succ_lt_succ h2_1,
            apply congr rfl,
            apply ih _ _ hi hj hj hi,
            replace a := @congr _ _ (vector.tail) _ _ _ rfl a,
            rw [vector.tail_cons, vector.tail_cons] at a,
            exact a } }
}

#check @finsupp.on_finset _ _ _ _ (basis_as_finset R n)
#check @set.finite

def fin_lc (v : vector R n) (i : fin n) : R := v.nth i

def lc_basis [d : decidable_eq R] : lc R (vector R n) :=
by { apply @finsupp.on_finset _ R _ _ (basis_as_finset R n),
    swap 2, intro a,
    have := ,
    -- intros a ha,
    -- unfold basis_as_finset basis,
    -- simp [vector.to_list_of_fn],
 }

-- lemma basis_is_spanning_set : ∀ (x : vector R n),
--     x ∈ span {v : vector R n | v ∈ basis_as_finset R n} :=
-- by { intro a,
--     rw [span, basis_as_finset],
--     split,  }

-- instance : is_basis { v | v ∈ basis_as_finset R n } :=
-- by { split,
--     { --simp [linear_independent],
--     unfold linear_independent basis_as_finset,
--     intros l h1 h2, simp at h1,
--     simp [vector.eq_nil 0, finsupp.sum] at h2,
--     -- induction n with _ ih generalizing l,
--     cases l with ls lf lh,
--     simp [list.of_fn, list.of_fn_aux] at h1,
--     simp [coe_fn, has_coe_to_fun.coe] at h1 h2,
--     simp [has_zero.zero],
--     simp [has_zero.zero, add_monoid.zero, add_group.zero,
--         add_comm_group.zero, vector.repeat] at h2,
--     cases ls with lsv lss,
--     split,
--     induction n with _ ih,

--      }, }

end fin_vector_space