/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Robert Y. Lewis
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.ring_theory.witt_vector.init_tail
import Mathlib.tactic.equiv_rw
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!

# Truncated Witt vectors

The ring of truncated Witt vectors (of length `n`) is a quotient of the ring of Witt vectors.
It retains the first `n` coefficients of each Witt vector.
In this file, we set up the basic quotient API for this ring.

The ring of Witt vectors is the projective limit of all the rings of truncated Witt vectors.

## Main declarations

- `truncated_witt_vector`: the underlying type of the ring of truncated Witt vectors
- `truncated_witt_vector.comm_ring`: the ring structure on truncated Witt vectors
- `witt_vector.truncate`: the quotient homomorphism that truncates a Witt vector,
  to obtain a truncated Witt vector
- `truncated_witt_vector.truncate`: the homomorphism that truncates
  a truncated Witt vector of length `n` to one of length `m` (for some `m ≤ n`)
- `witt_vector.lift`: the unique ring homomorphism into the ring of Witt vectors
  that is compatible with a family of ring homomorphisms to the truncated Witt vectors:
  this realizes the ring of Witt vectors as projective limit of the rings of truncated Witt vectors

-/

/--
A truncated Witt vector over `R` is a vector of elements of `R`,
i.e., the first `n` coefficients of a Witt vector.
We will define operations on this type that are compatible with the (untruncated) Witt
vector operations.

`truncated_witt_vector p n R` takes a parameter `p : ℕ` that is not used in the definition.
In practice, this number `p` is assumed to be a prime number,
and under this assumption we construct a ring structure on `truncated_witt_vector p n R`.
(`truncated_witt_vector p₁ n R` and `truncated_witt_vector p₂ n R` are definitionally
equal as types but will have different ring operations.)
-/
def truncated_witt_vector (p : ℕ) (n : ℕ) (R : Type u_1) := fin n → R

protected instance truncated_witt_vector.inhabited (p : ℕ) (n : ℕ) (R : Type u_1) [Inhabited R] :
    Inhabited (truncated_witt_vector p n R) :=
  { default := fun (_x : fin n) => Inhabited.default }

namespace truncated_witt_vector

/-- Create a `truncated_witt_vector` from a vector `x`. -/
def mk (p : ℕ) {n : ℕ} {R : Type u_1} (x : fin n → R) : truncated_witt_vector p n R := x

/-- `x.coeff i` is the `i`th entry of `x`. -/
def coeff {p : ℕ} {n : ℕ} {R : Type u_1} (i : fin n) (x : truncated_witt_vector p n R) : R := x i

theorem ext {p : ℕ} {n : ℕ} {R : Type u_1} {x : truncated_witt_vector p n R}
    {y : truncated_witt_vector p n R} (h : ∀ (i : fin n), coeff i x = coeff i y) : x = y :=
  funext h

theorem ext_iff {p : ℕ} {n : ℕ} {R : Type u_1} {x : truncated_witt_vector p n R}
    {y : truncated_witt_vector p n R} : x = y ↔ ∀ (i : fin n), coeff i x = coeff i y :=
  { mp :=
      fun (h : x = y) (i : fin n) =>
        eq.mpr (id (Eq._oldrec (Eq.refl (coeff i x = coeff i y)) h)) (Eq.refl (coeff i y)),
    mpr := ext }

@[simp] theorem coeff_mk {p : ℕ} {n : ℕ} {R : Type u_1} (x : fin n → R) (i : fin n) :
    coeff i (mk p x) = x i :=
  rfl

@[simp] theorem mk_coeff {p : ℕ} {n : ℕ} {R : Type u_1} (x : truncated_witt_vector p n R) :
    (mk p fun (i : fin n) => coeff i x) = x :=
  sorry

/--
We can turn a truncated Witt vector `x` into a Witt vector
by setting all coefficients after `x` to be 0.
-/
def out {p : ℕ} {n : ℕ} {R : Type u_1} [comm_ring R] (x : truncated_witt_vector p n R) :
    witt_vector p R :=
  witt_vector.mk p
    fun (i : ℕ) =>
      dite (i < n) (fun (h : i < n) => coeff { val := i, property := h } x) fun (h : ¬i < n) => 0

@[simp] theorem coeff_out {p : ℕ} {n : ℕ} {R : Type u_1} [comm_ring R]
    (x : truncated_witt_vector p n R) (i : fin n) : witt_vector.coeff (out x) ↑i = coeff i x :=
  sorry

theorem out_injective {p : ℕ} {n : ℕ} {R : Type u_1} [comm_ring R] : function.injective out := sorry

end truncated_witt_vector

namespace witt_vector

/-- `truncate_fun n x` uses the first `n` entries of `x` to construct a `truncated_witt_vector`,
which has the same base `p` as `x`.
This function is bundled into a ring homomorphism in `witt_vector.truncate` -/
def truncate_fun {p : ℕ} (n : ℕ) {R : Type u_1} (x : witt_vector p R) :
    truncated_witt_vector p n R :=
  truncated_witt_vector.mk p fun (i : fin n) => coeff x ↑i

@[simp] theorem coeff_truncate_fun {p : ℕ} {n : ℕ} {R : Type u_1} (x : witt_vector p R)
    (i : fin n) : truncated_witt_vector.coeff i (truncate_fun n x) = coeff x ↑i :=
  sorry

@[simp] theorem out_truncate_fun {p : ℕ} {n : ℕ} {R : Type u_1} [comm_ring R]
    (x : witt_vector p R) : truncated_witt_vector.out (truncate_fun n x) = init n x :=
  sorry

end witt_vector

namespace truncated_witt_vector

@[simp] theorem truncate_fun_out {p : ℕ} {n : ℕ} {R : Type u_1} [comm_ring R]
    (x : truncated_witt_vector p n R) : witt_vector.truncate_fun n (out x) = x :=
  sorry

protected instance has_zero (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) (R : Type u_1) [comm_ring R] :
    HasZero (truncated_witt_vector p n R) :=
  { zero := witt_vector.truncate_fun n 0 }

protected instance has_one (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) (R : Type u_1) [comm_ring R] :
    HasOne (truncated_witt_vector p n R) :=
  { one := witt_vector.truncate_fun n 1 }

protected instance has_add (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) (R : Type u_1) [comm_ring R] :
    Add (truncated_witt_vector p n R) :=
  { add := fun (x y : truncated_witt_vector p n R) => witt_vector.truncate_fun n (out x + out y) }

protected instance has_mul (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) (R : Type u_1) [comm_ring R] :
    Mul (truncated_witt_vector p n R) :=
  { mul := fun (x y : truncated_witt_vector p n R) => witt_vector.truncate_fun n (out x * out y) }

protected instance has_neg (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) (R : Type u_1) [comm_ring R] :
    Neg (truncated_witt_vector p n R) :=
  { neg := fun (x : truncated_witt_vector p n R) => witt_vector.truncate_fun n (-out x) }

@[simp] theorem coeff_zero (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) (R : Type u_1) [comm_ring R]
    (i : fin n) : coeff i 0 = 0 :=
  id
    (eq.mpr
      (id
        (Eq._oldrec (Eq.refl (coeff i (witt_vector.truncate_fun n 0) = 0))
          (witt_vector.coeff_truncate_fun 0 i)))
      (eq.mpr
        (id (Eq._oldrec (Eq.refl (witt_vector.coeff 0 ↑i = 0)) (witt_vector.zero_coeff p R ↑i)))
        (Eq.refl 0)))

end truncated_witt_vector

/-- A macro tactic used to prove that `truncate_fun` respects ring operations. -/
namespace witt_vector

theorem truncate_fun_surjective (p : ℕ) (n : ℕ) (R : Type u_1) [comm_ring R] :
    function.surjective (truncate_fun n) :=
  fun (x : truncated_witt_vector p n R) =>
    Exists.intro (truncated_witt_vector.out x) (truncated_witt_vector.truncate_fun_out x)

@[simp] theorem truncate_fun_zero (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) (R : Type u_1)
    [comm_ring R] : truncate_fun n 0 = 0 :=
  rfl

@[simp] theorem truncate_fun_one (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) (R : Type u_1)
    [comm_ring R] : truncate_fun n 1 = 1 :=
  rfl

@[simp] theorem truncate_fun_add {p : ℕ} [hp : fact (nat.prime p)] (n : ℕ) {R : Type u_1}
    [comm_ring R] (x : witt_vector p R) (y : witt_vector p R) :
    truncate_fun n (x + y) = truncate_fun n x + truncate_fun n y :=
  sorry

@[simp] theorem truncate_fun_mul {p : ℕ} [hp : fact (nat.prime p)] (n : ℕ) {R : Type u_1}
    [comm_ring R] (x : witt_vector p R) (y : witt_vector p R) :
    truncate_fun n (x * y) = truncate_fun n x * truncate_fun n y :=
  sorry

theorem truncate_fun_neg {p : ℕ} [hp : fact (nat.prime p)] (n : ℕ) {R : Type u_1} [comm_ring R]
    (x : witt_vector p R) : truncate_fun n (-x) = -truncate_fun n x :=
  sorry

end witt_vector

namespace truncated_witt_vector

protected instance comm_ring (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) (R : Type u_1)
    [comm_ring R] : comm_ring (truncated_witt_vector p n R) :=
  function.surjective.comm_ring (witt_vector.truncate_fun n)
    (witt_vector.truncate_fun_surjective p n R) (witt_vector.truncate_fun_zero p n R)
    (witt_vector.truncate_fun_one p n R) (witt_vector.truncate_fun_add n)
    (witt_vector.truncate_fun_mul n) (witt_vector.truncate_fun_neg n)

end truncated_witt_vector

namespace witt_vector

/-- `truncate n` is a ring homomorphism that truncates `x` to its first `n` entries
to obtain a `truncated_witt_vector`, which has the same base `p` as `x`. -/
def truncate {p : ℕ} [hp : fact (nat.prime p)] (n : ℕ) {R : Type u_1} [comm_ring R] :
    witt_vector p R →+* truncated_witt_vector p n R :=
  ring_hom.mk (truncate_fun n) (truncate_fun_one p n R) (truncate_fun_mul n)
    (truncate_fun_zero p n R) (truncate_fun_add n)

theorem truncate_surjective (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) (R : Type u_1) [comm_ring R] :
    function.surjective ⇑(truncate n) :=
  truncate_fun_surjective p n R

@[simp] theorem coeff_truncate {p : ℕ} [hp : fact (nat.prime p)] {n : ℕ} {R : Type u_1}
    [comm_ring R] (x : witt_vector p R) (i : fin n) :
    truncated_witt_vector.coeff i (coe_fn (truncate n) x) = coeff x ↑i :=
  coeff_truncate_fun x i

theorem mem_ker_truncate {p : ℕ} [hp : fact (nat.prime p)] (n : ℕ) {R : Type u_1} [comm_ring R]
    (x : witt_vector p R) : x ∈ ring_hom.ker (truncate n) ↔ ∀ (i : ℕ), i < n → coeff x i = 0 :=
  sorry

@[simp] theorem truncate_mk (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) {R : Type u_1} [comm_ring R]
    (f : ℕ → R) :
    coe_fn (truncate n) (mk p f) = truncated_witt_vector.mk p fun (k : fin n) => f ↑k :=
  sorry

end witt_vector

namespace truncated_witt_vector

/--
A ring homomorphism that truncates a truncated Witt vector of length `m` to
a truncated Witt vector of length `n`, for `n ≤ m`.
-/
def truncate {p : ℕ} [hp : fact (nat.prime p)] {n : ℕ} {R : Type u_1} [comm_ring R] {m : ℕ}
    (hm : n ≤ m) : truncated_witt_vector p m R →+* truncated_witt_vector p n R :=
  ring_hom.lift_of_surjective (witt_vector.truncate m) (witt_vector.truncate_surjective p m R)
    (witt_vector.truncate n) sorry

@[simp] theorem truncate_comp_witt_vector_truncate {p : ℕ} [hp : fact (nat.prime p)] {n : ℕ}
    {R : Type u_1} [comm_ring R] {m : ℕ} (hm : n ≤ m) :
    ring_hom.comp (truncate hm) (witt_vector.truncate m) = witt_vector.truncate n :=
  ring_hom.lift_of_surjective_comp (witt_vector.truncate m) (witt_vector.truncate_surjective p m R)
    (witt_vector.truncate n) (truncate._proof_1 hm)

@[simp] theorem truncate_witt_vector_truncate {p : ℕ} [hp : fact (nat.prime p)] {n : ℕ}
    {R : Type u_1} [comm_ring R] {m : ℕ} (hm : n ≤ m) (x : witt_vector p R) :
    coe_fn (truncate hm) (coe_fn (witt_vector.truncate m) x) = coe_fn (witt_vector.truncate n) x :=
  ring_hom.lift_of_surjective_comp_apply (witt_vector.truncate m)
    (witt_vector.truncate_surjective p m R) (witt_vector.truncate n) (truncate._proof_1 hm) x

@[simp] theorem truncate_truncate {p : ℕ} [hp : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    {n₁ : ℕ} {n₂ : ℕ} {n₃ : ℕ} (h1 : n₁ ≤ n₂) (h2 : n₂ ≤ n₃) (x : truncated_witt_vector p n₃ R) :
    coe_fn (truncate h1) (coe_fn (truncate h2) x) = coe_fn (truncate (has_le.le.trans h1 h2)) x :=
  sorry

@[simp] theorem truncate_comp {p : ℕ} [hp : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    {n₁ : ℕ} {n₂ : ℕ} {n₃ : ℕ} (h1 : n₁ ≤ n₂) (h2 : n₂ ≤ n₃) :
    ring_hom.comp (truncate h1) (truncate h2) = truncate (has_le.le.trans h1 h2) :=
  sorry

theorem truncate_surjective {p : ℕ} [hp : fact (nat.prime p)] {n : ℕ} {R : Type u_1} [comm_ring R]
    {m : ℕ} (hm : n ≤ m) : function.surjective ⇑(truncate hm) :=
  sorry

@[simp] theorem coeff_truncate {p : ℕ} [hp : fact (nat.prime p)] {n : ℕ} {R : Type u_1}
    [comm_ring R] {m : ℕ} (hm : n ≤ m) (i : fin n) (x : truncated_witt_vector p m R) :
    coeff i (coe_fn (truncate hm) x) = coeff (coe_fn (fin.cast_le hm) i) x :=
  sorry

protected instance fintype {p : ℕ} {n : ℕ} {R : Type u_1} [fintype R] :
    fintype (truncated_witt_vector p n R) :=
  pi.fintype

theorem card (p : ℕ) (n : ℕ) {R : Type u_1} [fintype R] :
    fintype.card (truncated_witt_vector p n R) = fintype.card R ^ n :=
  sorry

theorem infi_ker_truncate {p : ℕ} [hp : fact (nat.prime p)] {R : Type u_1} [comm_ring R] :
    (infi fun (i : ℕ) => ring_hom.ker (witt_vector.truncate i)) = ⊥ :=
  sorry

end truncated_witt_vector

namespace witt_vector

/--
Given a family `fₖ : S → truncated_witt_vector p k R` and `s : S`, we produce a Witt vector by
defining the `k`th entry to be the final entry of `fₖ s`.
-/
def lift_fun {p : ℕ} [hp : fact (nat.prime p)] {R : Type u_1} [comm_ring R] {S : Type u_2}
    [semiring S] (f : (k : ℕ) → S →+* truncated_witt_vector p k R) (s : S) : witt_vector p R :=
  mk p fun (k : ℕ) => truncated_witt_vector.coeff (fin.last k) (coe_fn (f (k + 1)) s)

@[simp] theorem truncate_lift_fun {p : ℕ} [hp : fact (nat.prime p)] (n : ℕ) {R : Type u_1}
    [comm_ring R] {S : Type u_2} [semiring S] {f : (k : ℕ) → S →+* truncated_witt_vector p k R}
    (f_compat :
      ∀ (k₁ k₂ : ℕ) (hk : k₁ ≤ k₂), ring_hom.comp (truncated_witt_vector.truncate hk) (f k₂) = f k₁)
    (s : S) : coe_fn (truncate n) (lift_fun f s) = coe_fn (f n) s :=
  sorry

/--
Given compatible ring homs from `S` into `truncated_witt_vector n` for each `n`, we can lift these
to a ring hom `S → 𝕎 R`.

`lift` defines the universal property of `𝕎 R` as the inverse limit of `truncated_witt_vector n`.
-/
def lift {p : ℕ} [hp : fact (nat.prime p)] {R : Type u_1} [comm_ring R] {S : Type u_2} [semiring S]
    (f : (k : ℕ) → S →+* truncated_witt_vector p k R)
    (f_compat :
      ∀ (k₁ k₂ : ℕ) (hk : k₁ ≤ k₂),
        ring_hom.comp (truncated_witt_vector.truncate hk) (f k₂) = f k₁) :
    S →+* witt_vector p R :=
  ring_hom.mk (lift_fun f) sorry sorry sorry sorry

@[simp] theorem truncate_lift {p : ℕ} [hp : fact (nat.prime p)] (n : ℕ) {R : Type u_1} [comm_ring R]
    {S : Type u_2} [semiring S] {f : (k : ℕ) → S →+* truncated_witt_vector p k R}
    (f_compat :
      ∀ (k₁ k₂ : ℕ) (hk : k₁ ≤ k₂), ring_hom.comp (truncated_witt_vector.truncate hk) (f k₂) = f k₁)
    (s : S) :
    coe_fn (truncate n) (coe_fn (lift (fun (k₂ : ℕ) => f k₂) f_compat) s) = coe_fn (f n) s :=
  truncate_lift_fun n f_compat s

@[simp] theorem truncate_comp_lift {p : ℕ} [hp : fact (nat.prime p)] (n : ℕ) {R : Type u_1}
    [comm_ring R] {S : Type u_2} [semiring S] {f : (k : ℕ) → S →+* truncated_witt_vector p k R}
    (f_compat :
      ∀ (k₁ k₂ : ℕ) (hk : k₁ ≤ k₂),
        ring_hom.comp (truncated_witt_vector.truncate hk) (f k₂) = f k₁) :
    ring_hom.comp (truncate n) (lift (fun (k₂ : ℕ) => f k₂) f_compat) = f n :=
  sorry

/-- The uniqueness part of the universal property of `𝕎 R`. -/
theorem lift_unique {p : ℕ} [hp : fact (nat.prime p)] {R : Type u_1} [comm_ring R] {S : Type u_2}
    [semiring S] {f : (k : ℕ) → S →+* truncated_witt_vector p k R}
    (f_compat :
      ∀ (k₁ k₂ : ℕ) (hk : k₁ ≤ k₂), ring_hom.comp (truncated_witt_vector.truncate hk) (f k₂) = f k₁)
    (g : S →+* witt_vector p R) (g_compat : ∀ (k : ℕ), ring_hom.comp (truncate k) g = f k) :
    lift (fun (k₂ : ℕ) => f k₂) f_compat = g :=
  sorry

/-- The universal property of `𝕎 R` as projective limit of truncated Witt vector rings. -/
@[simp] theorem lift_equiv_symm_apply_coe {p : ℕ} [hp : fact (nat.prime p)] {R : Type u_1}
    [comm_ring R] {S : Type u_2} [semiring S] (g : S →+* witt_vector p R) (k : ℕ) :
    coe (coe_fn (equiv.symm lift_equiv) g) k = ring_hom.comp (truncate k) g :=
  Eq.refl (coe (coe_fn (equiv.symm lift_equiv) g) k)

theorem hom_ext {p : ℕ} [hp : fact (nat.prime p)] {R : Type u_1} [comm_ring R] {S : Type u_2}
    [semiring S] (g₁ : S →+* witt_vector p R) (g₂ : S →+* witt_vector p R)
    (h : ∀ (k : ℕ), ring_hom.comp (truncate k) g₁ = ring_hom.comp (truncate k) g₂) : g₁ = g₂ :=
  equiv.injective (equiv.symm lift_equiv) (subtype.ext (funext h))

end Mathlib


import combinatorics.simple_graph.coloring

--OUTPUT 1
theorem bipartite_graph_two_colorable (G : Type*) (E : set (G × G)) :
  ∀ (V : set G), (∀ (v : G), (v ∈ V ∨ v ∉ V)) → 2-colorable V E → bipartite V E :=
begin
  assume (V : set G) (hV : ∀ (v : G), (v ∈ V ∨ v ∉ V)) (h2c : 2-colorable V E),
  have h1 : ∀ (v : G), ¬(v ∈ V ∧ v ∉ V), from by auto using [hV],
  have h2 : ∀ (v : G), (v ∈ V) ∨ (v ∉ V), from by auto using [hV],
  have h3 : ∃! (A : set G), (V = A ∪ (V \ A)) ∧ ∀ (e : G × G), (e ∈ E → (e.snd ∈ A ∧ e.fst ∈ (V \ A)) ∨ (e.fst ∈ A ∧ e.snd ∈ (V \ A))), from by auto using [use (color_red V E)] [use (color_blue V E)] [exists_unique.exists] [exists_unique.unique] [2-colorable.def],
  have h4 : ∃! (A : set G), (V = A ∪ (V \ A)) ∧ ∀ (e : G × G), (e ∈ E → (e.snd ∈ A ∧ e.fst ∈ (V \ A)) ∨ (e.fst ∈ A ∧ e.snd ∈ (V \ A))), from by auto using [use (color_red V E)] [use (color_blue V E)] [exists_unique.exists] [exists_unique.unique] [2-colorable.def],
  have h5 : (∃! (A : set G), (V = A ∪ (V \ A)) ∧ ∀ (e : G × G), (e ∈ E → (e.snd ∈ A ∧ e.fst ∈ (V \ A)) ∨ (e.fst ∈ A ∧ e.snd ∈ (V \ A)))), from by auto [h3, h4],
  have h6 : bipartite V E, from by auto [h3, h4, h5, bipartite.def] [exists_unique.unique] [exists_unique.exists],
  show bipartite V E, from by auto [h6]
end

--OUTPUT 2
theorem is_two_colorable_iff_is_bipartite {G : Type*} [graph G] :
  is_two_colorable G ↔ is_bipartite G := sorry
end

--OUTPUT 3
theorem two_colorable_bipartite (G : Type*) [graph G] :
  ∀ b, is_2_colorable G b ↔ is_bipartite G b :=
begin
  -- Let $G$ be a 2-colorable graph, which means we can color every vertex either red or blue, and no edge will have both endpoints colored the same color. Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue. Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$. This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.
  assume b : G → bool,
  have h1 : ∀ v0 v1 : G, v0 ≠ v1 → b v0 ≠ b v1, from by auto [is_2_colorable],
  have h2 : ∀ v0 v1 : G, v0 ≠ v1 → is_bipartite G b, from by auto [h1, graph_is_bipartite],
  show is_2_colorable G b → is_bipartite G b, from by auto [is_bipartite, h2],

  -- Conversely, suppose $G$ is bipartite, that is, we can partition the vertices into two subsets $V_{1}, V_{2}$ every edge has one endpoint in $V_{1}$ and the other in $V_{2}$. Then coloring every vertex of $V_{1}$ red and every vertex of $V_{2}$ blue yields a valid coloring, so $G$ is 2-colorable.
  assume h3 : is_bipartite G b,
  have h4 : ∀ v0 v1 : G, v0 ≠ v1 → b v0 ≠ b v1, from by auto [is_bipartite, h3],
  show is_bipartite G b → is_2_colorable G b, from by auto [is_2_colorable] using [h4],
end

--OUTPUT 4
theorem two_colorable_iff_bipartite {G : Type*}
  (g : graph G) :
  g.two_colorable ↔ g.is_bipartite :=
begin
  -- Let $G$ be a 2-colorable graph:
  assume two_colorable : g.two_colorable,

  -- Then we can color every vertex either red or blue:
  have coloring : ∃ R B : $V$, ∀ u : G, u ∈ R ∨ u ∈ B, from by auto [two_colorable],
  let R := classical.some coloring.exists,
  let B := classical.some coloring.exists_2,

  -- and no edge will have both endpoints colored the same color.
  have no_common_color : ∀ u v : G, ¬((u, v) ∈ g.edges ∧ u ∈ R ∧ v ∈ R), from by auto [two_colorable],

  -- Let $A$ denote the subset of vertices colored red:
  let A : $V$, from by auto [R],
  -- and let $B$ denote the subset of vertices colored blue.
  let B : $V$, from by auto [B],

  -- Since all vertices of $A$ are red,
  have vertices_A_are_red : ∀ u : G, u ∈ A → u ∈ R, from by auto [A, B],
  -- there are no edges within $A$:
  have no_edges_in_A : ¬∃ u v : G, (u, v) ∈ g.edges ∧ u ∈ A ∧ v ∈ A, from by auto [vertices_A_are_red, no_common_color],

  -- and similarly for $B$.
  have no_edges_in_B : ¬∃ u v : G, (u, v) ∈ g.edges ∧ u ∈ B ∧ v ∈ B, from by auto [vertices_A_are_red, no_common_color],

  -- This implies that every edge has one endpoint in $A$ and the other in $B$:
  have endpoints_A_B : ∀ u v : G, (u, v) ∈ g.edges → u ∈ A ∧ v ∈ B ∨ u ∈ B ∧ v ∈ A, from by auto [vertices_A_are_red, A, B, no_edges_in_A, no_edges_in_B],

  -- which means $G$ is bipartite.
  show g.is_bipartite, from by auto [g.is_bipartite, A, B, endpoints_A_B, no_edges_in_A, no_edges_in_B],

  -- Conversely, suppose $G$ is bipartite
  assume bipartite : g.is_bipartite,

  -- that is, we can partition the vertices into two subsets $V_{1}, V_{2}$:
  let A : $V$, from by auto [g.is_bipartite, bipartite],
  let B : $V$, from by auto [g.is_bipartite, bipartite],

  -- every edge has one endpoint in $V_{1}$ and the other in $V_{2}$:
  have endpoints_A_B : ∀ u v : G, (u, v) ∈ g.edges → u ∈ A ∧ v ∈ B ∨ u ∈ B ∧ v ∈ A, from by auto [g.is_bipartite, bipartite],

  -- Then coloring every vertex of $V_{1}$ red:
  have endpoints_A_red : ∀ u v : G, (u, v) ∈ g.edges → u ∈ A ∧ v ∈ B ↔ u = (1), from by auto [endpoints_A_B, A, B],
  let coloring_A : ∀ u : G, u ∈ A → u = (1), from by auto [endpoints_A_red],

  -- and every vertex of $V_{2}$ blue:
  have endpoints_B_blue : ∀ u v : G, (u, v) ∈ g.edges → u ∈ B ∧ v ∈ A ↔ u = (-1), from by auto [endpoints_A_B, A, B],
  let coloring_B : ∀ u : G, u ∈ B → u = (-1), from by auto [endpoints_B_blue],

  -- yields a valid coloring:
  have valid_coloring : ∀ u v : G, (u, v) ∈ g.edges → u ≠ v, from by auto [endpoints_A_B, coloring_A, coloring_B],

  -- so $G$ is 2-colorable.
  show g.two_colorable, from by auto [g.two_colorable, coloring_A, coloring_B, valid_coloring],
end

--OUTPUT 5
theorem bipartite_iff_two_colorable (G : Type*) [graph G] : bipartite G ↔ two_colorable G :=
begin
  have h1 : ∀ (G : Type*) [graph G], bipartite G → two_colorable G, from by auto [two_colorable.mk, bipartite],
  have h2 : ∀ (G : Type*) [graph G], two_colorable G → bipartite G, from by auto [bipartite.mk],
  show bipartite G ↔ two_colorable G, from iff.intro h1 h2,
end

--OUTPUT 6
theorem two_colorable_bipartite {G : Type*} [graph G] : (∃ c : coloring G 2, coloring.valid c) ↔ (bipartite G) :=
begin
  -- Suppose $G$ is bipartite
  have h1 : (bipartite G) → (∃ c : coloring G 2, coloring.valid c), from by auto [bipartite, coloring.valid],
  -- Then coloring every vertex of $V_{1}$ red and every vertex of $V_{2}$ blue yields a valid coloring, so $G$ is 2-colorable
  have h2 : ∀ (A B : set V) (h : bipartite G A B), ∃ c : coloring G 2, coloring.valid c, from by auto using [bipartite, coloring.valid],
  -- Suppose $G$ is 2-colorable graph, which means we can color every vertex either red or blue, and no edge will have both endpoints colored the same color
  have h3 : (∃ c : coloring G 2, coloring.valid c) → (bipartite G), from by auto [bipartite, coloring.valid],
  -- Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue
  have h4 : ∀ c : coloring G 2, coloring.valid c → (∃ A B : set V, (bipartite G A B)), from by auto using [bipartite, coloring.valid],

  show (∃ c : coloring G 2, coloring.valid c) ↔ (bipartite G), from by auto using [h1,h2,h3,h4]
end

--OUTPUT 7
theorem bipartite_graph_two_colorable (G : graph) : G.is_two_colorable ↔ G.is_bipartite :=
begin
  unfold is_two_colorable,
  unfold is_bipartite,

  split,
  case (classical.em (∃ (vs : set G.vertex) (es : set G.edge), G.is_subgraph vs es)) {
    assume h1 : ∃ (vs : set G.vertex) (es : set G.edge), G.is_subgraph vs es,

    show ∃ (A B : set G.vertex), ∀ (a : G.vertex), a ∈ A ∨ a ∈ B ∧ (∀ (x y : G.vertex), x ∈ A ∧ y ∈ B → (∃ (e : G.edge), ((G.E.val e).fst = x ∧ (G.E.val e).snd = y) ∨ ((G.E.val e).fst = y ∧ (G.E.val e).snd = x))) ∧ (∀ (x y : G.vertex), x ∈ A ∨ y ∈ B → (∃ (e : G.edge), ((G.E.val e).fst = x ∧ (G.E.val e).snd = y) ∨ ((G.E.val e).fst = y ∧ (G.E.val e).snd = x))) ∧ (∀ (v : G.vertex), v ∈ A → ∀ (w : G.vertex), w ∈ A → (∃ (e : G.edge), ((G.E.val e).fst = v ∧ (G.E.val e).snd = w) ∨ ((G.E.val e).fst = w ∧ (G.E.val e).snd = v)) → false) ∧ (∀ (v : G.vertex), v ∈ B → ∀ (w : G.vertex), w ∈ B → (∃ (e : G.edge), ((G.E.val e).fst = v ∧ (G.E.val e).snd = w) ∨ ((G.E.val e).fst = w ∧ (G.E.val e).snd = v)) → false),
    case exists.elim h1 ⟨vs, es, h2⟩ {
      have := graph.is_two_colorable.is_two_colorable_subgraph h2,
      cases this,
      cases this_left,
      cases this_left_left,
      cases this_left_right,
      cases this_right,
      cases this_right_left,
      cases this_right_right,
      have h3 : ∀ (a : G.vertex), a ∈ red_vertices ∨ a ∈ blue_vertices := this_left_left_left,
      have h4 : ∀ (x y : G.vertex), x ∈ red_vertices ∧ y ∈ blue_vertices → (∃ (e : G.edge), ((G.E.val e).fst = x ∧ (G.E.val e).snd = y) ∨ ((G.E.val e).fst = y ∧ (G.E.val e).snd = x)) := this_left_left_right,
      have h5 : ∀ (x y : G.vertex), x ∈ red_vertices ∨ y ∈ blue_vertices → (∃ (e : G.edge), ((G.E.val e).fst = x ∧ (G.E.val e).snd = y) ∨ ((G.E.val e).fst = y ∧ (G.E.val e).snd = x)) := this_left_right_right,
      have h6 : ∀ (v : G.vertex), v ∈ red_vertices → ∀ (w : G.vertex), w ∈ red_vertices → (∃ (e : G.edge), ((G.E.val e).fst = v ∧ (G.E.val e).snd = w) ∨ ((G.E.val e).fst = w ∧ (G.E.val e).snd = v)) → false := this_right_left_left,
      have h7 : ∀ (v : G.vertex), v ∈ blue_vertices → ∀ (w : G.vertex), w ∈ blue_vertices → (∃ (e : G.edge), ((G.E.val e).fst = v ∧ (G.E.val e).snd = w) ∨ ((G.E.val e).fst = w ∧ (G.E.val e).snd = v)) → false := this_right_right_right,

      show ∃ (A B : set G.vertex), ∀ (a : G.vertex), a ∈ A ∨ a ∈ B ∧ (∀ (x y : G.vertex), x ∈ A ∧ y ∈ B → (∃ (e : G.edge), ((G.E.val e).fst = x ∧ (G.E.val e).snd = y) ∨ ((G.E.val e).fst = y ∧ (G.E.val e).snd = x))) ∧ (∀ (x y : G.vertex), x ∈ A ∨ y ∈ B → (∃ (e : G.edge), ((G.E.val e).fst = x ∧ (G.E.val e).snd = y) ∨ ((G.E.val e).fst = y ∧ (G.E.val e).snd = x))) ∧ (∀ (v : G.vertex), v ∈ A → ∀ (w : G.vertex), w ∈ A → (∃ (e : G.edge), ((G.E.val e).fst = v ∧ (G.E.val e).snd = w) ∨ ((G.E.val e).fst = w ∧ (G.E.val e).snd = v)) → false) ∧ (∀ (v : G.vertex), v ∈ B → ∀ (w : G.vertex), w ∈ B → (∃ (e : G.edge), ((G.E.val e).fst = v ∧ (G.E.val e).snd = w) ∨ ((G.E.val e).fst = w ∧ (G.E.val e).snd = v)) → false),

      show ∃ (A B : set G.vertex), ∀ (a : G.vertex), a ∈ A ∨ a ∈ B ∧ (∀ (x y : G.vertex), x ∈ A ∧ y ∈ B → (∃ (e : G.edge), ((G.E.val e).fst = x ∧ (G.E.val e).snd = y) ∨ ((G.E.val e).fst = y ∧ (G.E.val e).snd = x))) ∧ (∀ (x y : G.vertex), x ∈ A ∨ y ∈ B → (∃ (e : G.edge), ((G.E.val e).fst = x ∧ (G.E.val e).snd = y) ∨ ((G.E.val e).fst = y ∧ (G.E.val e).snd = x))) ∧ (∀ (v : G.vertex), v ∈ A → ∀ (w : G.vertex), w ∈ A → (∃ (e : G.edge), ((G.E.val e).fst = v ∧ (G.E.val e).snd = w) ∨ ((G.E.val e).fst = w ∧ (G.E.val e).snd = v)) → false) ∧ (∀ (v : G.vertex), v ∈ B → ∀ (w : G.vertex), w ∈ B → (∃ (e : G.edge), ((G.E.val e).fst = v ∧ (G.E.val e).snd = w) ∨ ((G.E.val e).fst = w ∧ (G.E.val e).snd = v)) → false),
      show ∃
end --Needs more than 2000 tokens!

--OUTPUT 8
theorem bipartite_2_colorable {G : Type*} [graph G] : (∃ V1 V2 : set G, is_bipartite V1 V2 G) ↔ two_colorable G :=
begin
    -- Let $G$ be a 2-colorable graph, which means we can color every vertex either red or blue, and no edge will have both endpoints colored the same color.
    assume h1 : ∃ V1 V2 : set G, is_bipartite V1 V2 G,
    -- Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue.
    have h2 : ∃ A B : set G, valid_coloring G A B, from by auto [two_colorable_def, is_bipartite_def, h1],
    rcases h2 with ⟨A, hA⟩,
    rcases hA with ⟨B, hB⟩,

    -- Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$.
    have h3 : ∀ a : G, a ∈ A → ∀ b : G, b ∈ A → ¬edge G a b, from by auto [hB, valid_coloring_def],

    -- This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.
    have h4 : is_bipartite A B G, from by auto [hB, valid_coloring_def, is_bipartite_def, h3, not_false_iff],

    -- G is bipartite
    show (∃ V1 V2 : set G, is_bipartite V1 V2 G) → two_colorable G, from by auto [two_colorable_def, is_bipartite_def, h1, h4],
    -- G is 2-colorable
    show two_colorable G → (∃ V1 V2 : set G, is_bipartite V1 V2 G), from by auto [two_colorable_def, is_bipartite_def],
end

--OUTPUT 9
theorem two_colorable_graph_is_bipartite {G : Type*} [graph G] : ∀ G, 2-colorable G ⟺ bipartite G :=
begin
intros,
unfold 2-colorable,
unfold bipartite,
intuition,
revert H,
induction l,
intros,
exfalso,
cases H,
intros,
unfold col_for_all,
unfold not_col_for_all,
unfold col_for_all in H,
unfold not_col_for_all in H,
split_ifs,
unfold col_for_all,
unfold not_col_for_all,
split_ifs,
exfalso,
apply H,
existsi a,
split,
assumption,
apply H0,
split_ifs,
exfalso,
apply H,
existsi a,
split,
apply col_for_all.elim_left,
assumption,
assumption,
apply col_for_all.elim_right,
assumption,
assumption,
unfold col_for_all in H0,
unfold not_col_for_all in H0,
split_ifs,
exfalso,
apply H,
existsi a,
split,
assumption,
apply H0,
split_ifs,
exfalso,
apply H,
existsi a,
split,
apply col_for_all.elim_left,
assumption,
assumption,
apply col_for_all.elim_right,
assumption,
assumption,
unfold col_for_all,
unfold not_col_for_all,
split_ifs,
exfalso,
apply H,
existsi a,
split,
assumption,
apply H1,
split_ifs,
exfalso,
apply H,
existsi a,
split,
apply col_for_all.elim_left,
assumption,
assumption,
apply col_for_all.elim_right,
assumption,
assumption,
end

--OUTPUT 10
theorem two_colorable_bipartite :
  ∀  G : Type*,
    (∀ v : G, v = red ∨ v = blue)
    → (∀ e : G, e = red ∧ e = blue)
    →  G ≈ bipartite G :=
begin
  intros G v e,
    -- We can color every vertex either red or blue, and no edge will have both endpoints colored the same color.
  have h1 : ∀ v : G, v = red ∨ v = blue, from sorry,
  have h2 : ∀ e : G, e = red ∧ e = blue, from sorry,

  -- Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue.
  have A : G, from sorry,
  have B : G, from sorry,
  -- Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$.
  have h3 : ∀ A : G, ∀ e : G,  e = red ∧ e = blue, from sorry,
  have h4 : ∀ B : G, ∀ e : G,  e = red ∧ e = blue, from sorry,

  -- This implies that every edge has one endpoint in $A$ and the other in $B$,
  have H1 : ∀ e : G, e ∈ A ∨ e ∈ B, from sorry,
  have H2 : ∀ e : G, e ∈ A ∨ e ∈ B, from sorry,

  -- which means $G$ is bipartite.
  have h5 : G ≈ bipartite G, from sorry,

  -- Conversely, suppose $G$ is bipartite, that is, we can partition the vertices into two subsets $V_{1}, V_{2}$ every edge has one endpoint in $V_{1}$ and the other in $V_{2}$.
  have h6 : G ≈ bipartite G, from sorry,

  -- Then coloring every vertex of $V_{1}$ red and every vertex of $V_{2}$ blue yields a valid coloring, so $G$ is 2-colorable.
  have h7 : ∀ v : G, v = red ∨ v = blue, from sorry,
  have h8 : ∀ e : G, e = red ∧ e = blue, from sorry,

  exact sorry,
end

/- FEW SHOT PROMPTS TO CODEX(START)
/--`theorem`
Power Set is Closed under Intersection
Let $S$ be a set.

Let $\powerset S$ be the power set of $S$.

Then:
:$\forall A, B \in \powerset S: A \cap B \in \powerset S$
`proof`
Let $A, B \in \powerset S$.

Then by the definition of power set, $A \subseteq S$ and $B \subseteq S$.

From Intersection is Subset we have that $A \cap B \subseteq A$.

It follows from Subset Relation is Transitive that $A \cap B \subseteq S$.

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  -- $A$ and $B$ are sets. $A$ and $B$ belong to power set of $S$
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  -- Then $A ⊆ S$ and $B ⊆ S$, by power set definition
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from by auto [set.subset_of_mem_powerset, set.subset_of_mem_powerset],
  -- Then $(A ∩ B) ⊆ A$, by intersection of set is a subset
  have h2 : (A ∩ B) ⊆ A, from by auto [set.inter_subset_left],
  -- Then $(A ∩ B) ⊆ S$, by subset relation is transitive
  have h3 : (A ∩ B) ⊆ S, from by auto [set.subset.trans],
  -- Hence $(A ∩ B) ∈  𝒫 S$, by power set definition
  show (A ∩ B) ∈  𝒫 S, from by auto [set.mem_powerset],
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  -- expand the power
  calc (x + y)^2 = (x+y)*(x+y) : by auto [sq]
  -- distributive property of multiplication over addition gives:
  ... = x*(x+y) + y*(x+y) : by auto [add_mul]
  -- applying the above property further gives:
  ... = x*x + x*y + y*x + y*y : by auto [mul_comm, add_mul] using [ring]
  -- rearranging the terms using commutativity and adding gives:
  ... = x^2 + 2*x*y + y^2 : by auto [sq, mul_comm] using [ring]
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  -- Group has Latin Square Property
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from by auto using [use (a⁻¹ * b)],
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from by auto using [use b * a⁻¹],

  -- Setting $b = a$, this becomes:
  have h3 : ∀ a : G, ∃! x : G, a * x = a, from by auto [h1],
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from by auto [h2],

  -- These $x$ and $y$ are both $(1 : G)$, by definition of identity element
  have h5 : ∀ a : G, classical.some (h3 a).exists = (1 : G), from by auto [exists_unique.unique, h3, classical.some_spec, exists_unique.exists, mul_one],
  have h6 : ∀ a : G, classical.some (h4 a).exists = (1 : G), from by auto [exists_unique.unique, h4, classical.some_spec, exists_unique.exists, one_mul],

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by auto [h3, h4, exists_unique.unique, classical.some_spec, exists_unique.exists] using [use (1 : G)],
end

/--`theorem`
Bipartite Graph is two colorable
Let $G$ be a graph. Then $G$ is 2-colorable if and only if $G$ is bipartite.
`proof`
Let $G$ be a 2-colorable graph, which means we can color every vertex either red or blue, and no edge will have both endpoints colored the same color. Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue. Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$. This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.

Conversely, suppose $G$ is bipartite, that is, we can partition the vertices into two subsets $V_{1}, V_{2}$ every edge has one endpoint in $V_{1}$ and the other in $V_{2}$. Then coloring every vertex of $V_{1}$ red and every vertex of $V_{2}$ blue yields a valid coloring, so $G$ is 2-colorable.

QED

-/
theorem
FEW SHOT PROMPTS TO CODEX(END)-/


import data.equiv.encodable data.equiv.list data.fin data.finset data.fintype

/-
`Wfin α ar` is the type of finitely branching trees with labels from α, where
a node labeled `a` has `ar a` children.
-/

inductive Wfin {α : Type*} (ar : α → ℕ)
| mk (a : α) (f : fin (ar a) → Wfin) : Wfin

namespace Wfin

variables {α : Type*} {ar : α → ℕ}

def depth : Wfin ar → ℕ
| ⟨a, f⟩ := finset.sup finset.univ (λ n, depth (f n)) + 1

def not_depth_le_zero (t : Wfin ar) : ¬ t.depth ≤ 0 :=
by { cases t, apply nat.not_succ_le_zero }

lemma depth_lt_depth_mk (a : α) (f : fin (ar a) → Wfin ar) (i : fin (ar a)) :
  depth (f i) < depth ⟨a, f⟩ :=
nat.lt_succ_of_le (finset.le_sup (finset.mem_univ i))

end Wfin

/-
Show  `Wfin` types are encodable.
-/

namespace encodable

@[reducible] private def Wfin' {α : Type*} (ar : α → ℕ) (n : ℕ) :=
{ t : Wfin ar // t.depth ≤ n}

variables {α : Type*} {ar : α → ℕ}

private def encodable_zero : encodable (Wfin' ar 0) :=
let f    : Wfin' ar 0 → empty := λ ⟨x, h⟩, absurd h (Wfin.not_depth_le_zero _),
    finv : empty → Wfin' ar 0 := by { intro x, cases x} in
have ∀ x, finv (f x) = x, from λ ⟨x, h⟩, absurd h (Wfin.not_depth_le_zero _),
encodable.of_left_inverse f finv this

private def f (n : ℕ) : Wfin' ar (n + 1) → Σ a : α, fin (ar a) → Wfin' ar n
| ⟨t, h⟩ :=
  begin
    cases t with a f,
    have h₀ : ∀ i : fin (ar a), Wfin.depth (f i) ≤ n,
      from λ i, nat.le_of_lt_succ (lt_of_lt_of_le (Wfin.depth_lt_depth_mk a f i) h),
    exact ⟨a, λ i : fin (ar a), ⟨f i, h₀ i⟩⟩
  end

private def finv (n : ℕ) :
  (Σ a : α, fin (ar a) → Wfin' ar n) → Wfin' ar (n + 1)
| ⟨a, f⟩ :=
  let f' := λ i : fin (ar a), (f i).val in
  have Wfin.depth ⟨a, f'⟩ ≤ n + 1,
    from add_le_add_right (finset.sup_le (λ b h, (f b).2)) 1,
  ⟨⟨a, f'⟩, this⟩

variable [encodable α]

private def encodable_succ (n : nat) (h : encodable (Wfin' ar n)) :
  encodable (Wfin' ar (n + 1)) :=
encodable.of_left_inverse (f n) (finv n)
  (by { intro t, cases t with t h, cases t with a fn, reflexivity })

instance : encodable (Wfin ar) :=
begin
  haveI h' : Π n, encodable (Wfin' ar n) :=
    λ n, nat.rec_on n encodable_zero encodable_succ,
  let f    : Wfin ar → Σ n, Wfin' ar n   := λ t, ⟨t.depth, ⟨t, le_refl _⟩⟩,
  let finv : (Σ n, Wfin' ar n) → Wfin ar := λ p, p.2.1,
  have : ∀ t, finv (f t) = t, from λ t, rfl,
  exact encodable.of_left_inverse f finv this
end

end encodable

/-
Make it easier to construct funtions from a small `fin`.
-/

namespace fin
variable {α : Type*}

def mk_fn0 : fin 0 → α
| ⟨_, h⟩ := absurd h dec_trivial

def mk_fn1 (t : α) : fin 1 → α
| ⟨0, _⟩   := t
| ⟨n+1, h⟩ := absurd h dec_trivial

def mk_fn2 (s t : α) : fin 2 → α
| ⟨0, _⟩   := s
| ⟨1, _⟩   := t
| ⟨n+2, h⟩ := absurd h dec_trivial

attribute [simp] mk_fn0 mk_fn1 mk_fn2
end fin

/-
Show propositional formulas are encodable.
-/

inductive prop_form (α : Type*)
| var : α → prop_form
| not : prop_form → prop_form
| and : prop_form → prop_form → prop_form
| or  : prop_form → prop_form → prop_form

namespace prop_form

private def constructors (α : Type*) := α ⊕ unit ⊕ unit ⊕ unit

local notation `cvar` a := sum.inl a
local notation `cnot`   := sum.inr (sum.inl unit.star)
local notation `cand`   := sum.inr (sum.inr (sum.inr unit.star))
local notation `cor`    := sum.inr (sum.inr (sum.inl unit.star))

@[simp]
private def arity (α : Type*) : constructors α → nat
| (cvar a) := 0
| cnot     := 1
| cand     := 2
| cor      := 2

variable {α : Type*}

private def f : prop_form α → Wfin (arity α)
| (var a)   := ⟨cvar a, fin.mk_fn0⟩
| (not p)   := ⟨cnot, fin.mk_fn1 (f p)⟩
| (and p q) := ⟨cand, fin.mk_fn2 (f p) (f q)⟩
| (or  p q) := ⟨cor, fin.mk_fn2 (f p) (f q)⟩

private def finv : Wfin (arity α) → prop_form α
| ⟨cvar a, fn⟩ := var a
| ⟨cnot, fn⟩   := not (finv (fn ⟨0, dec_trivial⟩))
| ⟨cand, fn⟩   := and (finv (fn ⟨0, dec_trivial⟩)) (finv (fn ⟨1, dec_trivial⟩))
| ⟨cor, fn⟩    := or  (finv (fn ⟨0, dec_trivial⟩)) (finv (fn ⟨1, dec_trivial⟩))

instance [encodable α] : encodable (prop_form α) :=
begin
  haveI : encodable (constructors α) :=
    by { unfold constructors, apply_instance },
  exact encodable.of_left_inverse f finv
    (by { intro p, induction p; simp [f, finv, *] })
end

end prop_form


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

! This file was ported from Lean 3 source module ring_theory.adjoin_root
! leanprover-community/mathlib commit da420a8c6dd5bdfb85c4ced85c34388f633bc6ff
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Algebra.Basic
import Mathbin.Data.Polynomial.FieldDivision
import Mathbin.FieldTheory.Minpoly.Basic
import Mathbin.RingTheory.Adjoin.Basic
import Mathbin.RingTheory.FinitePresentation
import Mathbin.RingTheory.FiniteType
import Mathbin.RingTheory.PowerBasis
import Mathbin.RingTheory.PrincipalIdealDomain
import Mathbin.RingTheory.QuotientNoetherian

/-!
# Adjoining roots of polynomials

This file defines the commutative ring `adjoin_root f`, the ring R[X]/(f) obtained from a
commutative ring `R` and a polynomial `f : R[X]`. If furthermore `R` is a field and `f` is
irreducible, the field structure on `adjoin_root f` is constructed.

We suggest stating results on `is_adjoin_root` instead of `adjoin_root` to achieve higher
generality, since `is_adjoin_root` works for all different constructions of `R[α]`
including `adjoin_root f = R[X]/(f)` itself.

## Main definitions and results

The main definitions are in the `adjoin_root` namespace.

*  `mk f : R[X] →+* adjoin_root f`, the natural ring homomorphism.

*  `of f : R →+* adjoin_root f`, the natural ring homomorphism.

* `root f : adjoin_root f`, the image of X in R[X]/(f).

* `lift (i : R →+* S) (x : S) (h : f.eval₂ i x = 0) : (adjoin_root f) →+* S`, the ring
  homomorphism from R[X]/(f) to S extending `i : R →+* S` and sending `X` to `x`.

* `lift_hom (x : S) (hfx : aeval x f = 0) : adjoin_root f →ₐ[R] S`, the algebra
  homomorphism from R[X]/(f) to S extending `algebra_map R S` and sending `X` to `x`

* `equiv : (adjoin_root f →ₐ[F] E) ≃ {x // x ∈ (f.map (algebra_map F E)).roots}` a
  bijection between algebra homomorphisms from `adjoin_root` and roots of `f` in `S`

-/

noncomputable section

open Classical

open BigOperators Polynomial

universe u v w

variable {R : Type u} {S : Type v} {K : Type w}

open Polynomial Ideal

/-- Adjoin a root of a polynomial `f` to a commutative ring `R`. We define the new ring
as the quotient of `R[X]` by the principal ideal generated by `f`. -/
def AdjoinRoot [CommRing R] (f : R[X]) : Type u :=
  Polynomial R ⧸ (span {f} : Ideal R[X])
#align adjoin_root AdjoinRoot

namespace AdjoinRoot

section CommRing

variable [CommRing R] (f : R[X])

instance : CommRing (AdjoinRoot f) :=
  Ideal.Quotient.commRing _

instance : Inhabited (AdjoinRoot f) :=
  ⟨0⟩

instance : DecidableEq (AdjoinRoot f) :=
  Classical.decEq _

protected theorem nontrivial [IsDomain R] (h : degree f ≠ 0) : Nontrivial (AdjoinRoot f) :=
  Ideal.Quotient.nontrivial
    (by
      simp_rw [Ne.def, span_singleton_eq_top, Polynomial.isUnit_iff, not_exists, not_and]
      rintro x hx rfl
      exact h (degree_C hx.ne_zero))
#align adjoin_root.nontrivial AdjoinRoot.nontrivial

/-- Ring homomorphism from `R[x]` to `adjoin_root f` sending `X` to the `root`. -/
def mk : R[X] →+* AdjoinRoot f :=
  Ideal.Quotient.mk _
#align adjoin_root.mk AdjoinRoot.mk

@[elab_as_elim]
theorem induction_on {C : AdjoinRoot f → Prop} (x : AdjoinRoot f) (ih : ∀ p : R[X], C (mk f p)) :
    C x :=
  Quotient.inductionOn' x ih
#align adjoin_root.induction_on AdjoinRoot.induction_on

/-- Embedding of the original ring `R` into `adjoin_root f`. -/
def of : R →+* AdjoinRoot f :=
  (mk f).comp C
#align adjoin_root.of AdjoinRoot.of

instance [CommSemiring S] [Algebra S R] : Algebra S (AdjoinRoot f) :=
  Ideal.Quotient.algebra S

instance [CommSemiring S] [CommSemiring K] [SMul S K] [Algebra S R] [Algebra K R]
    [IsScalarTower S K R] : IsScalarTower S K (AdjoinRoot f) :=
  Submodule.Quotient.isScalarTower _ _

instance [CommSemiring S] [CommSemiring K] [Algebra S R] [Algebra K R] [SMulCommClass S K R] :
    SMulCommClass S K (AdjoinRoot f) :=
  Submodule.Quotient.smulCommClass _ _

@[simp]
theorem algebraMap_eq : algebraMap R (AdjoinRoot f) = of f :=
  rfl
#align adjoin_root.algebra_map_eq AdjoinRoot.algebraMap_eq

variable (S)

theorem algebraMap_eq' [CommSemiring S] [Algebra S R] :
    algebraMap S (AdjoinRoot f) = (of f).comp (algebraMap S R) :=
  rfl
#align adjoin_root.algebra_map_eq' AdjoinRoot.algebraMap_eq'

variable {S}

theorem finiteType : Algebra.FiniteType R (AdjoinRoot f) :=
  (Algebra.FiniteType.polynomial R).ofSurjective _ (Ideal.Quotient.mkₐ_surjective R _)
#align adjoin_root.finite_type AdjoinRoot.finiteType

theorem finitePresentation : Algebra.FinitePresentation R (AdjoinRoot f) :=
  (Algebra.FinitePresentation.polynomial R).Quotient (Submodule.fg_span_singleton f)
#align adjoin_root.finite_presentation AdjoinRoot.finitePresentation

/-- The adjoined root. -/
def root : AdjoinRoot f :=
  mk f X
#align adjoin_root.root AdjoinRoot.root

variable {f}

instance hasCoeT : CoeTC R (AdjoinRoot f) :=
  ⟨of f⟩
#align adjoin_root.has_coe_t AdjoinRoot.hasCoeT

/-- Two `R`-`alg_hom` from `adjoin_root f` to the same `R`-algebra are the same iff
    they agree on `root f`. -/
@[ext]
theorem algHom_ext [Semiring S] [Algebra R S] {g₁ g₂ : AdjoinRoot f →ₐ[R] S}
    (h : g₁ (root f) = g₂ (root f)) : g₁ = g₂ :=
  Ideal.Quotient.algHom_ext R <| Polynomial.algHom_ext h
#align adjoin_root.alg_hom_ext AdjoinRoot.algHom_ext

@[simp]
theorem mk_eq_mk {g h : R[X]} : mk f g = mk f h ↔ f ∣ g - h :=
  Ideal.Quotient.eq.trans Ideal.mem_span_singleton
#align adjoin_root.mk_eq_mk AdjoinRoot.mk_eq_mk

@[simp]
theorem mk_eq_zero {g : R[X]} : mk f g = 0 ↔ f ∣ g :=
  mk_eq_mk.trans <| by rw [sub_zero]
#align adjoin_root.mk_eq_zero AdjoinRoot.mk_eq_zero

@[simp]
theorem mk_self : mk f f = 0 :=
  Quotient.sound' <| QuotientAddGroup.leftRel_apply.mpr (mem_span_singleton.2 <| by simp)
#align adjoin_root.mk_self AdjoinRoot.mk_self

@[simp]
theorem mk_c (x : R) : mk f (C x) = x :=
  rfl
#align adjoin_root.mk_C AdjoinRoot.mk_c

@[simp]
theorem mk_x : mk f X = root f :=
  rfl
#align adjoin_root.mk_X AdjoinRoot.mk_x

theorem mk_ne_zero_of_degree_lt (hf : Monic f) {g : R[X]} (h0 : g ≠ 0) (hd : degree g < degree f) :
    mk f g ≠ 0 :=
  mk_eq_zero.Not.2 <| hf.not_dvd_of_degree_lt h0 hd
#align adjoin_root.mk_ne_zero_of_degree_lt AdjoinRoot.mk_ne_zero_of_degree_lt

theorem mk_ne_zero_of_natDegree_lt (hf : Monic f) {g : R[X]} (h0 : g ≠ 0)
    (hd : natDegree g < natDegree f) : mk f g ≠ 0 :=
  mk_eq_zero.Not.2 <| hf.not_dvd_of_natDegree_lt h0 hd
#align adjoin_root.mk_ne_zero_of_nat_degree_lt AdjoinRoot.mk_ne_zero_of_natDegree_lt

@[simp]
theorem aeval_eq (p : R[X]) : aeval (root f) p = mk f p :=
  Polynomial.induction_on p
    (fun x => by
      rw [aeval_C]
      rfl)
    (fun p q ihp ihq => by rw [AlgHom.map_add, RingHom.map_add, ihp, ihq]) fun n x ih =>
    by
    rw [AlgHom.map_mul, aeval_C, AlgHom.map_pow, aeval_X, RingHom.map_mul, mk_C, RingHom.map_pow,
      mk_X]
    rfl
#align adjoin_root.aeval_eq AdjoinRoot.aeval_eq

theorem adjoinRoot_eq_top : Algebra.adjoin R ({root f} : Set (AdjoinRoot f)) = ⊤ :=
  Algebra.eq_top_iff.2 fun x =>
    induction_on f x fun p =>
      (Algebra.adjoin_singleton_eq_range_aeval R (root f)).symm ▸ ⟨p, aeval_eq p⟩
#align adjoin_root.adjoin_root_eq_top AdjoinRoot.adjoinRoot_eq_top

@[simp]
theorem eval₂_root (f : R[X]) : f.eval₂ (of f) (root f) = 0 := by
  rw [← algebra_map_eq, ← aeval_def, aeval_eq, mk_self]
#align adjoin_root.eval₂_root AdjoinRoot.eval₂_root

theorem isRoot_root (f : R[X]) : IsRoot (f.map (of f)) (root f) := by
  rw [is_root, eval_map, eval₂_root]
#align adjoin_root.is_root_root AdjoinRoot.isRoot_root

theorem isAlgebraic_root (hf : f ≠ 0) : IsAlgebraic R (root f) :=
  ⟨f, hf, eval₂_root f⟩
#align adjoin_root.is_algebraic_root AdjoinRoot.isAlgebraic_root

theorem of.injective_of_degree_ne_zero [IsDomain R] (hf : f.degree ≠ 0) :
    Function.Injective (AdjoinRoot.of f) :=
  by
  rw [injective_iff_map_eq_zero]
  intro p hp
  rw [AdjoinRoot.of, RingHom.comp_apply, AdjoinRoot.mk_eq_zero] at hp
  by_cases h : f = 0
  · exact C_eq_zero.mp (eq_zero_of_zero_dvd (by rwa [h] at hp))
  · contrapose! hf with h_contra
    rw [← degree_C h_contra]
    apply le_antisymm (degree_le_of_dvd hp (by rwa [Ne.def, C_eq_zero])) _
    rwa [degree_C h_contra, zero_le_degree_iff]
#align adjoin_root.of.injective_of_degree_ne_zero AdjoinRoot.of.injective_of_degree_ne_zero

variable [CommRing S]

/-- Lift a ring homomorphism `i : R →+* S` to `adjoin_root f →+* S`. -/
def lift (i : R →+* S) (x : S) (h : f.eval₂ i x = 0) : AdjoinRoot f →+* S :=
  by
  apply Ideal.Quotient.lift _ (eval₂_ring_hom i x)
  intro g H
  rcases mem_span_singleton.1 H with ⟨y, hy⟩
  rw [hy, RingHom.map_mul, coe_eval₂_ring_hom, h, MulZeroClass.zero_mul]
#align adjoin_root.lift AdjoinRoot.lift

variable {i : R →+* S} {a : S} (h : f.eval₂ i a = 0)

@[simp]
theorem lift_mk (g : R[X]) : lift i a h (mk f g) = g.eval₂ i a :=
  Ideal.Quotient.lift_mk _ _ _
#align adjoin_root.lift_mk AdjoinRoot.lift_mk

@[simp]
theorem lift_root : lift i a h (root f) = a := by rw [root, lift_mk, eval₂_X]
#align adjoin_root.lift_root AdjoinRoot.lift_root

@[simp]
theorem lift_of {x : R} : lift i a h x = i x := by rw [← mk_C x, lift_mk, eval₂_C]
#align adjoin_root.lift_of AdjoinRoot.lift_of

@[simp]
theorem lift_comp_of : (lift i a h).comp (of f) = i :=
  RingHom.ext fun _ => @lift_of _ _ _ _ _ _ _ h _
#align adjoin_root.lift_comp_of AdjoinRoot.lift_comp_of

variable (f) [Algebra R S]

/-- Produce an algebra homomorphism `adjoin_root f →ₐ[R] S` sending `root f` to
a root of `f` in `S`. -/
def liftHom (x : S) (hfx : aeval x f = 0) : AdjoinRoot f →ₐ[R] S :=
  { lift (algebraMap R S) x hfx with
    commutes' := fun r => show lift _ _ hfx r = _ from lift_of hfx }
#align adjoin_root.lift_hom AdjoinRoot.liftHom

@[simp]
theorem coe_liftHom (x : S) (hfx : aeval x f = 0) :
    (liftHom f x hfx : AdjoinRoot f →+* S) = lift (algebraMap R S) x hfx :=
  rfl
#align adjoin_root.coe_lift_hom AdjoinRoot.coe_liftHom

@[simp]
theorem aeval_algHom_eq_zero (ϕ : AdjoinRoot f →ₐ[R] S) : aeval (ϕ (root f)) f = 0 :=
  by
  have h : ϕ.to_ring_hom.comp (of f) = algebraMap R S := ring_hom.ext_iff.mpr ϕ.commutes
  rw [aeval_def, ← h, ← RingHom.map_zero ϕ.to_ring_hom, ← eval₂_root f, hom_eval₂]
  rfl
#align adjoin_root.aeval_alg_hom_eq_zero AdjoinRoot.aeval_algHom_eq_zero

@[simp]
theorem liftHom_eq_algHom (f : R[X]) (ϕ : AdjoinRoot f →ₐ[R] S) :
    liftHom f (ϕ (root f)) (aeval_algHom_eq_zero f ϕ) = ϕ :=
  by
  suffices ϕ.equalizer (lift_hom f (ϕ (root f)) (aeval_alg_hom_eq_zero f ϕ)) = ⊤ by
    exact (AlgHom.ext fun x => (set_like.ext_iff.mp this x).mpr Algebra.mem_top).symm
  rw [eq_top_iff, ← adjoin_root_eq_top, Algebra.adjoin_le_iff, Set.singleton_subset_iff]
  exact (@lift_root _ _ _ _ _ _ _ (aeval_alg_hom_eq_zero f ϕ)).symm
#align adjoin_root.lift_hom_eq_alg_hom AdjoinRoot.liftHom_eq_algHom

variable (hfx : aeval a f = 0)

@[simp]
theorem liftHom_mk {g : R[X]} : liftHom f a hfx (mk f g) = aeval a g :=
  lift_mk hfx g
#align adjoin_root.lift_hom_mk AdjoinRoot.liftHom_mk

@[simp]
theorem liftHom_root : liftHom f a hfx (root f) = a :=
  lift_root hfx
#align adjoin_root.lift_hom_root AdjoinRoot.liftHom_root

@[simp]
theorem liftHom_of {x : R} : liftHom f a hfx (of f x) = algebraMap _ _ x :=
  lift_of hfx
#align adjoin_root.lift_hom_of AdjoinRoot.liftHom_of

section AdjoinInv

@[simp]
theorem root_is_inv (r : R) : of _ r * root (C r * X - 1) = 1 := by
  convert sub_eq_zero.1 ((eval₂_sub _).symm.trans <| eval₂_root <| C r * X - 1) <;>
    simp only [eval₂_mul, eval₂_C, eval₂_X, eval₂_one]
#align adjoin_root.root_is_inv AdjoinRoot.root_is_inv

theorem algHom_subsingleton {S : Type _} [CommRing S] [Algebra R S] {r : R} :
    Subsingleton (AdjoinRoot (C r * X - 1) →ₐ[R] S) :=
  ⟨fun f g =>
    algHom_ext
      (@inv_unique _ _ (algebraMap R S r) _ _
        (by rw [← f.commutes, ← f.map_mul, algebra_map_eq, root_is_inv, map_one])
        (by rw [← g.commutes, ← g.map_mul, algebra_map_eq, root_is_inv, map_one]))⟩
#align adjoin_root.alg_hom_subsingleton AdjoinRoot.algHom_subsingleton

end AdjoinInv

section Prime

variable {f}

theorem isDomain_of_prime (hf : Prime f) : IsDomain (AdjoinRoot f) :=
  (Ideal.Quotient.isDomain_iff_prime (span {f} : Ideal R[X])).mpr <|
    (Ideal.span_singleton_prime hf.NeZero).mpr hf
#align adjoin_root.is_domain_of_prime AdjoinRoot.isDomain_of_prime

theorem noZeroSMulDivisors_of_prime_of_degree_ne_zero [IsDomain R] (hf : Prime f)
    (hf' : f.degree ≠ 0) : NoZeroSMulDivisors R (AdjoinRoot f) :=
  haveI := is_domain_of_prime hf
  no_zero_smul_divisors.iff_algebra_map_injective.mpr (of.injective_of_degree_ne_zero hf')
#align adjoin_root.no_zero_smul_divisors_of_prime_of_degree_ne_zero AdjoinRoot.noZeroSMulDivisors_of_prime_of_degree_ne_zero

end Prime

end CommRing

section Irreducible

variable [Field K] {f : K[X]}

instance span_maximal_of_irreducible [Fact (Irreducible f)] : (span {f}).IsMaximal :=
  PrincipalIdealRing.isMaximal_of_irreducible <| Fact.out _
#align adjoin_root.span_maximal_of_irreducible AdjoinRoot.span_maximal_of_irreducible

noncomputable instance field [Fact (Irreducible f)] : Field (AdjoinRoot f) :=
  { AdjoinRoot.commRing f, Ideal.Quotient.field (span {f} : Ideal K[X]) with }
#align adjoin_root.field AdjoinRoot.field

theorem coe_injective (h : degree f ≠ 0) : Function.Injective (coe : K → AdjoinRoot f) :=
  have := AdjoinRoot.nontrivial f h
  (of f).Injective
#align adjoin_root.coe_injective AdjoinRoot.coe_injective

theorem coe_injective' [Fact (Irreducible f)] : Function.Injective (coe : K → AdjoinRoot f) :=
  (of f).Injective
#align adjoin_root.coe_injective' AdjoinRoot.coe_injective'

variable (f)

theorem mul_div_root_cancel [Fact (Irreducible f)] :
    (X - C (root f)) * (f.map (of f) / (X - C (root f))) = f.map (of f) :=
  mul_div_eq_iff_isRoot.2 <| isRoot_root _
#align adjoin_root.mul_div_root_cancel AdjoinRoot.mul_div_root_cancel

end Irreducible

section IsNoetherianRing

instance [CommRing R] [IsNoetherianRing R] {f : R[X]} : IsNoetherianRing (AdjoinRoot f) :=
  Ideal.Quotient.isNoetherianRing _

end IsNoetherianRing

section PowerBasis

variable [CommRing R] {g : R[X]}

theorem isIntegral_root' (hg : g.Monic) : IsIntegral R (root g) :=
  ⟨g, hg, eval₂_root g⟩
#align adjoin_root.is_integral_root' AdjoinRoot.isIntegral_root'

/-- `adjoin_root.mod_by_monic_hom` sends the equivalence class of `f` mod `g` to `f %ₘ g`.

This is a well-defined right inverse to `adjoin_root.mk`, see `adjoin_root.mk_left_inverse`. -/
def modByMonicHom (hg : g.Monic) : AdjoinRoot g →ₗ[R] R[X] :=
  (Submodule.liftQ _ (Polynomial.modByMonicHom g)
        fun f (hf : f ∈ (Ideal.span {g}).restrictScalars R) =>
        (mem_ker_mod_by_monic hg).mpr (Ideal.mem_span_singleton.mp hf)).comp <|
    (Submodule.Quotient.restrictScalarsEquiv R (Ideal.span {g} : Ideal R[X])).symm.toLinearMap
#align adjoin_root.mod_by_monic_hom AdjoinRoot.modByMonicHom

@[simp]
theorem modByMonicHom_mk (hg : g.Monic) (f : R[X]) : modByMonicHom hg (mk g f) = f %ₘ g :=
  rfl
#align adjoin_root.mod_by_monic_hom_mk AdjoinRoot.modByMonicHom_mk

theorem mk_leftInverse (hg : g.Monic) : Function.LeftInverse (mk g) (modByMonicHom hg) := fun f =>
  induction_on g f fun f =>
    by
    rw [mod_by_monic_hom_mk hg, mk_eq_mk, mod_by_monic_eq_sub_mul_div _ hg, sub_sub_cancel_left,
      dvd_neg]
    apply dvd_mul_right
#align adjoin_root.mk_left_inverse AdjoinRoot.mk_leftInverse

theorem mk_surjective (hg : g.Monic) : Function.Surjective (mk g) :=
  (mk_leftInverse hg).Surjective
#align adjoin_root.mk_surjective AdjoinRoot.mk_surjective

/-- The elements `1, root g, ..., root g ^ (d - 1)` form a basis for `adjoin_root g`,
where `g` is a monic polynomial of degree `d`. -/
def powerBasisAux' (hg : g.Monic) : Basis (Fin g.natDegree) R (AdjoinRoot g) :=
  Basis.ofEquivFun
    { toFun := fun f i => (modByMonicHom hg f).coeff i
      invFun := fun c => mk g <| ∑ i : Fin g.natDegree, monomial i (c i)
      map_add' := fun f₁ f₂ =>
        funext fun i => by simp only [(mod_by_monic_hom hg).map_add, coeff_add, Pi.add_apply]
      map_smul' := fun f₁ f₂ =>
        funext fun i => by
          simp only [(mod_by_monic_hom hg).map_smul, coeff_smul, Pi.smul_apply, RingHom.id_apply]
      left_inv := fun f =>
        induction_on g f fun f =>
          Eq.symm <|
            mk_eq_mk.mpr <|
              by
              simp only [mod_by_monic_hom_mk, sum_mod_by_monic_coeff hg degree_le_nat_degree]
              rw [mod_by_monic_eq_sub_mul_div _ hg, sub_sub_cancel]
              exact dvd_mul_right _ _
      right_inv := fun x =>
        funext fun i => by
          nontriviality R
          simp only [mod_by_monic_hom_mk]
          rw [(mod_by_monic_eq_self_iff hg).mpr, finset_sum_coeff]
          · simp_rw [coeff_monomial, Fin.val_eq_val, Finset.sum_ite_eq', if_pos (Finset.mem_univ _)]
          · simp_rw [← C_mul_X_pow_eq_monomial]
            exact (degree_eq_nat_degree <| hg.ne_zero).symm ▸ degree_sum_fin_lt _ }
#align adjoin_root.power_basis_aux' AdjoinRoot.powerBasisAux'

/-- This lemma could be autogenerated by `@[simps]` but unfortunately that would require
unfolding that causes a timeout. -/
@[simp]
theorem powerBasisAux'_repr_symm_apply (hg : g.Monic) (c : Fin g.natDegree →₀ R) :
    (powerBasisAux' hg).repr.symm c = mk g (∑ i : Fin _, monomial i (c i)) :=
  rfl
#align adjoin_root.power_basis_aux'_repr_symm_apply AdjoinRoot.powerBasisAux'_repr_symm_apply

/-- This lemma could be autogenerated by `@[simps]` but unfortunately that would require
unfolding that causes a timeout. -/
@[simp]
theorem powerBasisAux'_repr_apply_to_fun (hg : g.Monic) (f : AdjoinRoot g) (i : Fin g.natDegree) :
    (powerBasisAux' hg).repr f i = (modByMonicHom hg f).coeff ↑i :=
  rfl
#align adjoin_root.power_basis_aux'_repr_apply_to_fun AdjoinRoot.powerBasisAux'_repr_apply_to_fun

/-- The power basis `1, root g, ..., root g ^ (d - 1)` for `adjoin_root g`,
where `g` is a monic polynomial of degree `d`. -/
@[simps]
def powerBasis' (hg : g.Monic) : PowerBasis R (AdjoinRoot g)
    where
  gen := root g
  dim := g.natDegree
  Basis := powerBasisAux' hg
  basis_eq_pow i :=
    by
    simp only [power_basis_aux', Basis.coe_ofEquivFun, LinearEquiv.coe_symm_mk]
    rw [Finset.sum_eq_single i]
    · rw [Function.update_same, monomial_one_right_eq_X_pow, (mk g).map_pow, mk_X]
    · intro j _ hj
      rw [← monomial_zero_right _]
      convert congr_arg _ (Function.update_noteq hj _ _)
    -- Fix `decidable_eq` mismatch
    · intros
      have := Finset.mem_univ i
      contradiction
#align adjoin_root.power_basis' AdjoinRoot.powerBasis'

variable [Field K] {f : K[X]}

theorem isIntegral_root (hf : f ≠ 0) : IsIntegral K (root f) :=
  isAlgebraic_iff_isIntegral.mp (isAlgebraic_root hf)
#align adjoin_root.is_integral_root AdjoinRoot.isIntegral_root

theorem minpoly_root (hf : f ≠ 0) : minpoly K (root f) = f * C f.leadingCoeff⁻¹ :=
  by
  have f'_monic : monic _ := monic_mul_leading_coeff_inv hf
  refine' (minpoly.unique K _ f'_monic _ _).symm
  · rw [AlgHom.map_mul, aeval_eq, mk_self, MulZeroClass.zero_mul]
  intro q q_monic q_aeval
  have commutes : (lift (algebraMap K (AdjoinRoot f)) (root f) q_aeval).comp (mk q) = mk f :=
    by
    ext
    · simp only [RingHom.comp_apply, mk_C, lift_of]
      rfl
    · simp only [RingHom.comp_apply, mk_X, lift_root]
  rw [degree_eq_nat_degree f'_monic.ne_zero, degree_eq_nat_degree q_monic.ne_zero,
    WithBot.coe_le_coe, nat_degree_mul hf, nat_degree_C, add_zero]
  apply nat_degree_le_of_dvd
  · have : mk f q = 0 := by rw [← commutes, RingHom.comp_apply, mk_self, RingHom.map_zero]
    rwa [← Ideal.mem_span_singleton, ← Ideal.Quotient.eq_zero_iff_mem]
  · exact q_monic.ne_zero
  · rwa [Ne.def, C_eq_zero, inv_eq_zero, leading_coeff_eq_zero]
#align adjoin_root.minpoly_root AdjoinRoot.minpoly_root

/-- The elements `1, root f, ..., root f ^ (d - 1)` form a basis for `adjoin_root f`,
where `f` is an irreducible polynomial over a field of degree `d`. -/
def powerBasisAux (hf : f ≠ 0) : Basis (Fin f.natDegree) K (AdjoinRoot f) :=
  by
  set f' := f * C f.leading_coeff⁻¹ with f'_def
  have deg_f' : f'.nat_degree = f.nat_degree :=
    by
    rw [nat_degree_mul hf, nat_degree_C, add_zero]
    · rwa [Ne.def, C_eq_zero, inv_eq_zero, leading_coeff_eq_zero]
  have minpoly_eq : minpoly K (root f) = f' := minpoly_root hf
  apply @Basis.mk _ _ _ fun i : Fin f.nat_degree => root f ^ i.val
  · rw [← deg_f', ← minpoly_eq]
    exact linearIndependent_pow (root f)
  · rintro y -
    rw [← deg_f', ← minpoly_eq]
    apply (is_integral_root hf).mem_span_pow
    obtain ⟨g⟩ := y
    use g
    rw [aeval_eq]
    rfl
#align adjoin_root.power_basis_aux AdjoinRoot.powerBasisAux

/-- The power basis `1, root f, ..., root f ^ (d - 1)` for `adjoin_root f`,
where `f` is an irreducible polynomial over a field of degree `d`. -/
@[simps]
def powerBasis (hf : f ≠ 0) : PowerBasis K (AdjoinRoot f)
    where
  gen := root f
  dim := f.natDegree
  Basis := powerBasisAux hf
  basis_eq_pow := Basis.mk_apply _ _
#align adjoin_root.power_basis AdjoinRoot.powerBasis

theorem minpoly_powerBasis_gen (hf : f ≠ 0) :
    minpoly K (powerBasis hf).gen = f * C f.leadingCoeff⁻¹ := by
  rw [power_basis_gen, minpoly_root hf]
#align adjoin_root.minpoly_power_basis_gen AdjoinRoot.minpoly_powerBasis_gen

theorem minpoly_powerBasis_gen_of_monic (hf : f.Monic) (hf' : f ≠ 0 := hf.NeZero) :
    minpoly K (powerBasis hf').gen = f := by
  rw [minpoly_power_basis_gen hf', hf.leading_coeff, inv_one, C.map_one, mul_one]
#align adjoin_root.minpoly_power_basis_gen_of_monic AdjoinRoot.minpoly_powerBasis_gen_of_monic

end PowerBasis

section Equiv

section minpoly

variable [CommRing R] [CommRing S] [Algebra R S] (x : S) (R)

open Algebra Polynomial

/-- The surjective algebra morphism `R[X]/(minpoly R x) → R[x]`.
If `R` is a GCD domain and `x` is integral, this is an isomorphism,
see `adjoin_root.minpoly.equiv_adjoin`. -/
@[simps]
def Minpoly.toAdjoin : AdjoinRoot (minpoly R x) →ₐ[R] adjoin R ({x} : Set S) :=
  liftHom _ ⟨x, self_mem_adjoin_singleton R x⟩
    (by simp [← Subalgebra.coe_eq_zero, aeval_subalgebra_coe])
#align adjoin_root.minpoly.to_adjoin AdjoinRoot.Minpoly.toAdjoin

variable {R x}

theorem Minpoly.toAdjoin_apply' (a : AdjoinRoot (minpoly R x)) :
    Minpoly.toAdjoin R x a =
      liftHom (minpoly R x) (⟨x, self_mem_adjoin_singleton R x⟩ : adjoin R ({x} : Set S))
        (by simp [← Subalgebra.coe_eq_zero, aeval_subalgebra_coe]) a :=
  rfl
#align adjoin_root.minpoly.to_adjoin_apply' AdjoinRoot.Minpoly.toAdjoin_apply'

theorem Minpoly.toAdjoin.apply_x :
    Minpoly.toAdjoin R x (mk (minpoly R x) X) = ⟨x, self_mem_adjoin_singleton R x⟩ := by simp
#align adjoin_root.minpoly.to_adjoin.apply_X AdjoinRoot.Minpoly.toAdjoin.apply_x

variable (R x)

theorem Minpoly.toAdjoin.surjective : Function.Surjective (Minpoly.toAdjoin R x) :=
  by
  rw [← range_top_iff_surjective, _root_.eq_top_iff, ← adjoin_adjoin_coe_preimage]
  refine' adjoin_le _
  simp only [AlgHom.coe_range, Set.mem_range]
  rintro ⟨y₁, y₂⟩ h
  refine' ⟨mk (minpoly R x) X, by simpa using h.symm⟩
#align adjoin_root.minpoly.to_adjoin.surjective AdjoinRoot.Minpoly.toAdjoin.surjective

end minpoly

section Equiv'

variable [CommRing R] [CommRing S] [Algebra R S]

variable (g : R[X]) (pb : PowerBasis R S)

/-- If `S` is an extension of `R` with power basis `pb` and `g` is a monic polynomial over `R`
such that `pb.gen` has a minimal polynomial `g`, then `S` is isomorphic to `adjoin_root g`.

Compare `power_basis.equiv_of_root`, which would require
`h₂ : aeval pb.gen (minpoly R (root g)) = 0`; that minimal polynomial is not
guaranteed to be identical to `g`. -/
@[simps (config := { fullyApplied := false })]
def equiv' (h₁ : aeval (root g) (minpoly R pb.gen) = 0) (h₂ : aeval pb.gen g = 0) :
    AdjoinRoot g ≃ₐ[R] S :=
  {
    AdjoinRoot.liftHom g pb.gen
      h₂ with
    toFun := AdjoinRoot.liftHom g pb.gen h₂
    invFun := pb.lift (root g) h₁
    left_inv := fun x => induction_on g x fun f => by rw [lift_hom_mk, pb.lift_aeval, aeval_eq]
    right_inv := fun x => by
      nontriviality S
      obtain ⟨f, hf, rfl⟩ := pb.exists_eq_aeval x
      rw [pb.lift_aeval, aeval_eq, lift_hom_mk] }
#align adjoin_root.equiv' AdjoinRoot.equiv'

@[simp]
theorem equiv'_toAlgHom (h₁ : aeval (root g) (minpoly R pb.gen) = 0) (h₂ : aeval pb.gen g = 0) :
    (equiv' g pb h₁ h₂).toAlgHom = AdjoinRoot.liftHom g pb.gen h₂ :=
  rfl
#align adjoin_root.equiv'_to_alg_hom AdjoinRoot.equiv'_toAlgHom

@[simp]
theorem equiv'_symm_toAlgHom (h₁ : aeval (root g) (minpoly R pb.gen) = 0)
    (h₂ : aeval pb.gen g = 0) : (equiv' g pb h₁ h₂).symm.toAlgHom = pb.lift (root g) h₁ :=
  rfl
#align adjoin_root.equiv'_symm_to_alg_hom AdjoinRoot.equiv'_symm_toAlgHom

end Equiv'

section Field

variable (K) (L F : Type _) [Field F] [Field K] [Field L] [Algebra F K] [Algebra F L]

variable (pb : PowerBasis F K)

/-- If `L` is a field extension of `F` and `f` is a polynomial over `F` then the set
of maps from `F[x]/(f)` into `L` is in bijection with the set of roots of `f` in `L`. -/
def equiv (f : F[X]) (hf : f ≠ 0) :
    (AdjoinRoot f →ₐ[F] L) ≃ { x // x ∈ (f.map (algebraMap F L)).roots } :=
  (powerBasis hf).liftEquiv'.trans
    ((Equiv.refl _).subtypeEquiv fun x =>
      by
      rw [power_basis_gen, minpoly_root hf, Polynomial.map_mul, roots_mul, Polynomial.map_C,
        roots_C, add_zero, Equiv.refl_apply]
      rw [← Polynomial.map_mul]; exact map_monic_ne_zero (monic_mul_leading_coeff_inv hf))
#align adjoin_root.equiv AdjoinRoot.equiv

end Field

end Equiv

section

open Ideal DoubleQuot Polynomial

variable [CommRing R] (I : Ideal R) (f : R[X])

/-- The natural isomorphism `R[α]/(I[α]) ≅ R[α]/((I[x] ⊔ (f)) / (f))` for `α` a root of
`f : R[X]` and `I : ideal R`.

See `adjoin_root.quot_map_of_equiv` for the isomorphism with `(R/I)[X] / (f mod I)`. -/
def quotMapOfEquivQuotMapCMapSpanMk :
    AdjoinRoot f ⧸ I.map (of f) ≃+*
      AdjoinRoot f ⧸ (I.map (C : R →+* R[X])).map (span {f}).Quotient.mk :=
  Ideal.quotEquivOfEq (by rw [of, AdjoinRoot.mk, Ideal.map_map])
#align adjoin_root.quot_map_of_equiv_quot_map_C_map_span_mk AdjoinRoot.quotMapOfEquivQuotMapCMapSpanMk

@[simp]
theorem quotMapOfEquivQuotMapCMapSpanMk_mk (x : AdjoinRoot f) :
    quotMapOfEquivQuotMapCMapSpanMk I f (Ideal.Quotient.mk (I.map (of f)) x) =
      Ideal.Quotient.mk _ x :=
  rfl
#align adjoin_root.quot_map_of_equiv_quot_map_C_map_span_mk_mk AdjoinRoot.quotMapOfEquivQuotMapCMapSpanMk_mk

--this lemma should have the simp tag but this causes a lint issue
theorem quotMapOfEquivQuotMapCMapSpanMk_symm_mk (x : AdjoinRoot f) :
    (quotMapOfEquivQuotMapCMapSpanMk I f).symm
        (Ideal.Quotient.mk ((I.map (C : R →+* R[X])).map (span {f}).Quotient.mk) x) =
      Ideal.Quotient.mk (I.map (of f)) x :=
  by rw [quot_map_of_equiv_quot_map_C_map_span_mk, Ideal.quotEquivOfEq_symm, quot_equiv_of_eq_mk]
#align adjoin_root.quot_map_of_equiv_quot_map_C_map_span_mk_symm_mk AdjoinRoot.quotMapOfEquivQuotMapCMapSpanMk_symm_mk

/-- The natural isomorphism `R[α]/((I[x] ⊔ (f)) / (f)) ≅ (R[x]/I[x])/((f) ⊔ I[x] / I[x])`
  for `α` a root of `f : R[X]` and `I : ideal R`-/
def quotMapCMapSpanMkEquivQuotMapCQuotMapSpanMk :
    AdjoinRoot f ⧸ (I.map (C : R →+* R[X])).map (span ({f} : Set R[X])).Quotient.mk ≃+*
      (R[X] ⧸ I.map (C : R →+* R[X])) ⧸
        (span ({f} : Set R[X])).map (I.map (C : R →+* R[X])).Quotient.mk :=
  quotQuotEquivComm (Ideal.span ({f} : Set R[X])) (I.map (C : R →+* R[X]))
#align adjoin_root.quot_map_C_map_span_mk_equiv_quot_map_C_quot_map_span_mk AdjoinRoot.quotMapCMapSpanMkEquivQuotMapCQuotMapSpanMk

@[simp]
theorem quotMapCMapSpanMkEquivQuotMapCQuotMapSpanMk_mk (p : R[X]) :
    quotMapCMapSpanMkEquivQuotMapCQuotMapSpanMk I f (Ideal.Quotient.mk _ (mk f p)) =
      quotQuotMk (I.map C) (span {f}) p :=
  rfl
#align adjoin_root.quot_map_C_map_span_mk_equiv_quot_map_C_quot_map_span_mk_mk AdjoinRoot.quotMapCMapSpanMkEquivQuotMapCQuotMapSpanMk_mk

@[simp]
theorem quotMapCMapSpanMkEquivQuotMapCQuotMapSpanMk_symm_quotQuotMk (p : R[X]) :
    (quotMapCMapSpanMkEquivQuotMapCQuotMapSpanMk I f).symm (quotQuotMk (I.map C) (span {f}) p) =
      Ideal.Quotient.mk _ (mk f p) :=
  rfl
#align adjoin_root.quot_map_C_map_span_mk_equiv_quot_map_C_quot_map_span_mk_symm_quot_quot_mk AdjoinRoot.quotMapCMapSpanMkEquivQuotMapCQuotMapSpanMk_symm_quotQuotMk

/-- The natural isomorphism `(R/I)[x]/(f mod I) ≅ (R[x]/I*R[x])/(f mod I[x])` where
  `f : R[X]` and `I : ideal R`-/
def Polynomial.quotQuotEquivComm :
    (R ⧸ I)[X] ⧸ span ({f.map I.Quotient.mk} : Set (Polynomial (R ⧸ I))) ≃+*
      (R[X] ⧸ map C I) ⧸ span ({(Ideal.Quotient.mk (I C)) f} : Set (R[X] ⧸ map C I)) :=
  quotientEquiv (span ({f.map I.Quotient.mk} : Set (Polynomial (R ⧸ I))))
    (span {Ideal.Quotient.mk (I.map Polynomial.C) f}) (polynomialQuotientEquivQuotientPolynomial I)
    (by
      rw [map_span, Set.image_singleton, RingEquiv.coe_toRingHom,
        polynomial_quotient_equiv_quotient_polynomial_map_mk I f])
#align adjoin_root.polynomial.quot_quot_equiv_comm AdjoinRoot.Polynomial.quotQuotEquivComm

@[simp]
theorem Polynomial.quotQuotEquivComm_mk (p : R[X]) :
    (Polynomial.quotQuotEquivComm I f) (Ideal.Quotient.mk _ (p.map I.Quotient.mk)) =
      Ideal.Quotient.mk _ (Ideal.Quotient.mk _ p) :=
  by
  simp only [polynomial.quot_quot_equiv_comm, quotient_equiv_mk,
    polynomial_quotient_equiv_quotient_polynomial_map_mk]
#align adjoin_root.polynomial.quot_quot_equiv_comm_mk AdjoinRoot.Polynomial.quotQuotEquivComm_mk

@[simp]
theorem Polynomial.quotQuotEquivComm_symm_mk_mk (p : R[X]) :
    (Polynomial.quotQuotEquivComm I f).symm (Ideal.Quotient.mk _ (Ideal.Quotient.mk _ p)) =
      Ideal.Quotient.mk _ (p.map I.Quotient.mk) :=
  by
  simp only [polynomial.quot_quot_equiv_comm, quotient_equiv_symm_mk,
    polynomial_quotient_equiv_quotient_polynomial_symm_mk]
#align adjoin_root.polynomial.quot_quot_equiv_comm_symm_mk_mk AdjoinRoot.Polynomial.quotQuotEquivComm_symm_mk_mk

/-- The natural isomorphism `R[α]/I[α] ≅ (R/I)[X]/(f mod I)` for `α` a root of `f : R[X]`
  and `I : ideal R`.-/
def quotAdjoinRootEquivQuotPolynomialQuot :
    AdjoinRoot f ⧸ I.map (of f) ≃+* (R ⧸ I)[X] ⧸ span ({f.map I.Quotient.mk} : Set (R ⧸ I)[X]) :=
  (quotMapOfEquivQuotMapCMapSpanMk I f).trans
    ((quotMapCMapSpanMkEquivQuotMapCQuotMapSpanMk I f).trans
      ((Ideal.quotEquivOfEq
            (show
              (span ({f} : Set R[X])).map (I.map (C : R →+* R[X])).Quotient.mk =
                span ({(Ideal.Quotient.mk (I Polynomial.C)) f} : Set (R[X] ⧸ map C I))
              by rw [map_span, Set.image_singleton])).trans
        (Polynomial.quotQuotEquivComm I f).symm))
#align adjoin_root.quot_adjoin_root_equiv_quot_polynomial_quot AdjoinRoot.quotAdjoinRootEquivQuotPolynomialQuot

@[simp]
theorem quotAdjoinRootEquivQuotPolynomialQuot_mk_of (p : R[X]) :
    quotAdjoinRootEquivQuotPolynomialQuot I f (Ideal.Quotient.mk (I.map (of f)) (mk f p)) =
      Ideal.Quotient.mk (span ({f.map I.Quotient.mk} : Set (R ⧸ I)[X])) (p.map I.Quotient.mk) :=
  by
  rw [quot_adjoin_root_equiv_quot_polynomial_quot, RingEquiv.trans_apply, RingEquiv.trans_apply,
    RingEquiv.trans_apply, quot_map_of_equiv_quot_map_C_map_span_mk_mk,
    quot_map_C_map_span_mk_equiv_quot_map_C_quot_map_span_mk_mk, quot_quot_mk, RingHom.comp_apply,
    quot_equiv_of_eq_mk, polynomial.quot_quot_equiv_comm_symm_mk_mk]
#align adjoin_root.quot_adjoin_root_equiv_quot_polynomial_quot_mk_of AdjoinRoot.quotAdjoinRootEquivQuotPolynomialQuot_mk_of

@[simp]
theorem quotAdjoinRootEquivQuotPolynomialQuot_symm_mk_mk (p : R[X]) :
    (quotAdjoinRootEquivQuotPolynomialQuot I f).symm
        (Ideal.Quotient.mk (span ({f.map I.Quotient.mk} : Set (R ⧸ I)[X])) (p.map I.Quotient.mk)) =
      Ideal.Quotient.mk (I.map (of f)) (mk f p) :=
  by
  rw [quot_adjoin_root_equiv_quot_polynomial_quot, RingEquiv.symm_trans_apply,
    RingEquiv.symm_trans_apply, RingEquiv.symm_trans_apply, RingEquiv.symm_symm,
    polynomial.quot_quot_equiv_comm_mk, Ideal.quotEquivOfEq_symm, Ideal.quotEquivOfEq_mk, ←
    RingHom.comp_apply, ← DoubleQuot.quotQuotMk,
    quot_map_C_map_span_mk_equiv_quot_map_C_quot_map_span_mk_symm_quot_quot_mk,
    quot_map_of_equiv_quot_map_C_map_span_mk_symm_mk]
#align adjoin_root.quot_adjoin_root_equiv_quot_polynomial_quot_symm_mk_mk AdjoinRoot.quotAdjoinRootEquivQuotPolynomialQuot_symm_mk_mk

/-- Promote `adjoin_root.quot_adjoin_root_equiv_quot_polynomial_quot` to an alg_equiv.  -/
@[simps apply symm_apply]
noncomputable def quotEquivQuotMap (f : R[X]) (I : Ideal R) :
    (AdjoinRoot f ⧸ Ideal.map (of f) I) ≃ₐ[R]
      (R ⧸ I)[X] ⧸ Ideal.span ({Polynomial.map I.Quotient.mk f} : Set (R ⧸ I)[X]) :=
  AlgEquiv.ofRingEquiv
    (show ∀ x, (quotAdjoinRootEquivQuotPolynomialQuot I f) (algebraMap R _ x) = algebraMap R _ x
      from fun x =>
      by
      have :
        algebraMap R (AdjoinRoot f ⧸ Ideal.map (of f) I) x =
          Ideal.Quotient.mk (Ideal.map (AdjoinRoot.of f) I) ((mk f) (C x)) :=
        rfl
      simpa only [this, quot_adjoin_root_equiv_quot_polynomial_quot_mk_of, map_C] )
#align adjoin_root.quot_equiv_quot_map AdjoinRoot.quotEquivQuotMap

@[simp]
theorem quotEquivQuotMap_apply_mk (f g : R[X]) (I : Ideal R) :
    AdjoinRoot.quotEquivQuotMap f I (Ideal.Quotient.mk _ (AdjoinRoot.mk f g)) =
      Ideal.Quotient.mk _ (g.map I.Quotient.mk) :=
  by rw [AdjoinRoot.quotEquivQuotMap_apply, AdjoinRoot.quotAdjoinRootEquivQuotPolynomialQuot_mk_of]
#align adjoin_root.quot_equiv_quot_map_apply_mk AdjoinRoot.quotEquivQuotMap_apply_mk

@[simp]
theorem quotEquivQuotMap_symm_apply_mk (f g : R[X]) (I : Ideal R) :
    (AdjoinRoot.quotEquivQuotMap f I).symm (Ideal.Quotient.mk _ (map (Ideal.Quotient.mk I) g)) =
      Ideal.Quotient.mk _ (AdjoinRoot.mk f g) :=
  by
  rw [AdjoinRoot.quotEquivQuotMap_symm_apply,
    AdjoinRoot.quotAdjoinRootEquivQuotPolynomialQuot_symm_mk_mk]
#align adjoin_root.quot_equiv_quot_map_symm_apply_mk AdjoinRoot.quotEquivQuotMap_symm_apply_mk

end

end AdjoinRoot

namespace PowerBasis

open AdjoinRoot AlgEquiv

variable [CommRing R] [CommRing S] [Algebra R S]

/-- Let `α` have minimal polynomial `f` over `R` and `I` be an ideal of `R`,
then `R[α] / (I) = (R[x] / (f)) / pS = (R/p)[x] / (f mod p)`. -/
@[simps apply symm_apply]
noncomputable def quotientEquivQuotientMinpolyMap (pb : PowerBasis R S) (I : Ideal R) :
    (S ⧸ I.map (algebraMap R S)) ≃ₐ[R]
      Polynomial (R ⧸ I) ⧸
        Ideal.span ({(minpoly R pb).map I.Quotient.mk} : Set (Polynomial (R ⧸ I))) :=
  (ofRingEquiv
        (show
          ∀ x,
            (Ideal.quotientEquiv _ (Ideal.map (AdjoinRoot.of (minpoly R pb.gen)) I)
                  (AdjoinRoot.equiv' (minpoly R pb.gen) pb
                        (by rw [AdjoinRoot.aeval_eq, AdjoinRoot.mk_self])
                        (minpoly.aeval _ _)).symm.toRingEquiv
                  (by
                    rw [Ideal.map_map, AlgEquiv.toRingEquiv_eq_coe, ← AlgEquiv.coe_ringHom_commutes,
                      ← AdjoinRoot.algebraMap_eq, AlgHom.comp_algebraMap]))
                (algebraMap R (S ⧸ I.map (algebraMap R S)) x) =
              algebraMap R _ x
          from fun x => by
          rw [← Ideal.Quotient.mk_algebraMap, Ideal.quotientEquiv_apply, RingHom.toFun_eq_coe,
            Ideal.quotientMap_mk, AlgEquiv.toRingEquiv_eq_coe, RingEquiv.coe_toRingHom,
            AlgEquiv.coe_ringEquiv, AlgEquiv.commutes, quotient.mk_algebra_map])).trans
    (AdjoinRoot.quotEquivQuotMap _ _)
#align power_basis.quotient_equiv_quotient_minpoly_map PowerBasis.quotientEquivQuotientMinpolyMap

@[simp]
theorem quotientEquivQuotientMinpolyMap_apply_mk (pb : PowerBasis R S) (I : Ideal R) (g : R[X]) :
    pb.quotientEquivQuotientMinpolyMap I (Ideal.Quotient.mk _ (aeval pb.gen g)) =
      Ideal.Quotient.mk _ (g.map I.Quotient.mk) :=
  by
  rw [PowerBasis.quotientEquivQuotientMinpolyMap, AlgEquiv.trans_apply, AlgEquiv.ofRingEquiv_apply,
    quotient_equiv_mk, AlgEquiv.coe_ringEquiv', AdjoinRoot.equiv'_symm_apply, PowerBasis.lift_aeval,
    AdjoinRoot.aeval_eq, AdjoinRoot.quotEquivQuotMap_apply_mk]
#align power_basis.quotient_equiv_quotient_minpoly_map_apply_mk PowerBasis.quotientEquivQuotientMinpolyMap_apply_mk

@[simp]
theorem quotientEquivQuotientMinpolyMap_symm_apply_mk (pb : PowerBasis R S) (I : Ideal R)
    (g : R[X]) :
    (pb.quotientEquivQuotientMinpolyMap I).symm (Ideal.Quotient.mk _ (g.map I.Quotient.mk)) =
      Ideal.Quotient.mk _ (aeval pb.gen g) :=
  by
  simp only [quotient_equiv_quotient_minpoly_map, to_ring_equiv_eq_coe, symm_trans_apply,
    quot_equiv_quot_map_symm_apply_mk, of_ring_equiv_symm_apply, quotient_equiv_symm_mk,
    to_ring_equiv_symm, RingEquiv.symm_symm, AdjoinRoot.equiv'_apply, coe_ring_equiv, lift_hom_mk,
    symm_to_ring_equiv]
#align power_basis.quotient_equiv_quotient_minpoly_map_symm_apply_mk PowerBasis.quotientEquivQuotientMinpolyMap_symm_apply_mk

end PowerBasis


import order.filter.ennreal
import order.liminf_limsup
import topology.instances.nnreal

section nnreal

open filter
open_locale nnreal

--variables  {f : filter α} [countable_Inter_filter f]

lemma limsup_const_mul {α : Type*} {f : filter α } (hf : f.ne_bot) (u : α → ℝ≥0) (a : ℝ≥0)
  (hu_bdd : is_bounded_under has_le.le f u) : --(hu_cob : is_cobounded_under has_le.le f u) :
  f.limsup (λ (x : α), a * (u x)) = a * f.limsup u :=
begin
  by_cases ha_zero : a = 0,
  { simp_rw [ha_zero, zero_mul],
    exact limsup_const 0 },
  let g := λ x : ℝ≥0, a * x,
  have hg_bij : function.bijective g,
  from function.bijective_iff_has_inverse.mpr ⟨(λ x, a⁻¹ * x),
    ⟨λ x, by simp [←mul_assoc, inv_mul_cancel ha_zero],
    λ x, by simp [g, ←mul_assoc, mul_inv_cancel ha_zero]⟩⟩,
  have hg_mono : strict_mono g,
  { exact monotone.strict_mono_of_injective (λ x y hxy, mul_le_mul_left' hxy _) hg_bij.1 },
  let g_iso := strict_mono.order_iso_of_surjective g hg_mono hg_bij.2,
  refine (order_iso.limsup_apply g_iso _ _ _ _).symm,
  { exact hu_bdd },
  { use [0, λ a ha, zero_le'], },
  { obtain ⟨b, hb⟩ := hu_bdd,
    simp only [strict_mono.coe_order_iso_of_surjective, auto_param_eq],
    use g b,
    simp only [eventually_map, filter.eventually, mem_map, set.preimage_set_of_eq] at hb ⊢,
    simp_rw hg_mono.le_iff_le,
    exact hb, },
  { use [0, λ a ha, zero_le'], }
end

lemma limsup_mul_const {α : Type*} {f : filter α} (hf : f.ne_bot) (u : α → ℝ≥0) (a : ℝ≥0)
  (hu_bdd : is_bounded_under has_le.le f u) :
  f.limsup (λ (x : α), (u x) * a) = f.limsup u * a:=
begin
  rw mul_comm,
  simp_rw mul_comm,
  exact limsup_const_mul hf u a hu_bdd,
end

lemma foo {f : filter ℕ } (hf : f.ne_bot) (u : ℕ → ℝ≥0)
  (hu_bdd : is_bounded_under has_le.le f u) :
  (((f.limsup u) : nnreal) : ennreal) = f.limsup (λ x : ℕ, (u x : ennreal)) :=
begin
 -- obtain ⟨b, hb⟩ := hu_bdd,
  --simp only [eventually_map, filter.eventually, mem_map, set.preimage_set_of_eq] at hb,

  ext x,
  simp only [option.mem_def, ennreal.some_eq_coe, ennreal.coe_eq_coe],
  simp only [filter.limsup_eq],
  simp only [subset_Inf_def],
  have hcInf : (0 : ℝ) ≤ Inf (coe '' {a : ℝ≥0 | ∀ᶠ (n : ℕ) in f, u n ≤ a}),
  { refine le_cInf _ _,
    { simp only [set.nonempty_image_iff],
      exact hu_bdd },
    intros b hb,
    simp only [set.mem_image, set_coe.exists, subtype.coe_mk, exists_and_distrib_right,
      exists_eq_right] at hb,
    obtain ⟨c, hc_in, hcb⟩ := hb,
    rw ← hcb,
    exact nnreal.coe_nonneg c },
  erw dif_pos hcInf,
  { split; intro h,
    { rw ← h,
      have : ((⟨Inf ((coe : nnreal → ℝ) '' {a : ℝ≥0 | ∀ᶠ (n : ℕ) in f, u n ≤ a}),
        hcInf⟩ : nnreal): ℝ) =
        Inf ((coe : nnreal → ℝ) '' {a : ℝ≥0 | ∀ᶠ (n : ℕ) in f, u n ≤ a}) := rfl,
      sorry--rw this,
      },
    { sorry }},

end

section ennreal

--variables {α : Type*}

lemma eventually_le_limsup'  (u : ℕ → ennreal) :
  ∀ᶠ y in (filter.at_top : filter ℕ), u y ≤ (filter.at_top : filter ℕ).limsup u :=
begin
  set f := (filter.at_top : filter ℕ) with hf,
  by_cases hx_top : f.limsup u = ⊤,
  { simp_rw hx_top,
    exact eventually_of_forall (λ a, le_top), },
  have h_forall_le : ∀ᶠ y in f, ∀ n : ℕ, u y < f.limsup u + (1:ennreal)/n,
  { rw hf,
    simp only [eventually_at_top, ge_iff_le],
    sorry,/-  rw eventually_countable_forall,
    refine λ n, eventually_lt_of_limsup_lt _,
    nth_rewrite 0 ←add_zero (f.limsup u),
    exact (ennreal.add_lt_add_iff_left hx_top).mpr (by simp), -/ },
  refine h_forall_le.mono (λ y hy, ennreal.le_of_forall_pos_le_add (λ r hr_pos hx_top, _)),
  have hr_ne_zero : (r : ennreal) ≠ 0,
  { rw [ne.def, ennreal.coe_eq_zero],
    exact (ne_of_lt hr_pos).symm, },
  cases (ennreal.exists_inv_nat_lt hr_ne_zero) with i hi,
  rw inv_eq_one_div at hi,
  exact (hy i).le.trans (add_le_add_left hi.le (f.limsup u)),
end

end ennreal

#exit

lemma eventually_le_limsup {α : Type*} {f : filter α } [countable_Inter_filter f] (hf : f.ne_bot) (u : α → ℝ≥0) (a : ℝ≥0)
  (hu_bdd : is_bounded_under has_le.le f u) :
  ∀ᶠ y in f, u y ≤ f.limsup u :=
begin
  simp_rw ← ennreal.coe_le_coe,
  simp_rw foo hf u hu_bdd,
  exact ennreal.eventually_le_limsup _,
end

instance : countable_Inter_filter (filter.at_top : filter ℕ ) := infer_instance

#exit
lemma limsup_mul_le_of_bdd (u v : ℕ → nnreal) :
  filter.limsup filter.at_top (u * v) ≤ filter.at_top.limsup u * filter.at_top.limsup v :=
begin
  have : filter.at_top.limsup (u * v) ≤ filter.at_top.limsup (λ x, (filter.at_top.limsup u) * v x),
  { apply limsup_le_limsup,
    { filter_upwards [eventually_le_limsup _ u _] with x hx,
      exact mul_le_mul' hx le_rfl, },
    { obtain ⟨a, ha⟩ := eventually_at_top.mp (eventually_le_limsup v),
      use filter.at_top.limsup u * filter.at_top.limsup v,
      rw [eventually_map, eventually_at_top],
      use [a, λ b hb,mul_le_mul' (le_refl _) (ha b hb)], }},
  apply le_trans this,
  rw limsup_const_mul,
end

end nnreal


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.

Authors: Leonardo de Moura
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.logic

universes u l

namespace Mathlib

class setoid (α : Sort u) where
  r : α → α → Prop
  iseqv : equivalence r

protected instance setoid_has_equiv {α : Sort u} [setoid α] : has_equiv α := has_equiv.mk setoid.r

namespace setoid

theorem refl {α : Sort u} [setoid α] (a : α) : a ≈ a := sorry

theorem symm {α : Sort u} [setoid α] {a : α} {b : α} (hab : a ≈ b) : b ≈ a := sorry

theorem trans {α : Sort u} [setoid α] {a : α} {b : α} {c : α} (hab : a ≈ b) (hbc : b ≈ c) : a ≈ c :=
  sorry

end Mathlib