import compiler
import well_formedness

namespace rc_correctness

open rc_correctness.expr
open rc_correctness.fn_body
open rc_correctness.lin_type

lemma not_𝔹_iff_𝕆 {τ : lin_type} : τ ≠ 𝔹 ↔ τ = 𝕆 :=
begin
  cases τ;
  split; intro h; contradiction <|> refl
end

lemma not_𝕆_iff_𝔹 {τ : lin_type} : τ ≠ 𝕆 ↔ τ = 𝔹 :=
begin
  cases τ;
  split; intro h; contradiction <|> refl
end

section FV_wf
  open finset
  open list

  theorem FV_sub_wf_context {δ : program} {β : const → var → lin_type} {Γ : finset var} {F : fn_body}
    (h : β; δ; Γ ⊢ F) :
    FV F ⊆ Γ :=
  begin
    with_cases { induction F using rc_correctness.fn_body.rec_wf generalizing Γ };
    simp only [subset_iff],
    case ret : x {
      intros y h₁,
      simp only [FV, finset.mem_singleton, insert_empty_eq_singleton] at h₁,
      cases h,
      rwa h₁
    },
    case «let» : x e F ih {
      intros y h₁,
      simp only [FV, mem_erase, finset.mem_union] at h₁,
      cases h₁,
      { cases h;
        simp only [FV_expr, mem_to_finset, mem_insert,
                  finset.mem_singleton, has_insert_eq_insert, insert_empty_eq_singleton] at h₁;
        try { simp only [subset_iff, mem_to_finset] at h_ys_def };
        try { exact h_ys_def h₁ };
        try { rwa h₁ },
        cases h₁; rwa h₁ },
      { cases h₁,
        cases h;
        { replace ih := subset_iff.mp (ih h_F_wf) h₁_right,
          rw mem_insert at ih,
          cases ih,
          { contradiction },
          { assumption } } }
    },
    case «case» : x Fs ih {
      intros y h₁,
      simp only [FV, mem_insert, finset.mem_join] at h₁,
      cases h,
      cases h₁,
      { rwa h₁ },
      rw map_wf_eq_map at h₁,
      simp only [exists_prop, list.mem_map] at h₁,
      rcases h₁ with ⟨l, ⟨⟨a, ⟨a_in_Fs, FV_a_eq_l⟩⟩, y_in_l⟩⟩,
      rw ←FV_a_eq_l at y_in_l,
      have a_wf : (β; δ; Γ ⊢ a), from h_Fs_wf a a_in_Fs,
      have FV_a_sub_Γ : FV a ⊆ Γ, from ih a a_in_Fs a_wf,
      exact subset_iff.mp FV_a_sub_Γ y_in_l
    },
    all_goals {
      intros x F ih Γ h y h₁,
      cases h
    }
  end
end FV_wf

section FV_C
  open finset

  lemma FV_inc_𝕆_var_eq_FV {x : var} {F : fn_body} (V : finset var) (βₗ : var → lin_type)
    (h : x ∈ FV F) :
    FV (inc_𝕆_var x V F βₗ) = FV F :=
  begin
    unfold inc_𝕆_var,
    split_ifs,
    { refl },
    unfold FV,
    exact insert_eq_of_mem h
  end

  lemma FV_sub_FV_dec_𝕆 (ys : list var) (F : fn_body) (βₗ : var → lin_type)
    : FV F ⊆ FV (dec_𝕆 ys F βₗ) :=
  begin
    apply subset_iff.mpr,
    intros x h,
    unfold dec_𝕆 dec_𝕆_var,
    induction ys,
    { simpa only [list.foldr_nil] },
    simp only [list.foldr_cons],
    split_ifs,
    { simp only [FV, mem_insert],
      exact or.inr ys_ih },
    { exact ys_ih }
  end

  lemma FV_dec_𝕆_filter (ys : list var) (F : fn_body) (βₗ : var → lin_type)
    : FV (dec_𝕆 ys F βₗ) = ys.to_finset.filter (λ y, βₗ y = 𝕆 ∧ y ∉ FV F) ∪ FV F :=
  begin
    induction ys,
    { simp only [dec_𝕆, filter_empty, finset.empty_union, list.to_finset_nil, list.foldr_nil] },
    simp only [dec_𝕆, dec_𝕆_var, filter_insert, list.foldr_cons, list.to_finset_cons] at *,
    split_ifs;
    try { simp only [FV, insert_union] },
    { rw ys_ih },
    { simp only [not_and, not_not] at h_1,
      have ys_hd_in_FV, from h_1 h.left,
      have :
        FV (list.foldr (λ (x : var) (acc : fn_body),
          ite (βₗ x = 𝕆 ∧ x ∉ FV acc) (dec x; acc) acc)
          F ys_tl) = FV (dec_𝕆 ys_tl F βₗ), from rfl,
      rw this at h,
      exact absurd (subset_iff.mp (FV_sub_FV_dec_𝕆 ys_tl F βₗ) ys_hd_in_FV) h.right },
    { simp only [not_and, not_not] at h,
      have ys_hd_in_FV, from h h_1.left,
      rw ys_ih at *,
      rw insert_eq_of_mem ys_hd_in_FV },
    { rw ys_ih }
  end

  lemma FV_dec_𝕆_sub_vars_FV (vars : list var) (F : fn_body) (βₗ : var → lin_type)
  : FV (dec_𝕆 vars F βₗ) ⊆ vars.to_finset ∪ FV F :=
  begin
    simp only [FV_dec_𝕆_filter, subset_iff, mem_union, mem_filter, list.mem_to_finset],
    intros x h,
    cases h,
    { exact or.inl h.left },
    { exact or.inr h }
  end

  lemma FV_dec_eq_FV {e : expr} {x z : var} {F : fn_body}
    (h : x ∈ FV_expr e ∪ erase (FV F) z) :
    FV_expr e ∪ erase (FV (dec x; F)) z = FV_expr e ∪ erase (FV F) z :=
  begin
    unfold FV,
    have hem : x = z ∨ x ≠ z, from dec_em (x = z),
    cases hem,
    { rw hem,
      rw erase_insert_eq_erase },
    { rw erase_insert_eq_insert_erase _ hem,
      simp only [union_insert],
      exact insert_eq_of_mem h }
  end

  lemma FV_Capp_eq_FV {xs : list (var × lin_type)} {z : var} {e : expr} {F1 F2 : fn_body} (βₗ : var → lin_type)
    (heq : FV F1 = FV F2) (h : ∀ xτ ∈ xs, (xτ : var × lin_type).1 ∈ FV (z ≔ e; F1)) :
    FV (C_app xs (z ≔ e; F1) βₗ) = FV (z ≔ e; F2) :=
  begin
    induction xs generalizing F1 F2,
    { simp only [FV, C_app],
      rw heq },
    cases xs_hd with x τ,
    simp only [list.mem_cons_iff, list.forall_mem_cons'] at h,
    cases h with x_in_FV h,
    simp only [C_app, FV] at *,
    cases τ,
    { rw if_pos rfl,
      unfold inc_𝕆_var,
      split_ifs,
      { exact xs_ih heq h },
      unfold FV,
      rw xs_ih heq h,
      rw heq at x_in_FV,
      exact insert_eq_of_mem x_in_FV },
    { simp only [dec_𝕆_var, if_false],
      split_ifs,
      { suffices h2 : ∀ (xτ : var × lin_type), xτ ∈ xs_tl → xτ.fst ∈ FV_expr e ∪ erase (FV (dec x; F1)) z,
        { have h3 : FV (dec x; F1) = FV (dec x; F2), from by
          { unfold FV, rw heq },
          rw xs_ih h3 h2,
          rw heq at x_in_FV,
          exact FV_dec_eq_FV x_in_FV },
        { intros yτ yτ_in_tl,
          have y_in_FV, from h yτ yτ_in_tl,
          rwa FV_dec_eq_FV x_in_FV } },
      { exact xs_ih heq h } }
  end

  theorem FV_C_eq_FV (β : const → var → lin_type) (F : fn_body) (βₗ : var → lin_type) : FV (C β F βₗ) = FV F :=
  begin
    with_cases { induction F using rc_correctness.fn_body.rec_wf generalizing βₗ },
    case ret : x {
      unfold FV C inc_𝕆_var,
      split_ifs;
      simp only [FV, insert_eq_of_mem, insert_empty_eq_singleton, mem_singleton]
    },
    case «case» : x Fs ih {
      unfold C FV,
      repeat { rw list.map_wf_eq_map },
      simp only [list.map_map],
      ext,
      apply iff.intro,
      { intro h,
        apply mem_insert.mpr,
        replace h := mem_insert.mp h,
        cases h,
        { exact or.inl h },
        { rw mem_join at h,
          rcases h with ⟨S, h, a_in_S⟩,
          simp only [list.mem_map, function.comp_app] at h,
          rcases h with ⟨b, b_in_Fs, h⟩,
          rw ←h at a_in_S,
          have h2, from FV_dec_𝕆_sub_vars_FV (sort var_le (insert x (join (list.map FV Fs)))) (C β b βₗ) βₗ,
          rw sort_to_finset _ at h2,
          have h3, from mem_of_subset h2 a_in_S,
          simp only [mem_union, mem_insert] at h3,
          rcases h3 with ⟨l, m, r⟩,
          { exact or.inl h3 },
          { exact or.inr h3 },
          rw ih b b_in_Fs βₗ at h3,
          simp only [exists_prop, list.mem_map, mem_join],
          exact or.inr ⟨FV b, ⟨⟨b, ⟨b_in_Fs, rfl⟩⟩, h3⟩⟩ } },
      { intro h,
        apply mem_insert.mpr,
        replace h := mem_insert.mp h,
        cases h,
        { exact or.inl h },
        { rw mem_join at h,
          rcases h with ⟨S, h, a_in_S⟩,
          rw list.mem_map at h,
          rcases h with ⟨b, ⟨b_in_Fs, FV_b_eq_S⟩⟩,
          apply or.inr,
          simp only [mem_join, exists_prop, list.mem_map, function.comp_app],
          apply exists.intro (FV (dec_𝕆 (sort var_le (insert x (join (list.map FV Fs)))) (C β b βₗ) βₗ)),
          apply and.intro,
          { exact ⟨b, ⟨b_in_Fs, rfl⟩⟩ },
          rw ←ih b b_in_Fs βₗ at FV_b_eq_S,
          rw ←FV_b_eq_S at a_in_S,
          have h, from FV_sub_FV_dec_𝕆 (sort var_le (insert x (join (list.map FV Fs)))) (C β b βₗ) βₗ,
          exact mem_of_subset h a_in_S } }
    },
    case «let» : x e F ih {
      induction e;
      unfold C;
      try {
        apply FV_Capp_eq_FV βₗ (ih (βₗ[x↦𝕆])),
        intros xτ h
      };
      try {
        rw list.mem_map at h,
        apply Exists.rec_on h,
        intros x h_h,
        apply and.rec_on h_h,
        intros x_in_ys xτ_def,
        cases xτ,
        rw ←xτ_def,
        simp only [FV, FV_expr, mem_union, mem_insert, insert_union, list.mem_to_finset, mem_erase]
      },
      { exact or.inl x_in_ys },
      { exact or.inl x_in_ys },
      { simp only [list.mem_cons_iff, list.mem_singleton] at h,
        simp only [FV, FV_expr, mem_union, mem_insert, insert_union,
                  has_insert_eq_insert, insert_empty_eq_singleton, mem_singleton],
        cases h;
        rw h,
        { exact or.inr (or.inl rfl) },
        { exact or.inl (rfl) } },
      { exact or.inl x_in_ys },
      { simp only [FV, C, dec_𝕆_var, FV_expr, insert_empty_eq_singleton],
        split_ifs;
        simp only [FV, erase_insert_eq_erase, FV_expr, insert_empty_eq_singleton],
        { rw ih (βₗ[x↦𝕆]) at *,
          have hem : e_x = x ∨ e_x ≠ x, from dec_em (e_x = x),
          cases hem,
          { rw hem at *,
            rw erase_insert_eq_erase, },
          { rw erase_insert_eq_insert_erase _ hem,
            simp } },
        { rw ih (βₗ[x↦𝕆]) },
        { rw ih (βₗ[x↦𝔹]) } },
    },
    all_goals { intros x F ih βₗ, simp only [FV, C] }
  end
end FV_C

section sandwich
  open finset

  lemma wf_sandwich {β : const → var → lin_type} {δ : program} {Γ Γ' Γ'' : finset var} {F : fn_body}
    (Γ_sub_Γ' : Γ ⊆ Γ') (Γ'_sub_Γ'' : Γ' ⊆ Γ'') (hΓ : β; δ; Γ ⊢ F) (hΓ'' : β; δ; Γ'' ⊢ F)
    : β; δ; Γ' ⊢ F :=
  begin
    with_cases { induction F using rc_correctness.fn_body.rec_wf generalizing Γ Γ' Γ'' },
    case ret : x {
      apply fn_body_wf.ret,
      cases hΓ,
      exact subset_iff.mp Γ_sub_Γ' hΓ_x_def
    },
    case «let» : x e F ih {
      cases e;
      cases hΓ;
      cases hΓ'';
      let h1 := insert_subset_insert x Γ_sub_Γ';
      let h2 := insert_subset_insert x Γ'_sub_Γ'',
      any_goals {
        apply fn_body_wf.let_const_app_full
        <|> apply fn_body_wf.let_const_app_part
        <|> apply fn_body_wf.let_var_app
        <|> apply fn_body_wf.let_ctor
        <|> apply fn_body_wf.let_proj },
      any_goals { assumption },
      any_goals {
        transitivity,
        { exact hΓ_ys_def },
        { assumption }
      },
      any_goals {
        intro h,
        have h', from subset_iff.mp Γ'_sub_Γ'' h,
        contradiction
      },
      any_goals { exact ih h1 h2 hΓ_F_wf hΓ''_F_wf },
      any_goals { exact subset_iff.mp Γ_sub_Γ' hΓ_x_def },
      any_goals { exact subset_iff.mp Γ_sub_Γ' hΓ_y_in_Γ }
    },
    case «case» : x Fs ih {
      cases hΓ,
      cases hΓ'',
      apply fn_body_wf.case,
      { exact subset_iff.mp Γ_sub_Γ' hΓ_x_def },
      intros F F_in_Fs,
      exact ih F F_in_Fs Γ_sub_Γ' Γ'_sub_Γ'' (hΓ_Fs_wf F F_in_Fs) (hΓ''_Fs_wf F F_in_Fs)
    },
    case «inc» : x F ih {
      cases hΓ
    },
    case «dec» : x F ih {
      cases hΓ
    }
  end

  lemma FV_wf {β : const → var → lin_type} {δ : program} {Γ : finset var} {F : fn_body} (h : β; δ; Γ ⊢ F)
    : β; δ; FV F ⊢ F :=
  begin
    induction h,
    { apply fn_body_wf.ret,
      simp only [FV, insert_empty_eq_singleton, mem_singleton] },
    any_goals {
      apply fn_body_wf.let_const_app_full
      <|> apply fn_body_wf.let_const_app_part
      <|> apply fn_body_wf.let_var_app
      <|> apply fn_body_wf.let_ctor
      <|> apply fn_body_wf.let_proj
    },
    any_goals { simp [FV, FV_expr, subset_union_left, not_or_distrib] },
    any_goals {
      intro h,
      simp only [subset_iff, list.mem_to_finset] at h_ys_def,
      have : h_z ∈ h_Γ, from h_ys_def h,
      contradiction
    },
    any_goals { split },
    any_goals {
      intro h,
      rw h at h_z_undef,
      contradiction
    },
    any_goals { apply wf_sandwich _ _ h_ih h_F_wf },
    any_goals {
      simp only [subset_iff, mem_union, mem_insert, mem_erase],
      intros x x_in_FV,
      by_cases eq : x = h_z,
      { exact or.inl eq },
      { repeat { apply or.inr },
        exact ⟨eq, x_in_FV⟩ }
    },
    any_goals {
      apply insert_subset_insert,
      simp only [subset_iff, mem_union, list.mem_to_finset, mem_erase, mem_insert, mem_singleton],
      intros x h,
      repeat { cases h }
    },
    any_goals {
      simp only [subset_iff, list.mem_to_finset] at h_ys_def,
      exact h_ys_def h
    },
    any_goals {
      cases mem_insert.mp (subset_iff.mp (FV_sub_wf_context h_F_wf) h_right),
      { contradiction },
      { assumption }
    },
    any_goals { assumption },
    { apply fn_body_wf.case,
      { exact mem_insert_self h_x _ },
      intros F F_in_Fs,
      apply wf_sandwich _ _ (h_ih F F_in_Fs) (h_Fs_wf F F_in_Fs);
      simp only [subset_iff, list.map_wf_eq_map, exists_prop, mem_join, mem_insert, list.mem_map],
      { intros x x_in_FV,
        apply or.inr,
        use FV F,
        use F,
        { exact ⟨F_in_Fs, rfl⟩ },
        { assumption } },
      { intros x h,
        cases h,
        { rwa h },
        rcases h with ⟨S, ⟨⟨a, ⟨a_in_Fs, a_def⟩⟩, x_in_S⟩⟩,
        rw ←a_def at x_in_S,
        exact subset_iff.mp (FV_sub_wf_context (h_Fs_wf a a_in_Fs)) x_in_S } }
  end

  lemma wf_FV_sandwich {β : const → var → lin_type} {δ : program} {Γ Γ' : finset var} {F : fn_body}
    (Γ'_low : FV F ⊆ Γ') (Γ'_high : Γ' ⊆ Γ) (h : β; δ; Γ ⊢ F)
    : β; δ; Γ' ⊢ F := wf_sandwich Γ'_low Γ'_high (FV_wf h) h
end sandwich

lemma vars_sub_FV_dec_𝕆 (ys : list var) (F : fn_body) (βₗ : var → lin_type)
  : ∀ y ∈ ys, βₗ y = 𝕆 → y ∈ FV (dec_𝕆 ys F βₗ) :=
begin
  intros y y_in_ys y𝕆,
  rw FV_dec_𝕆_filter,
  simp only [list.mem_to_finset, finset.mem_union, finset.mem_filter],
  by_cases y ∈ FV F,
  { exact or.inr h },
  { exact or.inl ⟨y_in_ys, y𝕆, h⟩ }
end

lemma dec_𝕆_eq_dec_𝕆'_of_nodup {ys : list var} (F : fn_body) (βₗ : var → lin_type)
  (d : list.nodup ys) : dec_𝕆 ys F βₗ = dec_𝕆' ys F βₗ :=
begin
  unfold dec_𝕆 dec_𝕆_var dec_𝕆',
  induction ys,
  { simp only [list.foldr_nil] },
  cases list.nodup_cons.mp d with ys_hd_not_in_ys_tl nodup_ys_tl,
  simp only [list.foldr_cons],
  split_ifs,
  { exact ⟨rfl, ys_ih nodup_ys_tl⟩ },
  { simp only [not_and, not_not] at h_1,
    have g1, from h.right,
    have g2, from finset.subset_iff.mp (FV_sub_FV_dec_𝕆 ys_tl F βₗ) (h_1 h.left),
    contradiction },
  { simp only [not_and, not_not] at h,
    have g1, from h_1.right,
    have g2, from finset.subset_iff.mp (FV_dec_𝕆_sub_vars_FV ys_tl F βₗ) (h h_1.left),
    simp only [list.mem_to_finset, finset.mem_union] at g2,
    cases g2; contradiction },
  { exact ys_ih nodup_ys_tl }
end

open multiset (hiding coe_sort)

lemma inductive_dec' {β : const → var → lin_type} {ys : list var} {y𝕆 y𝔹 : multiset var} {F : fn_body} {βₗ : var → lin_type}
  (ys_sub_vars : ↑ys ⊆ y𝕆 + y𝔹) (d : list.nodup ys)
  (y𝕆_𝕆 : ∀ y ∈ y𝕆, βₗ y = 𝕆) (y𝔹_𝔹 : ∀ y ∈ y𝔹, βₗ y = 𝔹) (nd_y𝕆 : nodup y𝕆) (nd_y𝔹 : nodup y𝔹)
  (h : β; (filter (λ y, y ∉ ys ∨ y ∈ FV F) y𝕆 {∶} 𝕆) + (y𝔹 {∶} 𝔹) ⊩ F ∷ 𝕆)
  : β; (y𝕆 {∶} 𝕆) + (y𝔹 {∶} 𝔹) ⊩ dec_𝕆 ys F βₗ ∷ 𝕆 :=
begin
  have h_congr : ∀ {ys_hd : var} {ys_tl : list var} {ys' : multiset var}
    (f : ∀ y ∈ ys', y ∉ ys_tl → ¬y = ys_hd ∧ y ∉ ys_tl ∨ y ∈ FV F),
    ∀ y ∈ ys', y ∉ (ys_hd :: ys_tl : list var) ∨ y ∈ FV F ↔ y ∉ ys_tl ∨ y ∈ FV F,
  { intros ys_hd ys_tl ys' f y y_in_ys',
    rw [list.mem_cons_iff, not_or_distrib],
    exact ⟨λ h', h'.elim (λ h'', or.inl h''.right) (λ h'', or.inr h''),
           λ h', h'.elim (λ h'', f y y_in_ys' h'') (λ h'', or.inr h'')⟩ },
  rw dec_𝕆_eq_dec_𝕆'_of_nodup F βₗ d,
  induction ys generalizing y𝕆 y𝔹,
  { rw [dec_𝕆', list.foldr_nil],
    simp only [list.not_mem_nil, true_or, not_false_iff, filter_true] at h,
    assumption },
  cases list.nodup_cons.mp d with ys_hd_not_in_ys_tl nodup_ys_tl,
  rw ←cons_coe at ys_sub_vars,
  simp only [cons_subset, mem_add] at ys_sub_vars,
  cases ys_sub_vars with ys_hd_def ys_tl_sub_vars,
  rw [dec_𝕆', list.foldr_cons],
  split_ifs,
  { cases ys_hd_def, swap,
    { rw y𝔹_𝔹 ys_hd ys_hd_def at h_1,
      simp only [false_and] at h_1,
      contradiction },
    cases exists_cons_of_mem ys_hd_def with y𝕆' y𝕆_def,
    rw [y𝕆_def, map_cons, cons_add],
    apply linear.dec,
    apply ys_ih,
    { assumption },
    { rw y𝕆_def at ys_tl_sub_vars,
      rw subset_iff at ys_tl_sub_vars ⊢,
      intros x x_in_tl,
      let := ys_tl_sub_vars x_in_tl,
      simp only [mem_add, mem_cons] at this,
      repeat { cases this },
      { contradiction },
      { exact mem_add.mpr (or.inl this) },
      { exact mem_add.mpr (or.inr this) } },
    { simp only [y𝕆_def, mem_cons] at y𝕆_𝕆,
      intros y y_in_y𝕆',
      exact y𝕆_𝕆 y (or.inr y_in_y𝕆') },
    { assumption },
    { simp only [y𝕆_def, nodup_cons] at nd_y𝕆,
      exact nd_y𝕆.right },
    { assumption },
    { rw y𝕆_def at h nd_y𝕆,
      rw filter_cons_of_neg at h, swap,
      { simp, exact h_1.right },
      rw nodup_cons at nd_y𝕆,
      have : ∀ y ∈ y𝕆', y ∉ ys_tl → ¬y = ys_hd ∧ y ∉ ys_tl ∨ y ∈ FV F,
      { intros y y_in_y𝕆' h',
        apply or.inl (and.intro _ h'),
        intro h',
        rw h' at y_in_y𝕆',
        exact absurd y_in_y𝕆' nd_y𝕆.left },
      rwa filter_congr (h_congr this) at h } },
  apply ys_ih,
  any_goals { assumption },
  rw not_and_distrib at h_1,
  cases h_1,
  { rw [←ne.def, not_𝕆_iff_𝔹] at h_1,
    cases ys_hd_def,
    { rw y𝕆_𝕆 ys_hd ys_hd_def at h_1,
      contradiction },
    have : ∀ y ∈ y𝕆, y ∉ ys_tl → ¬y = ys_hd ∧ y ∉ ys_tl ∨ y ∈ FV F,
    { intros y y_in_y𝕆 h',
      apply or.inl (and.intro _ h'),
      intro h'',
      rw h'' at y_in_y𝕆,
      rw y𝕆_𝕆 ys_hd y_in_y𝕆 at h_1,
      contradiction },
    rwa filter_congr (h_congr this) at h },
  { have : ∀ y ∈ y𝕆, y ∉ ys_tl → ¬y = ys_hd ∧ y ∉ ys_tl ∨ y ∈ FV F,
    { intros y y_in_y𝕆 h',
      rw not_not at h_1,
      by_cases h'' : y = ys_hd,
      { rw h'',
        exact or.inr h_1 },
      { exact or.inl ⟨h'', h'⟩ } },
    rwa filter_congr (h_congr this) at h }
end

lemma inductive_dec {β : const → var → lin_type} {ys : list var} {y𝕆 y𝔹 : multiset var} {F : fn_body} {βₗ : var → lin_type}
  (y𝕆_sub_ys : y𝕆 ⊆ ↑ys) (ys_sub_vars : ↑ys ⊆ y𝕆 + y𝔹) (d : list.nodup ys)
  (y𝕆_𝕆 : ∀ y ∈ y𝕆, βₗ y = 𝕆) (y𝔹_𝔹 : ∀ y ∈ y𝔹, βₗ y = 𝔹) (nd_y𝕆 : nodup y𝕆) (nd_y𝔹 : nodup y𝔹)
  (h : β; (filter (λ y, y ∈ FV F) y𝕆 {∶} 𝕆) + (y𝔹 {∶} 𝔹) ⊩ F ∷ 𝕆)
  : β; (y𝕆 {∶} 𝕆) + (y𝔹 {∶} 𝔹) ⊩ dec_𝕆 ys F βₗ ∷ 𝕆 :=
begin
  have : ∀ y ∈ y𝕆, y ∈ FV F ↔ y ∉ ys ∨ y ∈ FV F,
  { intros y y_in_y𝕆,
    split; intro h',
    { exact or.inr h' },
    { cases h',
      { exact absurd (y𝕆_sub_ys y_in_y𝕆) h' },
      { assumption } } },
  rw filter_congr this at h,
  exact inductive_dec' ys_sub_vars d y𝕆_𝕆 y𝔹_𝔹 nd_y𝕆 nd_y𝔹 h
end

lemma inductive_weakening {β : const → var → lin_type} {ys : multiset typed_var} {y𝔹 : multiset var}
  {r : rc} {τ : lin_type}
  (h : β; ys ⊩ r ∷ τ)
  : β; ys + (y𝔹 {∶} 𝔹) ⊩ r ∷ τ :=
begin
  apply multiset.induction_on y𝔹,
  { simp only [map_zero, add_zero],
    assumption },
  intros a s ih,
  simp only [map_cons, add_cons],
  apply linear.weaken,
  assumption
end

theorem C_app_rc_insertion_correctness {β : const → var → lin_type} {βₗ : var → lin_type} {δ : program}
  {y : var} {e : expr} {F : fn_body} {y𝕆 y𝔹 : multiset var} {Γ : list (var × lin_type)}
  (ih : ∀ (βₗ : var → lin_type),
    nodup y𝕆 →
    nodup y𝔹 →
    (∀ (y : var), y ∈ y𝕆 → βₗ y = 𝕆) →
    (∀ (y : var), y ∈ y𝔹 → βₗ y = 𝔹) →
    (β; δ; to_finset y𝕆 ∪ to_finset y𝔹 ⊢ F) →
    (∀ ⦃x : var⦄, x ∈ y𝕆 → x ∈ FV F) →
    (β; (y𝕆 {∶} 𝕆) + (y𝔹 {∶} 𝔹) ⊩ ↑(C β F βₗ) ∷ 𝕆))
  (nd_y𝕆 : nodup y𝕆) (nd_y𝔹 : nodup y𝔹)
  (y𝕆_𝕆 : ∀ (y : var), y ∈ y𝕆 → βₗ y = 𝕆)
  (y𝔹_𝔹 : ∀ (y : var), y ∈ y𝔹 → βₗ y = 𝔹)
  (wf : β; δ; to_finset y𝕆 ∪ to_finset y𝔹 ⊢ (y ≔ e; F))
  (y𝕆_free : ∀ ⦃x : var⦄, x ∈ y𝕆 → x ∈ FV (y ≔ e; F))
  (ty : β; (Γ.map (λ (yτ : var × lin_type), yτ.1 ∶ yτ.2)) ⊩ e ∷ 𝕆)
  : (β; (y𝕆 {∶} 𝕆) + (y𝔹 {∶} 𝔹) ⊩ ↑(C_app Γ (y ≔ e; C β F (βₗ[y↦𝕆])) βₗ) ∷ 𝕆) :=
begin
  sorry
end

theorem rc_insertion_correctness' {β : const → var → lin_type} {δ : program} {c : const}
  {y𝕆 y𝔹 : multiset var}
  (nd_y𝕆 : nodup y𝕆) (nd_y𝔹 : nodup y𝔹)
  (y𝕆_𝕆 : ∀ y ∈ y𝕆, β c y = 𝕆) (y𝔹_𝔹 : ∀ y ∈ y𝔹, β c y = 𝔹)
  (y𝕆_sub_FV : y𝕆.to_finset ⊆ FV (δ c).F) (wf : β; δ; y𝕆.to_finset ∪ y𝔹.to_finset ⊢ (δ c).F)
  : β; (y𝕆 {∶} 𝕆) + (y𝔹 {∶} 𝔹) ⊩ C β ((δ c).F) (β c) ∷ 𝕆 :=
begin
  generalize h : β c = βₗ,
  rw h at *,
  clear h,
  simp only [finset.subset_iff, mem_to_finset] at y𝕆_sub_FV,
  generalize h : (δ c).F = F,
  rw h at *,
  clear h,
  with_cases { induction F using rc_correctness.fn_body.rec_wf generalizing y𝕆 y𝔹 βₗ },
  case ret : x {
    unfold C,
    unfold FV at y𝕆_sub_FV,
    cases wf,
    simp only [mem_union, ndunion_eq_union, to_finset_val, nodup_erase_dup, mem_erase_dup, finset.mem_mk] at wf_x_def,
    unfold inc_𝕆_var,
    cases wf_x_def,
    { have : βₗ x = 𝕆 ∧ x ∉ finset.empty, from ⟨y𝕆_𝕆 x wf_x_def, finset.not_mem_empty x⟩,
      rw if_pos this,
      have : y𝕆 = x :: 0,
      { rw nodup_ext nd_y𝕆 (nodup_singleton x),
        intro a,
        split;
        intro h,
        { exact y𝕆_sub_FV h },
        { rw mem_singleton at h,
          rwa h } },
      rw this,
      simp only [finset.singleton_val, finset.insert_empty_eq_singleton, zero_add, map_cons, cons_add, map_zero],
      rw ←singleton_add,
      apply inductive_weakening,
      apply linear.ret },
    { have : ¬(βₗ x = 𝕆 ∧ x ∉ finset.empty),
      { simp only [not_and],
        intro h,
        rw y𝔹_𝔹 x wf_x_def at h,
        simp only [] at h,
        contradiction },
      rw if_neg this,
      apply linear.inc_𝔹,
      { apply mem_add.mpr,
        apply or.inr,
        exact mem_map_of_mem _ wf_x_def },
      have : y𝕆 = ∅,
      { apply eq_zero_of_forall_not_mem,
        simp only [finset.insert_empty_eq_singleton, finset.mem_singleton] at y𝕆_sub_FV,
        intros y y_in_y𝕆,
        have x_in_y𝕆, from (y𝕆_sub_FV y_in_y𝕆).subst y_in_y𝕆,
        have dj : multiset.disjoint y𝕆 y𝔹,
        { rw disjoint_iff_ne,
          intros a a_in_y𝕆 b b_in_y𝔹 h,
          rw h at a_in_y𝕆,
          let := y𝕆_𝕆 b a_in_y𝕆,
          rw y𝔹_𝔹 b b_in_y𝔹 at this,
          contradiction },
        let := disjoint_right.mp dj wf_x_def,
        contradiction },
      simp only [this, empty_eq_zero, zero_add, map_zero],
      rw ←singleton_add,
      apply inductive_weakening,
      apply linear.ret }
  },
  case «let» : y e F ih {
    with_cases { cases e },
    case rc_correctness.expr.proj : i x wf {
      unfold C,
      split_ifs,
      { have x_in_y𝕆 : x ∈ y𝕆,
        { let := subset_iff.mp (FV_sub_wf_context wf),
          simp only [FV, FV_expr, mem_union, finset.singleton_val, to_finset_val,
            finset.insert_empty_eq_singleton, mem_erase_dup, finset.erase_val,
            finset.union_val, mem_singleton] at this,
          have h : x ∈ y𝕆 ∨ x ∈ y𝔹, from this (or.inl rfl),
          cases h,
          { assumption },
          { rw y𝔹_𝔹 x h_1 at h,
            contradiction } },
        apply linear.proj_𝕆,
        { simpa },
        unfold dec_𝕆_var,
        split_ifs,
        { rcases exists_cons_of_mem x_in_y𝕆 with ⟨y𝕆', y𝕆_def⟩,
          rw y𝕆_def at *,
          simp only [map_cons, cons_add],
          rw cons_swap,
          apply linear.dec,
          rw ←cons_add,
          rw ←map_cons (∶ 𝕆),
          apply ih,
          any_goals { assumption },
          { cases wf,
            simp only [not_or_distrib, mem_ndinsert, mem_ndunion, to_finset_val,
              mem_erase_dup, to_finset_cons, finset.insert_val, finset.mem_mk] at wf_z_undef,
            simp only [nodup_cons] at ⊢ nd_y𝕆,
            exact ⟨wf_z_undef.left.right, nd_y𝕆.right⟩ },
          { simp only [mem_cons],
            intros z z_in_y𝕆',
            cases z_in_y𝕆',
            { rw z_in_y𝕆',
              rw function.update_same },
            { by_cases z = y,
              { rw [h, function.update_same] },
              { rw function.update_noteq,
                { exact y𝕆_𝕆 z (mem_cons_of_mem z_in_y𝕆') },
                { assumption } } } },
          { intros z z_in_y𝔹,
            by_cases z = y,
            { cases wf,
              simp [not_or_distrib] at wf_z_undef,
              rw h at z_in_y𝔹,
              exact absurd z_in_y𝔹 wf_z_undef.right },
            { rw function.update_noteq,
              { exact y𝔹_𝔹 z z_in_y𝔹 },
              { assumption } } },
          { cases wf,
            apply wf_FV_sandwich _ _ wf_F_wf,
            { let := FV_sub_wf_context wf_F_wf,
              rw finset.subset_iff at ⊢ this,
              simp only [mem_ndinsert, mem_ndunion, to_finset_val, finset.insert_union, finset.mem_union,
                finset.mem_insert, mem_erase_dup, to_finset_cons, finset.insert_val, finset.mem_mk, mem_to_finset] at ⊢ this,
              intros z z_in_FV,
              have h', from this z_in_FV,
              repeat { cases h' },
              { exact or.inl rfl },
              { rw FV_C_eq_FV at h_1,
                exact absurd z_in_FV h_1.right },
              { exact or.inr (or.inl h') },
              { exact or.inr (or.inr h') } },
            { rw finset.subset_iff,
              simp only [mem_ndinsert, mem_ndunion, to_finset_val, finset.insert_union, finset.mem_union, finset.mem_insert,
                mem_erase_dup, to_finset_cons, finset.insert_val, finset.mem_mk, mem_to_finset],
              intros y h',
              repeat { cases h' },
              { exact or.inl rfl },
              { exact or.inr (or.inl (or.inr h')) },
              { exact or.inr (or.inr h') } } },
          { cases wf,
            simp only [FV, FV_expr, mem_cons, finset.insert_empty_eq_singleton, finset.mem_union,
              finset.mem_singleton, finset.mem_erase] at ⊢ y𝕆_sub_FV,
            intros z h',
            cases h',
            { rwa h' },
            have h'', from y𝕆_sub_FV (or.inr h'),
            cases h'',
            { rw h'' at h',
              rw nodup_cons at nd_y𝕆,
              exact absurd h' nd_y𝕆.left },
            { exact h''.right } } },
        simp only [not_and_distrib, not_not] at h_1,
        rw [←ne.def, not_𝕆_iff_𝔹] at h_1,
        cases h_1,
        { rw h at h_1, contradiction },
        rw ←cons_add,
        rw ←map_cons (∶ 𝕆),
        apply ih,
        any_goals { assumption },
        { cases wf,
          simp only [nodup_cons],
          simp only [not_or_distrib, mem_union, ndunion_eq_union, to_finset_val,
            nodup_erase_dup, mem_erase_dup, finset.mem_mk] at wf_z_undef,
          exact ⟨wf_z_undef.left, nd_y𝕆⟩ },
        { simp only [mem_cons],
          intros z h',
          cases h',
          { rw h', rw function.update_same },
          { by_cases eq : y = z,
            { rw eq, rw function.update_same },
            rw function.update_noteq,
            { exact y𝕆_𝕆 z h' },
            symmetry,
            assumption } },
        { intros z z_in_y𝔹,
          by_cases z = y,
          { cases wf,
            simp only [not_or_distrib, mem_union, ndunion_eq_union, to_finset_val, nodup_erase_dup,
              mem_erase_dup, finset.mem_mk] at wf_z_undef,
            rw h at z_in_y𝔹,
            exact absurd z_in_y𝔹 wf_z_undef.right },
          { rw function.update_noteq,
            { exact y𝔹_𝔹 z z_in_y𝔹 },
            { assumption } } },
        { cases wf,
          apply wf_FV_sandwich _ _ wf_F_wf,
          { let := FV_sub_wf_context wf_F_wf,
            rw finset.subset_iff at ⊢ this,
            simp only [mem_union, ndunion_eq_union, to_finset_val, nodup_erase_dup, finset.insert_union,
              finset.mem_union, finset.mem_insert, mem_erase_dup, to_finset_cons, finset.mem_mk, mem_to_finset] at ⊢ this,
            assumption },
          { rw finset.subset_iff,
            simp only [multiset.mem_erase_dup, multiset.mem_union, multiset.nodup_erase_dup, imp_self,
              multiset.to_finset_val, multiset.mem_to_finset, multiset.to_finset_cons, finset.insert_union,
              finset.mem_union, finset.mem_insert, finset.mem_mk, multiset.ndunion_eq_union, forall_true_iff] } },
        { cases wf,
          simp only [mem_cons],
          simp only [FV, FV_expr, finset.insert_empty_eq_singleton, finset.mem_union,
            finset.mem_singleton, finset.mem_erase] at y𝕆_sub_FV,
          intros z h',
          cases h',
          { rwa h' },
          have h'', from y𝕆_sub_FV h',
          cases h'',
          { rw h'',
            rwa FV_C_eq_FV at h_1 },
          { exact h''.right } } },
      rw [←ne.def, not_𝕆_iff_𝔹] at h,
      have x_in_y𝔹 : x ∈ y𝔹,
      { let := subset_iff.mp (FV_sub_wf_context wf),
        simp only [FV, FV_expr, mem_union, finset.singleton_val, to_finset_val,
          finset.insert_empty_eq_singleton, mem_erase_dup, finset.erase_val,
          finset.union_val, mem_singleton] at this,
        have h : x ∈ y𝕆 ∨ x ∈ y𝔹, from this (or.inl rfl),
        cases h,
        { rw y𝕆_𝕆 x h_1 at h,
          contradiction },
        { assumption } },
      apply linear.proj_𝔹,
      { simpa },
      rw [add_comm, ←cons_add, add_comm, ←map_cons (∶ 𝔹)],
      apply ih,
      any_goals { assumption },
      { cases wf,
        simp only [nodup_cons],
        simp only [not_or_distrib, mem_union, ndunion_eq_union, to_finset_val,
          nodup_erase_dup, mem_erase_dup, finset.mem_mk] at wf_z_undef,
        exact ⟨wf_z_undef.right, nd_y𝔹⟩ },
      { intros z z_in_y𝕆,
        by_cases z = y,
        { cases wf,
          simp only [not_or_distrib, mem_union, ndunion_eq_union, to_finset_val,
            nodup_erase_dup, mem_erase_dup, finset.mem_mk] at wf_z_undef,
          rw h at z_in_y𝕆,
          exact absurd z_in_y𝕆 wf_z_undef.left },
        { rw function.update_noteq,
          { exact y𝕆_𝕆 z z_in_y𝕆 },
          { assumption } } },
      { simp only [mem_cons],
        intros z h',
        cases h',
        { rw h', rw function.update_same },
        { by_cases eq : y = z,
          { rw eq, rw function.update_same },
          rw function.update_noteq,
          { exact y𝔹_𝔹 z h' },
          symmetry,
          assumption } },
      { cases wf,
        apply wf_FV_sandwich _ _ wf_F_wf,
        { let := FV_sub_wf_context wf_F_wf,
          rw finset.subset_iff at ⊢ this,
          simp only [mem_union, ndunion_eq_union, to_finset_val, nodup_erase_dup, finset.mem_union, finset.union_insert,
            finset.mem_insert, mem_erase_dup, to_finset_cons, finset.mem_mk, mem_to_finset] at ⊢ this,
          assumption },
        { rw finset.subset_iff,
          simp only [mem_erase_dup,mem_union, nodup_erase_dup, imp_self, to_finset_val, mem_to_finset, to_finset_cons,
            finset.mem_union, finset.union_insert, finset.mem_insert, finset.mem_mk, ndunion_eq_union, forall_true_iff] } },
      { simp only [FV, FV_expr, finset.insert_empty_eq_singleton, finset.mem_union, finset.mem_singleton, finset.mem_erase] at y𝕆_sub_FV,
        intros z z_in_y𝕆,
        have h', from y𝕆_sub_FV z_in_y𝕆,
        cases h',
        { rw h' at z_in_y𝕆,
          rw y𝕆_𝕆 x z_in_y𝕆 at h,
          contradiction },
        { exact h'.right } }
    },
    case rc_correctness.expr.const_app_full : c' ys {
      unfold C,
      apply C_app_rc_insertion_correctness ih nd_y𝕆 nd_y𝔹 y𝕆_𝕆 y𝔹_𝔹 wf y𝕆_sub_FV,
      simp only [list.map_map],
      have : ∀ y ∈ ys, ((λ (yτ : var × lin_type), yτ.fst ∶ yτ.snd) ∘ (λ (y : var), (y, β c' y))) y = (λ (y : var), y ∶ β c' y) y,
      { intros y' y'_in_ys,
        refl },
      rw list.map_congr this,
      exact linear.const_app_full β ys c'
    },
    case rc_correctness.expr.const_app_part : c' ys {
      unfold C,
      have : ∀ y ∈ ys, (y, β c' y) = (y, 𝕆),
      { cases wf,
        intros y' y'_in_ys,
        have not_𝔹, from wf_no_𝔹_var y',
        rw not_𝔹_iff_𝕆 at not_𝔹,
        rw not_𝔹 },
      rw list.map_congr this,
      apply C_app_rc_insertion_correctness ih nd_y𝕆 nd_y𝔹 y𝕆_𝕆 y𝔹_𝔹 wf y𝕆_sub_FV,
      rw list.map_map,
      have : ∀ y ∈ ys, ((λ (yτ : var × lin_type), yτ.fst ∶ yτ.snd) ∘ (λ (y : var), (y, 𝕆))) y = (λ (y : var), y ∶ 𝕆) y,
      { intros y' y'_in_ys,
        refl },
      rw list.map_congr this,
      exact linear.const_app_part β ys c'
    },
    case rc_correctness.expr.var_app : x z {
      unfold C,
      apply C_app_rc_insertion_correctness ih nd_y𝕆 nd_y𝔹 y𝕆_𝕆 y𝔹_𝔹 wf y𝕆_sub_FV,
      simp only [list.map],
      exact linear.var_app β x z
    },
    case rc_correctness.expr.ctor : i ys {
      unfold C,
      apply C_app_rc_insertion_correctness ih nd_y𝕆 nd_y𝔹 y𝕆_𝕆 y𝔹_𝔹 wf y𝕆_sub_FV,
      rw list.map_map,
      have : ∀ y ∈ ys, ((λ (yτ : var × lin_type), yτ.fst ∶ yτ.snd) ∘ (λ (y : var), (y, 𝕆))) y = (λ (y : var), y ∶ 𝕆) y,
      { intros y' y'_in_ys,
        refl },
      rw list.map_congr this,
      exact linear.ctor_app β ys i
    }
  },
  case «case» : x Fs ih {
    unfold C,
    have FV_sub_y𝕆_y𝔹 : (FV (case x of Fs)).val ⊆ y𝕆 + y𝔹,
    { let := FV_sub_wf_context wf,
      rw finset.subset_def at this,
      rw subset_iff at ⊢ this,
      simp only [mem_union, to_finset_val, mem_add, mem_erase_dup, finset.union_val] at ⊢ this,
      assumption },
    cases wf,
    simp only [mem_union, ndunion_eq_union, to_finset_val, nodup_erase_dup, mem_erase_dup, finset.mem_mk] at wf_x_def,
    cases wf_x_def,
    apply linear.case_𝕆,
    { simpa },
    swap,
    apply linear.case_𝔹,
    { simpa },
    all_goals {
      intros F' h,
      rw list.map_wf_eq_map at h,
      rw list.mem_map at h,
      rcases h with ⟨F, ⟨F_in_Fs, F'_def⟩⟩,
      rw ←F'_def,
      apply inductive_dec,
      any_goals { assumption },
      { rw subset_iff,
        rw finset.sort_eq,
        intros y y_in_y𝕆,
        exact y𝕆_sub_FV y_in_y𝕆 },
      { simp only [finset.sort_eq],
        assumption },
      { exact finset.sort_nodup var_le (FV (case x of Fs)) },
      apply ih,
      any_goals { assumption },
      { apply nodup_filter,
        assumption },
      { simp only [and_imp, mem_filter, finset.mem_sort],
        intros y y_in_y𝕆 h,
        exact y𝕆_𝕆 y y_in_y𝕆 },
      { have wf, from wf_Fs_wf F F_in_Fs,
        apply wf_FV_sandwich _ _ wf,
        { rw finset.subset_iff,
          rw subset_iff at FV_sub_y𝕆_y𝔹,
          simp only [FV, list.map_wf_eq_map, mem_ndinsert, mem_add, finset.insert_val] at FV_sub_y𝕆_y𝔹,
          simp [FV, list.map_wf_eq_map, not_or_distrib],
          intros y y_in_FV,
          replace FV_sub_y𝕆_y𝔹 := @FV_sub_y𝕆_y𝔹 y,
          rw ←finset.mem_def at FV_sub_y𝕆_y𝔹,
          simp only [exists_prop, list.mem_map, finset.mem_join] at FV_sub_y𝕆_y𝔹,
          rw FV_C_eq_FV,
          have : ∃ (S : finset var), (∃ (a : fn_body), a ∈ Fs ∧ FV a = S) ∧ y ∈ S,
          { use FV F, apply and.intro _ y_in_FV, use F, exact ⟨F_in_Fs, rfl⟩ },
          have : y ∈ y𝕆 ∨ y ∈ y𝔹, from FV_sub_y𝕆_y𝔹 (or.inr this),
          cases this,
          { exact or.inr ⟨this_1, y_in_FV⟩ },
          { exact or.inl this_1 } },
        { rw finset.subset_iff,
          simp only [mem_union, ndunion_eq_union, mem_filter, to_finset_val,
            nodup_erase_dup, finset.mem_union, mem_erase_dup, finset.mem_mk, mem_to_finset],
          intros y h,
          cases h,
          { exact or.inl (h.left) },
          { exact or.inr h } } },
      { simp only [and_imp, mem_filter, FV_C_eq_FV, imp_self, forall_true_iff] }
    }
  },
  case «inc» : x F ih {
    cases wf
  },
  case «dec» : x F ih {
    cases wf
  }
end

theorem rc_insertion_correctness (β : const → var → lin_type) (δ : program) (wf : β ⊢ δ) : β ⊩ C_prog β δ :=
begin
  cases wf,
  split,
  intro c,
  replace wf_const_wf := wf_const_wf c,
  cases wf_const_wf,
  rename wf_const_wf_F_wf wf,
  split,
  simp only [C_prog],
  let ys := (δ c).ys,
  let Γ := (↑(list.map (λ (y : var), y ∶ β c y) ys) : multiset typed_var),
  let y𝕆 := filter (λ y, β c y = 𝕆) ys,
  let y𝔹 := filter (λ y, β c y = 𝔹) ys,
  obtain ⟨y𝕆_𝕆, y𝔹_𝔹⟩
    : (∀ y ∈ y𝕆, β c y = 𝕆) ∧ (∀ y ∈ y𝔹, β c y = 𝔹),
  { repeat { split }; { intros y h, rw (mem_filter.mp h).right } },
  obtain ⟨y𝕆_sub_ys, y𝔹_sub_ys⟩ : (y𝕆 ⊆ ys ∧ y𝔹 ⊆ ys),
  { repeat { split }; simp only [filter_subset] },
  obtain ⟨ys_𝕆_sub_y𝕆, ys_𝔹_sub_y𝔹⟩
    : (∀ y ∈ ys, β c y = 𝕆 → y ∈ y𝕆) ∧ (∀ y ∈ ys, β c y = 𝔹 → y ∈ y𝔹),
  { repeat { split };
    { intros y y_in_ys y_ty,
      simp only [mem_filter, mem_coe], try { rw ←coe_eq_coe }, exact ⟨y_in_ys, y_ty⟩ } },
  obtain ⟨nd_y𝕆, nd_y𝔹⟩ : multiset.nodup y𝕆 ∧ multiset.nodup y𝔹,
  { split; exact nodup_filter _ (coe_nodup.mpr wf_const_wf_nd_ys) },
  have ys_subdiv : ↑ys = y𝕆 + y𝔹,
  { have : ∀ y ∈ (↑ys : multiset var), β c y = 𝔹 ↔ β c y ≠ 𝕆,
    { intros y y_in_ys,
      split; intro h; cases β c y; simp at h ⊢; assumption },
    simp only [y𝕆, y𝔹],
    rw filter_congr this,
    exact (filter_add_not ↑ys).symm },
  have Γ_subdiv : ↑(list.map (λ (y : var), y ∶ β c y) ys) = (y𝕆 {∶} 𝕆) + (y𝔹 {∶} 𝔹),
  { have : ↑(list.map (λ (y : var), y ∶ β c y) ys) = map (λ (y : var), y ∶ β c y) ↑ys,
      from rfl,
    rw this,
    rw ys_subdiv,
    simp only [map_add],
    have : ∀ (τ : lin_type) (yτ : multiset var), (∀ y ∈ yτ, β c y = τ) →
      ∀ y ∈ yτ, (y ∶ β c y) = (y ∶ τ),
    { intros τ yτ h y y_in_yτ,
      rw h y y_in_yτ },
    simp only [map_congr (this 𝕆 y𝕆 y𝕆_𝕆), map_congr (this 𝔹 y𝔹 y𝔹_𝔹)] },
  have y𝕆_sub_FV : y𝕆.to_finset ⊆ FV (dec_𝕆 ((δ c).ys) (C β ((δ c).F) (β c)) (β c)),
  { rw finset.subset_iff,
    intros y y_in_y𝕆,
    simp only [mem_filter, mem_coe, mem_to_finset] at y_in_y𝕆,
    exact vars_sub_FV_dec_𝕆 ys (C β ((δ c).F) (β c)) (β c) y y_in_y𝕆.left y_in_y𝕆.right },
  rw Γ_subdiv,
  unfold list.to_finset at wf,
  rw ys_subdiv at wf,
  have : ↑ys ⊆ y𝕆 + y𝔹, { rw ys_subdiv, exact subset.refl _ },
  apply inductive_dec y𝕆_sub_ys this wf_const_wf_nd_ys y𝕆_𝕆 y𝔹_𝔹 nd_y𝕆 nd_y𝔹,
  let y𝕆' := filter (λ (y : var), y ∈ FV (C β ((δ c).F) (β c))) y𝕆,
  have y𝕆'_𝕆 : ∀ y ∈ y𝕆', β c y = 𝕆,
  { simp only [and_imp, mem_filter, mem_coe],
    intros y y_in_ys y_𝕆 y_in_FV,
    assumption },
  have nd_y𝕆' : nodup y𝕆', from nodup_filter _ nd_y𝕆,
  have y𝕆'_sub_y𝕆 : y𝕆' ⊆ y𝕆, from filter_subset y𝕆,
  have y𝕆'_sub_FV : y𝕆'.to_finset ⊆ FV (δ c).F,
  { rw finset.subset_iff, rw finset.subset_iff at y𝕆_sub_FV, rw subset_iff at y𝕆'_sub_y𝕆,
    simp only [mem_to_finset], simp only [mem_to_finset] at y𝕆_sub_FV,
    rw FV_dec_𝕆_filter at y𝕆_sub_FV,
    intros x x_in_y𝕆',
    have h, from y𝕆_sub_FV (y𝕆'_sub_y𝕆 x_in_y𝕆'),
    simp only [mem_filter, mem_coe] at x_in_y𝕆',
    simp only [list.mem_to_finset, finset.mem_union, finset.mem_filter] at h,
    cases h,
    { exact absurd x_in_y𝕆'.right h.right.right },
    rwa FV_C_eq_FV at h },
  have wf' : (β; δ; to_finset y𝕆' ∪ to_finset y𝔹 ⊢ (δ c).F),
  { rw to_finset_add at wf,
    have h1 : FV (δ c).F ⊆ to_finset y𝕆' ∪ to_finset y𝔹,
    { have : FV (δ c).F ⊆ to_finset y𝕆 ∪ to_finset y𝔹, from FV_sub_wf_context wf,
      rw finset.subset_iff at this,
      rw finset.subset_iff,
      intros x x_in_FV,
      let := this x_in_FV,
      simp only [mem_filter, mem_coe, finset.mem_union, mem_to_finset] at this ⊢,
      cases this,
      { rw FV_C_eq_FV,
        exact or.inl ⟨this_1, x_in_FV ⟩ },
      { exact or.inr this_1 } },
    have h2 : to_finset y𝕆' ∪ to_finset y𝔹 ⊆ to_finset y𝕆 ∪ to_finset y𝔹,
    { rw subset_iff at y𝕆'_sub_y𝕆,
      simp only [finset.subset_iff, finset.mem_union, mem_to_finset],
      intros x h,
      cases h,
      { exact or.inl (y𝕆'_sub_y𝕆 h) },
      { exact or.inr h } },
    exact wf_FV_sandwich h1 h2 wf },
  exact rc_insertion_correctness' nd_y𝕆' nd_y𝔹 y𝕆'_𝕆 y𝔹_𝔹 y𝕆'_sub_FV wf'
end

end rc_correctness


import to_mathlib
import data.fin.basic
import Rings.ToMathlib.fin

namespace dvector

variables {α : Type*} {n : ℕ}

lemma nil_append (as : dvector α n) :
  dvector.append dvector.nil as = as :=
by simp

/-- Converts a dvector into an n-ary tuple -/
@[simp] def fin_val (as : dvector α n) : fin n → α :=
λ k, dvector.nth' as k
 @[simp] lemma cons_nth'_succ_eq_nth' {n} {x : α} {as : dvector α n} {k : fin n} :
(dvector.cons x as).nth' (k.succ) = as.nth' k :=
begin
  unfold dvector.nth',
  simp,
end

/-- x_val is the same data as concatenation of dvectors -/
lemma fin_val_eq_x_val {x : α} {as : dvector α n} :
  fin_val (dvector.cons x as) = fin.x_val x (fin_val as) :=
funext (
  @fin.cases n
  (λ k, fin_val (dvector.cons x as) k = fin.x_val x (fin_val as) k)
  rfl
  (λ k, begin unfold fin_val, simp, end)
  )

lemma nth_eq_succ_nth : Π {k n : ℕ} {as : dvector α (n + 1)} {h : k < n},
as.nth k (lt_trans h (by simp)) = (dvector.remove_mth (n + 2) as).nth k h
| k nat.zero (dvector.cons a _) h := by {exfalso, simpa using h}
| nat.zero (nat.succ n) (dvector.cons a as) h := by simp
| (nat.succ k) (nat.succ n) (dvector.cons a as) h :=
  by {simpa using nth_eq_succ_nth}

def of_list : Π (as : list α), dvector α (list.length as)
| list.nil := dvector.nil
| (list.cons a as) := dvector.cons a (of_list as)

def reverse : Π {n : ℕ} (v : dvector α n),
  dvector α n
| nat.zero _ := dvector.nil
| (nat.succ n) (dvector.cons a v) := dvector.concat (reverse v) a

/-- if you append and take nth its the same as just taking nth for small n-/
lemma nth_append_small : Π {xl yl : ℕ}
  {xs : dvector α xl} {ys : dvector α yl} {n : ℕ} (h : n < xl),
  (dvector.append xs ys).nth n (nat.lt_of_lt_of_le h (nat.le_add_left _ _))
  = xs.nth n h
| 0             yl xs                  ys n h := by simpa using h
| (nat.succ xl) yl (dvector.cons x xs) ys 0 h := by simp
| (nat.succ xl) yl (dvector.cons x xs) ys (nat.succ n) h :=
begin
  simp only [dvector.nth, dvector.append],
  rw ← (@nth_append_small xl yl xs ys n (nat.succ_lt_succ_iff.1 h)),
  refl,
end

/-- if you append and take nth its the same as just taking n - kth for big n-/
lemma nth_append_big : Π {xl yl : ℕ}
  {xs : dvector α xl} {ys : dvector α yl} {n : ℕ}
  (hbig : xl ≤ n) (h : n < yl + xl),
  (dvector.append xs ys).nth n h
  = ys.nth (n - xl) ((tsub_lt_iff_right hbig).2 h)
| 0             yl nil                 ys n hbig h := by simpa
| (nat.succ xl) yl (dvector.cons x xs) ys 0 hbig h :=
begin
  exfalso,
  exact nat.not_succ_le_zero _ hbig,
end
| (nat.succ xl) yl (dvector.cons x xs) ys (nat.succ n) hbig h :=
begin
  simp only [nat.succ_sub_succ_eq_sub, dvector.append, dvector.nth],
  apply nth_append_big (nat.le_of_succ_le_succ hbig),
end

lemma nth_cast : Π {xl yl k : ℕ}
  {xs : dvector α xl}
  (heq : xl = yl) (hk : k < yl),
  (dvector.cast heq xs).nth k hk = xs.nth k (by simp [heq, hk])
| 0             yl            k nil          heq hk :=
  (k.not_lt_zero (by simp [heq, hk])).elim
| (nat.succ xl) 0             k (cons x xs) heq hk :=
  (nat.succ_ne_zero _ heq).elim
| (nat.succ xl) (nat.succ yl) k (cons x xs) heq hk :=
begin
  rw dvector.cast_cons heq x xs,
  induction k with k hk,
  {simp},
  rw dvector.nth_cons _ _ _ (nat.lt_of_succ_lt_succ hk),
  exact nth_cast (nat.succ_injective heq) (nat.lt_of_succ_lt_succ hk),
end

lemma nth_of_list : Π (l : list α) (k : ℕ) (h : k < l.length),
  (dvector.of_list l).nth k h = list.nth_le l k h
| list.nil k h :=
begin
  exfalso,
  rw list.length at h,
  exact nat.not_lt_zero _ h,
end
| (a :: l) k h :=
begin
  rw of_list,
  induction k with k hk,
  {rw [dvector.nth, list.nth_le]},
  {simpa [dvector.nth, list.nth_le, nth_of_list l]},
end

def of_fn : (fin n → α) → dvector α n :=
λ f, dvector.cast (list.length_of_fn _) (dvector.of_list (list.of_fn f))

lemma nth_of_fn (as : fin n → α) (k : ℕ) (hk : k < n) :
  (dvector.of_fn as).nth k hk = as ⟨ k , hk ⟩ :=
by rw [of_fn, nth_cast, nth_of_list, list.nth_le_of_fn']

lemma nth'_of_fn (as : fin n → α) (k : fin n) :
  (dvector.of_fn as).nth' k = as k :=
by simp only [dvector.nth', nth_of_fn, fin.val_eq_coe, fin.eta]

lemma nth'_of_fn1 (as : fin n → α) :
  (dvector.of_fn as).nth' = as :=
funext $ nth'_of_fn as
--by rw [of_fn, nth_cast, nth_of_list, list.nth_le_of_fn']

def to_list : Π {n : ℕ},
  dvector α n → list α
| 0            as := []
| (nat.succ n) (dvector.cons a as) := list.cons a (to_list as)

lemma to_list_length : Π {n : ℕ} {as : dvector α n},
  list.length (to_list as) = n
| 0            as := rfl
| (nat.succ n) (dvector.cons a as) :=
by simp only [to_list, list.length_cons, @to_list_length n as]

lemma ith_chunk_aux {n m : ℕ} (i : fin n) (k : fin m) :
  i.val * m + ↑k < n * m :=
begin
  induction n with n hn,
  { apply fin_zero_elim i },
  {
    rw nat.succ_mul,
    cases fin.lt_or_eq_nat i with hi hi,
    {
      apply add_lt_add _ k.2,
      apply lt_of_le_of_lt _ (hn ⟨ i.1 , hi ⟩),
      apply le_add_right,
      apply le_of_eq,
      refl,
    },
    { rw [fin.val_eq_coe, hi, add_lt_add_iff_left],
      exact k.2, }
  }
end

def ith_chunk {n m : ℕ} (i : fin n) (xs : dvector α (n * m)) :
  dvector α m :=
  of_fn (λ k, dvector.nth xs (i.1 * m + k) (dvector.ith_chunk_aux i k))

lemma nth'_eq {α} {n} (ys : dvector α n) :
  (λ (i : fin n), ys.nth i i.2) = ys.nth' :=
begin
  funext, rw dvector.nth', refl,
end

lemma ith_chunk_nth {n m : ℕ} (i : fin n) (xs : dvector α (n * m))
  (l : ℕ) (hl : l < m) :
  dvector.nth (dvector.ith_chunk i xs) l hl =
  xs.nth (i.1 * m + l) (dvector.ith_chunk_aux i ⟨ l , hl ⟩) :=
by simpa only [dvector.ith_chunk, dvector.nth_of_fn]

lemma nth_remove_mth_big_m : Π {n m} (xs : dvector α (n+1)) {k : ℕ}
  (hk : k < n) (hm : k < m),
  (dvector.remove_mth m xs).nth k hk
  =
  xs.nth k (lt_trans hk (nat.lt_succ_self _))
| 0 _ _ k hk hm := false.elim (nat.not_lt_zero _ hk)
| n 0 (dvector.cons y ys) k hk hm := false.elim (nat.not_lt_zero _ hm)
| (n+1) (m+1) (dvector.cons y ys) 0 hk hm :=
begin
  simp only [dvector.remove_mth, dvector.nth],
end
| (n+1) (m+1) (dvector.cons y ys) (k+1) hk hm :=
begin
  rw [dvector.remove_mth,
    dvector.nth_cons y (dvector.remove_mth m ys) _ (nat.succ_lt_succ_iff.mp hk),
    dvector.nth_cons y ys _ (lt_trans (nat.lt_succ_self _) hk)],
  apply nth_remove_mth_big_m,
  rw ← nat.succ_lt_succ_iff,
  exact hm,
end

lemma ext : Π {as bs : dvector α n},
  as = bs ↔ ∀ (i : fin n), as.nth' i = bs.nth' i :=
begin
  intros as bs,
  induction as with n a as hind, cases bs,
  { simp only [implies_true_iff, eq_self_iff_true] },
  {
    cases bs with _ b bs,
    split,
    {
      intros heq i, rw heq,
    },
    {
      intros heq,
      simp only,
      split,
      {
        specialize heq 0,
        simp [dvector.nth', fin.val_zero', dvector.nth] at heq,
        exact heq,
      },
      {
        rw hind,
        intro i,
        specialize heq ⟨ i + 1 , nat.succ_lt_succ i.2 ⟩,
        simp [dvector.nth', dvector.nth] at heq,
        simp only [dvector.nth'],
        convert heq,
      },
    },
  },
end

lemma of_fn_eq_cons_of_fn_succ {f : ℕ → α} :
  of_fn (λ i : fin (n+1), f i) =
  cons (f 0) (of_fn (λ (i : fin n), f (i + 1))) :=
begin
  rw ext,
  intro i,
  cases i with i hi,
  cases i with i hind,
  { simp only [nth'_of_fn, fin.mk_zero, fin.coe_eq_cast_succ,
      fin.coe_succ_eq_succ],
    simpa only [dvector.nth', fin.val_zero', dvector.nth], },
  {
    simp only [nth'_of_fn, dvector.nth', dvector.nth, nth_of_fn],
    congr1,
  },
end

lemma remove_mth_of_fn_last_aux (i : fin n) :
  ((i : fin n.succ) : fin n.succ.succ) = (i : fin n.succ.succ) :=
begin
  cases i with i hi,
  simp only [fin.coe_eq_cast_succ, fin.cast_succ_mk, fin.coe_mk, coe_coe],
  ext1,
  simp only [fin.coe_of_nat_eq_mod],
  rw nat.mod_eq_of_lt (lt_trans hi (nat.lt_succ_self _)),
end

lemma remove_mth_of_fn_last {n : ℕ} : Π {f : ℕ → α},
  dvector.remove_mth n (of_fn (λ (i : fin (n+1)), f i))
  =
  dvector.of_fn (λ i : fin n, f i) :=
begin
  induction n with n hn,
  {intro f, refl},
  {
    intro f,
    have hrw : (of_fn (λ (i : fin (n+2)), f i))
      = cons (f 0) (of_fn (λ i : fin n.succ, f (i + 1))) :=
    of_fn_eq_cons_of_fn_succ,
    have hrw1 : of_fn (λ (i : fin n.succ), f i)
      = cons (f 0) (of_fn (λ i : fin n, f (i + 1))) :=
    of_fn_eq_cons_of_fn_succ,
    rw hrw,
    rw [dvector.remove_mth],
    rw hrw1,
    congr1,
    rw @hn (λ n, f (n + 1)),
  },
end

section ulift

def ulift_up {α} {n} : dvector α n → dvector (ulift α) n :=
  dvector.map ulift.up

def ulift_down {α} {n} : dvector (ulift α) n → dvector α n :=
  dvector.map ulift.down

end ulift

@[simp] protected lemma map_id' : ∀{n : ℕ} (xs : dvector α n), xs.map id = xs
| _ dvector.nil      := rfl
| _ (dvector.cons x xs) := by { dsimp, simp* }

@[simp] protected lemma map_comp {β γ : Type*} :
∀{n : ℕ} (xs : dvector α n) (g : α → β) (f : β → γ),
  xs.map (f ∘ g) = (xs.map g).map f
| _ dvector.nil  g f    := rfl
| _ (dvector.cons x xs) g f := by simp

lemma pmem_nth {xs : dvector α n} {k : ℕ} (hk : k < n) :
  dvector.pmem (xs.nth k hk) xs :=
begin
  induction xs with m a xs hind generalizing k,
  { exfalso, apply nat.not_lt_zero _ hk, },
  { cases k with k,
    { exact psum.inl rfl },
    { dsimp only [dvector.nth, dvector.pmem],
      apply psum.inr,
      apply hind }},
end

lemma pmem_nth' {xs : dvector α n} {k : fin n} :
  dvector.pmem (xs.nth' k) xs := pmem_nth _

lemma cast_nil {α} (h : 0 = 0) : (dvector.cast h dvector.nil : dvector α 0) = dvector.nil :=
by refl

lemma of_fn_zero {α : Type*} (f : fin 0 → α) : dvector.of_fn f = dvector.nil := rfl

lemma of_fn_eq_cons_of_fn_succ' {α : Type*} {n : ℕ} {f : fin n.succ → α} :
  dvector.of_fn f = dvector.cons (f 0) (dvector.of_fn (λ (i : fin n), f (i + 1))) :=
begin
  set g : ℕ → α := λ k, ite (k < n.succ) (f k) (f 0) with hg,
  have hrw1 : dvector.of_fn f = dvector.of_fn (λ k, g k),
  { congr, ext x, rw hg, simp only [fin.coe_coe_eq_self],
    by_cases hx : (x : ℕ) < n.succ,
    { simp [if_pos hx] },
    { exfalso, apply hx x.2 }},
  rw hrw1,
  rw dvector.of_fn_eq_cons_of_fn_succ,
  congr,
  ext,
  rw hg,
  simp only [fin.coe_coe_eq_self],
  by_cases hx : (x : ℕ) + 1 < n.succ,
  { simp only [if_pos hx], congr },
  { exfalso, apply hx, apply nat.succ_lt_succ x.2 }
end

end dvector


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

import field_theory.intermediate_field
import field_theory.minpoly
import field_theory.splitting_field
import field_theory.minpoly
import field_theory.separable
import ring_theory.adjoin_root
import ring_theory.power_basis

/-!
# 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 _, adjoin F S,
  gc := intermediate_field.gc,
  le_l_u := λ S, (intermediate_field.gc (S : set E) (adjoin F S)).1 $ le_refl _,
  choice_eq := λ _ _, rfl }

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

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

lemma mem_bot {x : E} : x ∈ (⊥ : intermediate_field F E) ↔ x ∈ set.range (algebra_map F E) :=
begin
  suffices : set.range (algebra_map F E) = (⊥ : intermediate_field F E),
  { rw this, refl },
  { change set.range (algebra_map F E) = subfield.closure (set.range (algebra_map F E) ∪ ∅),
    simp [←set.image_univ, ←ring_hom.map_field_closure] }
end

lemma mem_top {x : E} : x ∈ (⊤ : intermediate_field F E) :=
subfield.subset_closure $ or.inr trivial

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

@[simp] lemma top_to_subalgebra : (⊤ : intermediate_field F E).to_subalgebra = ⊤ :=
by { ext, rw [mem_to_subalgebra, iff_true_right algebra.mem_top], exact mem_top }

/--  Construct an algebra isomorphism from an equality of subalgebras -/
def subalgebra.equiv_of_eq {X Y : subalgebra F E} (h : X = Y) : X ≃ₐ[F] Y :=
by refine { to_fun := λ x, ⟨x, _⟩, inv_fun := λ x, ⟨x, _⟩, .. }; tidy

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

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

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

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. -/
noncomputable def top_equiv : (⊤ : intermediate_field F E) ≃ₐ[F] E :=
(subalgebra.equiv_of_eq top_to_subalgebra).trans algebra.top_equiv

@[simp] lemma top_equiv_def (x : (⊤ : intermediate_field F E)) : top_equiv x = ↑x :=
begin
  suffices : algebra.to_top (top_equiv x) = algebra.to_top (x : E),
  { rwa subtype.ext_iff at this },
  exact alg_equiv.apply_symm_apply (alg_equiv.of_bijective algebra.to_top
    ⟨λ _ _, subtype.mk.inj, λ x, ⟨x.val, by { ext, refl }⟩⟩ : E ≃ₐ[F] (⊤ : subalgebra F E))
    (subalgebra.equiv_of_eq top_to_subalgebra x),
end

@[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) :=
intermediate_field.ext'_iff.mpr (set.ext_iff.mpr (λ _, 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 _))

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

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, submodule.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 vector_space

variables {K L : intermediate_field F E}

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

@[simp] lemma findim_eq_one_iff : findim F K = 1 ↔ K = ⊥ :=
by rw [← to_subalgebra_eq_iff, ← findim_eq_findim_subalgebra,
  subalgebra.findim_eq_one_iff, bot_to_subalgebra]

lemma dim_adjoin_eq_one_iff : dim 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 : dim F F⟮α⟯ = 1 ↔ α ∈ (⊥ : intermediate_field F E) :=
by { rw dim_adjoin_eq_one_iff, exact set.singleton_subset_iff }

lemma findim_adjoin_eq_one_iff : findim F (adjoin F S) = 1 ↔ S ⊆ (⊥ : intermediate_field F E) :=
iff.trans findim_eq_one_iff adjoin_eq_bot_iff

lemma findim_adjoin_simple_eq_one_iff : findim F F⟮α⟯ = 1 ↔ α ∈ (⊥ : intermediate_field F E) :=
by { rw [findim_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, dim 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_findim_adjoin_eq_one (h : ∀ x : E, findim F F⟮x⟯ = 1) :
  (⊥ : intermediate_field F E) = ⊤ :=
begin
  ext,
  rw iff_true_right intermediate_field.mem_top,
  exact findim_adjoin_simple_eq_one_iff.mp (h x),
end

lemma subsingleton_of_dim_adjoin_eq_one (h : ∀ x : E, dim 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_findim_adjoin_eq_one (h : ∀ x : E, findim F F⟮x⟯ = 1) :
  subsingleton (intermediate_field F E) :=
subsingleton_of_bot_eq_top (bot_eq_top_of_findim_adjoin_eq_one h)

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

lemma subsingleton_of_findim_adjoin_le_one [finite_dimensional F E]
  (h : ∀ x : E, findim F F⟮x⟯ ≤ 1) : subsingleton (intermediate_field F E) :=
subsingleton_of_bot_eq_top (bot_eq_top_of_findim_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 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 (alg_hom.mk (adjoin_root.lift (algebra_map F F⟮α⟯)
  (adjoin_simple.gen F α) (aeval_gen_minpoly F α)) (ring_hom.map_one _)
  (λ x y, ring_hom.map_mul _ x y) (ring_hom.map_zero _) (λ x y, ring_hom.map_add _ x y)
  (by { exact λ _, adjoin_root.lift_of })) (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.2⟩) },
      exact subfield.closure_le.mpr (set.union_subset (λ x hx, Exists.cases_on hx (λ y hy, ⟨y,
        ⟨subfield.mem_top y, by { rw [ring_hom.comp_apply, adjoin_root.lift_of], exact hy }⟩⟩))
        (set.singleton_subset_iff.mpr ⟨adjoin_root.root (minpoly F α),
        ⟨subfield.mem_top (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 α :=
begin
  refine adjoin_root.lift_root,
  { exact minpoly F α },
  { exact aeval_gen_minpoly F α }
end

/-- 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} :=
let ϕ := adjoin_root_equiv_adjoin F h,
  swap1 : (F⟮α⟯ →ₐ[F] K) ≃ (adjoin_root (minpoly F α) →ₐ[F] K) :=
  { to_fun := λ f, f.comp ϕ.to_alg_hom,
    inv_fun := λ f, f.comp ϕ.symm.to_alg_hom,
    left_inv := λ _, by { ext, simp only [alg_equiv.coe_alg_hom,
      alg_equiv.to_alg_hom_eq_coe, alg_hom.comp_apply, alg_equiv.apply_symm_apply]},
    right_inv := λ _, by { ext, simp only [alg_equiv.symm_apply_apply,
      alg_equiv.coe_alg_hom, alg_equiv.to_alg_hom_eq_coe, alg_hom.comp_apply] } },
  swap2 := adjoin_root.equiv F K (minpoly F α) (minpoly.ne_zero h) in
swap1.trans swap2

/-- Fintype of algebra homomorphism `F⟮α⟯ →ₐ[F] K` -/
noncomputable def fintype_of_alg_hom_adjoin_integral (h : is_integral F α) :
  fintype (F⟮α⟯ →ₐ[F] K) :=
fintype.of_equiv _ (alg_hom_adjoin_integral_equiv F h).symm

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
  let s := ((minpoly F α).map (algebra_map F K)).roots.to_finset,
  have H := λ x, multiset.mem_to_finset,
  rw [fintype.card_congr (alg_hom_adjoin_integral_equiv F h), fintype.card_of_subtype s H,
      nat_degree_eq_card_roots h_splits, multiset.to_finset_card_of_nodup],
  exact nodup_roots ((separable_map (algebra_map F K)).mpr h_sep),
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 :=
induction_on_adjoin_fg P base ih K K.fg_of_noetherian

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}

noncomputable instance : order_bot (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,
  bot := ⟨⊥, (algebra.of_id F K).comp bot_equiv.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

end intermediate_field

section power_basis

namespace intermediate_field

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

lemma power_basis_is_basis {x : L} (hx : is_integral K x) :
  is_basis K (λ (i : fin (minpoly K x).nat_degree), (adjoin_simple.gen K x ^ (i : ℕ))) :=
begin
  let ϕ := (adjoin_root_equiv_adjoin K hx).to_linear_equiv,
  have key : ϕ (adjoin_root.root (minpoly K x)) = adjoin_simple.gen K x,
  { exact intermediate_field.adjoin_root_equiv_adjoin_apply_root K hx },
  suffices : ϕ ∘ (λ (i : fin (minpoly K x).nat_degree),
    adjoin_root.root (minpoly K x) ^ (i.val)) =
      (λ (i : fin (minpoly K x).nat_degree),
        (adjoin_simple.gen K x) ^ ↑i),
  { rw ← this, exact linear_equiv.is_basis
    (adjoin_root.power_basis_is_basis (minpoly.ne_zero hx)) ϕ },
  ext y,
  rw [function.comp_app, fin.val_eq_coe, alg_equiv.to_linear_equiv_apply, alg_equiv.map_pow],
  rw intermediate_field.adjoin_root_equiv_adjoin_apply_root K hx,
end

/-- The power basis `1, x, ..., x ^ (d - 1)` for `K⟮x⟯`,
where `d` is the degree of the minimal polynomial of `x`. -/
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,
  is_basis := power_basis_is_basis hx }

@[simp] lemma adjoin.power_basis.gen_eq {x : L} (hx : is_integral K x) :
  (adjoin.power_basis hx).gen = adjoin_simple.gen K x := rfl

@[simp] lemma adjoin.power_basis.minpoly_gen_eq {x : L} (hx : is_integral K x) :
  (adjoin.power_basis hx).minpoly_gen = minpoly K x :=
by rw [(adjoin.power_basis hx).minpoly_gen_eq,
       ← minpoly.eq_of_algebra_map_eq (algebra_map K⟮x⟯ L).injective
         (adjoin.power_basis hx).is_integral_gen
         (adjoin_simple.algebra_map_gen K x).symm]

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.findim {x : L} (hx : is_integral K x) :
  finite_dimensional.findim K K⟮x⟯ = (minpoly K x).nat_degree :=
begin
  rw power_basis.findim (adjoin.power_basis hx),
  refl,
end

end intermediate_field

namespace power_basis

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

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 pb
  (by rw [adjoin.power_basis.minpoly_gen_eq, pb.minpoly_gen_eq])

@[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_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_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_symm, equiv_aeval, adjoin.power_basis.gen_eq]

@[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_symm, equiv_gen, adjoin.power_basis.gen_eq]

end power_basis

end power_basis