import util
import approach_one_symbol

open real set rnd_var_1

open_locale big_operators

noncomputable theory

variables {ι : Type} [fintype ι] [decidable_eq ι]

/-- U with q k divided on both sides and q₂ bounded further from below
{ k | (exp -ε) < q₂ k / q k * exp(err_exp_1 q₁ q₂ r) ≤ q₁ k / q k * (exp r) } -/
def U₁ (q q₁ q₂ : ι → ℝ) [rnd_var_1 q] [rnd_var_1 q₁] [rnd_var_1 q₂] (r ε : ℝ) :=
{ k | q₁ k / q k ≥ q₂ k / q k * exp(err_exp_1 q₁ q₂ r - r) ∧ q₂ k > q k * exp(-(err_exp_1 q₁ q₂ r + ε)) }

/-- Uᶜ but q₁ bounded further from below
{ k | (exp -ε) < q₁ k / q k * (exp r) < q₂ k / q k * exp(err_exp_1 q₁ q₂ r) } -/
def U₂ (q q₁ q₂ : ι → ℝ) [rnd_var_1 q] [rnd_var_1 q₁] [rnd_var_1 q₂] (r ε : ℝ) :=
{ k | q₁ k / q k < q₂ k / q k * exp(err_exp_1 q₁ q₂ r - r) ∧ q₁ k > q k * exp(-(ε + r)) }

def UA (q q₁ q₂ : ι → ℝ) [rnd_var_1 q] [rnd_var_1 q₁] [rnd_var_1 q₂] (r ε : ℝ) :=
{ k | exp(-ε) < q₁ k / q k * exp(r) }

def UB (q q₁ q₂ : ι → ℝ) [rnd_var_1 q] [rnd_var_1 q₁] [rnd_var_1 q₂] (r ε : ℝ) :=
{ k | exp(-ε) < q₂ k / q k * exp(err_exp_1 q₁ q₂ r) }

def UTA (q q₁ q₂ : ι → ℝ) [rnd_var_1 q] [rnd_var_1 q₁] [rnd_var_1 q₂] (r ε : ℝ) :=
{ k | abs(log( q k / q₁ k * exp(-r) )) ≥ ε }

def UTB (q q₁ q₂ : ι → ℝ) [rnd_var_1 q] [rnd_var_1 q₁] [rnd_var_1 q₂] (r ε : ℝ) :=
{ k | abs(log( q k / q₂ k * exp(-err_exp_1 q₁ q₂ r) )) ≥ ε }

variables
{q q₁ q₂ : ι → ℝ} [rnd_var_1 q] [rnd_var_1 q₁] [rnd_var_1 q₂]
{r T ε : ℝ} (HT : T = err_exp_1 q₁ q₂ r - r)
(Hr : r = ∑ k, q k * log(q k / q₁ k)) -- let q achieve err_exp_1(r)
(Hε : ε > 0)
(Herr_exp : err_exp_1 q₁ q₂ r = ∑ k, q k * log(q k / q₂ k))

@[simp] lemma exp_ne_zero : exp(r) ≠ 0 := ne_of_gt (exp_pos r)
@[simp] lemma q_pos       : ∀ k, 0 < q k := λk, probs_pos k
@[simp] lemma q₁_pos      : ∀ k, 0 < q₁ k := λk, probs_pos k
@[simp] lemma q₂_pos      : ∀ k, 0 < q₂ k := λk, probs_pos k

@[simp]
lemma q_div_q₁_ne_zero {k} :
  q k / q₁ k ≠ 0 :=
by {apply ne_of_gt, rw [(lt_div_iff _), zero_mul]; simp}

lemma in_U₂ :
  (∑ k, q k * (Φ (U₂ q q₁ q₂ r ε) k)) * exp(-(r + ε)) ≤ ∑ k, q₁ k * (Φ (U₂ q q₁ q₂ r ε) k) :=
begin
  rw finset.sum_mul,
  apply finset.sum_le_sum,
  intros k hk,
  rw [Φ, indicator],
  by_cases (k ∈ U₂ q q₁ q₂ r ε), simp only [h], simp,
  rw U₂ at h, norm_num at h,
  apply le_of_lt, rw add_comm, exact h.2,
  simp only [h], simp,
end

lemma in_U₁ :
(∑ k, q k * (Φ (U₁ q q₁ q₂ r ε) k))
                                   ≤ (∑ k, (q₂ k) * (Φ (U₁ q q₁ q₂ r ε) k)) * exp(err_exp_1 q₁ q₂ r + ε) :=
begin
  rw finset.sum_mul,
  apply finset.sum_le_sum,
  intros k hk,
  rw [Φ, indicator],
  by_cases (k ∈ U₁ q q₁ q₂ r ε), simp only [h], simp,
  rw U₁ at h, norm_num at h,
  apply le_of_lt,
  rw ← mul_lt_mul_right (exp_pos (-err_exp_1 q₁ q₂ r - ε)),
  rw mul_assoc, rw ← exp_add _ _, ring_nf, rw exp_zero, rw one_mul,
  rw ← tactic.ring.add_neg_eq_sub, rw add_comm, rw mul_comm, exact h.2,
  simp only [h], simp,
end

include HT

lemma U₁_subset_U :
  (U₁ q q₁ q₂ r ε) ⊆ (U q₁ q₂ T) :=
begin
  rw [U, U₁], intros k Hk, norm_num,
  have qk_pos : ∀ k, 0 < q k, by exact (probs_pos),
  rw ← div_le_div_right (qk_pos k),
  rw [mul_comm, ← mul_div, mul_comm, HT], exact Hk.1,
end

lemma U₂_subset_Uc :
  (U₂ q q₁ q₂ r ε) ⊆ (U q₁ q₂ T)ᶜ :=
begin
  rw [U, U₂], intros k Hk, norm_num,
  have qk_pos : ∀ k, 0 < q k, by exact (probs_pos),
  rw ← div_lt_div_right (qk_pos k),
  rw [mul_comm, ← mul_div, mul_comm, HT], exact Hk.1,
end

omit HT

lemma U₁_union_U₂_eq_UA_inter_UB :
  (U₁ q q₁ q₂ r ε) ∪ (U₂ q q₁ q₂ r ε) = (UA q q₁ q₂ r ε) ∩ (UB q q₁ q₂ r ε) :=
begin
  rw [union_def, inter_def], ext k,

  let a : Prop := exp (-ε) < q₁ k / q k * exp r,
  let b : Prop := exp (-ε) < q₂ k / q k * exp (err_exp_1 q₁ q₂ r),
  let c : Prop :=  q₂ k / q k * exp(err_exp_1 q₁ q₂ r) ≤ q₁ k / q k * exp(r),

  have a_def : a ↔ exp (-ε) < q₁ k / q k * exp r, refl,
  have b_def : b ↔ exp (-ε) < q₂ k / q k * exp (err_exp_1 q₁ q₂ r), refl,
  have c_def : c ↔ q₂ k / q k * exp(err_exp_1 q₁ q₂ r) ≤ q₁ k / q k * exp(r), refl,

  have a_rw     : a ↔ q k * exp (-r + -ε) < q₁ k, {
    rw ← mul_lt_mul_right (exp_pos(r)),
    rw [mul_assoc, ← exp_add, add_comm, ← add_assoc, add_neg_self, zero_add],
    have q_inv_pos : 0 < (q k)⁻¹, by exact inv_pos.mpr (q_pos k),
    rw [← mul_lt_mul_right q_inv_pos, mul_assoc, mul_comm],
    rw [← div_eq_mul_inv, div_mul, div_self, div_one],
    rw [mul_assoc, mul_comm (exp (r)) (q k)⁻¹],
    rw [← mul_assoc, ← div_eq_mul_inv],
    exact ne_of_gt (q_pos k),
  },
  have b_rw     : b ↔ q k * exp (-ε + -err_exp_1 q₁ q₂ r) < q₂ k, {
    rw ← mul_lt_mul_right (exp_pos(err_exp_1 q₁ q₂ r)),
    rw [mul_assoc, ← exp_add, add_assoc, neg_add_self, add_zero],
    have q_inv_pos : 0 < (q k)⁻¹, by exact inv_pos.mpr (q_pos k),
    rw [← mul_lt_mul_right q_inv_pos, mul_assoc, mul_comm],
    rw [← div_eq_mul_inv, div_mul, div_self, div_one],
    rw [mul_assoc, mul_comm (exp (err_exp_1 q₁ q₂ r)) (q k)⁻¹],
    rw [← mul_assoc, ← div_eq_mul_inv],
    exact ne_of_gt (q_pos k),
  },
  have c_rw     : c ↔ q₂ k / q k * exp (err_exp_1 q₁ q₂ r - r) ≤ q₁ k / q k, {
    rw ← mul_le_mul_right (exp_pos(r)),
    rw [mul_assoc, ← exp_add], simp,
  },
  have not_c_rw : ¬ c ↔ q₁ k / q k < q₂ k / q k * exp (err_exp_1 q₁ q₂ r - r), by rw [c_rw, not_le],

  have a_and_b_rw : (c ∧ b ∧ a) ∨ (¬ c ∧ b ∧ a) ↔ (a ∧ b), by {split, tauto, tauto},

  have c_and_b_rw     :   c ∧ b ↔ c ∧ b ∧ a, {
    rw [a_def, b_def, c_def],
    split, intro H,
    split, exact H.1, split, exact H.2,
    calc exp(-ε) < q₂ k / q k * exp (err_exp_1 q₁ q₂ r) : H.2
             ... ≤ q₁ k / q k * exp r : H.1,
    intro H, exact ⟨H.1, H.2.1⟩,
  },
  have not_c_and_b_rw : ¬ c ∧ a ↔ ¬ c ∧ b ∧ a, {
    rw [a_def, b_def, c_def, not_le],
    split,
    intro H, split, exact H.1, split,
    calc exp (-ε) < q₁ k / q k * exp r : H.2
              ... < q₂ k / q k * exp (err_exp_1 q₁ q₂ r) : H.1,
    exact H.2,
    intro H, exact ⟨H.1, H.2.2⟩,
  },
  split,
  {
    intro H, rw [U₁, U₂] at H, rw [UA, UB],
    norm_num, norm_num at H,
    rwa [← a_and_b_rw, ← c_and_b_rw, ← not_c_and_b_rw, not_c_rw, c_rw, a_rw, b_rw],
  },
  {
    intro H, rw [UA, UB] at H, rw [U₁, U₂],
    norm_num, norm_num at H,
    rw [← b_rw, ← a_rw, ← c_rw, ← not_c_rw, c_and_b_rw, not_c_and_b_rw],
    exact a_and_b_rw.mpr H,
  },
end

lemma sum_inter_ge :
  ∑ k, q k * (Φ ((UA q q₁ q₂ r ε) ∩ (UB q q₁ q₂ r ε)) k)
          ≥ 1 - ∑ k, q k * (Φ (UA q q₁ q₂ r ε)ᶜ k) - ∑ k, q k * (Φ (UB q q₁ q₂ r ε)ᶜ k) :=
begin
  calc ∑ k, q k * (Φ ((UA q q₁ q₂ r ε) ∩ (UB q q₁ q₂ r ε)) k)
                  = 1 - ∑ k, q k * (Φ ((UA q q₁ q₂ r ε) ∩ (UB q q₁ q₂ r ε))ᶜ k) : by rw in_self_or_in_compl
              ... = 1 - ∑ k, q k * (Φ ((UA q q₁ q₂ r ε)ᶜ ∪ (UB q q₁ q₂ r ε)ᶜ) k) : by rw compl_inter
              ... ≥ 1 - (∑ k, q k * (Φ (UA q q₁ q₂ r ε)ᶜ k) + ∑ k, q k * (Φ (UB q q₁ q₂ r ε)ᶜ k)) : by {apply sub_le_sub_left, exact add_ge_sum_union q_pos}
              ... ≥ 1 - ∑ k, q k * (Φ (UA q q₁ q₂ r ε)ᶜ k) - ∑ k, q k * (Φ (UB q q₁ q₂ r ε)ᶜ k) : by linarith,
end

lemma log_lt_of_lt_div_mul {k} :
  exp (-ε) < q₁ k / q k * exp r → log(q k / q₁ k * exp(-r)) < ε :=
begin
  intro H,
  rw [← exp_lt_exp, exp_log],
  rw [← mul_lt_mul_left (exp_pos _), ← (exp_add _ _)],
  rw [neg_add_self, exp_zero, ← mul_assoc],
  rw ← mul_lt_mul_right (exp_pos _),
  rw [mul_assoc, ← (exp_add _ _)],
  rw [neg_add_self, exp_zero, mul_one, one_mul, mul_div],
  rw div_lt_iff (q₁_pos k),
  have qk_pos : 0 < q k, by exact probs_pos k,
  rw [← div_lt_div_right (qk_pos), ← mul_div],
  rwa [div_self, mul_one, ← mul_div, mul_comm],
  exact ne_of_gt qk_pos, assumption,
  rw [zero_lt_mul_right, lt_div_iff, zero_mul],
  simp, simp, apply exp_pos,
end

lemma lt_div_mul_of_log_lt {k} :
  log(q k / q₁ k * exp(-r)) < ε → exp (-ε) < q₁ k / q k * exp r :=
begin
  intro H,
  rw ← mul_lt_mul_left (exp_pos $ ε),
  rw [← (exp_add _ _), add_neg_self, exp_zero],
  rw [← mul_assoc, ← mul_lt_mul_right (exp_pos $ -r)],
  rw [mul_assoc, ← (exp_add _ _), add_neg_self, exp_zero, mul_one, one_mul],
  rw mul_div,
  have qk_pos : 0 < q k, by exact probs_pos k,
  rw [lt_div_iff (qk_pos), ← div_lt_iff _],
  rw [← mul_div, mul_comm, ← log_lt_log_iff],
  rwa log_exp,
  rw zero_lt_mul_right (exp_pos $ -r),
  rw [lt_div_iff, zero_mul],
  simp, simp, apply exp_pos, simp,
end

lemma UA_rw :
  UA q q₁ q₂ r ε = { k | log(q k / q₁ k * exp(-r)) < ε } :=
by {ext, exact ⟨log_lt_of_lt_div_mul, lt_div_mul_of_log_lt⟩}

include Hr

lemma UTA_rw :
  UTA q q₁ q₂ r ε = { k | abs(log(q k / q₁ k) - ∑ k, q k * log(q k / q₁ k)) ≥ ε } :=
begin
  rw UTA, ext k, split,
  intro H, norm_num at *, rwa [log_mul, log_exp, Hr] at H, simp, simp,
  intro H, norm_num at *, rwa [log_mul, log_exp, Hr], simp, simp,
end

omit Hr
include Herr_exp

lemma UTB_rw :
  UTB q q₁ q₂ r ε = { k | abs(log(q k / q₂ k) - ∑ k, q k * log(q k / q₂ k)) ≥ ε } :=
begin
  rw UTB, ext k, split,
  intro H, norm_num at H, rwa [Herr_exp, log_mul, log_exp] at H, simp, simp,
  intro H, norm_num, rwa [Herr_exp, log_mul, log_exp], simp, simp,
end

omit Herr_exp

lemma UB_rw :
  UB q q₁ q₂ r ε = { k | log(q k / q₂ k * exp(-err_exp_1 q₁ q₂ r)) < ε } :=
by {ext, exact ⟨log_lt_of_lt_div_mul, lt_div_mul_of_log_lt⟩}

lemma UAc_subset_UTA :
  (UA q q₁ q₂ r ε)ᶜ ⊆ (UTA q q₁ q₂ r ε) :=
by {rw [UTA, UA_rw, gt_compl_le], apply subset_abs}

lemma sum_UAc_le_sum_UTA :
  ∑ k, q k * (Φ (UA q q₁ q₂ r ε)ᶜ k) ≤ ∑ k, q k * (Φ (UTA q q₁ q₂ r ε) k) :=
sum_le_of_subset q_pos (UAc_subset_UTA)

variables {σ₁ σ₂ : ℝ}
(Hσ₁ : σ₁ = Var q (λk, log(q k / q₁ k)))
(Hσ₂ : σ₂ = Var q (λk, log(q k / q₂ k)))

include Hσ₁ Hr Hε

lemma sum_UTA_le_var :
  ∑ k, q k * (Φ (UTA q q₁ q₂ r ε) k) ≤ σ₁/(ε^2) :=
by {rw [UTA_rw Hr, Hσ₁], apply Chebyshevs_ineq, assumption}

lemma sum_UAc_le_var :
  ∑ k, q k * (Φ (UA q q₁ q₂ r ε)ᶜ k) ≤ σ₁/(ε^2) :=
le_trans sum_UAc_le_sum_UTA (sum_UTA_le_var Hr Hε Hσ₁)

omit Hr Hε Hσ₁

lemma UBc_subset_UTB :
  (UB q q₁ q₂ r ε)ᶜ ⊆ (UTB q q₁ q₂ r ε) :=
by {rw [UTB, UB_rw, gt_compl_le], apply subset_abs}

lemma sum_UBc_le_sum_UTB :
  ∑ k, q k * (Φ (UB q q₁ q₂ r ε)ᶜ k) ≤ ∑ k, q k * (Φ (UTB q q₁ q₂ r ε) k) :=
sum_le_of_subset q_pos (UBc_subset_UTB)

include Hσ₂ Herr_exp Hε

lemma sum_UTB_le_var :
  ∑ k, q k * (Φ (UTB q q₁ q₂ r ε) k) ≤ σ₂/(ε^2) :=
by {rw [UTB_rw, Hσ₂], apply Chebyshevs_ineq, assumption, exact Herr_exp}

lemma sum_UBc_le_var  :
  ∑ k, q k * (Φ (UB q q₁ q₂ r ε)ᶜ k) ≤ σ₂/(ε^2) :=
le_trans sum_UBc_le_sum_UTB (sum_UTB_le_var Hε Herr_exp Hσ₂)

include Hσ₁ Hr

lemma sum_UA_inter_UB_ge :
  ∑ k, q k * (Φ ((UA q q₁ q₂ r ε) ∩ (UB q q₁ q₂ r ε)) k) ≥ 1 - (σ₁ + σ₂)/ε^2 :=
begin
  calc ∑ k, q k * (Φ ((UA q q₁ q₂ r ε) ∩ (UB q q₁ q₂ r ε)) k)
          ≥ 1 - ∑ k, q k * (Φ (UA q q₁ q₂ r ε)ᶜ k) - ∑ k, q k * (Φ (UB q q₁ q₂ r ε)ᶜ k) : sum_inter_ge
      ... ≥ 1 - ∑ k, q k * (Φ (UA q q₁ q₂ r ε)ᶜ k) - σ₂/(ε^2) : by apply sub_le_sub_left (sum_UBc_le_var Hε Herr_exp Hσ₂)
      ... ≥ 1 - σ₂/(ε^2) - ∑ k, q k * (Φ (UA q q₁ q₂ r ε)ᶜ k) : by linarith
      ... ≥ 1 - σ₂/(ε^2) - σ₁/(ε^2) : by apply sub_le_sub_left (sum_UAc_le_var Hr Hε Hσ₁)
      ... ≥ 1 - (σ₁/(ε^2) + σ₂/(ε^2)) : by linarith
      ... = 1 - (σ₁ + σ₂)/ε^2 : by simp only [add_div],
end

lemma sum_U2_ge_of_sum_U1_le {γ} :
  ∑ k, q k * (Φ (U₁ q q₁ q₂ r ε) k) ≤ γ
      → ∑ k, q k * (Φ (U₂ q q₁ q₂ r ε) k) + γ ≥ 1 - (σ₁ + σ₂)/ε^2 :=
begin
  intro H,
  calc ∑ k, q k * (Φ (U₂ q q₁ q₂ r ε) k) + γ
            ≥ ∑ k, q k * (Φ (U₂ q q₁ q₂ r ε) k) + ∑ k, q k * (Φ (U₁ q q₁ q₂ r ε) k) : by apply add_le_add_left H
        ... ≥ ∑ k, q k * (Φ ((U₂ q q₁ q₂ r ε) ∪ (U₁ q q₁ q₂ r ε)) k) : add_ge_sum_union q_pos
        ... = ∑ k, q k * (Φ ((UA q q₁ q₂ r ε) ∩ (UB q q₁ q₂ r ε)) k) : by rw [union_comm, U₁_union_U₂_eq_UA_inter_UB]
        ... ≥ 1 - (σ₁ + σ₂)/ε^2 : sum_UA_inter_UB_ge Hr Hε Herr_exp Hσ₁ Hσ₂,
end

include HT

/-- Thm. 10 in Blahut1974 -/
theorem prob_of_α_error_ge {γ > 0} :
  β q₁ q₂ T ≤ γ * exp(-(r + ε))
  → α q₁ q₂ T ≥ exp(-(err_exp_1 q₁ q₂ r + ε)) * (1 - (σ₁ + σ₂)/(ε^2) - γ) :=
begin
  intros Hβ,
  have Hγ : (∑ k, q k * (Φ (U₂ q q₁ q₂ r ε) k)) * exp(-(r + ε)) ≤ γ * exp(-(r + ε)), {
    calc (∑ k, q k * (Φ (U₂ q q₁ q₂ r ε) k)) * exp(-(r + ε))
                ≤ ∑ k, q₁ k * (Φ (U₂ q q₁ q₂ r ε) k) : in_U₂
            ... ≤ ∑ k, q₁ k * (Φ (U q₁ q₂ T)ᶜ k) : sum_le_of_subset q₁_pos (U₂_subset_Uc HT)
            ... = β q₁ q₂ T : by rw β
            ... ≤ γ * exp(-(r + ε)) : by assumption,
  },
  have γ_gt : ∑ k, q k * (Φ (U₂ q q₁ q₂ r ε) k) ≤ γ, {
    exact (mul_le_mul_right (exp_pos (-(r + ε)))).mp Hγ,
  },
  have : α q₁ q₂ T * exp(err_exp_1 q₁ q₂ r + ε) + γ ≥ 1 - (σ₁ + σ₂)/ε^2, {
    calc α q₁ q₂ T * exp(err_exp_1 q₁ q₂ r + ε) + γ
               = (∑ k, q₂ k * (Φ (U q₁ q₂ T) k)) * exp(err_exp_1 q₁ q₂ r + ε) + γ : by rw α
           ... ≥ (∑ k, q₂ k * (Φ (U₁ q q₁ q₂ r ε) k)) * exp(err_exp_1 q₁ q₂ r + ε) + γ : mul_add_ge_of_ge (exp_pos _) (sum_le_of_subset q₂_pos (U₁_subset_U HT))
           ... ≥ ∑ k, q k * (Φ (U₁ q q₁ q₂ r ε) k) + γ : by apply add_le_add_right in_U₁
           ... ≥ ∑ k, q k * (Φ (U₁ q q₁ q₂ r ε) k) + ∑ k, q k * (Φ (U₂ q q₁ q₂ r ε) k) : by apply add_le_add_left γ_gt
           ... ≥ ∑ k, q k * (Φ ((U₁ q q₁ q₂ r ε) ∪ (U₂ q q₁ q₂ r ε)) k) : add_ge_sum_union q_pos
           ... = ∑ k, q k * (Φ ((UA q q₁ q₂ r ε) ∩ (UB q q₁ q₂ r ε)) k) : by rw U₁_union_U₂_eq_UA_inter_UB
           ... ≥ 1 - (σ₁ + σ₂)/(ε^2) : by {apply sum_UA_inter_UB_ge; assumption},
  },
  have : α q₁ q₂ T * exp(err_exp_1 q₁ q₂ r + ε) ≥ 1 - (σ₁ + σ₂)/ε^2 - γ, {
    apply sub_le_iff_le_add.mpr this,
  },
  apply (mul_le_mul_right (exp_pos((err_exp_1 q₁ q₂ r + ε)))).mp _,
  rw [mul_comm, ← mul_assoc, ← exp_add _ _, neg_add, ← add_assoc],
  rw [add_assoc, add_assoc, add_comm, add_comm (-err_exp_1 q₁ q₂ r) (-ε), ← add_assoc],
  rw [add_neg_self, zero_add, add_comm, add_neg_self, exp_zero, one_mul], exact this,
end


/-
Copyright (c) 2019 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import ring_theory.adjoin
import ring_theory.algebra_tower
import ring_theory.polynomial.scale_roots

/-!
# Integral closure of a subring.

If A is an R-algebra then `a : A` is integral over R if it is a root of a monic polynomial
with coefficients in R. Enough theory is developed to prove that integral elements
form a sub-R-algebra of A.

## Main definitions

Let `R` be a `comm_ring` and let `A` be an R-algebra.

* `ring_hom.is_integral_elem (f : R →+* A) (x : A)` : `x` is integral with respect to the map `f`,

* `is_integral (x : A)`  : `x` is integral over `R`, i.e., is a root of a monic polynomial with
                           coefficients in `R`.
* `integral_closure R A` : the integral closure of `R` in `A`, regarded as a sub-`R`-algebra of `A`.
-/

open_locale classical
open_locale big_operators
open polynomial submodule

section ring
variables {R S A : Type*}
variables [comm_ring R] [ring A] [ring S] (f : R →+* S)

/-- An element `x` of `A` is said to be integral over `R` with respect to `f`
if it is a root of a monic polynomial `p : polynomial R` evaluated under `f` -/
def ring_hom.is_integral_elem (f : R →+* A) (x : A) :=
∃ p : polynomial R, monic p ∧ eval₂ f x p = 0

/-- A ring homomorphism `f : R →+* A` is said to be integral
if every element `A` is integral with respect to the map `f` -/
def ring_hom.is_integral (f : R →+* A) :=
∀ x : A, f.is_integral_elem x

variables [algebra R A] (R)

/-- An element `x` of an algebra `A` over a commutative ring `R` is said to be *integral*,
if it is a root of some monic polynomial `p : polynomial R`.
Equivalently, the element is integral over `R` with respect to the induced `algebra_map` -/
def is_integral (x : A) : Prop :=
(algebra_map R A).is_integral_elem x

variable (A)

/-- An algebra is integral if every element of the extension is integral over the base ring -/
def algebra.is_integral : Prop :=
(algebra_map R A).is_integral

variables {R A}

lemma ring_hom.is_integral_map {x : R} : f.is_integral_elem (f x) :=
⟨X - C x, monic_X_sub_C _, by simp⟩

theorem is_integral_algebra_map {x : R} : is_integral R (algebra_map R A x) :=
(algebra_map R A).is_integral_map

theorem is_integral_of_noetherian (H : is_noetherian R A) (x : A) :
  is_integral R x :=
begin
  let leval : @linear_map R (polynomial R) A _ _ _ _ _ := (aeval x).to_linear_map,
  let D : ℕ → submodule R A := λ n, (degree_le R n).map leval,
  let M := well_founded.min (is_noetherian_iff_well_founded.1 H)
    (set.range D) ⟨_, ⟨0, rfl⟩⟩,
  have HM : M ∈ set.range D := well_founded.min_mem _ _ _,
  cases HM with N HN,
  have HM : ¬M < D (N+1) := well_founded.not_lt_min
    (is_noetherian_iff_well_founded.1 H) (set.range D) _ ⟨N+1, rfl⟩,
  rw ← HN at HM,
  have HN2 : D (N+1) ≤ D N := classical.by_contradiction (λ H, HM
    (lt_of_le_not_le (map_mono (degree_le_mono
      (with_bot.coe_le_coe.2 (nat.le_succ N)))) H)),
  have HN3 : leval (X^(N+1)) ∈ D N,
  { exact HN2 (mem_map_of_mem (mem_degree_le.2 (degree_X_pow_le _))) },
  rcases HN3 with ⟨p, hdp, hpe⟩,
  refine ⟨X^(N+1) - p, monic_X_pow_sub (mem_degree_le.1 hdp), _⟩,
  show leval (X ^ (N + 1) - p) = 0,
  rw [linear_map.map_sub, hpe, sub_self]
end

theorem is_integral_of_submodule_noetherian (S : subalgebra R A)
  (H : is_noetherian R (S : submodule R A)) (x : A) (hx : x ∈ S) :
  is_integral R x :=
begin
  letI : algebra R S := S.algebra,
  letI : ring S := S.ring R A,
  suffices : is_integral R (⟨x, hx⟩ : S),
  { rcases this with ⟨p, hpm, hpx⟩,
    replace hpx := congr_arg subtype.val hpx,
    refine ⟨p, hpm, eq.trans _ hpx⟩,
    simp only [aeval_def, eval₂, finsupp.sum],
    rw ← p.support.sum_hom subtype.val,
    { refine finset.sum_congr rfl (λ n hn, _),
      change _ = _ * _,
      rw is_monoid_hom.map_pow coe, refl,
      split; intros; refl },
    refine { map_add := _, map_zero := _ }; intros; refl },
  refine is_integral_of_noetherian H ⟨x, hx⟩
end

end ring

section
variables {R A B S : Type*}
variables [comm_ring R] [comm_ring A] [comm_ring B] [comm_ring S]
variables [algebra R A] [algebra R B] (f : R →+* S)

theorem is_integral_alg_hom (f : A →ₐ[R] B) {x : A} (hx : is_integral R x) : is_integral R (f x) :=
let ⟨p, hp, hpx⟩ := hx in ⟨p, hp, by rw [← aeval_def, aeval_alg_hom_apply, aeval_def, hpx, f.map_zero]⟩

theorem is_integral_of_is_scalar_tower [algebra A B] [is_scalar_tower R A B]
  (x : B) (hx : is_integral R x) : is_integral A x :=
let ⟨p, hp, hpx⟩ := hx in
⟨p.map $ algebra_map R A, monic_map _ hp, by rw [← aeval_def, ← is_scalar_tower.aeval_apply, aeval_def, hpx]⟩

section
local attribute [instance] subset.comm_ring algebra.of_is_subring

theorem is_integral_of_subring {x : A} (T : set R) [is_subring T]
  (hx : is_integral T x) : is_integral R x :=
is_integral_of_is_scalar_tower x hx

lemma is_integral_algebra_map_iff [algebra A B] [is_scalar_tower R A B]
  {x : A} (hAB : function.injective (algebra_map A B)) :
  is_integral R (algebra_map A B x) ↔ is_integral R x :=
begin
  split; rintros ⟨f, hf, hx⟩; use [f, hf],
  { exact is_scalar_tower.aeval_eq_zero_of_aeval_algebra_map_eq_zero R A B hAB hx },
  { rw [is_scalar_tower.algebra_map_eq R A B, ← hom_eval₂, hx, ring_hom.map_zero] }
end

theorem is_integral_iff_is_integral_closure_finite {r : A} :
  is_integral R r ↔ ∃ s : set R, s.finite ∧ is_integral (ring.closure s) r :=
begin
  split; intro hr,
  { rcases hr with ⟨p, hmp, hpr⟩,
    refine ⟨_, set.finite_mem_finset _, p.restriction, subtype.eq hmp, _⟩,
    erw [← aeval_def, is_scalar_tower.aeval_apply _ R, map_restriction, aeval_def, hpr] },
  rcases hr with ⟨s, hs, hsr⟩,
  exact is_integral_of_subring _ hsr
end

end

theorem fg_adjoin_singleton_of_integral (x : A) (hx : is_integral R x) :
  (algebra.adjoin R ({x} : set A) : submodule R A).fg :=
begin
  rcases hx with ⟨f, hfm, hfx⟩,
  existsi finset.image ((^) x) (finset.range (nat_degree f + 1)),
  apply le_antisymm,
  { rw span_le, intros s hs, rw finset.mem_coe at hs,
    rcases finset.mem_image.1 hs with ⟨k, hk, rfl⟩, clear hk,
    exact is_submonoid.pow_mem (algebra.subset_adjoin (set.mem_singleton _)) },
  intros r hr, change r ∈ algebra.adjoin R ({x} : set A) at hr,
  rw algebra.adjoin_singleton_eq_range at hr,
  rcases (aeval x).mem_range.mp hr with ⟨p, rfl⟩,
  rw ← mod_by_monic_add_div p hfm,
  rw ← aeval_def at hfx,
  rw [alg_hom.map_add, alg_hom.map_mul, hfx, zero_mul, add_zero],
  have : degree (p %ₘ f) ≤ degree f := degree_mod_by_monic_le p hfm,
  generalize_hyp : p %ₘ f = q at this ⊢,
  rw [← sum_C_mul_X_eq q, aeval_def, eval₂_sum, finsupp.sum],
  refine sum_mem _ (λ k hkq, _),
  rw [eval₂_mul, eval₂_C, eval₂_pow, eval₂_X, ← algebra.smul_def],
  refine smul_mem _ _ (subset_span _),
  rw finset.mem_coe, refine finset.mem_image.2 ⟨_, _, rfl⟩,
  rw [finset.mem_range, nat.lt_succ_iff], refine le_of_not_lt (λ hk, _),
  rw [degree_le_iff_coeff_zero] at this,
  rw [finsupp.mem_support_iff] at hkq, apply hkq, apply this,
  exact lt_of_le_of_lt degree_le_nat_degree (with_bot.coe_lt_coe.2 hk)
end

theorem fg_adjoin_of_finite {s : set A} (hfs : s.finite)
  (his : ∀ x ∈ s, is_integral R x) : (algebra.adjoin R s : submodule R A).fg :=
set.finite.induction_on hfs (λ _, ⟨{1}, submodule.ext $ λ x,
  by { erw [algebra.adjoin_empty, finset.coe_singleton, ← one_eq_span, one_eq_map_top,
      map_top, linear_map.mem_range, algebra.mem_bot], refl }⟩)
(λ a s has hs ih his, by rw [← set.union_singleton, algebra.adjoin_union_coe_submodule]; exact
  fg_mul _ _ (ih $ λ i hi, his i $ set.mem_insert_of_mem a hi)
    (fg_adjoin_singleton_of_integral _ $ his a $ set.mem_insert a s)) his

theorem is_integral_of_mem_of_fg (S : subalgebra R A)
  (HS : (S : submodule R A).fg) (x : A) (hx : x ∈ S) : is_integral R x :=
begin
  cases HS with y hy,
  obtain ⟨lx, hlx1, hlx2⟩ :
    ∃ (l : A →₀ R) (H : l ∈ finsupp.supported R R ↑y), (finsupp.total A A R id) l = x,
  { rwa [←(@finsupp.mem_span_iff_total A A R _ _ _ id ↑y x), set.image_id ↑y, hy] },
  have hyS : ∀ {p}, p ∈ y → p ∈ S := λ p hp, show p ∈ (S : submodule R A),
    by { rw ← hy, exact subset_span hp },
  have : ∀ (jk : (↑(y.product y) : set (A × A))), jk.1.1 * jk.1.2 ∈ (S : submodule R A) :=
    λ jk, S.mul_mem (hyS (finset.mem_product.1 jk.2).1) (hyS (finset.mem_product.1 jk.2).2),
  rw [← hy, ← set.image_id ↑y] at this, simp only [finsupp.mem_span_iff_total] at this,
  choose ly hly1 hly2,
  let S₀ : set R := ring.closure ↑(lx.frange ∪ finset.bUnion finset.univ (finsupp.frange ∘ ly)),
  refine is_integral_of_subring S₀ _,
  letI : comm_ring S₀ := @subtype.comm_ring _ _ _ ring.closure.is_subring,
  letI : algebra S₀ A := algebra.of_is_subring _,
  have : span S₀ (insert 1 ↑y : set A) * span S₀ (insert 1 ↑y : set A) ≤ span S₀ (insert 1 ↑y : set A),
  { rw span_mul_span, refine span_le.2 (λ z hz, _),
    rcases set.mem_mul.1 hz with ⟨p, q, rfl | hp, hq, rfl⟩,
    { rw one_mul, exact subset_span hq },
    rcases hq with rfl | hq,
    { rw mul_one, exact subset_span (or.inr hp) },
    erw ← hly2 ⟨(p, q), finset.mem_product.2 ⟨hp, hq⟩⟩,
    rw [finsupp.total_apply, finsupp.sum],
    refine (span S₀ (insert 1 ↑y : set A)).sum_mem (λ t ht, _),
    have : ly ⟨(p, q), finset.mem_product.2 ⟨hp, hq⟩⟩ t ∈ S₀ :=
    ring.subset_closure (finset.mem_union_right _ $ finset.mem_bUnion.2
      ⟨⟨(p, q), finset.mem_product.2 ⟨hp, hq⟩⟩, finset.mem_univ _,
        finsupp.mem_frange.2 ⟨finsupp.mem_support_iff.1 ht, _, rfl⟩⟩),
    change (⟨_, this⟩ : S₀) • t ∈ _, exact smul_mem _ _ (subset_span $ or.inr $ hly1 _ ht) },
  haveI : is_subring (span S₀ (insert 1 ↑y : set A) : set A) :=
  { one_mem := subset_span $ or.inl rfl,
    mul_mem := λ p q hp hq, this $ mul_mem_mul hp hq,
    zero_mem := (span S₀ (insert 1 ↑y : set A)).zero_mem,
    add_mem := λ _ _, (span S₀ (insert 1 ↑y : set A)).add_mem,
    neg_mem := λ _, (span S₀ (insert 1 ↑y : set A)).neg_mem },
  have : span S₀ (insert 1 ↑y : set A) = algebra.adjoin S₀ (↑y : set A),
  { refine le_antisymm (span_le.2 $ set.insert_subset.2
        ⟨(algebra.adjoin S₀ ↑y).one_mem, algebra.subset_adjoin⟩) (λ z hz, _),
    rw [subalgebra.mem_to_submodule, algebra.mem_adjoin_iff] at hz, rw ← submodule.mem_coe,
    refine ring.closure_subset (set.union_subset (set.range_subset_iff.2 $ λ t, _)
      (λ t ht, subset_span $ or.inr ht)) hz,
    rw algebra.algebra_map_eq_smul_one,
    exact smul_mem (span S₀ (insert 1 ↑y : set A)) _ (subset_span $ or.inl rfl) },
  haveI : is_noetherian_ring ↥S₀ := is_noetherian_ring_closure _ (finset.finite_to_set _),
  refine is_integral_of_submodule_noetherian (algebra.adjoin S₀ ↑y)
    (is_noetherian_of_fg_of_noetherian _ ⟨insert 1 y, by rw [finset.coe_insert, this]⟩) _ _,
  rw [← hlx2, finsupp.total_apply, finsupp.sum], refine subalgebra.sum_mem _ (λ r hr, _),
  have : lx r ∈ S₀ := ring.subset_closure (finset.mem_union_left _ (finset.mem_image_of_mem _ hr)),
  change (⟨_, this⟩ : S₀) • r ∈ _,
  rw finsupp.mem_supported at hlx1,
  exact subalgebra.smul_mem _ (algebra.subset_adjoin $ hlx1 hr) _
end

lemma ring_hom.is_integral_of_mem_closure {x y z : S}
  (hx : f.is_integral_elem x) (hy : f.is_integral_elem y)
  (hz : z ∈ ring.closure ({x, y} : set S)) :
  f.is_integral_elem z :=
begin
  letI : algebra R S := f.to_algebra,
  have := fg_mul _ _ (fg_adjoin_singleton_of_integral x hx) (fg_adjoin_singleton_of_integral y hy),
  rw [← algebra.adjoin_union_coe_submodule, set.singleton_union] at this,
  exact is_integral_of_mem_of_fg (algebra.adjoin R {x, y}) this z
    (algebra.mem_adjoin_iff.2  $ ring.closure_mono (set.subset_union_right _ _) hz),
end

theorem is_integral_of_mem_closure {x y z : A}
  (hx : is_integral R x) (hy : is_integral R y)
  (hz : z ∈ ring.closure ({x, y} : set A)) :
  is_integral R z :=
(algebra_map R A).is_integral_of_mem_closure hx hy hz

lemma ring_hom.is_integral_zero : f.is_integral_elem 0 :=
f.map_zero ▸ f.is_integral_map

theorem is_integral_zero : is_integral R (0:A) :=
(algebra_map R A).is_integral_zero

lemma ring_hom.is_integral_one : f.is_integral_elem 1 :=
f.map_one ▸ f.is_integral_map

theorem is_integral_one : is_integral R (1:A) :=
(algebra_map R A).is_integral_one

lemma ring_hom.is_integral_add {x y : S}
  (hx : f.is_integral_elem x) (hy : f.is_integral_elem y) :
  f.is_integral_elem (x + y) :=
f.is_integral_of_mem_closure hx hy (is_add_submonoid.add_mem
  (ring.subset_closure (or.inl rfl)) (ring.subset_closure (or.inr rfl)))

theorem is_integral_add {x y : A}
  (hx : is_integral R x) (hy : is_integral R y) :
  is_integral R (x + y) :=
(algebra_map R A).is_integral_add hx hy

lemma ring_hom.is_integral_neg {x : S}
  (hx : f.is_integral_elem x) : f.is_integral_elem (-x) :=
f.is_integral_of_mem_closure hx hx (is_add_subgroup.neg_mem
  (ring.subset_closure (or.inl rfl)))

theorem is_integral_neg {x : A}
  (hx : is_integral R x) : is_integral R (-x) :=
(algebra_map R A).is_integral_neg hx

lemma ring_hom.is_integral_sub {x y : S}
  (hx : f.is_integral_elem x) (hy : f.is_integral_elem y) : f.is_integral_elem (x - y) :=
by simpa only [sub_eq_add_neg] using f.is_integral_add hx (f.is_integral_neg hy)

theorem is_integral_sub {x y : A}
  (hx : is_integral R x) (hy : is_integral R y) : is_integral R (x - y) :=
(algebra_map R A).is_integral_sub hx hy

lemma ring_hom.is_integral_mul {x y : S}
  (hx : f.is_integral_elem x) (hy : f.is_integral_elem y) : f.is_integral_elem (x * y) :=
f.is_integral_of_mem_closure hx hy (is_submonoid.mul_mem
  (ring.subset_closure (or.inl rfl)) (ring.subset_closure (or.inr rfl)))

theorem is_integral_mul {x y : A}
  (hx : is_integral R x) (hy : is_integral R y) : is_integral R (x * y) :=
(algebra_map R A).is_integral_mul hx hy

theorem ring_hom.is_integral_pow {x : S} :
  Π (n : ℕ) (hx : f.is_integral_elem x), f.is_integral_elem (x ^ n)
| 0 hx := by simpa using f.is_integral_one
| (n + 1) hx := by simpa using f.is_integral_mul hx (ring_hom.is_integral_pow n hx)

theorem is_integral_pow {x : A} (n : ℕ) (hx : is_integral R x) : is_integral R (x ^ n) :=
(algebra_map R A).is_integral_pow n hx

variables (R A)

/-- The integral closure of R in an R-algebra A. -/
def integral_closure : subalgebra R A :=
{ carrier := { r | is_integral R r },
  zero_mem' := is_integral_zero,
  one_mem' := is_integral_one,
  add_mem' := λ _ _, is_integral_add,
  mul_mem' := λ _ _, is_integral_mul,
  algebra_map_mem' := λ x, is_integral_algebra_map }

theorem mem_integral_closure_iff_mem_fg {r : A} :
  r ∈ integral_closure R A ↔ ∃ M : subalgebra R A, (M : submodule R A).fg ∧ r ∈ M :=
⟨λ hr, ⟨algebra.adjoin R {r}, fg_adjoin_singleton_of_integral _ hr, algebra.subset_adjoin rfl⟩,
λ ⟨M, Hf, hrM⟩, is_integral_of_mem_of_fg M Hf _ hrM⟩

variables {R} {A}

/-- Mapping an integral closure along an `alg_equiv` gives the integral closure. -/
lemma integral_closure_map_alg_equiv (f : A ≃ₐ[R] B) :
  (integral_closure R A).map (f : A →ₐ[R] B) = integral_closure R B :=
begin
  ext y,
  rw subalgebra.mem_map,
  split,
  { rintros ⟨x, hx, rfl⟩,
    exact is_integral_alg_hom f hx },
  { intro hy,
    use [f.symm y, is_integral_alg_hom (f.symm : B →ₐ[R] A) hy],
    simp }
end

lemma integral_closure.is_integral (x : integral_closure R A) : is_integral R x :=
let ⟨p, hpm, hpx⟩ := x.2 in ⟨p, hpm, subtype.eq $
by rwa [← aeval_def, subtype.val_eq_coe, ← subalgebra.val_apply, aeval_alg_hom_apply] at hpx⟩

lemma ring_hom.is_integral_of_is_integral_mul_unit (x y : S) (r : R) (hr : f r * y = 1)
  (hx : f.is_integral_elem (x * y)) : f.is_integral_elem x :=
begin
  obtain ⟨p, ⟨p_monic, hp⟩⟩ := hx,
  refine ⟨scale_roots p r, ⟨(monic_scale_roots_iff r).2 p_monic, _⟩⟩,
  convert scale_roots_eval₂_eq_zero f hp,
  rw [mul_comm x y, ← mul_assoc, hr, one_mul],
end

theorem is_integral_of_is_integral_mul_unit {x y : A} {r : R} (hr : algebra_map R A r * y = 1)
  (hx : is_integral R (x * y)) : is_integral R x :=
(algebra_map R A).is_integral_of_is_integral_mul_unit x y r hr hx

/-- Generalization of `is_integral_of_mem_closure` bootstrapped up from that lemma -/
lemma is_integral_of_mem_closure' (G : set A) (hG : ∀ x ∈ G, is_integral R x) :
  ∀ x ∈ (subring.closure G), is_integral R x :=
λ x hx, subring.closure_induction hx hG is_integral_zero is_integral_one
  (λ _ _, is_integral_add) (λ _, is_integral_neg) (λ _ _, is_integral_mul)

lemma is_integral_of_mem_closure'' {S : Type*} [comm_ring S] {f : R →+* S} (G : set S)
  (hG : ∀ x ∈ G, f.is_integral_elem x) : ∀ x ∈ (subring.closure G), f.is_integral_elem x :=
λ x hx, @is_integral_of_mem_closure' R S _ _ f.to_algebra G hG x hx

lemma algebra_map_injective (h : function.injective (algebra_map R A)) :
  function.injective (algebra_map R (integral_closure R A)) :=
λ x y hxy, h $
  show algebra_map (integral_closure R A) A (algebra_map R _ x) = _,
  from congr_arg (algebra_map (integral_closure R A) A) hxy

end

section algebra
open algebra
variables {R A B S T : Type*}
variables [comm_ring R] [comm_ring A] [comm_ring B] [comm_ring S] [comm_ring T]
variables [algebra A B] [algebra R B] (f : R →+* S) (g : S →+* T)

lemma is_integral_trans_aux (x : B) {p : polynomial A} (pmonic : monic p) (hp : aeval x p = 0) :
  is_integral (adjoin R (↑(p.map $ algebra_map A B).frange : set B)) x :=
begin
  generalize hS : (↑(p.map $ algebra_map A B).frange : set B) = S,
  have coeffs_mem : ∀ i, (p.map $ algebra_map A B).coeff i ∈ adjoin R S,
  { intro i, by_cases hi : (p.map $ algebra_map A B).coeff i = 0,
    { rw hi, exact subalgebra.zero_mem _ },
    rw ← hS, exact subset_adjoin (finsupp.mem_frange.2 ⟨hi, i, rfl⟩) },
  obtain ⟨q, hq⟩ : ∃ q : polynomial (adjoin R S), q.map (algebra_map (adjoin R S) B) =
      (p.map $ algebra_map A B),
  { rw ← set.mem_range, exact (polynomial.mem_map_range _).2 (λ i, ⟨⟨_, coeffs_mem i⟩, rfl⟩) },
  use q,
  split,
  { suffices h : (q.map (algebra_map (adjoin R S) B)).monic,
    { refine monic_of_injective _ h,
      exact subtype.val_injective },
    { rw hq, exact monic_map _ pmonic } },
  { convert hp using 1,
    replace hq := congr_arg (eval x) hq,
    convert hq using 1; symmetry; apply eval_map },
end

variables [algebra R A] [is_scalar_tower R A B]

/-- If A is an R-algebra all of whose elements are integral over R,
and x is an element of an A-algebra that is integral over A, then x is integral over R.-/
lemma is_integral_trans (A_int : is_integral R A) (x : B) (hx : is_integral A x) :
  is_integral R x :=
begin
  rcases hx with ⟨p, pmonic, hp⟩,
  let S : set B := ↑(p.map $ algebra_map A B).frange,
  refine is_integral_of_mem_of_fg (adjoin R (S ∪ {x})) _ _ (subset_adjoin $ or.inr rfl),
  refine fg_trans (fg_adjoin_of_finite (finset.finite_to_set _) (λ x hx, _)) _,
  { rw [finset.mem_coe, finsupp.mem_frange] at hx, rcases hx with ⟨_, i, rfl⟩,
    show is_integral R ((p.map $ algebra_map A B).coeff i), rw coeff_map,
    convert is_integral_alg_hom (is_scalar_tower.to_alg_hom R A B) (A_int _) },
  { apply fg_adjoin_singleton_of_integral,
    exact is_integral_trans_aux _ pmonic hp }
end

/-- If A is an R-algebra all of whose elements are integral over R,
and B is an A-algebra all of whose elements are integral over A,
then all elements of B are integral over R.-/
lemma algebra.is_integral_trans (hA : is_integral R A) (hB : is_integral A B) : is_integral R B :=
λ x, is_integral_trans hA x (hB x)

lemma ring_hom.is_integral_trans (hf : f.is_integral) (hg : g.is_integral) :
  (g.comp f).is_integral :=
@algebra.is_integral_trans R S T _ _ _ g.to_algebra (g.comp f).to_algebra f.to_algebra
  (@is_scalar_tower.of_algebra_map_eq R S T _ _ _ f.to_algebra g.to_algebra (g.comp f).to_algebra
  (ring_hom.comp_apply g f)) hf hg

lemma ring_hom.is_integral_of_surjective (hf : function.surjective f) : f.is_integral :=
λ x, (hf x).rec_on (λ y hy, (hy ▸ f.is_integral_map : f.is_integral_elem x))

lemma is_integral_of_surjective (h : function.surjective (algebra_map R A)) : is_integral R A :=
(algebra_map R A).is_integral_of_surjective h

/-- If `R → A → B` is an algebra tower with `A → B` injective,
then if the entire tower is an integral extension so is `R → A` -/
lemma is_integral_tower_bot_of_is_integral (H : function.injective (algebra_map A B))
  {x : A} (h : is_integral R (algebra_map A B x)) : is_integral R x :=
begin
  rcases h with ⟨p, ⟨hp, hp'⟩⟩,
  refine ⟨p, ⟨hp, _⟩⟩,
  rw [is_scalar_tower.algebra_map_eq R A B, ← eval₂_map,
      eval₂_hom, ← ring_hom.map_zero (algebra_map A B)] at hp',
  rw [eval₂_eq_eval_map],
  exact H hp',
end

lemma ring_hom.is_integral_tower_bot_of_is_integral (hg : function.injective g)
  (hfg : (g.comp f).is_integral) : f.is_integral :=
λ x, @is_integral_tower_bot_of_is_integral R S T _ _ _ g.to_algebra (g.comp f).to_algebra f.to_algebra
  (@is_scalar_tower.of_algebra_map_eq R S T _ _ _ f.to_algebra g.to_algebra (g.comp f).to_algebra
  (ring_hom.comp_apply g f))  hg x (hfg (g x))

lemma is_integral_tower_bot_of_is_integral_field {R A B : Type*} [comm_ring R] [field A]
  [comm_ring B] [nontrivial B] [algebra R A] [algebra A B] [algebra R B] [is_scalar_tower R A B]
  {x : A} (h : is_integral R (algebra_map A B x)) : is_integral R x :=
is_integral_tower_bot_of_is_integral (algebra_map A B).injective h

lemma ring_hom.is_integral_elem_of_is_integral_elem_comp {x : T}
  (h : (g.comp f).is_integral_elem x) : g.is_integral_elem x :=
let ⟨p, ⟨hp, hp'⟩⟩ := h in ⟨p.map f, monic_map f hp, by rwa ← eval₂_map at hp'⟩

lemma ring_hom.is_integral_tower_top_of_is_integral (h : (g.comp f).is_integral) : g.is_integral :=
λ x, ring_hom.is_integral_elem_of_is_integral_elem_comp f g (h x)

/-- If `R → A → B` is an algebra tower,
then if the entire tower is an integral extension so is `A → B`. -/
lemma is_integral_tower_top_of_is_integral {x : B} (h : is_integral R x) : is_integral A x :=
begin
  rcases h with ⟨p, ⟨hp, hp'⟩⟩,
  refine ⟨p.map (algebra_map R A), ⟨monic_map (algebra_map R A) hp, _⟩⟩,
  rw [is_scalar_tower.algebra_map_eq R A B, ← eval₂_map] at hp',
  exact hp',
end

lemma ring_hom.is_integral_quotient_of_is_integral {I : ideal S} (hf : f.is_integral) :
  (ideal.quotient_map I f le_rfl).is_integral :=
begin
  rintros ⟨x⟩,
  obtain ⟨p, ⟨p_monic, hpx⟩⟩ := hf x,
  refine ⟨p.map (ideal.quotient.mk _), ⟨monic_map _ p_monic, _⟩⟩,
  simpa only [hom_eval₂, eval₂_map] using congr_arg (ideal.quotient.mk I) hpx
end

lemma is_integral_quotient_of_is_integral {I : ideal A} (hRA : is_integral R A) :
  is_integral (I.comap (algebra_map R A)).quotient I.quotient :=
(algebra_map R A).is_integral_quotient_of_is_integral hRA

lemma is_integral_quotient_map_iff {I : ideal S} :
  (ideal.quotient_map I f le_rfl).is_integral ↔
    ((ideal.quotient.mk I).comp f : R →+* I.quotient).is_integral :=
begin
  let g := ideal.quotient.mk (I.comap f),
  have := ideal.quotient_map_comp_mk le_rfl,
  refine ⟨λ h, _, λ h, ring_hom.is_integral_tower_top_of_is_integral g _ (this ▸ h)⟩,
  refine this ▸ ring_hom.is_integral_trans g (ideal.quotient_map I f le_rfl) _ h,
  exact ring_hom.is_integral_of_surjective g ideal.quotient.mk_surjective,
end

/-- If the integral extension `R → S` is injective, and `S` is a field, then `R` is also a field. -/
lemma is_field_of_is_integral_of_is_field {R S : Type*} [integral_domain R] [integral_domain S]
  [algebra R S] (H : is_integral R S) (hRS : function.injective (algebra_map R S))
  (hS : is_field S) : is_field R :=
begin
  refine ⟨⟨0, 1, zero_ne_one⟩, mul_comm, λ a ha, _⟩,
  -- Let `a_inv` be the inverse of `algebra_map R S a`,
  -- then we need to show that `a_inv` is of the form `algebra_map R S b`.
  obtain ⟨a_inv, ha_inv⟩ := hS.mul_inv_cancel (λ h, ha (hRS (trans h (ring_hom.map_zero _).symm))),

  -- Let `p : polynomial R` be monic with root `a_inv`,
  -- and `q` be `p` with coefficients reversed (so `q(a) = q'(a) * a + 1`).
  -- We claim that `q(a) = 0`, so `-q'(a)` is the inverse of `a`.
  obtain ⟨p, p_monic, hp⟩ := H a_inv,
  use -∑ (i : ℕ) in finset.range p.nat_degree, (p.coeff i) * a ^ (p.nat_degree - i - 1),

  -- `q(a) = 0`, because multiplying everything with `a_inv^n` gives `p(a_inv) = 0`.
  -- TODO: this could be a lemma for `polynomial.reverse`.
  have hq : ∑ (i : ℕ) in finset.range (p.nat_degree + 1), (p.coeff i) * a ^ (p.nat_degree - i) = 0,
  { apply (algebra_map R S).injective_iff.mp hRS,
    have a_inv_ne_zero : a_inv ≠ 0 := right_ne_zero_of_mul (mt ha_inv.symm.trans one_ne_zero),
    refine (mul_eq_zero.mp _).resolve_right (pow_ne_zero p.nat_degree a_inv_ne_zero),
    rw [eval₂_eq_sum_range] at hp,
    rw [ring_hom.map_sum, finset.sum_mul],
    refine (finset.sum_congr rfl (λ i hi, _)).trans hp,
    rw [ring_hom.map_mul, mul_assoc],
    congr,
    have : a_inv ^ p.nat_degree = a_inv ^ (p.nat_degree - i) * a_inv ^ i,
    { rw [← pow_add a_inv, nat.sub_add_cancel (nat.le_of_lt_succ (finset.mem_range.mp hi))] },
    rw [ring_hom.map_pow, this, ← mul_assoc, ← mul_pow, ha_inv, one_pow, one_mul] },

  -- Since `q(a) = 0` and `q(a) = q'(a) * a + 1`, we have `a * -q'(a) = 1`.
  -- TODO: we could use a lemma for `polynomial.div_X` here.
  rw [finset.sum_range_succ, p_monic.coeff_nat_degree, one_mul, nat.sub_self, pow_zero,
      add_eq_zero_iff_eq_neg, eq_comm] at hq,
  rw [mul_comm, ← neg_mul_eq_neg_mul, finset.sum_mul],
  convert hq using 2,
  refine finset.sum_congr rfl (λ i hi, _),
  have : 1 ≤ p.nat_degree - i := nat.le_sub_left_of_add_le (finset.mem_range.mp hi),
  rw [mul_assoc, ← pow_succ', nat.sub_add_cancel this]
end

end algebra

section
local attribute [instance] subset.comm_ring algebra.of_is_subring
theorem integral_closure_idem {R : Type*} {A : Type*} [comm_ring R] [comm_ring A] [algebra R A] :
  integral_closure (integral_closure R A : set A) A = ⊥ :=
eq_bot_iff.2 $ λ x hx, algebra.mem_bot.2
⟨⟨x, @is_integral_trans _ _ _ _ _ _ _ _ (integral_closure R A).algebra
     _ integral_closure.is_integral x hx⟩, rfl⟩
end

section integral_domain
variables {R S : Type*} [comm_ring R] [integral_domain S] [algebra R S]

instance : integral_domain (integral_closure R S) :=
{ exists_pair_ne := ⟨0, 1, mt subtype.ext_iff_val.mp zero_ne_one⟩,
  eq_zero_or_eq_zero_of_mul_eq_zero := λ ⟨a, ha⟩ ⟨b, hb⟩ h,
    or.imp subtype.ext_iff_val.mpr subtype.ext_iff_val.mpr (eq_zero_or_eq_zero_of_mul_eq_zero (subtype.ext_iff_val.mp h)),
  ..(integral_closure R S).comm_ring R S }

end integral_domain


import UniverseAbstractions.Axioms.Universes
import UniverseAbstractions.Axioms.Universe.Identity
import UniverseAbstractions.Axioms.Universe.Functors
import UniverseAbstractions.Axioms.Universe.Singletons
import UniverseAbstractions.Axioms.Universe.Products
import UniverseAbstractions.Axioms.Universe.Equivalences
import UniverseAbstractions.Instances.Utils.Bundled
import UniverseAbstractions.Instances.Utils.Trivial

import UniverseAbstractions.MathlibFragments.Init.CoreExt

set_option autoBoundImplicitLocal false
--set_option pp.universes true

universe u v

-- TODO: Use a universe as the base, to make everything stackable, and to hopefully enable extension to vector spaces etc.

class CommSemigroup (α : Type u) : Type u where
(op                   : α → α → α)
(op_assoc (a b c : α) : op (op a b) c = op a (op b c))
(op_comm  (a b   : α) : op a b = op b a)

namespace CommSemigroup

  open MetaRelation Bundled

  @[reducible] def typeClass : SimpleTypeClass.{u + 1, u + 1} := CommSemigroup.{u}
  @[reducible] def univ : Universe.{u + 1, u + 2} := Bundled.univ typeClass.{u}

  instance inst (A : univ.{u}) : CommSemigroup.{u} A := A.inst

  -- Instance equivalences

  instance hasEquivalenceRelation (A : univ.{u}) : HasEquivalenceRelation A prop :=
  ⟨nativeRelation (@Eq A)⟩

  instance hasInstanceEquivalences : HasInstanceEquivalences univ.{u} prop :=
  ⟨hasEquivalenceRelation⟩

  -- Functors

  class IsHom {A B : univ} (f : A → B) : Prop where
  (h_op (a b : A) : f (op a b) = op (f a) (f b))

  instance hasFunctoriality : HasFunctoriality univ.{u} univ.{v} := ⟨IsHom⟩

  @[simp] theorem simp_op_arg' {A B : univ} (F : HasFunctoriality.Fun A B) (a₁ a₂ : A) :
    F.f ((inst A).op a₁ a₂) = (inst B).op (F.f a₁) (F.f a₂) :=
  F.isFun.h_op a₁ a₂

  theorem funExt' {A B : univ} {F G : HasFunctoriality.Fun A B} (h : ∀ a, F.f a = G.f a) : F = G :=
  have h₁ : F.f = G.f := funext h;
  by induction F; induction G; subst h₁; simp

  instance functorSemigroup (A B : univ) : CommSemigroup (HasFunctoriality.Fun A B) :=
  { op       := λ F G   => { f     := λ a => (inst B).op (F.f a) (G.f a),
                             isFun := ⟨λ a₁ a₂ => by simp;
                                                     rw [op_assoc, op_assoc];
                                                     apply congrArg;
                                                     rw [←op_assoc, ←op_assoc];
                                                     apply congrFun;
                                                     apply congrArg;
                                                     rw [op_comm]⟩ },
    op_assoc := λ F G H => funExt' λ a => (inst B).op_assoc (F.f a) (G.f a) (H.f a),
    op_comm  := λ F G   => funExt' λ a => (inst B).op_comm (F.f a) (G.f a) }

  instance hasFunctorialityInstances :
    HasFunctorialityInstances univ.{u} univ.{v} typeClass.{max u v} :=
  ⟨functorSemigroup⟩

  def defFun {A B : univ} {f : A → B} (isHom : IsHom f) : A ⟶{f} B :=
  Bundled.HasFunctorialityInstances.defFun isHom

  instance hasCongrArg : HasCongrArg univ.{u} univ.{v} :=
  ⟨λ F => congrArg F.f⟩

  instance hasInternalFunctors : HasInternalFunctors univ.{u} := ⟨⟩

  @[simp] theorem simp_op_arg {A B : univ} (F : A ⟶ B) (a₁ a₂ : A) : F (op a₁ a₂) = op (F a₁) (F a₂) :=
  simp_op_arg' F a₁ a₂

  @[simp] theorem simp_op_fun {A B : univ} (F G : A ⟶ B) (a : A) : (op F G) a = op (F a) (G a) :=
  rfl

  theorem funExt {A B : univ} {F G : A ⟶ B} (h : ∀ a, F a = G a) : F = G :=
  funExt' h

  -- TODO: Can we make everything `by simp` again?
  instance hasLinearFunOp : HasLinearFunOp univ.{u} :=
  { defIdFun     := λ A     => defFun ⟨λ a₁ a₂ => rfl⟩,
    defRevAppFun := λ A B   => ⟨λ a => defFun ⟨λ F₁ F₂ => rfl⟩,
                                defFun ⟨λ a₁ a₂ => funExt λ F => simp_op_arg F a₁ a₂⟩⟩,
    defCompFun   := λ A B C => ⟨λ F => ⟨λ G => defFun ⟨λ a₁ a₂ => by simp⟩,
                                        defFun ⟨λ G₁ G₂ => funExt λ a => rfl⟩⟩,
                                defFun ⟨λ F₁ F₂ => funExt λ G => funExt λ a => simp_op_arg G (F₁ a) (F₂ a)⟩⟩ }

  instance hasTrivialExtensionality : HasTrivialExtensionality univ.{u} univ.{v} := ⟨funExt⟩

  instance hasLinearFunctors : HasLinearFunctors univ.{u} := ⟨⟩

  -- Singletons

  instance unitSemigroup : CommSemigroup PUnit :=
  { op       := λ _ _   => PUnit.unit,
    op_assoc := λ _ _ _ => rfl,
    op_comm  := λ _ _   => rfl }

  instance hasTopInstance : HasTopInstance typeClass.{u} := ⟨unitSemigroup⟩

  instance hasTopEq : HasTop.HasTopEq univ.{u} := ⟨λ _ => rfl⟩

  instance emptySemigroup : CommSemigroup PEmpty :=
  { op       := λ a _   => PEmpty.elim a,
    op_assoc := λ a _ _ => PEmpty.elim a,
    op_comm  := λ a _   => PEmpty.elim a }

  instance hasBotInstance : HasBotInstance typeClass.{u} := ⟨emptySemigroup⟩

  instance hasInternalBot : HasInternalBot univ.{u} :=
  { defElimFun := λ A => defFun ⟨λ a _ => PEmpty.elim a⟩ }

  -- Products

  instance prodSemigroup (A : univ.{u}) (B : univ.{v}) : CommSemigroup (PProd A B) :=
  { op       := λ a b   => ⟨op a.fst b.fst, op a.snd b.snd⟩,
    op_assoc := λ a b c => PProd.ext' ⟨op_assoc a.fst b.fst c.fst, op_assoc a.snd b.snd c.snd⟩,
    op_comm  := λ a b   => PProd.ext' ⟨op_comm a.fst b.fst, op_comm a.snd b.snd⟩ }

  instance hasProductInstances : HasProductInstances univ.{u} univ.{v} typeClass.{max u v} :=
  ⟨prodSemigroup⟩

  instance hasProductEq : HasProducts.HasProductEq univ.{u} univ.{v} :=
  { introEq := λ _   => PProd.ext' ⟨rfl, rfl⟩,
    fstEq   := λ _ _ => rfl,
    sndEq   := λ _ _ => rfl }

end CommSemigroup


import data.fintype.basic
import data.finset.basic

import guidelines.definitions
import guidelines.protocol

variables {sys_state_t pid_t ballot_t value_t : Type}
  [linear_order ballot_t] [decidable_eq pid_t]

structure requirements
  (proto : protocol sys_state_t)
  (defs : paxos_defs sys_state_t pid_t ballot_t value_t) :=
  (quorums_intersect :
    ∀ q₁ q₂, defs.quorum q₁ → defs.quorum q₂ → (q₁ ∩ q₂).nonempty)
  (none_proposed_at_init :
    ∀ state ballot value, proto.init state → ¬defs.proposed state ballot value)
  (proposed_stable :
    ∀ ballot value,
      proto.stable (λ state, defs.proposed state ballot value))
  (proposals_unique :
    ∀ ballot v₁ v₂,
      proto.invariant (λ state,
        defs.proposed state ballot v₁ → defs.proposed state ballot v₂ → v₁ = v₂))
  (at_most_one_proposal_per_step :
    ∀ s',
      proto.invariant (λ state,
        proto.next state s' →
          ∃ b v, ∀ bal val, defs.proposed s' bal val →
                 (defs.proposed state bal val ∨ (bal = b ∧ val = v))))
  (curr_increases :
    ∀ process s',
      proto.invariant (λ state,
        proto.next state s' → defs.curr state process ≤ defs.curr s' process))
  (stored_ballot_increases :
    ∀ process prop s',
      proto.invariant (λ state,
        proto.next state s' →
          defs.stored state process = some prop →
            ∃ prop', defs.stored s' process = some prop' ∧ prop.b ≤ prop'.b))
  (stored_is_proposed :
    ∀ process prop,
      proto.invariant (λ state,
        defs.stored state process = some prop →
          defs.proposed state prop.b prop.v))
  (new_votes_ge_curr_ballot :
    ∀ process ballot s',
      proto.invariant (λ state,
        proto.next state s' →
          defs.voted s' process ballot →
            defs.voted state process ballot ∨ defs.curr state process ≤ ballot))
  (voted_stable :
    ∀ process ballot,
      proto.stable (λ state, defs.voted state process ballot))
  (voted_imp_proposed :
    ∀ process ballot,
      proto.invariant (λ state,
        defs.voted state process ballot →
          ∃ value, defs.proposed state ballot value))
  (voted_le_stored :
    ∀ process ballot,
      proto.invariant (λ state,
        defs.voted state process ballot →
          ∃ prop, defs.stored state process = some prop ∧ ballot ≤ prop.b))
  (majority_have_upper_interval_if_proposed :
    ∀ ballot value,
      (proto_with_intervals_recorded defs proto).invariant (λ state,
        defs.proposed state.fst ballot value →
        ∃ (q : finset pid_t)
             (promised_prop : pid_t → option (proposal ballot_t value_t)),
          defs.quorum q ∧
          (∀ (a ∈ q),
            {interval . lower := (promised_prop a), upper := ballot} ∈ state.snd a) ∧
          (∀ (a ∈ q) prop_a, promised_prop a = some prop_a → prop_a.b < ballot) ∧
          ((∀ (a ∈ q), promised_prop a = none) ∨
           (∃ (a ∈ q) prop_a,
             promised_prop a = some prop_a ∧
             (∀ (a' ∈ q) prop_a', promised_prop a' = some prop_a' → prop_a'.b ≤ prop_a.b) ∧
             prop_a.v = value))))

namespace requirements

variables {proto : protocol sys_state_t} {defs : paxos_defs sys_state_t pid_t ballot_t value_t}

lemma none_stored_at_init (reqs_sat : requirements proto defs) :
    ∀ state process, proto.init state → defs.stored state process = none :=
begin
intros state process is_init,
have key : ∀ (prop : proposal ballot_t value_t), defs.stored state process = some prop
  → defs.proposed state prop.b prop.v,
by { intro prop, exact reqs_sat.stored_is_proposed process prop state ⟨0, is_init⟩ },
cases defs.stored state process with stored,
{ refl },
specialize key stored (by refl),
exact absurd key (reqs_sat.none_proposed_at_init state stored.b stored.v is_init)
end

lemma all_lower_proposed (reqs_sat : requirements proto defs) :
  ∀ process, (proto_with_intervals_recorded defs proto).invariant
    (λ state, ∀ (i ∈ state.snd process) prop,
      (interval.lower i) = some prop →
        defs.proposed state.fst prop.b prop.v) :=
begin
intro process, rw protocol.prove_invariant, split,
{ intros lift_s lift_s_init i i_is_start_interval prop i_lower_is_some, exfalso,
  cases lift_s_init with s_init init_intervals_is_singleton,
  specialize init_intervals_is_singleton process,
  rw init_intervals_is_singleton at i_is_start_interval,
  rw set.mem_singleton_iff at  i_is_start_interval,
  rw i_is_start_interval at i_lower_is_some,
  rw reqs_sat.none_stored_at_init lift_s.fst process s_init at i_lower_is_some,
  injection i_lower_is_some },
rintros u u_r w hu ⟨u₁_n_w₁, fact⟩ i i_in_w_history prop i_lower_is_prop,
rw fact process at i_in_w_history, cases i_in_w_history,
{ apply (λ goal, reqs_sat.proposed_stable prop.b prop.v u.fst w.fst goal u₁_n_w₁),
  exact hu i i_in_w_history prop i_lower_is_prop },
rw set.mem_singleton_iff at i_in_w_history, rw i_in_w_history at i_lower_is_prop,
have w_r : (proto_with_intervals_recorded defs proto).reachable w,
by { cases u_r with k hk, exact ⟨k.succ, u, hk, ⟨u₁_n_w₁, fact⟩⟩ },
exact reqs_sat.stored_is_proposed process prop w.fst
  (reachable_in_proto_with_intervals_recorded_implies_first_reachable defs proto w w_r)
  i_lower_is_prop
end

lemma all_upper_le_curr (reqs_sat : requirements proto defs) :
  ∀ process, (proto_with_intervals_recorded defs proto).invariant
    (λ state, ∀ (i ∈ state.snd process) b,
      (interval.upper i) = b → b ≤ defs.curr state.fst process) :=
begin
intro process, rw protocol.prove_invariant, split,
{ intros lift_s lift_s_init i i_is_start_interval b i_upper_eq_b,
  cases lift_s_init with s_init init_intervals_is_singleton,
  specialize init_intervals_is_singleton process,
  rw init_intervals_is_singleton at i_is_start_interval,
  rw set.mem_singleton_iff at  i_is_start_interval,
  rw i_is_start_interval at i_upper_eq_b,
  rw ← i_upper_eq_b },
rintros u u_r w hu ⟨u₁_n_w₁, fact⟩ i i_in_w_history b i_upper_eq_b,
rw fact process at i_in_w_history, cases i_in_w_history,
{ apply le_trans (hu i i_in_w_history b i_upper_eq_b),
  apply (λ goal, reqs_sat.curr_increases process w.fst u.fst goal u₁_n_w₁),
  exact reachable_in_proto_with_intervals_recorded_implies_first_reachable defs proto u u_r },
rw set.mem_singleton_iff at i_in_w_history, rw i_in_w_history at i_upper_eq_b,
rw ← i_upper_eq_b
end

lemma none_voted_in_interval (reqs_sat : requirements proto defs) :
  ∀ process ballot, (proto_with_intervals_recorded defs proto).invariant
    (λ state, ∀ i ∈ state.snd process, defs.voted state.fst process ballot →
      (∃ prop, interval.lower i = some prop ∧ ballot ≤ prop.b) ∨ i.upper ≤ ballot)
  :=
begin
intros process ballot, rw protocol.prove_invariant, split,
{ intros lift_s lift_s_init i i_first_interval process_voted, exfalso,
  rcases reqs_sat.voted_imp_proposed process ballot lift_s.fst
    ⟨0, lift_s_init.left⟩ process_voted with ⟨value, bal_val_proposed⟩,
  exact reqs_sat.none_proposed_at_init lift_s.fst ballot value lift_s_init.left
    bal_val_proposed },
intros lift_u lift_u_reachable lift_w h_lift_u lift_u_next_lift_w i
  i_in_history process_voted,
rw lift_u_next_lift_w.right process at i_in_history,
have already_voted_or_new_vote := reqs_sat.new_votes_ge_curr_ballot
  process ballot lift_w.fst lift_u.fst
  (reachable_in_proto_with_intervals_recorded_implies_first_reachable
    defs proto lift_u lift_u_reachable)
  lift_u_next_lift_w.left process_voted,
cases i_in_history; cases already_voted_or_new_vote with already_voted new_vote,
{ exact h_lift_u i i_in_history already_voted },
{ right, exact le_trans
  (reqs_sat.all_upper_le_curr process lift_u lift_u_reachable i
    i_in_history i.upper (by refl)) new_vote },
{ left, rw set.mem_singleton_iff at i_in_history, rw i_in_history,
  rcases reqs_sat.voted_le_stored process ballot lift_u.fst
    (reachable_in_proto_with_intervals_recorded_implies_first_reachable
      defs proto lift_u lift_u_reachable) already_voted
    with ⟨prop_u, stored_at_u, ballot_le_stored_u⟩,
  rcases reqs_sat.stored_ballot_increases process prop_u lift_w.fst lift_u.fst
    (reachable_in_proto_with_intervals_recorded_implies_first_reachable
      defs proto lift_u lift_u_reachable) lift_u_next_lift_w.left stored_at_u
    with ⟨prop_w, stored_at_w, ballot_le_stored_w⟩,
  exact ⟨prop_w, stored_at_w, le_trans ballot_le_stored_u ballot_le_stored_w⟩ },
left, rw set.mem_singleton_iff at i_in_history, rw i_in_history,
apply (λ goal, reqs_sat.voted_le_stored process ballot lift_w.fst goal process_voted),
rcases reachable_in_proto_with_intervals_recorded_implies_first_reachable
      defs proto lift_u lift_u_reachable with ⟨k, hk⟩,
exact ⟨k.succ, lift_u.fst, hk, lift_u_next_lift_w.left⟩
end

lemma chosen_stable (reqs_sat : requirements proto defs) (v : value_t) :
  proto.stable (λ state, defs.chosen state v) :=
begin
intros s s' chosen_at_s s'_follows_s,
rcases chosen_at_s with ⟨b, ⟨q, q_is_quorum, majority_voted_at_q⟩, b_v_proposed_at_s⟩,
use b, split,
{ use [q, q_is_quorum],
  intros voter in_quorum,
  specialize majority_voted_at_q voter in_quorum,
  exact reqs_sat.voted_stable voter b s s' majority_voted_at_q s'_follows_s },
  exact reqs_sat.proposed_stable b v s s' b_v_proposed_at_s s'_follows_s,
end

end requirements


import Std.Classes.BEq

namespace MWE_eq1

example [BEq α] [LawfulBEq α] {x y : α}
  : (x == y) = (x = y) := by
  simp_all

end MWE_eq1


import tactic.norm_cast

structure hom (α β : Type) :=
(to_fun : α → β)

instance {α β} : has_coe_to_fun (hom α β) :=
⟨_, hom.to_fun⟩

structure hom_plus (α β) extends hom α β

instance {α β} : has_coe (hom_plus α β) (hom α β) :=
⟨hom_plus.to_hom⟩

instance {α β} : has_coe_to_fun (hom_plus α β) :=
⟨λ _, α → β, λ f, f⟩

@[norm_cast] lemma hom_plus.coe_fn (α β : Type) (a : α) (h : hom_plus α β) :
  (h : hom α β) a = h a :=
rfl

example (α β : Type) (a : α) (h : hom_plus α β) :
  (h : hom α β) a = h a :=
by norm_cast

def f1 (n : ℕ) : hom_plus ℕ ℕ := ⟨⟨λ m, m + n⟩⟩
def f2 : hom ℕ (hom ℕ ℕ) := ⟨λ n, f1 n⟩

@[norm_cast] lemma coe_f1 (n : ℕ) :
  (f1 n : hom ℕ ℕ) = f2 n :=
rfl


import MLIRSemantics.Toy.Toy
import MLIRSemantics.Fitree
import MLIRSemantics.Verifier
import MLIRSemantics.SSAEnv
import MLIRSemantics.InvalidOp
import MLIRSemantics.Util.Metagen

import MLIR.AST
import MLIR.EDSL

import Lean

open MLIR.AST

/- To be automatically generated -/

set_option hygiene false in
genInductive ToyOp #[
  OpSpec.mk "Constant" `(
    (D: DimList) → (Hknown: D.known) →
    (e: TensorElem) → (τ: MLIRTy) → (Htype: e.hasType τ) →
    (Hcompat: e.rankCompatibleWith D τ) →
    ToyOp (RankedTensor τ.eval D)),
  OpSpec.mk "Transpose" `(
    (α: Type) → (n m: Nat) →
    RankedTensor α [Dimension.Known n, Dimension.Known m] →
    ToyOp (RankedTensor α [Dimension.Known m, Dimension.Known n])),
  OpSpec.mk "Reshape" `(
    (α: Type) → (D D': DimList) → (H: D.known) → (H': D'.known) →
    (Hprod: D'.prod = D.prod) →
    RankedTensor α D →
    ToyOp (RankedTensor α D'))
]

/- To be automatically generated (hopefully; basically this is the
   verification stuff) -/

def toy_semantics_op (ret_name: Option SSAVal):
      Op → Fitree (InvalidOpE +' SSAEnvE +' ToyOp) Unit

  | Op.mk "toy.constant" [] [] [] attrs
        (MLIRTy.fn (MLIRTy.tuple []) (MLIRTy.tensorRanked D₁ τ₁)) =>
      match AttrDict.find attrs "value" with
      | some (AttrVal.dense elem (MLIRTy.tensorRanked D₂ τ₂)) =>
          if H: D₁ = D₂ ∧ DimList.known D₁ ∧ τ₁ = τ₂ ∧ elem.hasType τ₁ then
            match Heq: elem, τ₁ with
            | TensorElem.int i, MLIRTy.int 32 => do
                let t ← Fitree.trigger (ToyOp.Constant D₁ H.2.1 elem
                  (MLIRTy.int 32) (by simp [Heq, H.2.2.2])
                  (TensorElem.rankCompatibleWith.UniformInt i 32 Heq));
                SSAEnv.set? (MLIRTy.tensorRanked D₁ (MLIRTy.int 32)) ret_name t
            | elem, τ₁ => do
                if Hshape: elem.hasShape (DimList.default_refinement D₁) then
                  let t ← Fitree.trigger (ToyOp.Constant D₁ H.2.1 elem τ₁
                    H.2.2.2 (TensorElem.rankCompatibleWith.HasShape
                     (DimList.default_refinement D₁) _ Hshape
                     (default_refinement_refines D₁)));
                  SSAEnv.set? (MLIRTy.tensorRanked D₁ τ₁) ret_name t
                else
                  Fitree.trigger InvalidOpE.InvalidOp
          else
            Fitree.trigger InvalidOpE.InvalidOp
      | _ =>
          Fitree.trigger InvalidOpE.InvalidOp

  | Op.mk "toy.transpose" [t_name] [] [] _ (MLIRTy.fn τ₁ τ₂) =>
      match τ₁ with
      | MLIRTy.tensorRanked [Dimension.Known n, Dimension.Known m] τ => do
          let t ← Fitree.trigger (@SSAEnvE.Get (MLIRTy.tensorRanked
                  [Dimension.Known n, Dimension.Known m] τ) _ t_name);
          let t' ← Fitree.trigger (ToyOp.Transpose τ.eval n m t);
          SSAEnv.set? (MLIRTy.tensorRanked [Dimension.Known m,
                       Dimension.Known n] τ)
            ret_name t'
      | _ =>
          Fitree.trigger InvalidOpE.InvalidOp

  | Op.mk "toy.reshape" [t_name] [] [] _ (MLIRTy.fn τ₁ τ₂) =>
      match τ₁, τ₂ with
      | MLIRTy.tensorRanked D σ₁, MLIRTy.tensorRanked D' σ₂ =>
          if H: σ₁ = σ₂
             ∧ DimList.known D
             ∧ DimList.known D'
             ∧ DimList.prod D' = DimList.prod D then do
            let t ← Fitree.trigger (@SSAEnvE.Get (MLIRTy.tensorRanked D σ₁) _
                    t_name);
            let t' ← Fitree.trigger (ToyOp.Reshape σ₁.eval D D'
                     H.2.1 H.2.2.1 H.2.2.2 t);
            let t': RankedTensor σ₂.eval D' := cast (by rw [H.1]) t';
            SSAEnv.set? (MLIRTy.tensorRanked D' σ₂) ret_name t'
          else
            Fitree.trigger InvalidOpE.InvalidOp
      | _, _ =>
          Fitree.trigger InvalidOpE.InvalidOp

  | _ =>
      Fitree.trigger InvalidOpE.InvalidOp

def toy_semantics_bbstmt:
      BasicBlockStmt → Fitree (InvalidOpE +' SSAEnvE +' ToyOp) Unit
  | BasicBlockStmt.StmtAssign val _ op =>
      toy_semantics_op (some val) op
  | BasicBlockStmt.StmtOp op =>
      toy_semantics_op none op

-- TODO: toy_semantics_bb: handle basic block arguments
@[simp]
def toy_semantics_bb:
      BasicBlock → Fitree (InvalidOpE +' SSAEnvE +' ToyOp) Unit
  | BasicBlock.mk name args [] =>
      Fitree.ret ()
  | BasicBlock.mk name args (op1::ops) =>
      List.foldr (fun t acc => Fitree.bind acc (fun _ => t))
                 (toy_semantics_bbstmt op1)
                 (ops.map toy_semantics_bbstmt)

/- Manually specified: ToyOp event handler -/

def ToyOp.handle {E}: ToyOp ~> Fitree E :=
  fun _ e => match e with
  | ToyOp.Constant D Hknown elem τ Htype Hcompat =>
      return RankedTensor.ofTensorElem D elem Htype Hcompat
  | ToyOp.Transpose α n m t =>
      return transpose t
  | ToyOp.Reshape α D D' H H' Hprod t =>
      return reshape D' H H' Hprod t

-- Interpretation in context

def interp_toy {E} (t: Fitree (ToyOp +' E) R): Fitree E R :=
  interp (case_ ToyOp.handle (fun T => @Fitree.trigger E E T _)) t

@[simp]
def run_toy (t: Fitree (InvalidOpE +' SSAEnvE +' ToyOp) Unit) (env: SSAEnv):
    Fitree PVoid (Unit × SSAEnv) :=
  interp ToyOp.handle (interp_ssa (interp_invalid t sorry) env)

/-
### Interpretation layers for Toy programs

We first interpret away nonexsting invalid operations, then the memory layer,
and finally the Toy operations themselves.
-/

#check interp_invalid
#check interp_ssa
#check interp_toy

/-
### Examples and testing
-/

-- The following extends #reduce with a (skipProofs := true/false) parameter
-- to not reduce proofs in the kernel. Reducing proofs would cause constant
-- timeouts, and proofs are used implicitly through well-founded induction for
-- mutual definitions.
-- See: https://leanprover.zulipchat.com/#narrow/stream/270676-lean4/topic/Repr.20instance.20for.20functions/near/276504682

open Lean
open Lean.Parser.Term
open Lean.Elab.Command
open Lean.Elab
open Lean.Meta

elab "#reduce " skipProofs:group(atomic("(" &"skipProofs") " := " (trueVal <|> falseVal) ")") term:term : command =>
  let skipProofs := skipProofs[3].isOfKind ``trueVal
  withoutModifyingEnv <| runTermElabM (some `_check) fun _ => do
    -- dbg_trace term
    let e ← Term.elabTerm term none
    Term.synthesizeSyntheticMVarsNoPostponing
    let (e, _) ← Term.levelMVarToParam (← instantiateMVars e)
    withTheReader Core.Context (fun ctx => { ctx with options := ctx.options.setBool `smartUnfolding false }) do
      let e ← withTransparency (mode := TransparencyMode.all) <| reduce e (skipProofs := skipProofs) (skipTypes := false)
      logInfo e

---

def transpose_stmt := [mlir_bb_stmt|
  %t2 = "toy.transpose"(%t1): tensor<2×4×i32> -> tensor<4×2×i32>
]

def constant_stmt := [mlir_bb_stmt|
  %t = "toy.constant"() {value=dense<[[1,2],[3,4]]>: tensor<2×2×i32>}:
    () -> tensor<2×2×i32>
]

#reduce constant_stmt

def double_transpose := [mlir_bb|
  ^dbl:
    %t2 = "toy.transpose"(%t1): tensor<2×4×i32> -> tensor<4×2×i32>
    %t3 = "toy.transpose"(%t2): tensor<4×2×i32> -> tensor<2×4×i32>
]

#reduce (skipProofs := true)
  toy_semantics_bb double_transpose

#reduce (skipProofs := true)
  run_toy (toy_semantics_bbstmt transpose_stmt) [[]]

#reduce (skipProofs := true)
  run_toy (toy_semantics_bbstmt constant_stmt) [[]]

theorem double_transpose_correct:
  ∀ (t1: RankedTensor Int [2,4]),
    run_toy (toy_semantics_bb double_transpose)
      [[("t1", ⟨MLIRTy.tensorRanked [2,4] (MLIRTy.int 32), t1⟩)]]
    =
    Fitree.ret ((), [[
      (SSAVal.SSAVal "t1", ⟨MLIRTy.tensorRanked [2,4] (MLIRTy.int 32), t1⟩),
      (SSAVal.SSAVal "t2", ⟨MLIRTy.tensorRanked [4,2] (MLIRTy.int 32),
                           transpose t1⟩),
      (SSAVal.SSAVal "t3", ⟨MLIRTy.tensorRanked [2,4] (MLIRTy.int 32), t1⟩)
    ]]) := by
  intros t1
  unfold double_transpose
  simp
  simp [double_transpose, toy_semantics_bb, toy_semantics_bbstmt]; simp_itree
  simp [interp_invalid]; simp_itree
  simp [interp_ssa]; simp_itree
  rw [transpose_involutive]
  rfl


import util.data.functor

universes u v w

namespace ulift

variables {α β γ : Type u}

def pure (x : α) : ulift α := ⟨ x ⟩

def bind (x : ulift α) (f : α → ulift β) : ulift β :=
f (down x)

instance : has_bind ulift := ⟨ @bind ⟩

lemma bind_assoc (x : ulift α) (f : α → ulift β) (g : β → ulift γ)
: x >>= f >>= g = x >>= (λ i, f i >>= g) :=
by { cases x ; refl }

lemma pure_bind (x : α) (f : α → ulift β)
: pure x >>= f = f x := sorry

lemma id_map (x : ulift α)
: ulift.bind x (ulift.pure ∘ id) = x := sorry

end ulift

instance : monad ulift :=
{ bind := @ulift.bind
, pure := @ulift.pure }

instance : is_lawful_monad ulift :=
{ pure_bind := @ulift.pure_bind
, bind_assoc := @ulift.bind_assoc
, id_map := @ulift.id_map }

variables (m : Type (max w u) → Type v)

structure ulift_t (α : Type w) :=
(run : m (ulift α))

namespace ulift_t

export ulift (up down up_down)

variables {m}

variables {α β γ : Type w}

protected def bind [has_bind m] (x : ulift_t m α) (f : α → ulift_t m β) : ulift_t m β :=
⟨ x.run >>= ulift_t.run ∘ f ∘ down ⟩

protected def pure [has_pure m] (x : α) : ulift_t m α :=
⟨ pure (up x) ⟩

instance [has_bind m] : has_bind (ulift_t m) :=
⟨ λ α β, @ulift_t.bind m α β _ ⟩

instance [has_pure m] : has_pure (ulift_t m) :=
⟨ λ α, @ulift_t.pure m α _ ⟩

variables [monad m] [is_lawful_monad m]
open is_lawful_monad

lemma bind_assoc (x : ulift_t m α) (f : α → ulift_t m β) (g : β → ulift_t m γ)
: x >>= f >>= g = x >>= (λ i, f i >>= g) :=
by simp [has_bind.bind,ulift_t.bind,bind_assoc]

lemma pure_bind (x : α) (f : α → ulift_t m β)
: ulift_t.pure x >>= f = f x :=
begin
  destruct f x, intros y h,
  simp [has_bind.bind,ulift_t.bind,ulift_t.pure],
  simp [pure_bind,function.comp,h],
end

lemma id_map (x : ulift_t m α)
: x >>= pure ∘ id = x :=
begin
  cases x,
  simp [has_bind.bind,ulift_t.bind,function.comp,pure,has_pure.pure,ulift_t.pure],
  simp [up_down],
end

end ulift_t

instance {m : Type (max w u) → Type v} [monad m] : monad (ulift_t m) :=
{ bind := λ α β, ulift_t.bind
, pure := λ α, ulift_t.pure }

instance {m : Type (max w u) → Type v} [monad m] [is_lawful_monad m] : is_lawful_monad (ulift_t m) :=
{ pure_bind := λ α β, @ulift_t.pure_bind m α β _ _
, bind_assoc := λ α β γ, ulift_t.bind_assoc
, id_map := λ α, @ulift_t.id_map m α _ _ }


import data.cpi.species.basic

namespace cpi
namespace species

variables {ℍ : Type} {ω : context}

/-- A chain of rewrite rules, to transform a species from one kind to another
    equivalent one. -/
@[nolint has_inhabited_instance]
inductive equivalent : ∀ {Γ} (A B : species ℍ ω Γ), Type
| refl  {Γ} {A : species ℍ ω Γ} : equivalent A A
| trans {Γ} {A B C : species ℍ ω Γ} : equivalent A B → equivalent B C → equivalent A C

-- Protections into the body of a species.
| ξ_parallel₁
      {Γ} {A A' B : species ℍ ω Γ}
    : equivalent A A' → equivalent (A |ₛ B) (A' |ₛ B)
| ξ_parallel₂
      {Γ} {A B B' : species ℍ ω Γ}
    : equivalent B B' → equivalent (A |ₛ B) (A |ₛ B')
| ξ_restriction
      {Γ} (M : affinity ℍ) {A A' : species ℍ ω (context.extend (M.arity) Γ)}
    : equivalent A A' → equivalent (ν(M) A) (ν(M) A')
| ξ_choice_here
      {Γ} {f} (π : prefix_expr ℍ Γ f) {A A' : species ℍ ω (f.apply Γ)} {As : choices ℍ ω Γ}
    : equivalent A A'
    → equivalent (Σ# (whole.cons π A As)) (Σ# (whole.cons π A' As))
| ξ_choice_there
      {Γ} {f} (π : prefix_expr ℍ Γ f) {A : species ℍ ω (f.apply Γ)} {As As' : choices ℍ ω Γ}
    : equivalent (Σ# As) (Σ# As')
    → equivalent (Σ# (whole.cons π A As)) (Σ# (whole.cons π A As'))

-- | An element in the choice array can be swapped.
| choice_swap
    {Γ} {f g} (π₁ : prefix_expr ℍ Γ f) (π₂ : prefix_expr ℍ Γ g)
    {A : species ℍ ω (f.apply Γ)} {B : species ℍ ω (g.apply Γ)} {As : choices ℍ ω Γ}
  : equivalent (Σ# (whole.cons π₁ A (whole.cons π₂ B As)))
          (Σ# (whole.cons π₂ B (whole.cons π₁ A As)))

-- Species forms a commutative monoid using parallel.
| parallel_nil₁   {Γ} {A : species ℍ ω Γ}     : equivalent (A |ₛ nil) A
| parallel_nil₂   {Γ} {A : species ℍ ω Γ}     : equivalent A (A |ₛ nil)
| parallel_symm   {Γ} {A B : species ℍ ω Γ}   : equivalent (A |ₛ B) (B |ₛ A)
| parallel_assoc₁ {Γ} {A B C : species ℍ ω Γ} : equivalent ((A |ₛ B) |ₛ C) (A |ₛ (B |ₛ C))
| parallel_assoc₂ {Γ} {A B C : species ℍ ω Γ} : equivalent (A |ₛ (B |ₛ C)) ((A |ₛ B) |ₛ C)

| ν_parallel₁
    {Γ} (M : affinity ℍ) {A : species ℍ ω Γ} {B : species ℍ ω (context.extend M.arity Γ)}
  : equivalent (ν(M) (rename name.extend A |ₛ B)) (A |ₛ ν(M)B)
| ν_parallel₂
    {Γ} (M : affinity ℍ) {A : species ℍ ω Γ} {B : species ℍ ω (context.extend M.arity Γ)}
  : equivalent (A |ₛ ν(M)B) (ν(M) (rename name.extend A |ₛ B))
| ν_drop₁
    {Γ} (M : affinity ℍ) {A : species ℍ ω Γ}
  : equivalent (ν(M) (rename name.extend A)) A
| ν_drop₂
    {Γ} (M : affinity ℍ) {A : species ℍ ω Γ}
  : equivalent A (ν(M) (rename name.extend A))
| ν_swap₁
    {Γ} (M N : affinity ℍ)
    {A  : species ℍ ω (context.extend N.arity (context.extend M.arity Γ))}
  : equivalent (ν(M)ν(N) A) (ν(N)ν(M) rename name.swap A)
| ν_swap₂ -- Identical to ν_swap₁ but flipped. This is pointless, but makes symm_symm easier to show.
    {Γ} (M N : affinity ℍ)
    {A  : species ℍ ω (context.extend N.arity (context.extend M.arity Γ))}
  : @equivalent Γ (ν(N)ν(M) rename name.swap A) (ν(M)ν(N) A)

namespace equivalent
  /-- Flip an equivalence relationship. -/
  protected def symm : ∀ {Γ} {A B : species ℍ ω Γ}, equivalent A B → equivalent B A
  | Γ A B eq := begin
    induction eq,
    case refl { from refl },
    case trans : Γ A B C ab bc ih_ab ih_bc { from trans ih_bc ih_ab },

    case ξ_parallel₁ : Γ A A' B eq ih { from ξ_parallel₁ ih },
    case ξ_parallel₂ : Γ A A' B eq ih { from ξ_parallel₂ ih },
    case ξ_restriction : Γ M A A' eq ih { from ξ_restriction M ih },
    case ξ_choice_here : Γ f π A A' As eq ih { from ξ_choice_here π ih },
    case ξ_choice_there : Γ f π A A' As eq ih { from ξ_choice_there π ih },

    case choice_swap { from choice_swap _ _ },

    case parallel_nil₁ { from parallel_nil₂ },
    case parallel_nil₂ { from parallel_nil₁ },
    case parallel_symm { from parallel_symm },
    case parallel_assoc₁ { from parallel_assoc₂ },
    case parallel_assoc₂ { from parallel_assoc₁ },

    case ν_parallel₁ : Γ M { from ν_parallel₂ M },
    case ν_parallel₂ : Γ M { from ν_parallel₁ M },
    case ν_drop₁ : Γ M { from ν_drop₂ M },
    case ν_drop₂ : Γ M { from ν_drop₁ M },
    case ν_swap₁ : Γ M N { from ν_swap₂ M N },
    case ν_swap₂ : Γ M N { from ν_swap₁ M N },
  end

  /-- Flipping an equivalence relation twice gives the original. -/
  protected lemma symm_symm :
    ∀ {Γ} {A B : species ℍ ω Γ} (eq : equivalent A B)
    , eq = equivalent.symm (equivalent.symm eq)
  | Γ A B eq := begin
    induction eq,
    case equivalent.refl { from rfl },
    case equivalent.trans : Γ A B C ab bc ih_ab ih_bc {
      from congr_arg2 trans ih_ab ih_bc,
    },
    case ξ_parallel₁ : Γ A A' B eq ih { from congr_arg ξ_parallel₁ ih, },
    case ξ_parallel₂ : Γ A A' B eq ih { from congr_arg ξ_parallel₂ ih },
    case ξ_restriction : Γ M A A' eq ih { from congr_arg (ξ_restriction M) ih },
    case ξ_choice_here : Γ f π A A' As eq ih { from congr_arg (ξ_choice_here π) ih },
    case ξ_choice_there : Γ f π A A' As eq ih { from congr_arg (ξ_choice_there π) ih },

    repeat { from rfl },
  end

  local infix ` ~ ` := equivalent

  private def rename_swap
    {Γ Δ} {ρ : name Γ → name Δ} {M N : affinity ℍ}
    (A' : species ℍ ω (context.extend M.arity (context.extend N.arity Γ)))
    : rename (name.ext (name.ext ρ)) (rename name.swap A')
    = rename name.swap (rename (name.ext (name.ext ρ)) A')
    := by rw [rename_compose, name.swap_ext_ext, rename_compose]

  /-- Rename an equivalence relationship. -/
  protected def rename :
      ∀ {Γ Δ} {A B : species ℍ ω Γ} (ρ : name Γ → name Δ)
      , A ~ B → rename ρ A ~ rename ρ B
    | Γ Δ A B ρ eq := begin
      induction eq generalizing Δ,

      case refl : Γ A Δ ρ { from refl },
      case trans : Γ A B C ab bc ih_ab ih_bc { from trans (ih_ab _ ρ) (ih_bc _ ρ) },

      -- Projection
      case ξ_parallel₁ : Γ A A' B eq ih { simp, from ξ_parallel₁ (ih _ ρ) },
      case ξ_parallel₂ : Γ A A' B eq ih { simp, from ξ_parallel₂ (ih _ ρ) },
      case ξ_restriction : Γ M A A' eq ih {
        simp only [species.rename.restriction],
        from ξ_restriction M (ih _ (name.ext ρ))
      },
      case ξ_choice_here : Γ f π A A' As eq ih {
        simp only [species.rename.choice, species.rename.cons],
        from ξ_choice_here (prefix_expr.rename ρ π) (ih _ (prefix_expr.ext π ρ))
      },
      case ξ_choice_there : Γ f π A As As' eq ih {
        simp only [species.rename.choice, species.rename.cons],
        have h := ih _ ρ,
        have g : (Σ# species.rename ρ As) ~ (Σ# species.rename ρ As'), simp at h, from h,
        from ξ_choice_there (prefix_expr.rename ρ π) g
      },

      -- Choice
      case choice_swap : Γ f g π₁ π₂ A B As {
        simp only [species.rename.choice, species.rename.cons],
        from choice_swap _ _
      },

      -- Parallel
      case parallel_nil₁ : Γ A { simp only [species.rename.nil, species.rename.parallel], from parallel_nil₁ },
      case parallel_nil₂ : Γ A { simp only [species.rename.nil, species.rename.parallel], from parallel_nil₂ },
      case parallel_symm : Γ A B { simp only [species.rename.parallel], from parallel_symm },
      case parallel_assoc₁ : Γ A B C { simp only [species.rename.parallel], from parallel_assoc₁ },
      case parallel_assoc₂ : Γ A B C { simp only [species.rename.parallel], from parallel_assoc₂ },

      -- Restriction
      case ν_parallel₁ : Γ M A B {
        simp only [species.rename.restriction, species.rename.parallel],
        rw ← species.rename_ext _, from ν_parallel₁ M
      },
      case ν_parallel₂ : Γ M A B {
        simp only [species.rename.restriction, species.rename.parallel],
        rw ← species.rename_ext _, from ν_parallel₂ M
      },
      case ν_drop₁ : Γ M A {
        simp only [species.rename.restriction], rw ← species.rename_ext _, from ν_drop₁ M
      },
      case ν_drop₂ : Γ M A {
        simp only [species.rename.restriction], rw ← species.rename_ext _, from ν_drop₂ M
      },
      case ν_swap₁ : Γ M N A { simp only [species.rename.restriction], rw rename_swap _, from ν_swap₁ M N },
      case ν_swap₂ : Γ M N A { simp only [species.rename.restriction], rw rename_swap _, from ν_swap₂ M N },
    end
end equivalent

/-- Lower an equivalence relationship to a proof-irrelevant proposition.

    This allows us to use it as a normal proof object, while -/
inductive equiv {Γ} (A B : species ℍ ω Γ) : Prop
| intro : equivalent A B → equiv

namespace equiv
  local infix ` ~ ` := equiv
  @[pattern]
  protected lemma refl {Γ} (A : species ℍ ω Γ) : A ~ A := ⟨ equivalent.refl ⟩

  @[pattern]
  protected lemma rfl {Γ} {A : species ℍ ω Γ} : A ~ A := equiv.refl A

  protected lemma symm {Γ} {A B : species ℍ ω Γ} : A ~ B → B ~ A
  | ⟨ eq ⟩ := ⟨ equivalent.symm eq ⟩

  @[pattern]
  protected lemma trans {Γ} {A B C : species ℍ ω Γ} : A ~ B → B ~ C → A ~ C
  | ⟨ ab ⟩ ⟨ bc ⟩ := ⟨ equivalent.trans ab bc ⟩

  protected lemma rename {Γ Δ} {A B : species ℍ ω Γ} (ρ : name Γ → name Δ)
    : A ~ B → rename ρ A ~ rename ρ B
  | ⟨ eq ⟩ := ⟨ equivalent.rename ρ eq ⟩

  @[pattern]
  lemma ξ_parallel₁ {Γ} {A A' B : species ℍ ω Γ} : A ~ A' → (A |ₛ B) ~ (A' |ₛ B)
  | ⟨ eq ⟩ := ⟨ equivalent.ξ_parallel₁ eq ⟩

  @[pattern]
  lemma ξ_parallel₂ {Γ} {A B B' : species ℍ ω Γ} : B ~ B' → (A |ₛ B) ~ (A |ₛ B')
  | ⟨ eq ⟩ := ⟨ equivalent.ξ_parallel₂ eq ⟩

  @[pattern]
  lemma ξ_restriction {Γ} (M : affinity ℍ) {A A' : species ℍ ω (context.extend (M.arity) Γ)}
    : A ~ A' → (ν(M) A) ~ (ν(M) A')
  | ⟨ eq ⟩ := ⟨ equivalent.ξ_restriction M eq ⟩

  @[pattern]
  lemma ξ_choice_here
      {Γ} {f} (π : prefix_expr ℍ Γ f) {A A' : species ℍ ω (f.apply Γ)} {As : choices ℍ ω Γ}
    : A ~ A' → (Σ# (whole.cons π A As)) ~ (Σ# (whole.cons π A' As))
  | ⟨ eq ⟩ := ⟨ equivalent.ξ_choice_here π eq ⟩

  @[pattern]
  lemma ξ_choice_there
      {Γ} {f} (π : prefix_expr ℍ Γ f) {A : species ℍ ω (f.apply Γ)} {As As' : choices ℍ ω Γ}
    : (Σ# As) ~ (Σ# As')
    → (Σ# (whole.cons π A As)) ~ (Σ# (whole.cons π A As'))
  | ⟨ eq ⟩ := ⟨ equivalent.ξ_choice_there π eq ⟩

  @[pattern]
  lemma choice_swap
      {Γ} {f g} (π₁ : prefix_expr ℍ Γ f) (π₂ : prefix_expr ℍ Γ g)
      {A : species ℍ ω (f.apply Γ)} {B : species ℍ ω (g.apply Γ)} {As : choices ℍ ω Γ}
    : (Σ# (whole.cons π₁ A (whole.cons π₂ B As))) ~ (Σ# (whole.cons π₂ B (whole.cons π₁ A As)))
    := ⟨ equivalent.choice_swap π₁ π₂ ⟩

  @[pattern]
  lemma parallel_nil₁   {Γ} {A : species ℍ ω Γ}     : (A |ₛ nil) ~ A := ⟨ equivalent.parallel_nil₁ ⟩

  @[pattern]
  lemma parallel_nil₂   {Γ} {A : species ℍ ω Γ}     : A ~ (A |ₛ nil) := ⟨ equivalent.parallel_nil₂ ⟩

  @[pattern]
  lemma parallel_symm   {Γ} {A B : species ℍ ω Γ}   : (A |ₛ B) ~ (B |ₛ A) := ⟨ equivalent.parallel_symm ⟩

  @[pattern]
  lemma parallel_assoc₁ {Γ} {A B C : species ℍ ω Γ} : ((A |ₛ B) |ₛ C) ~ (A |ₛ (B |ₛ C)) := ⟨ equivalent.parallel_assoc₁ ⟩

  @[pattern]
  lemma parallel_assoc₂ {Γ} {A B C : species ℍ ω Γ} : (A |ₛ (B |ₛ C)) ~ ((A |ₛ B) |ₛ C) := ⟨ equivalent.parallel_assoc₂ ⟩

  @[pattern]
  lemma ν_parallel₁
      {Γ} (M : affinity ℍ) {A : species ℍ ω Γ} {B : species ℍ ω (context.extend M.arity Γ)}
    : (ν(M) (rename name.extend A |ₛ B)) ~ (A |ₛ ν(M)B)
    := ⟨ equivalent.ν_parallel₁ M ⟩

  @[pattern]
  lemma ν_parallel₂
      {Γ} (M : affinity ℍ) {A : species ℍ ω Γ} {B : species ℍ ω (context.extend M.arity Γ)}
    : (A |ₛ ν(M)B) ~ (ν(M) (rename name.extend A |ₛ B))
    := ⟨ equivalent.ν_parallel₂ M ⟩

  @[pattern]
  lemma ν_drop₁ {Γ} (M : affinity ℍ) {A : species ℍ ω Γ} : (ν(M) (rename name.extend A)) ~ A
    := ⟨ equivalent.ν_drop₁ M ⟩

  @[pattern]
  lemma ν_drop₂ {Γ} (M : affinity ℍ) {A : species ℍ ω Γ} : A ~ (ν(M) (rename name.extend A))
    := ⟨ equivalent.ν_drop₂ M ⟩

  @[pattern]
  lemma ν_swap₁
      {Γ} (M N : affinity ℍ) {A : species ℍ ω (context.extend N.arity (context.extend M.arity Γ))}
    : (ν(M)ν(N) A) ~ (ν(N)ν(M) rename name.swap A)
    := ⟨ equivalent.ν_swap₁ M N ⟩

  @[pattern]
  lemma ν_swap₂ -- Strictly the same as ν_swap₁, as name.swap is symmetric, but...
      {Γ} (M N : affinity ℍ) {A : species ℍ ω (context.extend N.arity (context.extend M.arity Γ))}
    : (ν(N)ν(M) rename name.swap A) ~ (ν(M)ν(N) A)
    := ⟨ equivalent.ν_swap₂ M N ⟩

  -- Show equiv is an equivalence and reflexive operator
  instance {Γ} : is_equiv (species ℍ ω Γ) equiv :=
    { refl := equiv.refl, symm := @equiv.symm ℍ ω Γ, trans := @equiv.trans ℍ ω Γ }
  instance {Γ} : is_refl (species ℍ ω Γ) equiv := ⟨ equiv.refl ⟩

  /-- The setoid of species under structural congruence. Can be brought into
      scope with the "congruence" locale. -/
  def setoid {Γ} : setoid (species ℍ ω Γ) :=
    ⟨ equiv, ⟨ @equiv.refl ℍ ω Γ, @equiv.symm ℍ ω Γ, @equiv.trans ℍ ω Γ ⟩ ⟩

  localized "attribute [instance] cpi.species.equiv.setoid" in congruence

  lemma parallel_symm₁ {Γ} {A B C : species ℍ ω Γ} : (A |ₛ B |ₛ C) ≈ (B |ₛ A |ₛ C) :=
    calc  (A |ₛ (B |ₛ C))
        ≈ ((A |ₛ B) |ₛ C) : parallel_assoc₂
    ... ≈ ((B |ₛ A) |ₛ C) : ξ_parallel₁ parallel_symm
    ... ≈ (B |ₛ (A |ₛ C)) : parallel_assoc₁

  lemma parallel_symm₂ {Γ} {A B C : species ℍ ω Γ} : ((A |ₛ B) |ₛ C) ≈ ((A |ₛ C) |ₛ B) :=
    calc  ((A |ₛ B) |ₛ C)
        ≈ (A |ₛ (B |ₛ C)) : parallel_assoc₁
    ... ≈ (A |ₛ (C |ₛ B)) : ξ_parallel₂ parallel_symm
    ... ≈ ((A |ₛ C) |ₛ B) : parallel_assoc₂

  lemma ν_parallel' {Γ} (M : affinity ℍ) {A : species ℍ ω (context.extend M.arity Γ)} {B : species ℍ ω Γ}
    : (ν(M) (A |ₛ rename name.extend B)) ≈ ((ν(M)A) |ₛ B) :=
    calc  (ν(M) A |ₛ rename name.extend B)
        ≈ (ν(M) rename name.extend B |ₛ A) : ξ_restriction M parallel_symm
    ... ≈ (B |ₛ ν(M) A) : ν_parallel₁ M
    ... ≈ ((ν(M) A) |ₛ B) : parallel_symm

  lemma parallel_nil' {Γ} {A : species ℍ ω Γ} : (nil |ₛ A) ≈ A :=
    calc  (nil |ₛ A)
        ≈ (A |ₛ nil) : parallel_symm
    ... ≈ A : parallel_nil₁
end equiv

open_locale congruence

namespace parallel
  lemma from_list_cons {Γ} (A : species ℍ ω Γ) :
    ∀ (Bs : list(species ℍ ω Γ)), from_list (A :: Bs) ≈ (A |ₛ from_list Bs)
  | [] := equiv.parallel_nil₂
  | (B :: Bs) := refl _

  lemma from_append {Γ} :
    ∀ (As : list (species ℍ ω Γ)) (Bs : list (species ℍ ω Γ))
    , from_list (As ++ Bs) ≈ (from_list As |ₛ from_list Bs)
  | [] B := by { simp only [list.nil_append], from symm equiv.parallel_nil' }
  | [A] B := from_list_cons A _
  | (A :: A' :: As) B := begin
      have h := from_append (A' :: As) B,
      simp only [from_list, list.cons_append],
      calc  (A |ₛ from_list (A' :: (As ++ B)))
          ≈ (A |ₛ (from_list (A' :: As) |ₛ from_list B))
            : equiv.ξ_parallel₂ h
      ... ≈ ((A |ₛ from_list (A' :: As)) |ₛ from_list B)
            : symm equiv.parallel_assoc₁
    end

  lemma from_to {Γ} : ∀ (A : species ℍ ω Γ), from_list (to_list A) ≈ A
  | nil := by unfold from_list to_list
  | (Σ# _) := by unfold from_list to_list
  | (ν(_) _) := by unfold from_list to_list
  | (apply _ _) := by unfold from_list to_list
  | (A |ₛ B) := begin
      unfold from_list to_list,
      have a := from_to A, have b := from_to B,
      calc  from_list (to_list A ++ to_list B)
          ≈ (from_list (to_list A) |ₛ from_list (to_list B))
            : from_append (to_list A) (to_list B)
      ... ≈ (from_list (to_list A) |ₛ B) : equiv.ξ_parallel₂ b
      ... ≈ (A |ₛ B) : equiv.ξ_parallel₁ a,
    end

  lemma from_to_append {Γ} (A B : species ℍ ω Γ)
    : from_list (to_list A ++ to_list B) ≈ (A |ₛ B) := begin
    have h : to_list A ++ to_list B = to_list (A |ₛ B), unfold to_list,
    rw h, from from_to _,
  end

  private lemma from_cons {Γ} :
    ∀ (A : species ℍ ω Γ) {As Bs : list _}
    , from_list As ≈ from_list Bs
    → from_list (A :: As) ≈ from_list (A :: Bs)
  | A [] [] _ := refl _
  | A [] (B' :: Bs) eq :=
      calc  A
          ≈ (A |ₛ nil) : equiv.parallel_nil₂
      ... ≈ (A |ₛ from_list (B' :: Bs)) : equiv.ξ_parallel₂ eq
  | A (A' :: As) [] eq :=
      calc  (A |ₛ from_list (A' :: As))
          ≈ (A |ₛ nil) : equiv.ξ_parallel₂ eq
      ... ≈ A : equiv.parallel_nil₁
  | A (A' :: As) (B' :: Bs') eq := equiv.ξ_parallel₂ eq

  lemma permute {Γ} :
    ∀ {As Bs : list (species ℍ ω Γ)}
    , As ≈ Bs → from_list As ≈ from_list Bs := λ _ _ perm, begin
    induction perm,

    case list.perm.nil { from refl _ },
    case list.perm.skip : A As Bs pm ih { from from_cons A ih },
    case list.perm.swap : A B As {
      cases As,
      case list.nil { from equiv.parallel_symm },
      case list.cons { from equiv.parallel_symm₁ },
    },
    case list.perm.trans : As Bs Cs ab bc ih_ab ih_bc { from trans ih_ab ih_bc }
  end

  namespace quot
    /-- Make a parallel species from a quotient of two species. -/
    def mk {Γ} : species' ℍ ω Γ → species' ℍ ω Γ → species' ℍ ω Γ
    | A B := quotient.lift_on₂ A B (λ A B, ⟦ A |ₛ B ⟧)
        (λ A B A' B' eqA eqB, quot.sound (trans (equiv.ξ_parallel₁ eqA) ((equiv.ξ_parallel₂ eqB))))

    lemma assoc {Γ} (A B C : species' ℍ ω Γ)
      : mk A (mk B C) = mk (mk A B) C
      := begin
        rcases quot.exists_rep A with ⟨ A, ⟨ _ ⟩ ⟩,
        rcases quot.exists_rep B with ⟨ B, ⟨ _ ⟩ ⟩,
        rcases quot.exists_rep C with ⟨ C, ⟨ _ ⟩ ⟩,
        from quot.sound equiv.parallel_assoc₂,
      end

    /-- parallel.from_list, lifted to the level of quotients. -/
    def from_list {Γ} :
      list (species' ℍ ω Γ) → species' ℍ ω Γ
    | [] := ⟦ nil ⟧
    | [A] := A
    | (A :: As) := mk A (from_list As)

    lemma from_append {Γ} :
      ∀ (A B : list (species' ℍ ω Γ))
      , from_list (A ++ B) = mk (from_list A) (from_list B)
    | [] B := begin
        simp only [list.nil_append],
        from quot.induction_on (from_list B) (λ B, quot.sound (symm equiv.parallel_nil')),
      end
    | [A] [] := quot.induction_on A (λ A, quot.sound equiv.parallel_nil₂)
    | [A] (B :: Bs) := rfl
    | (A :: A' :: As) B := begin
        show mk A (from_list (A' :: As ++ B)) = mk (mk A (from_list (A' :: As))) (from_list B),
        rw (from_append (A' :: As) B),
        from assoc _ _ _,
      end

    private lemma from_cons {Γ} :
      ∀ (A : species' ℍ ω Γ) {As Bs : list _}
      , from_list As = from_list Bs
      → from_list (A :: As) = from_list (A :: Bs)
    | A [] [] _ := refl _
    | A [] (B' :: Bs) eq := begin
        rcases quot.exists_rep A with ⟨ A, ⟨ _ ⟩ ⟩,
        simp only [from_list, symm eq],
        from quot.sound equiv.parallel_nil₂,
      end
    | A (A' :: As) [] eq := begin
        rcases quot.exists_rep A with ⟨ A, ⟨ _ ⟩ ⟩,
        simp only [from_list, eq],
        from quot.sound equiv.parallel_nil₁,
      end
    | A (A' :: As) (B' :: Bs') eq := by simp only [from_list, eq]

    lemma permute {Γ} :
      ∀ {As Bs : list (species' ℍ ω Γ)}
      , As ≈ Bs → from_list As = from_list Bs := λ _ _ perm, begin
      induction perm,

      case list.perm.nil { from refl _ },
      case list.perm.skip : A As Bs pm ih { from from_cons A ih },
      case list.perm.swap : A B As {
        rcases quot.exists_rep A with ⟨ A, ⟨ _ ⟩ ⟩,
        rcases quot.exists_rep B with ⟨ B, ⟨ _ ⟩ ⟩,

        cases As,
        case list.nil { from quot.sound equiv.parallel_symm },
        case list.cons {
          unfold from_list,
          from quotient.induction_on (from_list (As_hd :: As_tl))
            (λ _, quot.sound equiv.parallel_symm₁),
        },
      },
      case list.perm.trans : As Bs Cs ab bc ih_ab ih_bc { from trans ih_ab ih_bc }
    end
  end quot
end parallel

section examples
  variable {Γ : context}
  variables A A' B C : species ℍ ω Γ

  example : A ≈ (A |ₛ nil) := symm equiv.parallel_nil₁

  example : A ≈ (nil |ₛ A) := trans equiv.parallel_nil₂ equiv.parallel_symm

  example : A ≈ A' → (A |ₛ B) ≈ C → (A' |ₛ B) ≈ C := begin
    assume a eq,
    from trans (symm $ equiv.ξ_parallel₁ a) eq
  end
end examples

end species

end cpi

#lint-