/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.geom_sum
import Mathlib.order.filter.archimedean
import Mathlib.order.iterate
import Mathlib.topology.instances.ennreal
import Mathlib.tactic.ring_exp
import Mathlib.analysis.asymptotics
import Mathlib.PostPort

universes u_1 u_4

namespace Mathlib

/-!
# A collection of specific limit computations
-/

theorem tendsto_norm_at_top_at_top : filter.tendsto norm filter.at_top filter.at_top :=
  filter.tendsto_abs_at_top_at_top

theorem summable_of_absolute_convergence_real {f : ℕ → ℝ} : (∃ (r : ℝ),
    filter.tendsto (fun (n : ℕ) => finset.sum (finset.range n) fun (i : ℕ) => abs (f i)) filter.at_top (nhds r)) →
  summable f := sorry

theorem tendsto_inverse_at_top_nhds_0_nat : filter.tendsto (fun (n : ℕ) => ↑n⁻¹) filter.at_top (nhds 0) :=
  filter.tendsto.comp tendsto_inv_at_top_zero tendsto_coe_nat_at_top_at_top

theorem tendsto_const_div_at_top_nhds_0_nat (C : ℝ) : filter.tendsto (fun (n : ℕ) => C / ↑n) filter.at_top (nhds 0) := sorry

theorem nnreal.tendsto_inverse_at_top_nhds_0_nat : filter.tendsto (fun (n : ℕ) => ↑n⁻¹) filter.at_top (nhds 0) := sorry

theorem nnreal.tendsto_const_div_at_top_nhds_0_nat (C : nnreal) : filter.tendsto (fun (n : ℕ) => C / ↑n) filter.at_top (nhds 0) := sorry

theorem tendsto_one_div_add_at_top_nhds_0_nat : filter.tendsto (fun (n : ℕ) => 1 / (↑n + 1)) filter.at_top (nhds 0) := sorry

/-! ### Powers -/

theorem tendsto_add_one_pow_at_top_at_top_of_pos {α : Type u_1} [linear_ordered_semiring α] [archimedean α] {r : α} (h : 0 < r) : filter.tendsto (fun (n : ℕ) => (r + 1) ^ n) filter.at_top filter.at_top :=
  filter.tendsto_at_top_at_top_of_monotone' (fun (n m : ℕ) => pow_le_pow (le_add_of_nonneg_left (le_of_lt h)))
    (iff.mpr not_bdd_above_iff fun (x : α) => iff.mpr set.exists_range_iff (add_one_pow_unbounded_of_pos x h))

theorem tendsto_pow_at_top_at_top_of_one_lt {α : Type u_1} [linear_ordered_ring α] [archimedean α] {r : α} (h : 1 < r) : filter.tendsto (fun (n : ℕ) => r ^ n) filter.at_top filter.at_top :=
  sub_add_cancel r 1 ▸ tendsto_add_one_pow_at_top_at_top_of_pos (iff.mpr sub_pos h)

theorem nat.tendsto_pow_at_top_at_top_of_one_lt {m : ℕ} (h : 1 < m) : filter.tendsto (fun (n : ℕ) => m ^ n) filter.at_top filter.at_top :=
  nat.sub_add_cancel (le_of_lt h) ▸ tendsto_add_one_pow_at_top_at_top_of_pos (nat.sub_pos_of_lt h)

theorem tendsto_norm_zero' {𝕜 : Type u_1} [normed_group 𝕜] : filter.tendsto norm (nhds_within 0 (set_of fun (x : 𝕜) => x ≠ 0)) (nhds_within 0 (set.Ioi 0)) :=
  filter.tendsto.inf tendsto_norm_zero
    (iff.mpr filter.tendsto_principal_principal
      fun (x : 𝕜) (hx : x ∈ set_of fun (x : 𝕜) => x ≠ 0) => iff.mpr norm_pos_iff hx)

theorem normed_field.tendsto_norm_inverse_nhds_within_0_at_top {𝕜 : Type u_1} [normed_field 𝕜] : filter.tendsto (fun (x : 𝕜) => norm (x⁻¹)) (nhds_within 0 (set_of fun (x : 𝕜) => x ≠ 0)) filter.at_top :=
  filter.tendsto.congr (fun (x : 𝕜) => Eq.symm (normed_field.norm_inv x))
    (filter.tendsto.comp tendsto_inv_zero_at_top tendsto_norm_zero')

theorem tendsto_pow_at_top_nhds_0_of_lt_1 {𝕜 : Type u_1} [linear_ordered_field 𝕜] [archimedean 𝕜] [topological_space 𝕜] [order_topology 𝕜] {r : 𝕜} (h₁ : 0 ≤ r) (h₂ : r < 1) : filter.tendsto (fun (n : ℕ) => r ^ n) filter.at_top (nhds 0) := sorry

theorem tendsto_pow_at_top_nhds_within_0_of_lt_1 {𝕜 : Type u_1} [linear_ordered_field 𝕜] [archimedean 𝕜] [topological_space 𝕜] [order_topology 𝕜] {r : 𝕜} (h₁ : 0 < r) (h₂ : r < 1) : filter.tendsto (fun (n : ℕ) => r ^ n) filter.at_top (nhds_within 0 (set.Ioi 0)) :=
  iff.mpr filter.tendsto_inf
    { left := tendsto_pow_at_top_nhds_0_of_lt_1 (has_lt.lt.le h₁) h₂,
      right := iff.mpr filter.tendsto_principal (filter.eventually_of_forall fun (n : ℕ) => pow_pos h₁ n) }

theorem is_o_pow_pow_of_lt_left {r₁ : ℝ} {r₂ : ℝ} (h₁ : 0 ≤ r₁) (h₂ : r₁ < r₂) : asymptotics.is_o (fun (n : ℕ) => r₁ ^ n) (fun (n : ℕ) => r₂ ^ n) filter.at_top := sorry

theorem is_O_pow_pow_of_le_left {r₁ : ℝ} {r₂ : ℝ} (h₁ : 0 ≤ r₁) (h₂ : r₁ ≤ r₂) : asymptotics.is_O (fun (n : ℕ) => r₁ ^ n) (fun (n : ℕ) => r₂ ^ n) filter.at_top :=
  or.elim (has_le.le.eq_or_lt h₂) (fun (h : r₁ = r₂) => h ▸ asymptotics.is_O_refl (fun (n : ℕ) => r₁ ^ n) filter.at_top)
    fun (h : r₁ < r₂) => asymptotics.is_o.is_O (is_o_pow_pow_of_lt_left h₁ h)

theorem is_o_pow_pow_of_abs_lt_left {r₁ : ℝ} {r₂ : ℝ} (h : abs r₁ < abs r₂) : asymptotics.is_o (fun (n : ℕ) => r₁ ^ n) (fun (n : ℕ) => r₂ ^ n) filter.at_top :=
  asymptotics.is_o.of_norm_right
    (asymptotics.is_o.of_norm_left
      (asymptotics.is_o.congr (pow_abs r₁) (pow_abs r₂) (is_o_pow_pow_of_lt_left (abs_nonneg r₁) h)))

/-- Various statements equivalent to the fact that `f n` grows exponentially slower than `R ^ n`.

* 0: $f n = o(a ^ n)$ for some $-R < a < R$;
* 1: $f n = o(a ^ n)$ for some $0 < a < R$;
* 2: $f n = O(a ^ n)$ for some $-R < a < R$;
* 3: $f n = O(a ^ n)$ for some $0 < a < R$;
* 4: there exist `a < R` and `C` such that one of `C` and `R` is positive and $|f n| ≤ Ca^n$
     for all `n`;
* 5: there exists `0 < a < R` and a positive `C` such that $|f n| ≤ Ca^n$ for all `n`;
* 6: there exists `a < R` such that $|f n| ≤ a ^ n$ for sufficiently large `n`;
* 7: there exists `0 < a < R` such that $|f n| ≤ a ^ n$ for sufficiently large `n`.

NB: For backwards compatibility, if you add more items to the list, please append them at the end of
the list. -/
theorem tfae_exists_lt_is_o_pow (f : ℕ → ℝ) (R : ℝ) : tfae
  [∃ (a : ℝ), ∃ (H : a ∈ set.Ioo (-R) R), asymptotics.is_o f (pow a) filter.at_top,
    ∃ (a : ℝ), ∃ (H : a ∈ set.Ioo 0 R), asymptotics.is_o f (pow a) filter.at_top,
    ∃ (a : ℝ), ∃ (H : a ∈ set.Ioo (-R) R), asymptotics.is_O f (pow a) filter.at_top,
    ∃ (a : ℝ), ∃ (H : a ∈ set.Ioo 0 R), asymptotics.is_O f (pow a) filter.at_top,
    ∃ (a : ℝ), ∃ (H : a < R), ∃ (C : ℝ), ∃ (h₀ : 0 < C ∨ 0 < R), ∀ (n : ℕ), abs (f n) ≤ C * a ^ n,
    ∃ (a : ℝ), ∃ (H : a ∈ set.Ioo 0 R), ∃ (C : ℝ), ∃ (H : C > 0), ∀ (n : ℕ), abs (f n) ≤ C * a ^ n,
    ∃ (a : ℝ), ∃ (H : a < R), filter.eventually (fun (n : ℕ) => abs (f n) ≤ a ^ n) filter.at_top,
    ∃ (a : ℝ), ∃ (H : a ∈ set.Ioo 0 R), filter.eventually (fun (n : ℕ) => abs (f n) ≤ a ^ n) filter.at_top] := sorry

theorem uniformity_basis_dist_pow_of_lt_1 {α : Type u_1} [metric_space α] {r : ℝ} (h₀ : 0 < r) (h₁ : r < 1) : filter.has_basis (uniformity α) (fun (k : ℕ) => True)
  fun (k : ℕ) => set_of fun (p : α × α) => dist (prod.fst p) (prod.snd p) < r ^ k :=
  metric.mk_uniformity_basis (fun (i : ℕ) (_x : True) => pow_pos h₀ i)
    fun (ε : ℝ) (ε0 : 0 < ε) =>
      Exists.imp (fun (k : ℕ) (hk : r ^ k < ε) => Exists.intro trivial (has_lt.lt.le hk)) (exists_pow_lt_of_lt_one ε0 h₁)

theorem geom_lt {u : ℕ → ℝ} {c : ℝ} (hc : 0 ≤ c) {n : ℕ} (hn : 0 < n) (h : ∀ (k : ℕ), k < n → c * u k < u (k + 1)) : c ^ n * u 0 < u n := sorry

theorem geom_le {u : ℕ → ℝ} {c : ℝ} (hc : 0 ≤ c) (n : ℕ) (h : ∀ (k : ℕ), k < n → c * u k ≤ u (k + 1)) : c ^ n * u 0 ≤ u n := sorry

/-- For any natural `k` and a real `r > 1` we have `n ^ k = o(r ^ n)` as `n → ∞`. -/
theorem is_o_pow_const_const_pow_of_one_lt {R : Type u_1} [normed_ring R] (k : ℕ) {r : ℝ} (hr : 1 < r) : asymptotics.is_o (fun (n : ℕ) => ↑n ^ k) (fun (n : ℕ) => r ^ n) filter.at_top := sorry

/-- For a real `r > 1` we have `n = o(r ^ n)` as `n → ∞`. -/
theorem is_o_coe_const_pow_of_one_lt {R : Type u_1} [normed_ring R] {r : ℝ} (hr : 1 < r) : asymptotics.is_o coe (fun (n : ℕ) => r ^ n) filter.at_top := sorry

/-- If `∥r₁∥ < r₂`, then for any naturak `k` we have `n ^ k r₁ ^ n = o (r₂ ^ n)` as `n → ∞`. -/
theorem is_o_pow_const_mul_const_pow_const_pow_of_norm_lt {R : Type u_1} [normed_ring R] (k : ℕ) {r₁ : R} {r₂ : ℝ} (h : norm r₁ < r₂) : asymptotics.is_o (fun (n : ℕ) => ↑n ^ k * r₁ ^ n) (fun (n : ℕ) => r₂ ^ n) filter.at_top := sorry

theorem tendsto_pow_const_div_const_pow_of_one_lt (k : ℕ) {r : ℝ} (hr : 1 < r) : filter.tendsto (fun (n : ℕ) => ↑n ^ k / r ^ n) filter.at_top (nhds 0) :=
  asymptotics.is_o.tendsto_0 (is_o_pow_const_const_pow_of_one_lt k hr)

/-- If `|r| < 1`, then `n ^ k r ^ n` tends to zero for any natural `k`. -/
theorem tendsto_pow_const_mul_const_pow_of_abs_lt_one (k : ℕ) {r : ℝ} (hr : abs r < 1) : filter.tendsto (fun (n : ℕ) => ↑n ^ k * r ^ n) filter.at_top (nhds 0) := sorry

/-- If a sequence `v` of real numbers satisfies `k * v n ≤ v (n+1)` with `1 < k`,
then it goes to +∞. -/
theorem tendsto_at_top_of_geom_le {v : ℕ → ℝ} {c : ℝ} (h₀ : 0 < v 0) (hc : 1 < c) (hu : ∀ (n : ℕ), c * v n ≤ v (n + 1)) : filter.tendsto v filter.at_top filter.at_top :=
  filter.tendsto_at_top_mono
    (fun (n : ℕ) => geom_le (has_le.le.trans zero_le_one (has_lt.lt.le hc)) n fun (k : ℕ) (hk : k < n) => hu k)
    (filter.tendsto.at_top_mul_const h₀ (tendsto_pow_at_top_at_top_of_one_lt hc))

theorem nnreal.tendsto_pow_at_top_nhds_0_of_lt_1 {r : nnreal} (hr : r < 1) : filter.tendsto (fun (n : ℕ) => r ^ n) filter.at_top (nhds 0) := sorry

theorem ennreal.tendsto_pow_at_top_nhds_0_of_lt_1 {r : ennreal} (hr : r < 1) : filter.tendsto (fun (n : ℕ) => r ^ n) filter.at_top (nhds 0) := sorry

/-- In a normed ring, the powers of an element x with `∥x∥ < 1` tend to zero. -/
theorem tendsto_pow_at_top_nhds_0_of_norm_lt_1 {R : Type u_1} [normed_ring R] {x : R} (h : norm x < 1) : filter.tendsto (fun (n : ℕ) => x ^ n) filter.at_top (nhds 0) :=
  squeeze_zero_norm' (eventually_norm_pow_le x) (tendsto_pow_at_top_nhds_0_of_lt_1 (norm_nonneg x) h)

theorem tendsto_pow_at_top_nhds_0_of_abs_lt_1 {r : ℝ} (h : abs r < 1) : filter.tendsto (fun (n : ℕ) => r ^ n) filter.at_top (nhds 0) :=
  tendsto_pow_at_top_nhds_0_of_norm_lt_1 h

/-! ### Geometric series-/

theorem has_sum_geometric_of_lt_1 {r : ℝ} (h₁ : 0 ≤ r) (h₂ : r < 1) : has_sum (fun (n : ℕ) => r ^ n) (1 - r⁻¹) := sorry

theorem summable_geometric_of_lt_1 {r : ℝ} (h₁ : 0 ≤ r) (h₂ : r < 1) : summable fun (n : ℕ) => r ^ n :=
  Exists.intro (1 - r⁻¹) (has_sum_geometric_of_lt_1 h₁ h₂)

theorem tsum_geometric_of_lt_1 {r : ℝ} (h₁ : 0 ≤ r) (h₂ : r < 1) : (tsum fun (n : ℕ) => r ^ n) = (1 - r⁻¹) :=
  has_sum.tsum_eq (has_sum_geometric_of_lt_1 h₁ h₂)

theorem has_sum_geometric_two : has_sum (fun (n : ℕ) => (1 / bit0 1) ^ n) (bit0 1) := sorry

theorem summable_geometric_two : summable fun (n : ℕ) => (1 / bit0 1) ^ n :=
  Exists.intro (bit0 1) has_sum_geometric_two

theorem tsum_geometric_two : (tsum fun (n : ℕ) => (1 / bit0 1) ^ n) = bit0 1 :=
  has_sum.tsum_eq has_sum_geometric_two

theorem sum_geometric_two_le (n : ℕ) : (finset.sum (finset.range n) fun (i : ℕ) => (1 / bit0 1) ^ i) ≤ bit0 1 := sorry

theorem has_sum_geometric_two' (a : ℝ) : has_sum (fun (n : ℕ) => a / bit0 1 / bit0 1 ^ n) a := sorry

theorem summable_geometric_two' (a : ℝ) : summable fun (n : ℕ) => a / bit0 1 / bit0 1 ^ n :=
  Exists.intro a (has_sum_geometric_two' a)

theorem tsum_geometric_two' (a : ℝ) : (tsum fun (n : ℕ) => a / bit0 1 / bit0 1 ^ n) = a :=
  has_sum.tsum_eq (has_sum_geometric_two' a)

theorem nnreal.has_sum_geometric {r : nnreal} (hr : r < 1) : has_sum (fun (n : ℕ) => r ^ n) (1 - r⁻¹) := sorry

theorem nnreal.summable_geometric {r : nnreal} (hr : r < 1) : summable fun (n : ℕ) => r ^ n :=
  Exists.intro (1 - r⁻¹) (nnreal.has_sum_geometric hr)

theorem tsum_geometric_nnreal {r : nnreal} (hr : r < 1) : (tsum fun (n : ℕ) => r ^ n) = (1 - r⁻¹) :=
  has_sum.tsum_eq (nnreal.has_sum_geometric hr)

/-- The series `pow r` converges to `(1-r)⁻¹`. For `r < 1` the RHS is a finite number,
and for `1 ≤ r` the RHS equals `∞`. -/
theorem ennreal.tsum_geometric (r : ennreal) : (tsum fun (n : ℕ) => r ^ n) = (1 - r⁻¹) := sorry

theorem has_sum_geometric_of_norm_lt_1 {K : Type u_4} [normed_field K] {ξ : K} (h : norm ξ < 1) : has_sum (fun (n : ℕ) => ξ ^ n) (1 - ξ⁻¹) := sorry

theorem summable_geometric_of_norm_lt_1 {K : Type u_4} [normed_field K] {ξ : K} (h : norm ξ < 1) : summable fun (n : ℕ) => ξ ^ n :=
  Exists.intro (1 - ξ⁻¹) (has_sum_geometric_of_norm_lt_1 h)

theorem tsum_geometric_of_norm_lt_1 {K : Type u_4} [normed_field K] {ξ : K} (h : norm ξ < 1) : (tsum fun (n : ℕ) => ξ ^ n) = (1 - ξ⁻¹) :=
  has_sum.tsum_eq (has_sum_geometric_of_norm_lt_1 h)

theorem has_sum_geometric_of_abs_lt_1 {r : ℝ} (h : abs r < 1) : has_sum (fun (n : ℕ) => r ^ n) (1 - r⁻¹) :=
  has_sum_geometric_of_norm_lt_1 h

theorem summable_geometric_of_abs_lt_1 {r : ℝ} (h : abs r < 1) : summable fun (n : ℕ) => r ^ n :=
  summable_geometric_of_norm_lt_1 h

theorem tsum_geometric_of_abs_lt_1 {r : ℝ} (h : abs r < 1) : (tsum fun (n : ℕ) => r ^ n) = (1 - r⁻¹) :=
  tsum_geometric_of_norm_lt_1 h

/-- A geometric series in a normed field is summable iff the norm of the common ratio is less than
one. -/
@[simp] theorem summable_geometric_iff_norm_lt_1 {K : Type u_4} [normed_field K] {ξ : K} : (summable fun (n : ℕ) => ξ ^ n) ↔ norm ξ < 1 := sorry

theorem summable_norm_pow_mul_geometric_of_norm_lt_1 {R : Type u_1} [normed_ring R] (k : ℕ) {r : R} (hr : norm r < 1) : summable fun (n : ℕ) => norm (↑n ^ k * r ^ n) := sorry

theorem summable_pow_mul_geometric_of_norm_lt_1 {R : Type u_1} [normed_ring R] [complete_space R] (k : ℕ) {r : R} (hr : norm r < 1) : summable fun (n : ℕ) => ↑n ^ k * r ^ n :=
  summable_of_summable_norm (summable_norm_pow_mul_geometric_of_norm_lt_1 k hr)

/-- If `∥r∥ < 1`, then `∑' n : ℕ, n * r ^ n = r / (1 - r) ^ 2`, `has_sum` version. -/
theorem has_sum_coe_mul_geometric_of_norm_lt_1 {𝕜 : Type u_1} [normed_field 𝕜] [complete_space 𝕜] {r : 𝕜} (hr : norm r < 1) : has_sum (fun (n : ℕ) => ↑n * r ^ n) (r / (1 - r) ^ bit0 1) := sorry

/-- If `∥r∥ < 1`, then `∑' n : ℕ, n * r ^ n = r / (1 - r) ^ 2`. -/
theorem tsum_coe_mul_geometric_of_norm_lt_1 {𝕜 : Type u_1} [normed_field 𝕜] [complete_space 𝕜] {r : 𝕜} (hr : norm r < 1) : (tsum fun (n : ℕ) => ↑n * r ^ n) = r / (1 - r) ^ bit0 1 :=
  has_sum.tsum_eq (has_sum_coe_mul_geometric_of_norm_lt_1 hr)

/-!
### Sequences with geometrically decaying distance in metric spaces

In this paragraph, we discuss sequences in metric spaces or emetric spaces for which the distance
between two consecutive terms decays geometrically. We show that such sequences are Cauchy
sequences, and bound their distances to the limit. We also discuss series with geometrically
decaying terms.
-/

/-- If `edist (f n) (f (n+1))` is bounded by `C * r^n`, `C ≠ ∞`, `r < 1`,
then `f` is a Cauchy sequence.-/
theorem cauchy_seq_of_edist_le_geometric {α : Type u_1} [emetric_space α] (r : ennreal) (C : ennreal) (hr : r < 1) (hC : C ≠ ⊤) {f : ℕ → α} (hu : ∀ (n : ℕ), edist (f n) (f (n + 1)) ≤ C * r ^ n) : cauchy_seq f := sorry

/-- If `edist (f n) (f (n+1))` is bounded by `C * r^n`, then the distance from
`f n` to the limit of `f` is bounded above by `C * r^n / (1 - r)`. -/
theorem edist_le_of_edist_le_geometric_of_tendsto {α : Type u_1} [emetric_space α] (r : ennreal) (C : ennreal) {f : ℕ → α} (hu : ∀ (n : ℕ), edist (f n) (f (n + 1)) ≤ C * r ^ n) {a : α} (ha : filter.tendsto f filter.at_top (nhds a)) (n : ℕ) : edist (f n) a ≤ C * r ^ n / (1 - r) := sorry

/-- If `edist (f n) (f (n+1))` is bounded by `C * r^n`, then the distance from
`f 0` to the limit of `f` is bounded above by `C / (1 - r)`. -/
theorem edist_le_of_edist_le_geometric_of_tendsto₀ {α : Type u_1} [emetric_space α] (r : ennreal) (C : ennreal) {f : ℕ → α} (hu : ∀ (n : ℕ), edist (f n) (f (n + 1)) ≤ C * r ^ n) {a : α} (ha : filter.tendsto f filter.at_top (nhds a)) : edist (f 0) a ≤ C / (1 - r) := sorry

/-- If `edist (f n) (f (n+1))` is bounded by `C * 2^-n`, then `f` is a Cauchy sequence.-/
theorem cauchy_seq_of_edist_le_geometric_two {α : Type u_1} [emetric_space α] (C : ennreal) (hC : C ≠ ⊤) {f : ℕ → α} (hu : ∀ (n : ℕ), edist (f n) (f (n + 1)) ≤ C / bit0 1 ^ n) : cauchy_seq f := sorry

/-- If `edist (f n) (f (n+1))` is bounded by `C * 2^-n`, then the distance from
`f n` to the limit of `f` is bounded above by `2 * C * 2^-n`. -/
theorem edist_le_of_edist_le_geometric_two_of_tendsto {α : Type u_1} [emetric_space α] (C : ennreal) {f : ℕ → α} (hu : ∀ (n : ℕ), edist (f n) (f (n + 1)) ≤ C / bit0 1 ^ n) {a : α} (ha : filter.tendsto f filter.at_top (nhds a)) (n : ℕ) : edist (f n) a ≤ bit0 1 * C / bit0 1 ^ n := sorry

/-- If `edist (f n) (f (n+1))` is bounded by `C * 2^-n`, then the distance from
`f 0` to the limit of `f` is bounded above by `2 * C`. -/
theorem edist_le_of_edist_le_geometric_two_of_tendsto₀ {α : Type u_1} [emetric_space α] (C : ennreal) {f : ℕ → α} (hu : ∀ (n : ℕ), edist (f n) (f (n + 1)) ≤ C / bit0 1 ^ n) {a : α} (ha : filter.tendsto f filter.at_top (nhds a)) : edist (f 0) a ≤ bit0 1 * C := sorry

theorem aux_has_sum_of_le_geometric {α : Type u_1} [metric_space α] {r : ℝ} {C : ℝ} (hr : r < 1) {f : ℕ → α} (hu : ∀ (n : ℕ), dist (f n) (f (n + 1)) ≤ C * r ^ n) : has_sum (fun (n : ℕ) => C * r ^ n) (C / (1 - r)) := sorry

/-- If `dist (f n) (f (n+1))` is bounded by `C * r^n`, `r < 1`, then `f` is a Cauchy sequence.
Note that this lemma does not assume `0 ≤ C` or `0 ≤ r`. -/
theorem cauchy_seq_of_le_geometric {α : Type u_1} [metric_space α] (r : ℝ) (C : ℝ) (hr : r < 1) {f : ℕ → α} (hu : ∀ (n : ℕ), dist (f n) (f (n + 1)) ≤ C * r ^ n) : cauchy_seq f :=
  cauchy_seq_of_dist_le_of_summable (fun (n : ℕ) => C * r ^ n) hu
    (Exists.intro (C / (1 - r)) (aux_has_sum_of_le_geometric hr hu))

/-- If `dist (f n) (f (n+1))` is bounded by `C * r^n`, `r < 1`, then the distance from
`f n` to the limit of `f` is bounded above by `C * r^n / (1 - r)`. -/
theorem dist_le_of_le_geometric_of_tendsto₀ {α : Type u_1} [metric_space α] (r : ℝ) (C : ℝ) (hr : r < 1) {f : ℕ → α} (hu : ∀ (n : ℕ), dist (f n) (f (n + 1)) ≤ C * r ^ n) {a : α} (ha : filter.tendsto f filter.at_top (nhds a)) : dist (f 0) a ≤ C / (1 - r) :=
  has_sum.tsum_eq (aux_has_sum_of_le_geometric hr hu) ▸
    dist_le_tsum_of_dist_le_of_tendsto₀ (fun (b : ℕ) => C * r ^ b) hu
      (Exists.intro (C / (1 - r)) (aux_has_sum_of_le_geometric hr hu)) ha

/-- If `dist (f n) (f (n+1))` is bounded by `C * r^n`, `r < 1`, then the distance from
`f 0` to the limit of `f` is bounded above by `C / (1 - r)`. -/
theorem dist_le_of_le_geometric_of_tendsto {α : Type u_1} [metric_space α] (r : ℝ) (C : ℝ) (hr : r < 1) {f : ℕ → α} (hu : ∀ (n : ℕ), dist (f n) (f (n + 1)) ≤ C * r ^ n) {a : α} (ha : filter.tendsto f filter.at_top (nhds a)) (n : ℕ) : dist (f n) a ≤ C * r ^ n / (1 - r) := sorry

/-- If `dist (f n) (f (n+1))` is bounded by `(C / 2) / 2^n`, then `f` is a Cauchy sequence. -/
theorem cauchy_seq_of_le_geometric_two {α : Type u_1} [metric_space α] (C : ℝ) {f : ℕ → α} (hu₂ : ∀ (n : ℕ), dist (f n) (f (n + 1)) ≤ C / bit0 1 / bit0 1 ^ n) : cauchy_seq f :=
  cauchy_seq_of_dist_le_of_summable (fun (n : ℕ) => C / bit0 1 / bit0 1 ^ n) hu₂
    (Exists.intro C (has_sum_geometric_two' C))

/-- If `dist (f n) (f (n+1))` is bounded by `(C / 2) / 2^n`, then the distance from
`f 0` to the limit of `f` is bounded above by `C`. -/
theorem dist_le_of_le_geometric_two_of_tendsto₀ {α : Type u_1} [metric_space α] (C : ℝ) {f : ℕ → α} (hu₂ : ∀ (n : ℕ), dist (f n) (f (n + 1)) ≤ C / bit0 1 / bit0 1 ^ n) {a : α} (ha : filter.tendsto f filter.at_top (nhds a)) : dist (f 0) a ≤ C :=
  tsum_geometric_two' C ▸
    dist_le_tsum_of_dist_le_of_tendsto₀ (fun (n : ℕ) => C / bit0 1 / bit0 1 ^ n) hu₂ (summable_geometric_two' C) ha

/-- If `dist (f n) (f (n+1))` is bounded by `(C / 2) / 2^n`, then the distance from
`f n` to the limit of `f` is bounded above by `C / 2^n`. -/
theorem dist_le_of_le_geometric_two_of_tendsto {α : Type u_1} [metric_space α] (C : ℝ) {f : ℕ → α} (hu₂ : ∀ (n : ℕ), dist (f n) (f (n + 1)) ≤ C / bit0 1 / bit0 1 ^ n) {a : α} (ha : filter.tendsto f filter.at_top (nhds a)) (n : ℕ) : dist (f n) a ≤ C / bit0 1 ^ n := sorry

theorem dist_partial_sum_le_of_le_geometric {α : Type u_1} [normed_group α] {r : ℝ} {C : ℝ} {f : ℕ → α} (hf : ∀ (n : ℕ), norm (f n) ≤ C * r ^ n) (n : ℕ) : dist (finset.sum (finset.range n) fun (i : ℕ) => f i) (finset.sum (finset.range (n + 1)) fun (i : ℕ) => f i) ≤ C * r ^ n := sorry

/-- If `∥f n∥ ≤ C * r ^ n` for all `n : ℕ` and some `r < 1`, then the partial sums of `f` form a
Cauchy sequence. This lemma does not assume `0 ≤ r` or `0 ≤ C`. -/
theorem cauchy_seq_finset_of_geometric_bound {α : Type u_1} [normed_group α] {r : ℝ} {C : ℝ} {f : ℕ → α} (hr : r < 1) (hf : ∀ (n : ℕ), norm (f n) ≤ C * r ^ n) : cauchy_seq fun (s : finset ℕ) => finset.sum s fun (x : ℕ) => f x :=
  cauchy_seq_finset_of_norm_bounded (fun (n : ℕ) => C * r ^ n)
    (has_sum.summable (aux_has_sum_of_le_geometric hr (dist_partial_sum_le_of_le_geometric hf))) hf

/-- If `∥f n∥ ≤ C * r ^ n` for all `n : ℕ` and some `r < 1`, then the partial sums of `f` are within
distance `C * r ^ n / (1 - r)` of the sum of the series. This lemma does not assume `0 ≤ r` or
`0 ≤ C`. -/
theorem norm_sub_le_of_geometric_bound_of_has_sum {α : Type u_1} [normed_group α] {r : ℝ} {C : ℝ} {f : ℕ → α} (hr : r < 1) (hf : ∀ (n : ℕ), norm (f n) ≤ C * r ^ n) {a : α} (ha : has_sum f a) (n : ℕ) : norm ((finset.sum (finset.range n) fun (x : ℕ) => f x) - a) ≤ C * r ^ n / (1 - r) := sorry

/-- A geometric series in a complete normed ring is summable.
Proved above (same name, different namespace) for not-necessarily-complete normed fields. -/
theorem normed_ring.summable_geometric_of_norm_lt_1 {R : Type u_4} [normed_ring R] [complete_space R] (x : R) (h : norm x < 1) : summable fun (n : ℕ) => x ^ n := sorry

/-- Bound for the sum of a geometric series in a normed ring.  This formula does not assume that the
normed ring satisfies the axiom `∥1∥ = 1`. -/
theorem normed_ring.tsum_geometric_of_norm_lt_1 {R : Type u_4} [normed_ring R] [complete_space R] (x : R) (h : norm x < 1) : norm (tsum fun (n : ℕ) => x ^ n) ≤ norm 1 - 1 + (1 - norm x⁻¹) := sorry

theorem geom_series_mul_neg {R : Type u_4} [normed_ring R] [complete_space R] (x : R) (h : norm x < 1) : (tsum fun (i : ℕ) => x ^ i) * (1 - x) = 1 := sorry

theorem mul_neg_geom_series {R : Type u_4} [normed_ring R] [complete_space R] (x : R) (h : norm x < 1) : ((1 - x) * tsum fun (i : ℕ) => x ^ i) = 1 := sorry

/-! ### Positive sequences with small sums on encodable types -/

/-- For any positive `ε`, define on an encodable type a positive sequence with sum less than `ε` -/
def pos_sum_of_encodable {ε : ℝ} (hε : 0 < ε) (ι : Type u_1) [encodable ι] : Subtype fun (ε' : ι → ℝ) => (∀ (i : ι), 0 < ε' i) ∧ ∃ (c : ℝ), has_sum ε' c ∧ c ≤ ε :=
  let f : ℕ → ℝ := fun (n : ℕ) => ε / bit0 1 / bit0 1 ^ n;
  { val := f ∘ encodable.encode, property := sorry }

namespace nnreal

theorem exists_pos_sum_of_encodable {ε : nnreal} (hε : 0 < ε) (ι : Type u_1) [encodable ι] : ∃ (ε' : ι → nnreal), (∀ (i : ι), 0 < ε' i) ∧ ∃ (c : nnreal), has_sum ε' c ∧ c < ε := sorry

end nnreal

namespace ennreal

theorem exists_pos_sum_of_encodable {ε : ennreal} (hε : 0 < ε) (ι : Type u_1) [encodable ι] : ∃ (ε' : ι → nnreal), (∀ (i : ι), 0 < ε' i) ∧ (tsum fun (i : ι) => ↑(ε' i)) < ε := sorry

end ennreal

/-!
### Factorial
-/

theorem factorial_tendsto_at_top : filter.tendsto nat.factorial filter.at_top filter.at_top :=
  filter.tendsto_at_top_at_top_of_monotone nat.monotone_factorial fun (n : ℕ) => Exists.intro n (nat.self_le_factorial n)

theorem tendsto_factorial_div_pow_self_at_top : filter.tendsto (fun (n : ℕ) => ↑(nat.factorial n) / ↑n ^ n) filter.at_top (nhds 0) := sorry


import data.matrix data.rat.basic .misc tactic.fin_cases
import .matrix_pequiv order.order_iso .simplex_new_pivot

open matrix fintype finset function pequiv simplex simplex.prebasis

variables {m n k: ℕ}

local notation `rvec`:2000 n := matrix (fin 1) (fin n) ℚ
local notation `cvec`:2000 m := matrix (fin m) (fin 1) ℚ
local infix ` ⬝ `:70 := matrix.mul
local postfix `ᵀ` : 1500 := transpose
local attribute [instance] matrix.partial_order

namespace simplex'

def choose_pivot_column (AN_bar : matrix (fin m) (fin (n - m)) ℚ)
  (c : rvec (n - m)) : option (fin (n - m)) :=
fin.find (λ s : fin (n - m), 0 < c 0 s)

def choose_pivot_row (AN_bar : matrix (fin m) (fin (n - m)) ℚ) (b_bar : cvec m)
  (s : fin (n - m)) : option (fin m) :=
fin.find (λ r : fin m, 0 < AN_bar r s ∧ ∀ i : fin m, 0 < AN_bar i s →
  (AN_bar r s)⁻¹ * b_bar r 0 ≤ (AN_bar i s)⁻¹ * b_bar i 0)

lemma choose_pivot_column_eq_none (B : prebasis m n) (A_bar : matrix (fin m) (fin n) ℚ)
  (b_bar : cvec m) (c : rvec n) (hA_bar : A_bar ⬝ B.basis.to_matrixᵀ = 1)
  (h0b : 0 ≤ b_bar)
  (h : choose_pivot_column (A_bar ⬝ B.nonbasis.to_matrixᵀ) (reduced_cost B A_bar c) = none) :
  is_optimal_basis B A_bar b_bar c :=
is_optimal_basis_of_reduced_cost_nonpos _ _ hA_bar h0b $
  begin
    intros i j,
    fin_cases i,
    exact le_of_not_gt (fin.find_eq_none_iff.1 h j : _)
  end

lemma choose_pivot_row_eq_none (B : prebasis m n) (A_bar : matrix (fin m) (fin n) ℚ)
  (b_bar : cvec m) (r : fin m) (s : fin (n - m))
  (hn : choose_pivot_row (A_bar ⬝ B.nonbasis.to_matrixᵀ) b_bar s = none) :
  (A_bar ⬝ B.nonbasis.to_matrixᵀ) r s ≤ 0 :=
le_of_not_gt $ λ (hpivot : _ < _), begin
  rw [choose_pivot_row, fin.find_eq_none_iff] at hn,
  cases @finset.min_of_mem _ _
    ((univ.filter (λ j : fin m, 0 < (A_bar ⬝ B.nonbasis.to_matrixᵀ) j s)).image
      (λ i, ((A_bar ⬝ B.nonbasis.to_matrixᵀ) i s)⁻¹ * b_bar i 0))
      (((A_bar ⬝ B.nonbasis.to_matrixᵀ) r s)⁻¹ * b_bar r 0)
     (mem_image_of_mem _ (by simp *)) with q hq,
  rcases mem_image.1 (mem_of_min hq) with ⟨i, hip, hiq⟩,
  subst hiq,
  refine hn i ⟨(finset.mem_filter.1 hip).2, λ j hj, _⟩,
  refine min_le_of_mem _ hq,
  refine mem_image_of_mem _ _,
  simpa using hj
end

lemma choose_pivot_column_spec (AN_bar : matrix (fin m) (fin (n - m)) ℚ) (c : rvec (n - m))
  (s : fin (n - m)) (hs : s ∈ choose_pivot_column AN_bar c) : 0 < c 0 s :=
fin.find_spec _ hs

def swap_inverse (AN_bar : matrix (fin m) (fin (n - m)) ℚ) (r : fin m) (s : fin (n - m)) :
  matrix (fin m) (fin m) ℚ :=
let pivot_inv := (AN_bar r s)⁻¹ in
(1 : matrix (fin m) (fin m) ℚ).write_column r
  (λ i, if i = r then pivot_inv else -AN_bar i s * pivot_inv)

lemma pivot_element_eq (B : prebasis m n) (A_bar : matrix (fin m) (fin n) ℚ)
  (r : fin m) (s : fin (n - m)) :
  (pivot_element B A_bar r s) = (λ _ _, (A_bar ⬝ B.nonbasis.to_matrixᵀ) r s) :=
begin
  ext i j,
  have hi : i = 0, from subsingleton.elim _ _,
  have hj : j = 0, from subsingleton.elim _ _,
  substs hi hj,
  simp only [pivot_element, matrix_mul_apply, mul_matrix_apply, (to_matrix_symm _).symm],
  refl
end

lemma single_apply {α β : Type*} [decidable_eq α] [decidable_eq β] (a a' : α) (b : β) :
  single a b a' = if a' = a then some b else none := rfl

@[simp] lemma add_add_neg_cancel'_right {α : Type*} [add_comm_group α] (a b : α) : a + (b + -a) = b :=
add_sub_cancel'_right a b

lemma swap_inverse_eq_swap_inverse (B : prebasis m n) (AN_bar : matrix (fin m) (fin (n - m)) ℚ)
  (r : fin m) (s : fin (n - m)) (hpivot : AN_bar r s ≠ 0) :
  swap_inverse AN_bar r s =
  simplex.swap_inverse B (AN_bar ⬝ B.nonbasis.to_matrix) r s :=
have ∀ i j r s, (AN_bar ⬝ ((single s (0 : fin 1)).to_matrix ⬝ (λ (_ _ : fin 1), (AN_bar r s)⁻¹))) i j
  = (AN_bar r s)⁻¹ * AN_bar i s,
  begin
    intros, fin_cases j,
    rw [← matrix.mul_assoc, mul_eq_smul, matrix.smul_val, matrix_mul_apply, symm_single,
      simplex'.single_apply, if_pos],
    congr,
  end,
begin
  ext i j,
  simp [simplex'.swap_inverse, simplex.swap_inverse,
    matrix.mul_add, matrix.add_mul, matrix.add_val, write_column_apply,
    matrix.neg_val,
    mul_matrix_apply, matrix_mul_apply, one_val, pivot_element_eq, inv_def],
  dsimp [symm_single, simplex'.single_apply],
  split_ifs,
  { rw [if_pos h.symm, if_pos h_1],
    simp [add_val, neg_val, one_val, matrix.mul_assoc, this, h_1, inv_mul_cancel hpivot], },
  { cc },
  { cc },
  { rw [if_neg h_1, if_pos h.symm],
    simp [matrix.mul_assoc, this, mul_comm] },
  { cc },
  { rw [if_neg (ne.symm h), if_neg h_2], simp },
  { rw [if_pos h_2, if_neg (ne.symm h)], simp },
  { rw [if_neg h_2, if_neg (ne.symm h)], simp }
end

lemma swap_nonbasis_eq (B : prebasis m n) (r : fin m) (s : fin (n - m)) :
  (B.swap r s).nonbasis.to_matrix = (B.nonbasis.to_matrix : matrix _ _ ℚ)
  + (single s (B.basisg r)).to_matrix - (single s (B.nonbasisg s)).to_matrix :=
begin
  dsimp [prebasis.swap],
  simp only [to_matrix_swap, to_matrix_trans],
  simp [matrix.mul_add, (to_matrix_trans _ _).symm,
    trans_single_of_mem _ (nonbasisg_mem B s),
    trans_single_of_eq_none _ (nonbasis_basisg_eq_none B r)]
end

lemma nonbasis_transpose_mul_single (B : prebasis m n) (i : fin (n - m)) (j : fin k) :
  (B.nonbasis.to_matrixᵀ : matrix _ _ ℚ) ⬝ (single i j).to_matrix =
  (single (B.nonbasisg i) j).to_matrix :=
by rw [← to_matrix_symm, ← to_matrix_trans, trans_single_of_mem _ (nonbasis_nonbasisg _ _)]

lemma basis_transpose_mul_single (B : prebasis m n) (i : fin m) (j : fin k) :
  (B.basis.to_matrixᵀ : matrix _ _ ℚ) ⬝ (single i j).to_matrix =
  (single (B.basisg i) j).to_matrix :=
by rw [← to_matrix_symm, ← to_matrix_trans, trans_single_of_mem _ (basis_basisg _ _)]

@[simp] lemma swap_nonbasis_mul_single_of_eq (B : prebasis m n) (r : fin m) (s : fin (n - m)) :
  ((B.swap r s).nonbasis.to_matrixᵀ : matrix _ _ ℚ) ⬝ (single s (0 : fin 1)).to_matrix =
  B.basis.to_matrixᵀ ⬝ (single r 0).to_matrix  :=
begin
  simp [swap_nonbasis_eq, transpose_add, (to_matrix_symm _).symm, matrix.add_mul],
  simp [to_matrix_symm, nonbasis_transpose_mul_single, basis_transpose_mul_single],
end

@[simp] lemma swap_nonbasis_mul_single_of_ne (B : prebasis m n) (r : fin m) {s : fin (n - m)}
  {j : fin (n - m)} (hsj : s ≠ j) :
  ((B.swap r s).nonbasis.to_matrixᵀ : matrix _ _ ℚ) ⬝ (single j (0 : fin 1)).to_matrix =
  B.nonbasis.to_matrixᵀ ⬝ (single j 0).to_matrix  :=
begin
  simp [swap_nonbasis_eq, transpose_add, (to_matrix_symm _).symm, matrix.add_mul],
  simp [to_matrix_symm, nonbasis_transpose_mul_single, basis_transpose_mul_single,
    single_mul_single_of_ne hsj],
end

lemma reduced_cost_swap (B : prebasis m n) (A_bar : matrix (fin m) (fin n) ℚ) (c : rvec n)
  (r : fin m) (s : fin (n - m)) (hA_bar : A_bar ⬝ B.basis.to_matrixᵀ = 1)
  (hpivot : pivot_element B A_bar r s ≠ 0) :
  reduced_cost (B.swap r s) (simplex.swap_inverse B A_bar r s ⬝ A_bar) c =
  reduced_cost B A_bar c ⬝ (1 - (single s (0 : fin 1)).to_matrix ⬝
    (pivot_element B A_bar r s)⁻¹ ⬝ (single 0 r).to_matrix ⬝ A_bar ⬝ B.nonbasis.to_matrixᵀ -
    (single s 0).to_matrix ⬝ (pivot_element B A_bar r s)⁻¹ ⬝ (single 0 s).to_matrix) :=
have h₁ : simplex.swap_inverse B A_bar r s ⬝ A_bar ⬝ (to_matrix ((swap B r s).basis))ᵀ = 1,
  by rw [matrix.mul_assoc, swap_mul_swap_inverse hA_bar hpivot],
have h₂ : ∀ {k : ℕ}, ∀ {M : matrix (fin 1) (fin k) ℚ},
    to_matrix (single s r) ⬝ (A_bar ⬝ ((to_matrix (B.nonbasis))ᵀ ⬝
    (to_matrix (single s 0) ⬝ ((pivot_element B A_bar r s)⁻¹ ⬝ M)))) =
    (single s 0).to_matrix ⬝ M,
  begin
    intros,
    rw [← single_mul_single s (0 : fin 1) r, matrix.mul_assoc],
    refine congr_arg (matrix.mul _) _,
    simp only [(matrix.mul_assoc _ _ _).symm, pivot_element, inv_eq_inverse] at ⊢ hpivot,
    rw [one_by_one_mul_inv_cancel hpivot, matrix.one_mul]
  end,
begin
  refine mul_single_ext (λ j, _),
  let x : matrix _ _ ℚ := (B.swap r s).nonbasis.to_matrixᵀ ⬝
    (single j (0 : fin 1)).to_matrix,
  have hxdef : x = (B.swap r s).nonbasis.to_matrixᵀ ⬝
    (single j (0 : fin 1)).to_matrix, from rfl,
  have hx : (single j (0 : fin 1)).to_matrix = (B.swap r s).nonbasis.to_matrix ⬝ x,
  { simp [x, (matrix.mul_assoc _ _ _).symm] },
  let b_bar := (simplex.swap_inverse B A_bar r s ⬝ A_bar) ⬝ x,
  rw [hx, ← matrix.mul_assoc, ← add_left_inj (c ⬝ (B.swap r s).basis.to_matrixᵀ ⬝ b_bar),
    ← objective_function_eq rfl h₁, matrix.mul_assoc c _ b_bar],
  have h₃ : A_bar ⬝ ((to_matrix ((swap B r s).basis))ᵀ ⬝ b_bar) = A_bar ⬝ x,
  { simp only [b_bar, x, (matrix.mul_assoc _ _ _).symm],
    rw [mul_eq_one_comm.1 (swap_mul_swap_inverse hA_bar hpivot),
      matrix.one_mul], },
  conv_rhs {rw [objective_function_eq h₃ hA_bar], },
  conv_lhs {rw [objective_function_eq rfl hA_bar] },
  simp [x, b_bar, simplex.swap_inverse, matrix.mul_add, matrix.mul_assoc,
    mul_right_eq_of_mul_eq (nonbasis_mul_nonbasis_transpose _),
    matrix.add_mul, mul_right_eq_of_mul_eq (nonbasis_mul_swap_basis_tranpose _ _ _), h₂],
  by_cases hjs : j = s,
  { simp only [pivot_element, matrix.mul_assoc] at hpivot,
    simp [hjs, mul_right_eq_of_mul_eq hA_bar, matrix.mul_assoc,
      mul_right_eq_of_mul_eq (nonbasis_mul_basis_transpose _),
      pivot_element, inv_eq_inverse, one_by_one_inv_mul_cancel hpivot] },
  { simp [mul_right_eq_of_mul_eq hA_bar, single_mul_single_of_ne (ne.symm hjs),
      swap_nonbasis_mul_single_of_ne _ _ (ne.symm hjs),
      mul_right_eq_of_mul_eq (nonbasis_mul_nonbasis_transpose _)] }
end

set_option eqn_compiler.zeta true

def simplex : Π (B : prebasis m n) (AN_bar : matrix (fin m) (fin (n - m)) ℚ) (b_bar : cvec m)
  (c : rvec (n - m)),
  option (prebasis m n × matrix (fin m) (fin (n - m)) ℚ × (cvec m) × (rvec (n - m)))
| B AN_bar b_bar c :=
  match choose_pivot_column AN_bar c with
  | none   := some (B, AN_bar, b_bar, c)
  | some s :=
    match choose_pivot_row AN_bar b_bar s with
    | none   := none
    | some r :=
      have wf : false, from sorry,
      let S := simplex'.swap_inverse AN_bar r s in
      let AN_bar' : matrix (fin m) (fin (n - m)) ℚ :=
        AN_bar.write_column s (λ j, if j = r then (1 : ℚ) else 0) in
      simplex (B.swap r s) (S ⬝ AN_bar') (S ⬝ b_bar)
        ((c - (c 0 s / AN_bar r s) • (λ _, AN_bar r) -
          (0 : matrix _ _ ℚ).write_column s (λ _, c 0 s / AN_bar r s)))
    end
  end
using_well_founded { rel_tac := λ _ _, `[exact ⟨_, empty_wf⟩], dec_tac := tactic.assumption }

lemma simplex_spec : Π (B : prebasis m n) (A_bar : matrix (fin m) (fin n) ℚ)
  (b_bar : cvec m) (c : rvec n) (hA_bar : A_bar ⬝ B.basis.to_matrixᵀ = 1) (h0b : 0 ≤ b_bar),
  (option.cases_on (simplex B (A_bar ⬝ B.nonbasis.to_matrixᵀ) b_bar (reduced_cost B A_bar c))
    (is_unbounded A_bar b_bar c)
    (λ P, is_optimal_basis P.1 A_bar b_bar c) : Prop)
| B A_bar b_bar c := assume hA_bar h0b,
  begin
    rw [simplex'.simplex],
    cases hs : choose_pivot_column (A_bar ⬝ B.nonbasis.to_matrixᵀ)
      (reduced_cost B A_bar c) with s,
    { dsimp [simplex'.simplex._match_3],
      exact choose_pivot_column_eq_none _ _ _ _ hA_bar h0b hs },
    { dsimp [simplex'.simplex._match_3],
      cases hr : choose_pivot_row (A_bar ⬝ B.nonbasis.to_matrixᵀ) b_bar s with r,
      { dsimp [simplex'.simplex._match_4],
        have : 0 < reduced_cost B A_bar c ⬝ (single s (0 : fin 1)).to_matrix,
        { rw [cvec_one_lt_iff, matrix_mul_apply],
          exact choose_pivot_column_spec _ _ _ hs },
        exact is_unbounded_of_pivot_element_nonpos b_bar _ hA_bar h0b this
          (λ r i j, by rw [pivot_element_eq];
            exact choose_pivot_row_eq_none _ _ _ _ _ hr) },
      { dsimp [simplex'.simplex._match_4],
        let AN_bar := A_bar ⬝ B.nonbasis.to_matrixᵀ,
        let S := simplex'.swap_inverse AN_bar r s,
        let AN_bar' : matrix (fin m) (fin (n - m)) ℚ :=
          AN_bar.write_column s (λ j, if j = r then (1 : ℚ) else 0),
        have := simplex_spec (B.swap r s) _ _ _ _ _,
         } },
  end

end simplex'

def ex.A := list.to_matrix 3 4 [[1/64443321,   18932,    -1, 9],
                                [1/2, -7/145931, -1/145903, 3],
                                [  -11,     -1111,     22, 100]]

def ex.b : cvec 3 := (λ i _, list.nth_le [0,0,1] i sorry)
--#eval ex.b
def ex.c : rvec 4 := λ _ i, (list.nth_le [3/4, -20, 1/2, -6] i sorry)

#eval @_root_.simplex 3 7 ex.A ex.b ex.c


import tactic

def hom  {X Y : Type} (f : X → X) (g : Y → Y) : Type :=
{ h : X → Y // ∀ z, h (f z) = g (h z) }

instance {X Y : Type} (f : X → X) (g : Y → Y) :
  has_coe_to_fun (hom f g) (λ _, X → Y) :=
{ coe := subtype.val }

-- Σ (X : Type) (x : X), (X → X)

-- def T := Σ (X : Type), X → X

-- def C := Σ t : T, t.fst

@[simp] lemma map_f {X Y : Type} (f : X → X) (g : Y → Y)
  (h : hom f g) : ∀ z, h (f z) = g (h z) := h.2

@[simp] def iterate_aux {X : Type} (x : X) (f : X → X) : ℕ → X
| 0     := x
| (n+1) := f (iterate_aux n)

def iterate {X : Sort*} (x : X) (f : X → X) : ℕ → X :=
iterate_aux x f
-- #print nat.rec_on
def nat.rec_on2 {motive : ℕ → Sort*} (n : ℕ) (h0 : motive 0)
  (h1 : Π (n : ℕ), motive n → motive n.succ) : motive n :=
let x : Σ n, motive n := iterate ⟨0, h0⟩ (λ x, ⟨x.1 + 1, h1 x.1 x.2⟩) n in

def factorial (n : ℕ) : ℕ :=
(iterate (1, 1) (λ x, (x.1 + 1, x.1 * x.2)) n).2

lemma factorial_zero : factorial 0 = 1 := rfl

#eval factorial 0

@[simp] lemma iterate_zero {X : Type} (x : X) (f : X → X) :
  iterate x f 0 = x := rfl

@[simp] lemma iterate_succ {X : Type} (x : X) (f : X → X) (n : ℕ) :
  iterate x f n.succ = f (iterate x f n) := rfl

lemma factorial_succ_aux (n : ℕ) :
  (iterate (1, 1) (λ x, (x.1 + 1, x.1 * x.2)) (n + 1)) =
    let x := iterate (1, 1) (λ x, (x.1 + 1, x.1 * x.2)) n in
      (n + 2, (n + 1) * x.2) :=
by induction n; simp *

lemma factorial_succ (n : ℕ) : factorial (n + 1) = (n + 1) * factorial n :=
begin
  rw [factorial, factorial_succ_aux],
  refl
end

lemma app_iterate {X Y : Type} (h : X → Y) (x : X) (n : ℕ) (f : X → X)
  (g : Y → Y)
  (H : ∀ x, h (f x) = g (h x)) :
  h (iterate x f n) = iterate (h x) g n :=
begin
  induction n with n ih,
  { refl },
  { rw [iterate_succ, iterate_succ, H, ih], }
end

lemma iterate_iterate {X : Type} (f : X → X) (x : X) (g : ℕ → ℕ) (y : ℕ) (n : ℕ)
  (H : ∀ z, iterate x f (g z) = f (iterate x f z)) :
  iterate x f (iterate y g n) = iterate (iterate x f y) f n :=
begin
  induction n with n ih,
  { refl },
  { simp [H, ih] }
end

-- @[simp] lemma iterate_zero_succ : ⇑(iterate 0 nat.succ) = id :=
-- by funext n; induction n; simp *

-- @[simp] lemma iterate_one_succ : ⇑(iterate 1 nat.succ) = nat.succ :=
-- by funext n; induction n; simp *

lemma succ_iterate (g : ℕ → ℕ) (y : ℕ) (n : ℕ)
  (H : ∀ z, nat.succ (g z) = nat.succ z.succ) :
  nat.succ (iterate y g n) = iterate y.succ nat.succ n :=
begin
  have := iterate_iterate nat.succ 1,
  rw [iterate_one_succ] at this,
  apply this,
  assumption,
end

@[simp] lemma iterate_zero_id {X : Type} {x : X}: ⇑(iterate x id) = (λ _, x) :=
by funext n; induction n; simp *

lemma iterate_eq (x : ℕ) (f : ℕ → ℕ) (g : ℕ → ℕ) (n : ℕ)
  (h0 : x = g 0)
  (h1 : ∀ n, f (g n) = g n.succ) :
  iterate x f n = g n :=
begin
  subst h0,
  induction n,
  { simp },
  { simp * }
end

@[simp] def add (a : ℕ) : ℕ → ℕ := iterate a nat.succ
@[simp] def mul (a : ℕ) : ℕ → ℕ := iterate 0 (add a)

infix ` + ` := add
infix ` * ` := mul

lemma add_assoc' (a b c : ℕ) : add (add a b) c = add a (add b c) :=
begin
  dunfold add,
  rw [iterate_iterate],
  intros,
  simp,
end

lemma succ_add (a b : ℕ) : (add a b).succ = add a.succ b :=
begin
  simp [add],
  rw succ_iterate,
  intros, refl
end

meta def tactic.interactive.fold :=
`[repeat { rw [← add] }, repeat { rw ← mul}]

lemma mul_add' (a b c : ℕ) : mul a (add b c) = add (mul a b) (mul a c) :=
begin
  delta add mul,
  rw [app_iterate (iterate 0 (iterate a nat.succ)) b],
  rw iterate_iterate,
  { apply iterate_eq,
    { refl },
    { intro c,
      rw iterate_iterate,
      { simp,
        symmetry,
        rw iterate_iterate,
        { apply iterate_eq,
          { simp,
            induction a with a ih,
            { simp, },
            { simp,
              rw [ih],
              fold, }
             } }

          } } }
end

def succ_eq_iterate (n : ℕ) : n.succ = iterate n nat.succ 1 := rfl

lemma mul_assoc' (a b c : ℕ) : mul (mul a b) c = mul a (mul b c) :=
begin
  delta add mul,
  dsimp,
  rw [app_iterate],

end


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/

import group_theory.finiteness
import ring_theory.algebra_tower
import ring_theory.ideal.quotient
import ring_theory.noetherian

/-!
# Finiteness conditions in commutative algebra

In this file we define several notions of finiteness that are common in commutative algebra.

## Main declarations

- `module.finite`, `algebra.finite`, `ring_hom.finite`, `alg_hom.finite`
  all of these express that some object is finitely generated *as module* over some base ring.
- `algebra.finite_type`, `ring_hom.finite_type`, `alg_hom.finite_type`
  all of these express that some object is finitely generated *as algebra* over some base ring.
- `algebra.finite_presentation`, `ring_hom.finite_presentation`, `alg_hom.finite_presentation`
  all of these express that some object is finitely presented *as algebra* over some base ring.

-/

open function (surjective)
open_locale big_operators polynomial

section module_and_algebra

variables (R A B M N : Type*)

/-- A module over a semiring is `finite` if it is finitely generated as a module. -/
class module.finite [semiring R] [add_comm_monoid M] [module R M] :
  Prop := (out : (⊤ : submodule R M).fg)

/-- An algebra over a commutative semiring is of `finite_type` if it is finitely generated
over the base ring as algebra. -/
class algebra.finite_type [comm_semiring R] [semiring A] [algebra R A] : Prop :=
(out : (⊤ : subalgebra R A).fg)

/-- An algebra over a commutative semiring is `finite_presentation` if it is the quotient of a
polynomial ring in `n` variables by a finitely generated ideal. -/
def algebra.finite_presentation [comm_semiring R] [semiring A] [algebra R A] : Prop :=
∃ (n : ℕ) (f : mv_polynomial (fin n) R →ₐ[R] A),
  surjective f ∧ f.to_ring_hom.ker.fg

namespace module

variables [semiring R] [add_comm_monoid M] [module R M] [add_comm_monoid N] [module R N]

lemma finite_def {R M} [semiring R] [add_comm_monoid M] [module R M] :
  finite R M ↔ (⊤ : submodule R M).fg := ⟨λ h, h.1, λ h, ⟨h⟩⟩

@[priority 100] -- see Note [lower instance priority]
instance is_noetherian.finite [is_noetherian R M] : finite R M :=
⟨is_noetherian.noetherian ⊤⟩

namespace finite
open _root_.submodule set

lemma iff_add_monoid_fg {M : Type*} [add_comm_monoid M] : module.finite ℕ M ↔ add_monoid.fg M :=
⟨λ h, add_monoid.fg_def.2 $ (fg_iff_add_submonoid_fg ⊤).1 (finite_def.1 h),
  λ h, finite_def.2 $ (fg_iff_add_submonoid_fg ⊤).2 (add_monoid.fg_def.1 h)⟩

lemma iff_add_group_fg {G : Type*} [add_comm_group G] : module.finite ℤ G ↔ add_group.fg G :=
⟨λ h, add_group.fg_def.2 $ (fg_iff_add_subgroup_fg ⊤).1 (finite_def.1 h),
  λ h, finite_def.2 $ (fg_iff_add_subgroup_fg ⊤).2 (add_group.fg_def.1 h)⟩

variables {R M N}

lemma exists_fin [finite R M] : ∃ (n : ℕ) (s : fin n → M), span R (range s) = ⊤ :=
submodule.fg_iff_exists_fin_generating_family.mp out

lemma of_surjective [hM : finite R M] (f : M →ₗ[R] N) (hf : surjective f) :
  finite R N :=
⟨begin
  rw [← linear_map.range_eq_top.2 hf, ← submodule.map_top],
  exact hM.1.map f
end⟩

lemma of_injective [is_noetherian R N] (f : M →ₗ[R] N)
  (hf : function.injective f) : finite R M :=
⟨fg_of_injective f hf⟩

variables (R)

instance self : finite R R :=
⟨⟨{1}, by simpa only [finset.coe_singleton] using ideal.span_singleton_one⟩⟩

variable (M)

lemma of_restrict_scalars_finite (R A M : Type*) [comm_semiring R] [semiring A] [add_comm_monoid M]
  [module R M] [module A M] [algebra R A] [is_scalar_tower R A M] [hM : finite R M] :
  finite A M :=
begin
  rw [finite_def, fg_def] at hM ⊢,
  obtain ⟨S, hSfin, hSgen⟩ := hM,
  refine ⟨S, hSfin, eq_top_iff.2 _⟩,
  have := submodule.span_le_restrict_scalars R A S,
  rw hSgen at this,
  exact this
end

variables {R M}

instance prod [hM : finite R M] [hN : finite R N] : finite R (M × N) :=
⟨begin
  rw ← submodule.prod_top,
  exact submodule.fg_prod hM.1 hN.1
end⟩

instance pi {ι : Type*} {M : ι → Type*} [fintype ι] [Π i, add_comm_monoid (M i)]
  [Π i, module R (M i)] [h : ∀ i, finite R (M i)] : finite R (Π i, M i) :=
⟨begin
  rw ← submodule.pi_top,
  exact submodule.fg_pi (λ i, (h i).1),
end⟩

lemma equiv [hM : finite R M] (e : M ≃ₗ[R] N) : finite R N :=
of_surjective (e : M →ₗ[R] N) e.surjective

section algebra

lemma trans {R : Type*} (A B : Type*) [comm_semiring R] [comm_semiring A] [algebra R A]
  [semiring B] [algebra R B] [algebra A B] [is_scalar_tower R A B] :
  ∀ [finite R A] [finite A B], finite R B
| ⟨⟨s, hs⟩⟩ ⟨⟨t, ht⟩⟩ := ⟨submodule.fg_def.2
  ⟨set.image2 (•) (↑s : set A) (↑t : set B),
    set.finite.image2 _ s.finite_to_set t.finite_to_set,
    by rw [set.image2_smul, submodule.span_smul hs (↑t : set B),
      ht, submodule.restrict_scalars_top]⟩⟩

@[priority 100] -- see Note [lower instance priority]
instance finite_type {R : Type*} (A : Type*) [comm_semiring R] [comm_semiring A]
  [algebra R A] [hRA : finite R A] : algebra.finite_type R A :=
⟨subalgebra.fg_of_submodule_fg hRA.1⟩

end algebra

end finite

end module

namespace algebra

variables [comm_ring R] [comm_ring A] [algebra R A] [comm_ring B] [algebra R B]
variables [add_comm_group M] [module R M]
variables [add_comm_group N] [module R N]

namespace finite_type

lemma self : finite_type R R := ⟨⟨{1}, subsingleton.elim _ _⟩⟩

section
open_locale classical

protected lemma mv_polynomial (ι : Type*) [fintype ι] : finite_type R (mv_polynomial ι R) :=
⟨⟨finset.univ.image mv_polynomial.X, begin
  rw eq_top_iff, refine λ p, mv_polynomial.induction_on' p
    (λ u x, finsupp.induction u (subalgebra.algebra_map_mem _ x)
      (λ i n f hif hn ih, _))
    (λ p q ihp ihq, subalgebra.add_mem _ ihp ihq),
  rw [add_comm, mv_polynomial.monomial_add_single],
  exact subalgebra.mul_mem _ ih
    (subalgebra.pow_mem _ (subset_adjoin $ finset.mem_image_of_mem _ $ finset.mem_univ _) _)
end⟩⟩
end

lemma of_restrict_scalars_finite_type [algebra A B] [is_scalar_tower R A B] [hB : finite_type R B] :
  finite_type A B :=
begin
  obtain ⟨S, hS⟩ := hB.out,
  refine ⟨⟨S, eq_top_iff.2 (λ b, _)⟩⟩,
  have le : adjoin R (S : set B) ≤ subalgebra.restrict_scalars R (adjoin A S),
  { apply (algebra.adjoin_le _ : _ ≤ (subalgebra.restrict_scalars R (adjoin A ↑S))),
    simp only [subalgebra.coe_restrict_scalars],
    exact algebra.subset_adjoin, },
  exact le (eq_top_iff.1 hS b),
end

variables {R A B}

lemma of_surjective (hRA : finite_type R A) (f : A →ₐ[R] B) (hf : surjective f) :
  finite_type R B :=
⟨begin
  convert subalgebra.fg_map _ f hRA.1,
  simpa only [map_top f, @eq_comm _ ⊤, eq_top_iff, alg_hom.mem_range] using hf
end⟩

lemma equiv (hRA : finite_type R A) (e : A ≃ₐ[R] B) : finite_type R B :=
hRA.of_surjective e e.surjective

lemma trans [algebra A B] [is_scalar_tower R A B] (hRA : finite_type R A) (hAB : finite_type A B) :
  finite_type R B :=
⟨fg_trans' hRA.1 hAB.1⟩

/-- An algebra is finitely generated if and only if it is a quotient
of a polynomial ring whose variables are indexed by a finset. -/
lemma iff_quotient_mv_polynomial : (finite_type R A) ↔ ∃ (s : finset A)
  (f : (mv_polynomial {x // x ∈ s} R) →ₐ[R] A), (surjective f) :=
begin
  split,
  { rintro ⟨s, hs⟩,
    use [s, mv_polynomial.aeval coe],
    intro x,
    have hrw : (↑s : set A) = (λ (x : A), x ∈ s.val) := rfl,
    rw [← set.mem_range, ← alg_hom.coe_range, ← adjoin_eq_range, ← hrw, hs],
    exact set.mem_univ x },
  { rintro ⟨s, ⟨f, hsur⟩⟩,
    exact finite_type.of_surjective (finite_type.mv_polynomial R {x // x ∈ s}) f hsur }
end

/-- An algebra is finitely generated if and only if it is a quotient
of a polynomial ring whose variables are indexed by a fintype. -/
lemma iff_quotient_mv_polynomial' : (finite_type R A) ↔ ∃ (ι : Type u_2) (_ : fintype ι)
  (f : (mv_polynomial ι R) →ₐ[R] A), (surjective f) :=
begin
  split,
  { rw iff_quotient_mv_polynomial,
    rintro ⟨s, ⟨f, hsur⟩⟩,
    use [{x // x ∈ s}, by apply_instance, f, hsur] },
  { rintro ⟨ι, ⟨hfintype, ⟨f, hsur⟩⟩⟩,
    letI : fintype ι := hfintype,
    exact finite_type.of_surjective (finite_type.mv_polynomial R ι) f hsur }
end

/-- An algebra is finitely generated if and only if it is a quotient of a polynomial ring in `n`
variables. -/
lemma iff_quotient_mv_polynomial'' : (finite_type R A) ↔ ∃ (n : ℕ)
  (f : (mv_polynomial (fin n) R) →ₐ[R] A), (surjective f) :=
begin
  split,
  { rw iff_quotient_mv_polynomial',
    rintro ⟨ι, hfintype, ⟨f, hsur⟩⟩,
    letI := hfintype,
    obtain ⟨equiv⟩ := @fintype.trunc_equiv_fin ι (classical.dec_eq ι) hfintype,
    replace equiv := mv_polynomial.rename_equiv R equiv,
    exact ⟨fintype.card ι, alg_hom.comp f equiv.symm, function.surjective.comp hsur
      (alg_equiv.symm equiv).surjective⟩ },
  { rintro ⟨n, ⟨f, hsur⟩⟩,
    exact finite_type.of_surjective (finite_type.mv_polynomial R (fin n)) f hsur }
end

/-- A finitely presented algebra is of finite type. -/
lemma of_finite_presentation : finite_presentation R A → finite_type R A :=
begin
  rintro ⟨n, f, hf⟩,
  apply (finite_type.iff_quotient_mv_polynomial'').2,
  exact ⟨n, f, hf.1⟩
end

instance prod [hA : finite_type R A] [hB : finite_type R B] : finite_type R (A × B) :=
⟨begin
  rw ← subalgebra.prod_top,
  exact subalgebra.fg_prod hA.1 hB.1
end⟩

end finite_type

namespace finite_presentation

variables {R A B}

/-- An algebra over a Noetherian ring is finitely generated if and only if it is finitely
presented. -/
lemma of_finite_type [is_noetherian_ring R] : finite_type R A ↔ finite_presentation R A :=
begin
  refine ⟨λ h, _, algebra.finite_type.of_finite_presentation⟩,
  obtain ⟨n, f, hf⟩ := algebra.finite_type.iff_quotient_mv_polynomial''.1 h,
  refine ⟨n, f, hf, _⟩,
  have hnoet : is_noetherian_ring (mv_polynomial (fin n) R) := by apply_instance,
  replace hnoet := (is_noetherian_ring_iff.1 hnoet).noetherian,
  exact hnoet f.to_ring_hom.ker,
end

/-- If `e : A ≃ₐ[R] B` and `A` is finitely presented, then so is `B`. -/
lemma equiv (hfp : finite_presentation R A) (e : A ≃ₐ[R] B) : finite_presentation R B :=
begin
  obtain ⟨n, f, hf⟩ := hfp,
  use [n, alg_hom.comp ↑e f],
  split,
  { exact function.surjective.comp e.surjective hf.1 },
  suffices hker : (alg_hom.comp ↑e f).to_ring_hom.ker = f.to_ring_hom.ker,
  { rw hker, exact hf.2 },
  { have hco : (alg_hom.comp ↑e f).to_ring_hom = ring_hom.comp ↑e.to_ring_equiv f.to_ring_hom,
    { have h : (alg_hom.comp ↑e f).to_ring_hom = e.to_alg_hom.to_ring_hom.comp f.to_ring_hom := rfl,
      have h1 : ↑(e.to_ring_equiv) = (e.to_alg_hom).to_ring_hom := rfl,
      rw [h, h1] },
    rw [ring_hom.ker_eq_comap_bot, hco, ← ideal.comap_comap, ← ring_hom.ker_eq_comap_bot,
      ring_hom.ker_coe_equiv (alg_equiv.to_ring_equiv e), ring_hom.ker_eq_comap_bot] }
end

variable (R)

/-- The ring of polynomials in finitely many variables is finitely presented. -/
protected lemma mv_polynomial (ι : Type u_2) [fintype ι] :
  finite_presentation R (mv_polynomial ι R) :=
begin
  obtain ⟨equiv⟩ := @fintype.trunc_equiv_fin ι (classical.dec_eq ι) _,
  replace equiv := mv_polynomial.rename_equiv R equiv,
  refine ⟨_, alg_equiv.to_alg_hom equiv.symm, _⟩,
  split,
  { exact (alg_equiv.symm equiv).surjective },
  suffices hinj : function.injective equiv.symm.to_alg_hom.to_ring_hom,
  { rw [(ring_hom.injective_iff_ker_eq_bot _).1 hinj],
    exact submodule.fg_bot },
  exact (alg_equiv.symm equiv).injective
end

/-- `R` is finitely presented as `R`-algebra. -/
lemma self : finite_presentation R R :=
equiv (finite_presentation.mv_polynomial R pempty) (mv_polynomial.is_empty_alg_equiv R pempty)

variable {R}

/-- The quotient of a finitely presented algebra by a finitely generated ideal is finitely
presented. -/
protected lemma quotient {I : ideal A} (h : I.fg) (hfp : finite_presentation R A) :
  finite_presentation R (A ⧸ I) :=
begin
  obtain ⟨n, f, hf⟩ := hfp,
  refine ⟨n, (ideal.quotient.mkₐ R I).comp f, _, _⟩,
  { exact (ideal.quotient.mkₐ_surjective R I).comp hf.1 },
  { refine ideal.fg_ker_comp _ _ hf.2 _ hf.1,
    simp [h] }
end

/-- If `f : A →ₐ[R] B` is surjective with finitely generated kernel and `A` is finitely presented,
then so is `B`. -/
lemma of_surjective {f : A →ₐ[R] B} (hf : function.surjective f) (hker : f.to_ring_hom.ker.fg)
  (hfp : finite_presentation R A) : finite_presentation R B :=
equiv (hfp.quotient hker) (ideal.quotient_ker_alg_equiv_of_surjective hf)

lemma iff : finite_presentation R A ↔
  ∃ n (I : ideal (mv_polynomial (fin n) R)) (e : (_ ⧸ I) ≃ₐ[R] A), I.fg :=
begin
  split,
  { rintros ⟨n, f, hf⟩,
    exact ⟨n, f.to_ring_hom.ker, ideal.quotient_ker_alg_equiv_of_surjective hf.1, hf.2⟩ },
  { rintros ⟨n, I, e, hfg⟩,
    exact equiv ((finite_presentation.mv_polynomial R _).quotient hfg) e }
end

/-- An algebra is finitely presented if and only if it is a quotient of a polynomial ring whose
variables are indexed by a fintype by a finitely generated ideal. -/
lemma iff_quotient_mv_polynomial' : finite_presentation R A ↔ ∃ (ι : Type u_2) (_ : fintype ι)
  (f : mv_polynomial ι R →ₐ[R] A), surjective f ∧ f.to_ring_hom.ker.fg :=
begin
  split,
  { rintro ⟨n, f, hfs, hfk⟩,
    set ulift_var := mv_polynomial.rename_equiv R equiv.ulift,
    refine ⟨ulift (fin n), infer_instance, f.comp ulift_var.to_alg_hom,
      hfs.comp ulift_var.surjective,
      ideal.fg_ker_comp _ _ _ hfk ulift_var.surjective⟩,
    convert submodule.fg_bot,
    exact ring_hom.ker_coe_equiv ulift_var.to_ring_equiv, },
  { rintro ⟨ι, hfintype, f, hf⟩,
    haveI : fintype ι := hfintype,
    obtain ⟨equiv⟩ := @fintype.trunc_equiv_fin ι (classical.dec_eq ι) _,
    replace equiv := mv_polynomial.rename_equiv R equiv,
    refine ⟨fintype.card ι, f.comp equiv.symm,
      hf.1.comp (alg_equiv.symm equiv).surjective,
      ideal.fg_ker_comp _ f _ hf.2 equiv.symm.surjective⟩,
    convert submodule.fg_bot,
    exact ring_hom.ker_coe_equiv (equiv.symm.to_ring_equiv), }
end

/-- If `A` is a finitely presented `R`-algebra, then `mv_polynomial (fin n) A` is finitely presented
as `R`-algebra. -/
lemma mv_polynomial_of_finite_presentation (hfp : finite_presentation R A) (ι : Type*)
  [fintype ι] : finite_presentation R (mv_polynomial ι A) :=
begin
  rw iff_quotient_mv_polynomial' at hfp ⊢,
  classical,
  obtain ⟨ι', _, f, hf_surj, hf_ker⟩ := hfp,
  resetI,
  let g := (mv_polynomial.map_alg_hom f).comp (mv_polynomial.sum_alg_equiv R ι ι').to_alg_hom,
  refine ⟨ι ⊕ ι', by apply_instance, g,
    (mv_polynomial.map_surjective f.to_ring_hom hf_surj).comp (alg_equiv.surjective _),
    ideal.fg_ker_comp _ _ _ _ (alg_equiv.surjective _)⟩,
  { convert submodule.fg_bot,
    exact ring_hom.ker_coe_equiv (mv_polynomial.sum_alg_equiv R ι ι').to_ring_equiv },
  { rw [alg_hom.to_ring_hom_eq_coe, mv_polynomial.map_alg_hom_coe_ring_hom, mv_polynomial.ker_map],
    exact hf_ker.map mv_polynomial.C, }
end

/-- If `A` is an `R`-algebra and `S` is an `A`-algebra, both finitely presented, then `S` is
  finitely presented as `R`-algebra. -/
lemma trans [algebra A B] [is_scalar_tower R A B] (hfpA : finite_presentation R A)
  (hfpB : finite_presentation A B) : finite_presentation R B :=
begin
  obtain ⟨n, I, e, hfg⟩ := iff.1 hfpB,
  exact equiv ((mv_polynomial_of_finite_presentation hfpA _).quotient hfg) (e.restrict_scalars R)
end

end finite_presentation

end algebra

end module_and_algebra

namespace ring_hom
variables {A B C : Type*} [comm_ring A] [comm_ring B] [comm_ring C]

/-- A ring morphism `A →+* B` is `finite` if `B` is finitely generated as `A`-module. -/
def finite (f : A →+* B) : Prop :=
by letI : algebra A B := f.to_algebra; exact module.finite A B

/-- A ring morphism `A →+* B` is of `finite_type` if `B` is finitely generated as `A`-algebra. -/
def finite_type (f : A →+* B) : Prop := @algebra.finite_type A B _ _ f.to_algebra

/-- A ring morphism `A →+* B` is of `finite_presentation` if `B` is finitely presented as
`A`-algebra. -/
def finite_presentation (f : A →+* B) : Prop := @algebra.finite_presentation A B _ _ f.to_algebra

namespace finite

variables (A)

lemma id : finite (ring_hom.id A) := module.finite.self A

variables {A}

lemma of_surjective (f : A →+* B) (hf : surjective f) : f.finite :=
begin
  letI := f.to_algebra,
  exact module.finite.of_surjective (algebra.of_id A B).to_linear_map hf
end

lemma comp {g : B →+* C} {f : A →+* B} (hg : g.finite) (hf : f.finite) : (g.comp f).finite :=
@module.finite.trans A B C _ _ f.to_algebra _ (g.comp f).to_algebra g.to_algebra
begin
  fconstructor,
  intros a b c,
  simp only [algebra.smul_def, ring_hom.map_mul, mul_assoc],
  refl
end
hf hg

lemma finite_type {f : A →+* B} (hf : f.finite) : finite_type f :=
@module.finite.finite_type _ _ _ _ f.to_algebra hf

lemma of_comp_finite {f : A →+* B} {g : B →+* C} (h : (g.comp f).finite) : g.finite :=
begin
  letI := f.to_algebra,
  letI := g.to_algebra,
  letI := (g.comp f).to_algebra,
  letI : is_scalar_tower A B C := restrict_scalars.is_scalar_tower A B C,
  letI : module.finite A C := h,
  exact module.finite.of_restrict_scalars_finite A B C
end

end finite

namespace finite_type

variables (A)

lemma id : finite_type (ring_hom.id A) := algebra.finite_type.self A

variables {A}

lemma comp_surjective {f : A →+* B} {g : B →+* C} (hf : f.finite_type) (hg : surjective g) :
  (g.comp f).finite_type :=
@algebra.finite_type.of_surjective A B C _ _ f.to_algebra _ (g.comp f).to_algebra hf
{ to_fun := g, commutes' := λ a, rfl, .. g } hg

lemma of_surjective (f : A →+* B) (hf : surjective f) : f.finite_type :=
by { rw ← f.comp_id, exact (id A).comp_surjective hf }

lemma comp {g : B →+* C} {f : A →+* B} (hg : g.finite_type) (hf : f.finite_type) :
  (g.comp f).finite_type :=
@algebra.finite_type.trans A B C _ _ f.to_algebra _ (g.comp f).to_algebra g.to_algebra
begin
  fconstructor,
  intros a b c,
  simp only [algebra.smul_def, ring_hom.map_mul, mul_assoc],
  refl
end
hf hg

lemma of_finite_presentation {f : A →+* B} (hf : f.finite_presentation) : f.finite_type :=
@algebra.finite_type.of_finite_presentation A B _ _ f.to_algebra hf

lemma of_comp_finite_type {f : A →+* B} {g : B →+* C} (h : (g.comp f).finite_type) :
  g.finite_type :=
begin
  letI := f.to_algebra,
  letI := g.to_algebra,
  letI := (g.comp f).to_algebra,
  letI : is_scalar_tower A B C := restrict_scalars.is_scalar_tower A B C,
  letI : algebra.finite_type A C := h,
  exact algebra.finite_type.of_restrict_scalars_finite_type A B C
end

end finite_type

namespace finite_presentation

variables (A)

lemma id : finite_presentation (ring_hom.id A) := algebra.finite_presentation.self A

variables {A}

lemma comp_surjective {f : A →+* B} {g : B →+* C} (hf : f.finite_presentation) (hg : surjective g)
  (hker : g.ker.fg) :  (g.comp f).finite_presentation :=
@algebra.finite_presentation.of_surjective A B C _ _ f.to_algebra _ (g.comp f).to_algebra
{ to_fun := g, commutes' := λ a, rfl, .. g } hg hker hf

lemma of_surjective (f : A →+* B) (hf : surjective f) (hker : f.ker.fg) : f.finite_presentation :=
by { rw ← f.comp_id, exact (id A).comp_surjective hf hker}

lemma of_finite_type [is_noetherian_ring A] {f : A →+* B} : f.finite_type ↔ f.finite_presentation :=
@algebra.finite_presentation.of_finite_type A B _ _ f.to_algebra _

lemma comp {g : B →+* C} {f : A →+* B} (hg : g.finite_presentation) (hf : f.finite_presentation) :
  (g.comp f).finite_presentation :=
@algebra.finite_presentation.trans A B C _ _ f.to_algebra _ (g.comp f).to_algebra g.to_algebra
{ smul_assoc := λ a b c, begin
    simp only [algebra.smul_def, ring_hom.map_mul, mul_assoc],
    refl
  end }
hf hg

end finite_presentation

end ring_hom

namespace alg_hom

variables {R A B C : Type*} [comm_ring R]
variables [comm_ring A] [comm_ring B] [comm_ring C]
variables [algebra R A] [algebra R B] [algebra R C]

/-- An algebra morphism `A →ₐ[R] B` is finite if it is finite as ring morphism.
In other words, if `B` is finitely generated as `A`-module. -/
def finite (f : A →ₐ[R] B) : Prop := f.to_ring_hom.finite

/-- An algebra morphism `A →ₐ[R] B` is of `finite_type` if it is of finite type as ring morphism.
In other words, if `B` is finitely generated as `A`-algebra. -/
def finite_type (f : A →ₐ[R] B) : Prop := f.to_ring_hom.finite_type

/-- An algebra morphism `A →ₐ[R] B` is of `finite_presentation` if it is of finite presentation as
ring morphism. In other words, if `B` is finitely presented as `A`-algebra. -/
def finite_presentation (f : A →ₐ[R] B) : Prop := f.to_ring_hom.finite_presentation

namespace finite

variables (R A)

lemma id : finite (alg_hom.id R A) := ring_hom.finite.id A

variables {R A}

lemma comp {g : B →ₐ[R] C} {f : A →ₐ[R] B} (hg : g.finite) (hf : f.finite) : (g.comp f).finite :=
ring_hom.finite.comp hg hf

lemma of_surjective (f : A →ₐ[R] B) (hf : surjective f) : f.finite :=
ring_hom.finite.of_surjective f hf

lemma finite_type {f : A →ₐ[R] B} (hf : f.finite) : finite_type f :=
ring_hom.finite.finite_type hf

lemma of_comp_finite {f : A →ₐ[R] B} {g : B →ₐ[R] C} (h : (g.comp f).finite) : g.finite :=
ring_hom.finite.of_comp_finite h

end finite

namespace finite_type

variables (R A)

lemma id : finite_type (alg_hom.id R A) := ring_hom.finite_type.id A

variables {R A}

lemma comp {g : B →ₐ[R] C} {f : A →ₐ[R] B} (hg : g.finite_type) (hf : f.finite_type) :
  (g.comp f).finite_type :=
ring_hom.finite_type.comp hg hf

lemma comp_surjective {f : A →ₐ[R] B} {g : B →ₐ[R] C} (hf : f.finite_type) (hg : surjective g) :
  (g.comp f).finite_type :=
ring_hom.finite_type.comp_surjective hf hg

lemma of_surjective (f : A →ₐ[R] B) (hf : surjective f) : f.finite_type :=
ring_hom.finite_type.of_surjective f hf

lemma of_finite_presentation {f : A →ₐ[R] B} (hf : f.finite_presentation) : f.finite_type :=
ring_hom.finite_type.of_finite_presentation hf

lemma of_comp_finite_type {f : A →ₐ[R] B} {g : B →ₐ[R] C} (h : (g.comp f).finite_type) :
g.finite_type :=
ring_hom.finite_type.of_comp_finite_type h

end finite_type

namespace finite_presentation

variables (R A)

lemma id : finite_presentation (alg_hom.id R A) := ring_hom.finite_presentation.id A

variables {R A}

lemma comp {g : B →ₐ[R] C} {f : A →ₐ[R] B} (hg : g.finite_presentation)
  (hf : f.finite_presentation) : (g.comp f).finite_presentation :=
ring_hom.finite_presentation.comp hg hf

lemma comp_surjective {f : A →ₐ[R] B} {g : B →ₐ[R] C} (hf : f.finite_presentation)
  (hg : surjective g) (hker : g.to_ring_hom.ker.fg) : (g.comp f).finite_presentation :=
ring_hom.finite_presentation.comp_surjective hf hg hker

lemma of_surjective (f : A →ₐ[R] B) (hf : surjective f) (hker : f.to_ring_hom.ker.fg) :
  f.finite_presentation :=
ring_hom.finite_presentation.of_surjective f hf hker

lemma of_finite_type [is_noetherian_ring A] {f : A →ₐ[R] B} :
  f.finite_type ↔ f.finite_presentation :=
ring_hom.finite_presentation.of_finite_type

end finite_presentation

end alg_hom

section monoid_algebra

variables {R : Type*} {M : Type*}

namespace add_monoid_algebra

open algebra add_submonoid submodule

section span

section semiring

variables [comm_semiring R] [add_monoid M]

/-- An element of `add_monoid_algebra R M` is in the subalgebra generated by its support. -/
lemma mem_adjoin_support (f : add_monoid_algebra R M) : f ∈ adjoin R (of' R M '' f.support) :=
begin
  suffices : span R (of' R M '' f.support) ≤ (adjoin R (of' R M '' f.support)).to_submodule,
  { exact this (mem_span_support f) },
  rw submodule.span_le,
  exact subset_adjoin
end

/-- If a set `S` generates, as algebra, `add_monoid_algebra R M`, then the set of supports of
elements of `S` generates `add_monoid_algebra R M`. -/
lemma support_gen_of_gen {S : set (add_monoid_algebra R M)} (hS : algebra.adjoin R S = ⊤) :
  algebra.adjoin R (⋃ f ∈ S, (of' R M '' (f.support : set M))) = ⊤ :=
begin
  refine le_antisymm le_top _,
  rw [← hS, adjoin_le_iff],
  intros f hf,
  have hincl : of' R M '' f.support ⊆
    ⋃ (g : add_monoid_algebra R M) (H : g ∈ S), of' R M '' g.support,
  { intros s hs,
    exact set.mem_Union₂.2 ⟨f, ⟨hf, hs⟩⟩ },
  exact adjoin_mono hincl (mem_adjoin_support f)
end

/-- If a set `S` generates, as algebra, `add_monoid_algebra R M`, then the image of the union of
the supports of elements of `S` generates `add_monoid_algebra R M`. -/
lemma support_gen_of_gen' {S : set (add_monoid_algebra R M)} (hS : algebra.adjoin R S = ⊤) :
  algebra.adjoin R (of' R M '' (⋃ f ∈ S, (f.support : set M))) = ⊤ :=
begin
  suffices : of' R M '' (⋃ f ∈ S, (f.support : set M)) = ⋃ f ∈ S, (of' R M '' (f.support : set M)),
  { rw this,
    exact support_gen_of_gen hS },
  simp only [set.image_Union]
end

end semiring

section ring

variables [comm_ring R] [add_comm_monoid M]

/-- If `add_monoid_algebra R M` is of finite type, there there is a `G : finset M` such that its
image generates, as algera, `add_monoid_algebra R M`. -/
lemma exists_finset_adjoin_eq_top [h : finite_type R (add_monoid_algebra R M)] :
  ∃ G : finset M, algebra.adjoin R (of' R M '' G) = ⊤ :=
begin
  unfreezingI { obtain ⟨S, hS⟩ := h },
  letI : decidable_eq M := classical.dec_eq M,
  use finset.bUnion S (λ f, f.support),
  have : (finset.bUnion S (λ f, f.support) : set M) = ⋃ f ∈ S, (f.support : set M),
  { simp only [finset.set_bUnion_coe, finset.coe_bUnion] },
  rw [this],
  exact support_gen_of_gen' hS
end

/-- The image of an element `m : M` in `add_monoid_algebra R M` belongs the submodule generated by
`S : set M` if and only if `m ∈ S`. -/
lemma of'_mem_span [nontrivial R] {m : M} {S : set M} :
  of' R M m ∈ span R (of' R M '' S) ↔ m ∈ S :=
begin
  refine ⟨λ h, _, λ h, submodule.subset_span $ set.mem_image_of_mem (of R M) h⟩,
  rw [of', ← finsupp.supported_eq_span_single, finsupp.mem_supported,
    finsupp.support_single_ne_zero (@one_ne_zero R _ (by apply_instance))] at h,
  simpa using h
end

/--If the image of an element `m : M` in `add_monoid_algebra R M` belongs the submodule generated by
the closure of some `S : set M` then `m ∈ closure S`. -/
lemma mem_closure_of_mem_span_closure [nontrivial R] {m : M} {S : set M}
  (h : of' R M m ∈ span R (submonoid.closure (of' R M '' S) : set (add_monoid_algebra R M))) :
  m ∈ closure S :=
begin
  suffices : multiplicative.of_add m ∈ submonoid.closure (multiplicative.to_add ⁻¹' S),
  { simpa [← to_submonoid_closure] },
  rw [set.image_congr' (show ∀ x, of' R M x = of R M x, from λ x, of'_eq_of x),
    ← monoid_hom.map_mclosure] at h,
  simpa using of'_mem_span.1 h
end

end ring

end span

variables [add_comm_monoid M]

/-- If a set `S` generates an additive monoid `M`, then the image of `M` generates, as algebra,
`add_monoid_algebra R M`. -/
lemma mv_polynomial_aeval_of_surjective_of_closure [comm_semiring R] {S : set M}
  (hS : closure S = ⊤) : function.surjective (mv_polynomial.aeval
  (λ (s : S), of' R M ↑s) : mv_polynomial S R → add_monoid_algebra R M) :=
begin
  refine λ f, induction_on f (λ m, _) _ _,
  { have : m ∈ closure S := hS.symm ▸ mem_top _,
    refine closure_induction this (λ m hm, _) _ _,
    { exact ⟨mv_polynomial.X ⟨m, hm⟩, mv_polynomial.aeval_X _ _⟩ },
    { exact ⟨1, alg_hom.map_one _⟩ },
    { rintro m₁ m₂ ⟨P₁, hP₁⟩ ⟨P₂, hP₂⟩,
      exact ⟨P₁ * P₂, by rw [alg_hom.map_mul, hP₁, hP₂, of_apply, of_apply, of_apply,
        single_mul_single, one_mul]; refl⟩ } },
  { rintro f g ⟨P, rfl⟩ ⟨Q, rfl⟩,
    exact ⟨P + Q, alg_hom.map_add _ _ _⟩ },
  { rintro r f ⟨P, rfl⟩,
    exact ⟨r • P, alg_hom.map_smul _ _ _⟩ }
end

variables (R M)

/-- If an additive monoid `M` is finitely generated then `add_monoid_algebra R M` is of finite
type. -/
instance finite_type_of_fg [comm_ring R] [h : add_monoid.fg M] :
  finite_type R (add_monoid_algebra R M) :=
begin
  obtain ⟨S, hS⟩ := h.out,
  exact (finite_type.mv_polynomial R (S : set M)).of_surjective (mv_polynomial.aeval
    (λ (s : (S : set M)), of' R M ↑s)) (mv_polynomial_aeval_of_surjective_of_closure hS)
end

variables {R M}

/-- An additive monoid `M` is finitely generated if and only if `add_monoid_algebra R M` is of
finite type. -/
lemma finite_type_iff_fg [comm_ring R] [nontrivial R] :
  finite_type R (add_monoid_algebra R M) ↔ add_monoid.fg M :=
begin
  refine ⟨λ h, _, λ h, @add_monoid_algebra.finite_type_of_fg _ _ _ _ h⟩,
  obtain ⟨S, hS⟩ := @exists_finset_adjoin_eq_top R M _ _ h,
  refine add_monoid.fg_def.2 ⟨S, (eq_top_iff' _).2 (λ m, _)⟩,
  have hm : of' R M m ∈ (adjoin R (of' R M '' ↑S)).to_submodule,
  { simp only [hS, top_to_submodule, submodule.mem_top], },
  rw [adjoin_eq_span] at hm,
  exact mem_closure_of_mem_span_closure hm
end

/-- If `add_monoid_algebra R M` is of finite type then `M` is finitely generated. -/
lemma fg_of_finite_type [comm_ring R] [nontrivial R] [h : finite_type R (add_monoid_algebra R M)] :
  add_monoid.fg M :=
finite_type_iff_fg.1 h

/-- An additive group `G` is finitely generated if and only if `add_monoid_algebra R G` is of
finite type. -/
lemma finite_type_iff_group_fg {G : Type*} [add_comm_group G] [comm_ring R] [nontrivial R] :
  finite_type R (add_monoid_algebra R G) ↔ add_group.fg G :=
by simpa [add_group.fg_iff_add_monoid.fg] using finite_type_iff_fg

end add_monoid_algebra

namespace monoid_algebra

open algebra submonoid submodule

section span

section semiring

variables [comm_semiring R] [monoid M]

/-- An element of `monoid_algebra R M` is in the subalgebra generated by its support. -/
lemma mem_adjoint_support (f : monoid_algebra R M) : f ∈ adjoin R (of R M '' f.support) :=
begin
  suffices : span R (of R M '' f.support) ≤ (adjoin R (of R M '' f.support)).to_submodule,
  { exact this (mem_span_support f) },
  rw submodule.span_le,
  exact subset_adjoin
end

/-- If a set `S` generates, as algebra, `monoid_algebra R M`, then the set of supports of elements
of `S` generates `monoid_algebra R M`. -/
lemma support_gen_of_gen {S : set (monoid_algebra R M)} (hS : algebra.adjoin R S = ⊤) :
  algebra.adjoin R (⋃ f ∈ S, (of R M '' (f.support : set M))) = ⊤ :=
begin
  refine le_antisymm le_top _,
  rw [← hS, adjoin_le_iff],
  intros f hf,
  have hincl : (of R M) '' f.support ⊆
    ⋃ (g : monoid_algebra R M) (H : g ∈ S), of R M '' g.support,
  { intros s hs,
    exact set.mem_Union₂.2 ⟨f, ⟨hf, hs⟩⟩ },
  exact adjoin_mono hincl (mem_adjoint_support f)
end

/-- If a set `S` generates, as algebra, `monoid_algebra R M`, then the image of the union of the
supports of elements of `S` generates `monoid_algebra R M`. -/
lemma support_gen_of_gen' {S : set (monoid_algebra R M)} (hS : algebra.adjoin R S = ⊤) :
  algebra.adjoin R (of R M '' (⋃ f ∈ S, (f.support : set M))) = ⊤ :=
begin
  suffices : of R M '' (⋃ f ∈ S, (f.support : set M)) = ⋃ f ∈ S, (of R M '' (f.support : set M)),
  { rw this,
    exact support_gen_of_gen hS },
  simp only [set.image_Union]
end

end semiring

section ring

variables [comm_ring R] [comm_monoid M]

/-- If `monoid_algebra R M` is of finite type, there there is a `G : finset M` such that its image
generates, as algera, `monoid_algebra R M`. -/
lemma exists_finset_adjoin_eq_top [h :finite_type R (monoid_algebra R M)] :
  ∃ G : finset M, algebra.adjoin R (of R M '' G) = ⊤ :=
begin
  unfreezingI { obtain ⟨S, hS⟩ := h },
  letI : decidable_eq M := classical.dec_eq M,
  use finset.bUnion S (λ f, f.support),
  have : (finset.bUnion S (λ f, f.support) : set M) = ⋃ f ∈ S, (f.support : set M),
  { simp only [finset.set_bUnion_coe, finset.coe_bUnion] },
  rw [this],
  exact support_gen_of_gen' hS
end

/-- The image of an element `m : M` in `monoid_algebra R M` belongs the submodule generated by
`S : set M` if and only if `m ∈ S`. -/
lemma of_mem_span_of_iff [nontrivial R] {m : M} {S : set M} :
  of R M m ∈ span R (of R M '' S) ↔ m ∈ S :=
begin
  refine ⟨λ h, _, λ h, submodule.subset_span $ set.mem_image_of_mem (of R M) h⟩,
  rw [of, monoid_hom.coe_mk, ← finsupp.supported_eq_span_single, finsupp.mem_supported,
    finsupp.support_single_ne_zero (@one_ne_zero R _ (by apply_instance))] at h,
  simpa using h
end

/--If the image of an element `m : M` in `monoid_algebra R M` belongs the submodule generated by the
closure of some `S : set M` then `m ∈ closure S`. -/
lemma mem_closure_of_mem_span_closure [nontrivial R] {m : M} {S : set M}
  (h : of R M m ∈ span R (submonoid.closure (of R M '' S) : set (monoid_algebra R M))) :
  m ∈ closure S :=
begin
  rw ← monoid_hom.map_mclosure at h,
  simpa using of_mem_span_of_iff.1 h
end

end ring

end span

variables [comm_monoid M]

/-- If a set `S` generates a monoid `M`, then the image of `M` generates, as algebra,
`monoid_algebra R M`. -/
lemma mv_polynomial_aeval_of_surjective_of_closure [comm_semiring R] {S : set M}
  (hS : closure S = ⊤) : function.surjective (mv_polynomial.aeval
  (λ (s : S), of R M ↑s) : mv_polynomial S R → monoid_algebra R M) :=
begin
  refine λ f, induction_on f (λ m, _) _ _,
  { have : m ∈ closure S := hS.symm ▸ mem_top _,
    refine closure_induction this (λ m hm, _) _ _,
    { exact ⟨mv_polynomial.X ⟨m, hm⟩, mv_polynomial.aeval_X _ _⟩ },
    { exact ⟨1, alg_hom.map_one _⟩ },
    { rintro m₁ m₂ ⟨P₁, hP₁⟩ ⟨P₂, hP₂⟩,
      exact ⟨P₁ * P₂, by rw [alg_hom.map_mul, hP₁, hP₂, of_apply, of_apply, of_apply,
        single_mul_single, one_mul]⟩ } },
  { rintro f g ⟨P, rfl⟩ ⟨Q, rfl⟩,
    exact ⟨P + Q, alg_hom.map_add _ _ _⟩ },
  { rintro r f ⟨P, rfl⟩,
    exact ⟨r • P, alg_hom.map_smul _ _ _⟩ }
end

/-- If a monoid `M` is finitely generated then `monoid_algebra R M` is of finite type. -/
instance finite_type_of_fg [comm_ring R] [monoid.fg M] : finite_type R (monoid_algebra R M) :=
(add_monoid_algebra.finite_type_of_fg R (additive M)).equiv (to_additive_alg_equiv R M).symm

/-- A monoid `M` is finitely generated if and only if `monoid_algebra R M` is of finite type. -/
lemma finite_type_iff_fg [comm_ring R] [nontrivial R] :
  finite_type R (monoid_algebra R M) ↔ monoid.fg M :=
⟨λ h, monoid.fg_iff_add_fg.2 $ add_monoid_algebra.finite_type_iff_fg.1 $ h.equiv $
  to_additive_alg_equiv R M, λ h, @monoid_algebra.finite_type_of_fg _ _ _ _ h⟩

/-- If `monoid_algebra R M` is of finite type then `M` is finitely generated. -/
lemma fg_of_finite_type [comm_ring R] [nontrivial R] [h : finite_type R (monoid_algebra R M)] :
  monoid.fg M :=
finite_type_iff_fg.1 h

/-- A group `G` is finitely generated if and only if `add_monoid_algebra R G` is of finite type. -/
lemma finite_type_iff_group_fg {G : Type*} [comm_group G] [comm_ring R] [nontrivial R] :
  finite_type R (monoid_algebra R G) ↔ group.fg G :=
by simpa [group.fg_iff_monoid.fg] using finite_type_iff_fg

end monoid_algebra

end monoid_algebra

section vasconcelos
variables {R : Type*} [comm_ring R] {M : Type*} [add_comm_group M] [module R M] (f : M →ₗ[R] M)

noncomputable theory

/-- The structure of a module `M` over a ring `R` as a module over `polynomial R` when given a
choice of how `X` acts by choosing a linear map `f : M →ₗ[R] M` -/
@[simps]
def module_polynomial_of_endo : module R[X] M :=
module.comp_hom M (polynomial.aeval f).to_ring_hom

include f
lemma module_polynomial_of_endo.is_scalar_tower : @is_scalar_tower R R[X] M _
  (by { letI := module_polynomial_of_endo f, apply_instance }) _ :=
begin
  letI := module_polynomial_of_endo f,
  constructor,
  intros x y z,
  simp,
end

open polynomial module

/-- A theorem/proof by Vasconcelos, given a finite module `M` over a commutative ring, any
surjective endomorphism of `M` is also injective. Based on,
https://math.stackexchange.com/a/239419/31917,
https://www.ams.org/journals/tran/1969-138-00/S0002-9947-1969-0238839-5/.
This is similar to `is_noetherian.injective_of_surjective_endomorphism` but only applies in the
commutative case, but does not use a Noetherian hypothesis. -/
theorem module.finite.injective_of_surjective_endomorphism [hfg : finite R M]
  (f_surj : function.surjective f) : function.injective f :=
begin
  letI := module_polynomial_of_endo f,
  haveI : is_scalar_tower R R[X] M := module_polynomial_of_endo.is_scalar_tower f,
  have hfgpoly : finite R[X] M, from finite.of_restrict_scalars_finite R _ _,
  have X_mul : ∀ o, (X : R[X]) • o = f o,
  { intro,
    simp, },
  have : (⊤ : submodule R[X] M) ≤ ideal.span {X} • ⊤,
  { intros a ha,
    obtain ⟨y, rfl⟩ := f_surj a,
    rw [← X_mul y],
    exact submodule.smul_mem_smul (ideal.mem_span_singleton.mpr (dvd_refl _)) trivial, },
  obtain ⟨F, hFa, hFb⟩ := submodule.exists_sub_one_mem_and_smul_eq_zero_of_fg_of_le_smul _
    (⊤ : submodule R[X] M) (finite_def.mp hfgpoly) this,
  rw [← linear_map.ker_eq_bot, linear_map.ker_eq_bot'],
  intros m hm,
  rw ideal.mem_span_singleton' at hFa,
  obtain ⟨G, hG⟩ := hFa,
  suffices : (F - 1) • m = 0,
  { have Fmzero := hFb m (by simp),
    rwa [← sub_add_cancel F 1, add_smul, one_smul, this, zero_add] at Fmzero, },
  rw [← hG, mul_smul, X_mul m, hm, smul_zero],
end

end vasconcelos


/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz

! This file was ported from Lean 3 source module category_theory.sites.compatible_plus
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Sites.Whiskering
import Mathbin.CategoryTheory.Sites.Plus

/-!

In this file, we prove that the plus functor is compatible with functors which
preserve the correct limits and colimits.

See `category_theory/sites/compatible_sheafification` for the compatibility
of sheafification, which follows easily from the content in this file.

-/

namespace CategoryTheory.GrothendieckTopology

open CategoryTheory

open CategoryTheory.Limits

open Opposite

universe w₁ w₂ v u

variable {C : Type u} [Category.{v} C] (J : GrothendieckTopology C)

variable {D : Type w₁} [Category.{max v u} D]

variable {E : Type w₂} [Category.{max v u} E]

variable (F : D ⥤ E)

noncomputable section

variable [∀ (α β : Type max v u) (fst snd : β → α), HasLimitsOfShape (WalkingMulticospan fst snd) D]

variable [∀ (α β : Type max v u) (fst snd : β → α), HasLimitsOfShape (WalkingMulticospan fst snd) E]

variable [∀ (X : C) (W : J.cover X) (P : Cᵒᵖ ⥤ D), PreservesLimit (W.index P).multicospan F]

variable (P : Cᵒᵖ ⥤ D)

/-- The diagram used to define `P⁺`, composed with `F`, is isomorphic
to the diagram used to define `P ⋙ F`. -/
def diagramCompIso (X : C) : J.diagram P X ⋙ F ≅ J.diagram (P ⋙ F) X :=
  NatIso.ofComponents
    (fun W => by
      refine' _ ≪≫ has_limit.iso_of_nat_iso (W.unop.multicospan_comp _ _).symm
      refine'
        (is_limit_of_preserves F (limit.is_limit _)).conePointUniqueUpToIso (limit.is_limit _))
    (by
      intro A B f
      ext
      dsimp
      simp only [functor.map_cone_π_app, multiequalizer.multifork_π_app_left, iso.symm_hom,
        multiequalizer.lift_ι, eq_to_hom_refl, category.comp_id,
        limit.cone_point_unique_up_to_iso_hom_comp,
        grothendieck_topology.cover.multicospan_comp_hom_inv_left, has_limit.iso_of_nat_iso_hom_π,
        category.assoc]
      simp only [← F.map_comp, multiequalizer.lift_ι])
#align category_theory.grothendieck_topology.diagram_comp_iso CategoryTheory.GrothendieckTopology.diagramCompIso

@[simp, reassoc.1]
theorem diagramCompIso_hom_ι (X : C) (W : (J.cover X)ᵒᵖ) (i : W.unop.arrow) :
    (J.diagramCompIso F P X).Hom.app W ≫ Multiequalizer.ι _ i = F.map (Multiequalizer.ι _ _) :=
  by
  delta diagram_comp_iso
  dsimp
  simp
#align category_theory.grothendieck_topology.diagram_comp_iso_hom_ι CategoryTheory.GrothendieckTopology.diagramCompIso_hom_ι

variable [∀ X : C, HasColimitsOfShape (J.cover X)ᵒᵖ D]

variable [∀ X : C, HasColimitsOfShape (J.cover X)ᵒᵖ E]

variable [∀ X : C, PreservesColimitsOfShape (J.cover X)ᵒᵖ F]

/-- The isomorphism between `P⁺ ⋙ F` and `(P ⋙ F)⁺`. -/
def plusCompIso : J.plusObj P ⋙ F ≅ J.plusObj (P ⋙ F) :=
  NatIso.ofComponents
    (fun X => by
      refine' _ ≪≫ has_colimit.iso_of_nat_iso (J.diagram_comp_iso F P X.unop)
      refine'
        (is_colimit_of_preserves F
              (colimit.is_colimit (J.diagram P (unop X)))).coconePointUniqueUpToIso
          (colimit.is_colimit _))
    (by
      intro X Y f
      apply (is_colimit_of_preserves F (colimit.is_colimit (J.diagram P X.unop))).hom_ext
      intro W
      dsimp [plus_obj, plus_map]
      simp only [functor.map_comp, category.assoc]
      slice_rhs 1 2 =>
        erw [(is_colimit_of_preserves F (colimit.is_colimit (J.diagram P X.unop))).fac]
      slice_lhs 1 3 =>
        simp only [← F.map_comp]
        dsimp [colim_map, is_colimit.map, colimit.pre]
        simp only [colimit.ι_desc_assoc, colimit.ι_desc]
        dsimp [cocones.precompose]
        rw [category.assoc, colimit.ι_desc]
        dsimp [cocone.whisker]
        rw [F.map_comp]
      simp only [category.assoc]
      slice_lhs 2 3 =>
        erw [(is_colimit_of_preserves F (colimit.is_colimit (J.diagram P Y.unop))).fac]
      dsimp
      simp only [has_colimit.iso_of_nat_iso_ι_hom_assoc, grothendieck_topology.diagram_pullback_app,
        colimit.ι_pre, has_colimit.iso_of_nat_iso_ι_hom, ι_colim_map_assoc]
      simp only [← category.assoc]
      congr 1
      ext
      dsimp
      simp only [category.assoc]
      erw [multiequalizer.lift_ι, diagram_comp_iso_hom_ι, diagram_comp_iso_hom_ι, ← F.map_comp,
        multiequalizer.lift_ι])
#align category_theory.grothendieck_topology.plus_comp_iso CategoryTheory.GrothendieckTopology.plusCompIso

@[simp, reassoc.1]
theorem ι_plusCompIso_hom (X) (W) :
    F.map (colimit.ι _ W) ≫ (J.plusCompIso F P).Hom.app X =
      (J.diagramCompIso F P X.unop).Hom.app W ≫ colimit.ι _ W :=
  by
  delta diagram_comp_iso plus_comp_iso
  simp only [is_colimit.desc_cocone_morphism_hom, is_colimit.unique_up_to_iso_hom,
    cocones.forget_map, iso.trans_hom, nat_iso.of_components_hom_app, functor.map_iso_hom, ←
    category.assoc]
  erw [(is_colimit_of_preserves F (colimit.is_colimit (J.diagram P (unop X)))).fac]
  simp only [category.assoc, has_limit.iso_of_nat_iso_hom_π, iso.symm_hom,
    cover.multicospan_comp_hom_inv_left, eq_to_hom_refl, category.comp_id,
    limit.cone_point_unique_up_to_iso_hom_comp, functor.map_cone_π_app,
    multiequalizer.multifork_π_app_left, multiequalizer.lift_ι, functor.map_comp, eq_self_iff_true,
    category.assoc, iso.trans_hom, iso.cancel_iso_hom_left, nat_iso.of_components_hom_app,
    colimit.cocone_ι, category.assoc, has_colimit.iso_of_nat_iso_ι_hom]
#align category_theory.grothendieck_topology.ι_plus_comp_iso_hom CategoryTheory.GrothendieckTopology.ι_plusCompIso_hom

@[simp, reassoc.1]
theorem plusCompIso_whiskerLeft {F G : D ⥤ E} (η : F ⟶ G) (P : Cᵒᵖ ⥤ D)
    [∀ X : C, PreservesColimitsOfShape (J.cover X)ᵒᵖ F]
    [∀ (X : C) (W : J.cover X) (P : Cᵒᵖ ⥤ D), PreservesLimit (W.index P).multicospan F]
    [∀ X : C, PreservesColimitsOfShape (J.cover X)ᵒᵖ G]
    [∀ (X : C) (W : J.cover X) (P : Cᵒᵖ ⥤ D), PreservesLimit (W.index P).multicospan G] :
    whiskerLeft _ η ≫ (J.plusCompIso G P).Hom =
      (J.plusCompIso F P).Hom ≫ J.plusMap (whiskerLeft _ η) :=
  by
  ext X
  apply (is_colimit_of_preserves F (colimit.is_colimit (J.diagram P X.unop))).hom_ext
  intro W
  dsimp [plus_obj, plus_map]
  simp only [ι_plus_comp_iso_hom, ι_colim_map, whisker_left_app, ι_plus_comp_iso_hom_assoc,
    nat_trans.naturality_assoc, grothendieck_topology.diagram_nat_trans_app]
  simp only [← category.assoc]
  congr 1
  ext
  dsimp
  simpa
#align category_theory.grothendieck_topology.plus_comp_iso_whisker_left CategoryTheory.GrothendieckTopology.plusCompIso_whiskerLeft

/-- The isomorphism between `P⁺ ⋙ F` and `(P ⋙ F)⁺`, functorially in `F`. -/
@[simps hom_app inv_app]
def plusFunctorWhiskerLeftIso (P : Cᵒᵖ ⥤ D)
    [∀ (F : D ⥤ E) (X : C), PreservesColimitsOfShape (J.cover X)ᵒᵖ F]
    [∀ (F : D ⥤ E) (X : C) (W : J.cover X) (P : Cᵒᵖ ⥤ D),
        PreservesLimit (W.index P).multicospan F] :
    (whiskeringLeft _ _ E).obj (J.plusObj P) ≅ (whiskeringLeft _ _ _).obj P ⋙ J.plusFunctor E :=
  NatIso.ofComponents (fun X => plusCompIso _ _ _) fun F G η => plusCompIso_whiskerLeft _ _ _
#align category_theory.grothendieck_topology.plus_functor_whisker_left_iso CategoryTheory.GrothendieckTopology.plusFunctorWhiskerLeftIso

@[simp, reassoc.1]
theorem plusCompIso_whiskerRight {P Q : Cᵒᵖ ⥤ D} (η : P ⟶ Q) :
    whiskerRight (J.plusMap η) F ≫ (J.plusCompIso F Q).Hom =
      (J.plusCompIso F P).Hom ≫ J.plusMap (whiskerRight η F) :=
  by
  ext X
  apply (is_colimit_of_preserves F (colimit.is_colimit (J.diagram P X.unop))).hom_ext
  intro W
  dsimp [plus_obj, plus_map]
  simp only [ι_colim_map, whisker_right_app, ι_plus_comp_iso_hom_assoc,
    grothendieck_topology.diagram_nat_trans_app]
  simp only [← category.assoc, ← F.map_comp]
  dsimp [colim_map, is_colimit.map]
  simp only [colimit.ι_desc]
  dsimp [cocones.precompose]
  simp only [functor.map_comp, category.assoc, ι_plus_comp_iso_hom]
  simp only [← category.assoc]
  congr 1
  ext
  dsimp
  simp only [diagram_comp_iso_hom_ι_assoc, multiequalizer.lift_ι, diagram_comp_iso_hom_ι,
    category.assoc]
  simp only [← F.map_comp, multiequalizer.lift_ι]
#align category_theory.grothendieck_topology.plus_comp_iso_whisker_right CategoryTheory.GrothendieckTopology.plusCompIso_whiskerRight

/-- The isomorphism between `P⁺ ⋙ F` and `(P ⋙ F)⁺`, functorially in `P`. -/
@[simps hom_app inv_app]
def plusFunctorWhiskerRightIso :
    J.plusFunctor D ⋙ (whiskeringRight _ _ _).obj F ≅
      (whiskeringRight _ _ _).obj F ⋙ J.plusFunctor E :=
  NatIso.ofComponents (fun P => J.plusCompIso _ _) fun P Q η => plusCompIso_whiskerRight _ _ _
#align category_theory.grothendieck_topology.plus_functor_whisker_right_iso CategoryTheory.GrothendieckTopology.plusFunctorWhiskerRightIso

@[simp, reassoc.1]
theorem whiskerRight_toPlus_comp_plusCompIso_hom :
    whiskerRight (J.toPlus _) _ ≫ (J.plusCompIso F P).Hom = J.toPlus _ :=
  by
  ext
  dsimp [to_plus]
  simp only [ι_plus_comp_iso_hom, functor.map_comp, category.assoc]
  simp only [← category.assoc]
  congr 1
  ext
  delta cover.to_multiequalizer
  simp only [diagram_comp_iso_hom_ι, category.assoc, ← F.map_comp]
  erw [multiequalizer.lift_ι, multiequalizer.lift_ι]
  rfl
#align category_theory.grothendieck_topology.whisker_right_to_plus_comp_plus_comp_iso_hom CategoryTheory.GrothendieckTopology.whiskerRight_toPlus_comp_plusCompIso_hom

@[simp]
theorem toPlus_comp_plusCompIso_inv :
    J.toPlus _ ≫ (J.plusCompIso F P).inv = whiskerRight (J.toPlus _) _ := by simp [iso.comp_inv_eq]
#align category_theory.grothendieck_topology.to_plus_comp_plus_comp_iso_inv CategoryTheory.GrothendieckTopology.toPlus_comp_plusCompIso_inv

theorem plusCompIso_inv_eq_plusLift (hP : Presheaf.IsSheaf J (J.plusObj P ⋙ F)) :
    (J.plusCompIso F P).inv = J.plusLift (whiskerRight (J.toPlus _) _) hP :=
  by
  apply J.plus_lift_unique
  simp [iso.comp_inv_eq]
#align category_theory.grothendieck_topology.plus_comp_iso_inv_eq_plus_lift CategoryTheory.GrothendieckTopology.plusCompIso_inv_eq_plusLift

end CategoryTheory.GrothendieckTopology


import QL.FOL.semantics order.filter.ultrafilter data.finset.basic
open encodable

universes u v

namespace fol

open_locale logic_symbol
open logic.semantics

variables {L : language.{u}} {μ : Type v} {n : ℕ} {I : Type u} [inhabited I] (F : ultrafilter I)
  {𝔄 : I → nonempty_Structure L}

def uequiv : (Π i, 𝔄 i) → (Π i, 𝔄 i) → Prop :=
λ u₁ u₂, {i | u₁ i = u₂ i} ∈ F

notation u` ~[`:80 F`] `v:80 := uequiv F u v

@[simp] lemma uequiv_refl (u : Π i, 𝔄 i) : u ~[F] u :=
by { simp[uequiv], exact F.univ_sets }

lemma uequiv_symm {u₁ u₂ : Π i, 𝔄 i} : u₁ ~[F] u₂ → u₂ ~[F] u₁ :=
by { simp[uequiv], have : {i | u₁ i = u₂ i} = {i | u₂ i = u₁ i}, { ext, simp, exact eq_comm }, simp[this] }

lemma uequiv_trans {u₁ u₂ u₃ : Π i, 𝔄 i} : u₁ ~[F] u₂ → u₂ ~[F] u₃ → u₁ ~[F] u₃ :=
by { simp[uequiv], intros h₁ h₂,
     have : {i | u₁ i = u₂ i} ∩ {i | u₂ i = u₃ i} ⊆ {i | u₁ i = u₃ i},
     { intros i hi, simp* at* },
     exact F.sets_of_superset (F.inter_sets h₁ h₂) this }

theorem uequiv_equivalence : equivalence (@uequiv L I _ F 𝔄) :=
⟨uequiv_refl F, λ _ _ , uequiv_symm F, λ _ _ _, uequiv_trans F⟩

@[reducible, simp, instance]
def ult (𝔄 : I → nonempty_Structure L) (F : ultrafilter I) : setoid (Π i, 𝔄 i) := ⟨@uequiv L I _ F 𝔄, uequiv_equivalence F⟩

def Ult (𝔄 : I → nonempty_Structure L) (F : ultrafilter I) : Type* :=
quotient (ult 𝔄 F: setoid (Π i, 𝔄 i))

def to_quotient {𝔄 : I → nonempty_Structure L} {F : ultrafilter I} (u : Π i, 𝔄 i) : Ult 𝔄 F := quotient.mk' u

notation `⟦`u`⟧*` :max := to_quotient u

instance : inhabited (Ult 𝔄 F) := ⟨⟦λ i, default⟧*⟩

namespace Ult
open logic.semantics

@[elab_as_eliminator]
protected lemma ind_on {C : Ult 𝔄 F → Prop} (u : Ult 𝔄 F)
  (h : ∀ u : Π i, 𝔄 i, C ⟦u⟧*) : C u :=
quotient.induction_on' u h

@[elab_as_eliminator, reducible]
protected def lift_on {φ} (d : Ult 𝔄 F) (f : (Π i, 𝔄 i) → φ)
  (h : ∀ (v u : Π i, 𝔄 i), v ~[F] u → f v = f u) : φ :=
quotient.lift_on' d f h

@[simp]
protected lemma lift_on_eq {φ} (u₀ : Π i, 𝔄 i) (f : (Π i, 𝔄 i) → φ)
  (h : ∀ v u, v ~[F] u → f v = f u) : fol.Ult.lift_on F ⟦u₀⟧* f h = f u₀ := rfl

@[elab_as_eliminator, reducible, simp]
protected def lift_on₂ {φ} (u₁ u₂ : Ult 𝔄 F) (f : (Π i, 𝔄 i) → (Π i, 𝔄 i) → φ)
  (h : ∀ u₁ u₂ v₁ v₂, u₁ ~[F] v₁ → u₂ ~[F] v₂ → f u₁ u₂ = f v₁ v₂) : φ :=
quotient.lift_on₂' u₁ u₂ f h

@[simp]
protected lemma lift_on₂_eq {φ} (u₁ u₂ : Π i, 𝔄 i) (f : (Π i, 𝔄 i) → (Π i, 𝔄 i) → φ)
  (h : ∀ t₁ t₂ u₁ u₂, (t₁ ~[F] u₁) → (t₂ ~[F] u₂) → f t₁ t₂ = f u₁ u₂) :
  fol.Ult.lift_on₂ F ⟦u₁⟧* ⟦u₂⟧* f h = f u₁ u₂ := rfl

@[elab_as_eliminator, reducible]
protected def lift_on_finitary {φ} {n : ℕ} (v : finitary (Ult 𝔄 F) n) (f : finitary (Π i, 𝔄 i) n → φ)
  (h : ∀ v₁ v₂ : finitary (Π i, 𝔄 i) n, (∀ n, (v₁ n) ~[F] (v₂ n)) → f v₁ = f v₂) : φ :=
quotient.lift_on_finitary v f h

@[simp]
protected lemma lift_on_finitary_eq {φ} {n} (v : finitary (Π i, 𝔄 i) n) (f : finitary (Π i, 𝔄 i) n → φ)
  (h : ∀ v₁ v₂ : finitary (Π i, 𝔄 i) n, (∀ n, (v₁ n) ~[F] (v₂ n)) → f v₁ = f v₂) :
  fol.Ult.lift_on_finitary F (λ x, ⟦v x⟧*) f h = f v :=
quotient.lift_on_finitary_eq v f h

@[simp] lemma of_eq_of {u₁ u₂ : Π i, 𝔄 i} : (⟦u₁⟧* : Ult 𝔄 F) = ⟦u₂⟧* ↔ u₁ ~[F] u₂ :=
by simp[to_quotient, quotient.eq']

lemma equivs_mem {n} {v₁ v₂ : finitary (Π i, 𝔄 i) n} (h : ∀ (x : fin n), {i : I | v₁ x i = v₂ x i} ∈ F) :
  {i | (λ x, v₁ x i) = (λ x, v₂ x i)} ∈ F :=
begin
  induction n with n IH,
  { have : {i : I | (λ x, v₁ x i) = (λ x, v₂ x i)} = set.univ,
    { ext i, simp }, rw this, exact F.univ_sets },
  { have ss : {i | v₁ 0 i = v₂ 0 i} ∩ {i | (λ x, v₁.tail x i) = (λ x, v₂.tail x i)} ⊆ {i : I | (λ x, v₁ x i) = (λ x, v₂ x i)},
    { intros i hi, simp[finitary.tail] at*,
      funext x, refine fin.cases _ _ x,
      { exact hi.1 },
      { intros j, have := congr_fun hi.2 j, simp at this, exact this } },
    have : {i | v₁ 0 i = v₂ 0 i} ∩ {i | (λ x, v₁.tail x i) = (λ x, v₂.tail x i)} ∈ F,
      from (F.inter_sets (h _) (@IH v₁.tail v₂.tail (λ x, h _))),
    refine F.sets_of_superset this ss }
end

lemma fn_equiv {n} {v₁ v₂ : finitary (Π i, 𝔄 i) n} (h : ∀ x, v₁ x ~[F] v₂ x) (f : L.fn n) :
  (λ i, (𝔄 i).fn f (λ x, v₁ x i)) ~[F] (λ i, (𝔄 i).fn f (λ x, v₂ x i)) :=
begin
  simp[uequiv] at*,
  have : {i | (λ x, v₁ x i) = (λ x, v₂ x i)} ⊆ {i | (𝔄 i).fn f (λ x, v₁ x i) = (𝔄 i).fn f (λ x, v₂ x i)},
  { intros i hi, simp* at* },
  exact F.sets_of_superset (equivs_mem F h) this
end

lemma pr_equiv : ∀ {n} {v₁ v₂ : finitary (Π i, 𝔄 i) n} (h : ∀ x, v₁ x ~[F] v₂ x) (p : L.pr n),
  {i | (𝔄 i).pr p (λ x, v₁ x i)} ∈ F ↔ {i | (𝔄 i).pr p (λ x, v₂ x i)} ∈ F :=
begin
  suffices : ∀ {n} {v₁ v₂ : finitary (Π i, 𝔄 i) n} (h : ∀ x, v₁ x ~[F] v₂ x) (p : L.pr n),
  {i | (𝔄 i).pr p (λ x, v₁ x i)} ∈ F → {i | (𝔄 i).pr p (λ x, v₂ x i)} ∈ F,
  { intros n v₁ v₂ eqn p, refine ⟨this eqn p, this (λ x, uequiv_symm _ (eqn x)) p⟩ },
  intros n v₁ v₂ eqn p h,
  have : {i | (𝔄 i).pr p (λ x, v₁ x i)} ∩ {i | (λ x, v₁ x i) = (λ x, v₂ x i)} ⊆ {i | (𝔄 i).pr p (λ x, v₂ x i)},
  { intros i hi, simp* at*, simp[←hi.2], exact hi.1 },
  refine F.sets_of_superset (F.inter_sets h (equivs_mem _ eqn)) this
end

def product_fn (k) (f : L.fn k) : finitary (Ult 𝔄 F) k → Ult 𝔄 F :=
λ v, fol.Ult.lift_on_finitary F v (λ v, (⟦λ i, (𝔄 i).fn f (λ x, v x i)⟧* : Ult 𝔄 F)) $ λ u₁ u₂ eqn,
by { simp, exact fn_equiv F eqn f }

def product_pr (n) (p : L.pr n) : finitary (Ult 𝔄 F) n → Prop :=
λ v, fol.Ult.lift_on_finitary F v (λ v, {i | (𝔄 i).pr p (λ x, v x i)} ∈ F) $ λ u₁ u₂ eqn,
by { simp, exact pr_equiv F eqn p }

@[reducible] def product (𝔄 : I → nonempty_Structure L) (F : ultrafilter I) : nonempty_Structure L :=
{ dom := Ult 𝔄 F,
  fn := product_fn F,
  pr := product_pr F,
  dom_inhabited := Ult.inhabited F }

variables {F}
open subformula

lemma Structure_fn_eq {n} (f : L.fn n) : (product 𝔄 F).fn f = product_fn F _ f := rfl

lemma Structure_pr_eq {n} (r : L.pr n) : (product 𝔄 F).pr r = product_pr F _ r := rfl

variables (Φ : Π i, μ → 𝔄 i) (e : Π i, fin n → 𝔄 i)

lemma val_subterm (t : subterm L μ n) :
  subterm.val (product 𝔄 F : Structure L) (λ x, ⟦λ i, Φ i x⟧*) (λ x, ⟦λ i, e i x⟧*) t = ⟦λ i, subterm.val (𝔄 i) (Φ i) (e i) t⟧* :=
by induction t; simp[Structure_fn_eq, product_fn, *]

private lemma concat_to_quo (u : Π i, 𝔄 i) :
  ((⟦u⟧* : Ult 𝔄 F) *> λ x, ⟦λ i, e i x⟧*) = λ x, ⟦λ i, (u i *> e i) x⟧* :=
by ext x; refine fin.cases _ _ x; simp

theorem subval_subformula : ∀ {n} (e : Π i, fin n → 𝔄 i) (p : subformula L μ n),
  subval (product 𝔄 F : Structure L) (λ x, ⟦λ i, Φ i x⟧*) (λ x, ⟦λ i, e i x⟧*) p ↔ {i | subval (𝔄 i : Structure L) (Φ i) (e i) p} ∈ F
| n e verum          := by simp[top_eq]; exact F.univ_sets
| n e (relation r v) := by simp[Structure_pr_eq, product_pr, val_subterm, (∘)]
| n e (imply p q)    :=
    by simp[imply_eq, subval_subformula _ p, subval_subformula _ q, decidable.imp_iff_not_or,
      ←ultrafilter.compl_mem_iff_not_mem]; exact ultrafilter.union_mem_iff.symm
| n e (neg p)        := by simp[neg_eq, subval_subformula _ p]; exact ultrafilter.compl_mem_iff_not_mem.symm
| n e (fal p)        :=
    begin
      simp[fal_eq],
      let e' := λ (u : Π i, 𝔄 i), (λ i, u i *> e i),
      calc (∀ u : product 𝔄 F, subval (product 𝔄 F : Structure L) (λ x, ⟦λ i, Φ i x⟧*) (u *> λ x, ⟦λ i, e i x⟧*) p)
          ↔ (∀ u : Π i, 𝔄 i, subval (product 𝔄 F : Structure L) (λ x, ⟦λ i, Φ i x⟧*) (λ x, ⟦λ i, e' u i x⟧*) p)
      : by { split,
             { intros h u, simpa[e', concat_to_quo] using h ⟦u⟧* },
             { intros h u, induction u using fol.Ult.ind_on, simpa[concat_to_quo] using h u } }
      ... ↔ ∀ u : Π i, 𝔄 i, {i | subval (𝔄 i : Structure L) (Φ i) (e' u i) p} ∈ F
      : by { exact forall_congr (λ u, subval_subformula (e' u) p) }
      ... ↔ {i : I | ∀ (x : 𝔄 i), subval (𝔄 i : Structure L) (Φ i) (x *> e i) p} ∈ F
      : by { simp[e'], split,
            { intros h,
              let u : Π i, 𝔄 i := λ i, classical.epsilon (λ u, ¬subval ↑(𝔄 i) (Φ i) (u *> e i) p),
              refine F.sets_of_superset (h u) _,
              { intros i, simp, intros hi, by_contradiction A, simp at A,
                have : ¬subval ↑(𝔄 i) (Φ i) (u i *> e i) p,
                from classical.epsilon_spec_aux _ _ A,
                contradiction } },
            { intros h u, refine filter.mem_of_superset h (by intros i hi; exact hi (u i)) } }
    end

-- Łoś's theorem
theorem fundamental_param (p : formula L μ) (Φ : ∀ i, μ → 𝔄 i) :
  val (product 𝔄 F : Structure L) (λ x, ⟦λ i, Φ i x⟧*) p ↔ {i | val (𝔄 i : Structure L) (Φ i) p} ∈ F :=
by have := @subval_subformula L _ _ _ F _ Φ _ (λ i, fin.nil) p; exact cast (by congr) this

theorem fundamental {σ : sentence L} :
  product 𝔄 F ⊧ σ ↔ {i | 𝔄 i ⊧ σ} ∈ F :=
by have := @fundamental_param L _ _ _ F 𝔄 σ (λ i, fin.nil); simp[nonempty_Structure.sentence_models_def];
   exact cast (by congr) this

end Ult
end fol

namespace fol
variables {L : language.{u}}

def finTheory (T : Theory L) := {s : finset (sentence L) // ↑s ⊆ T}

variables {T : Theory L}

def finTheory.empty {T : Theory L} : finTheory T := ⟨∅, by simp⟩
instance : inhabited (finTheory T) := ⟨⟨∅, by simp⟩⟩

noncomputable def finTheory.insert (P : finTheory T) {σ : sentence L} (h : σ ∈ T) : finTheory T :=
⟨insert σ P.val, λ x hx,  by { simp at hx, cases hx, simp[hx, h], refine P.property hx }⟩

@[simp] lemma finTheory.insert_val (P : finTheory T) {σ : sentence L} (h : σ ∈ T) :
  (P.insert h).val = insert σ P.val := rfl

instance : has_coe (finTheory T) (Theory L) := ⟨λ s, {p | p ∈ s.val}⟩

namespace compactness
open nonempty_Structure

variables (𝔄 : finTheory T → nonempty_Structure L)

def formdomain (p : sentence L) : set (finTheory T) := {i | 𝔄 i ⊧ p}

def F : set (set (finTheory T)) := {x | ∃ p, T p ∧ x = formdomain 𝔄 p}

private lemma finite_intersection_lmm (nonempty : ∃ p, T p) (H : ∀ (i : finTheory T) p, p ∈ i.val → 𝔄 i ⊧ p) :
  ∀ S : finset (set (finTheory T)), (↑S : set (set (finTheory T))) ⊆ F 𝔄 →
  ∃ P : finTheory T,
  (∀ p, p ∈ P.val → formdomain 𝔄 p ∈ S) ∧ (∀ S', S' ∈ S → ∃ p, p ∈ P.val ∧ S' = formdomain 𝔄 p) :=
begin
  intros S, induction S using finset.induction with i S i_fresh IH,
  { intros _, simp[set.nonempty], rcases nonempty with ⟨p₀, hyp_p₀⟩,
    refine ⟨⟨∅, by simp⟩, _⟩, unfold_coes, simp },
  { intros h, simp at*,
    have lmm₁ : ↑S ⊆ F 𝔄, from set.subset.trans (set.subset_insert _ _) h,
    have : ∃ (P : finTheory T),
      (∀ p, p ∈ ↑P → formdomain 𝔄 p ∈ S) ∧ (∀ S', S' ∈ S → ∃ p, p ∈ ↑P ∧ S' = formdomain 𝔄 p),
    from IH lmm₁, rcases this with ⟨P, IH₁, IH₂⟩,
    have : ∃ p, T p ∧ i = formdomain 𝔄 p, from h (set.mem_insert i ↑S),
    rcases this with ⟨p, hyp_p, rfl⟩,
    refine ⟨P.insert hyp_p, _, _, _⟩; unfold_coes; simp,
    { refine λ q hyp_q, or.inr (IH₁ _ hyp_q) },
    { refine ⟨p, or.inl rfl, rfl⟩ },
    { intros S' hyp_S',
      have : ∃ p, p ∈ ↑P ∧ S' = formdomain 𝔄 p, from IH₂ _ hyp_S', rcases this with ⟨p, hyp, rfl⟩,
      refine ⟨p, or.inr hyp, rfl⟩ } }
end

theorem finite_intersection (h : ∃ p, T p) (H : ∀ (i : finTheory T) p, p ∈ i.val → 𝔄 i ⊧ p) :
  ∀ S : finset (set (finTheory T)),
  (↑S : set (set (finTheory T))) ⊆ F 𝔄 → (⋂₀ (↑S : set (set (finTheory T)))).nonempty :=
begin
  intros S hS, have := finite_intersection_lmm _ h H S hS, rcases this with ⟨P, hyp⟩,
  refine ⟨P, λ S' hS', _⟩,
  have := hyp.2 S' hS', rcases this with ⟨p, hyp_p, rfl⟩, simp[formdomain] at*,
  refine H _ _ hyp_p
end

theorem ultrafilter_exists (h : ∃ p, p ∈ T) (H : ∀ (i : finTheory T) p, p ∈ i.val → 𝔄 i ⊧ p) :
  ∃ U : ultrafilter (finTheory T), F 𝔄 ⊆ U.to_filter.sets :=
ultrafilter.exists_ultrafilter_of_finite_inter_nonempty _ (finite_intersection _ h H)

theorem compact (T : Theory L) :
  Satisfiable T ↔ ∀ S : finset (sentence L), ↑S ⊆ T → Satisfiable (S : Theory L) :=
  ⟨by { intros H S hyp_S, rcases H with ⟨𝔄, hyp⟩,
        refine ⟨𝔄, λ p h, hyp (hyp_S h)⟩ },
   by { suffices : (∀ S : finTheory T, Satisfiable (↑S : Theory L)) → Satisfiable T,
        { intros h, refine this (λ S, _),
          rcases h S.val S.property with ⟨𝔄, hyp_𝔄⟩, refine ⟨𝔄, hyp_𝔄⟩ },
    intros H, by_cases C : T = ∅,
        { rcases C with rfl, refine ⟨default, by intros p; simp⟩ },
        { have ex : ∃ p, p ∈ T, { by_contra, simp at*, refine C _, { ext x, simp, refine h _ } },
          have : ∃ (𝔄 : finTheory T → nonempty_Structure L), ∀ (i : finTheory T) p, p ∈ i.val → 𝔄 i ⊧ p,
          from classical.skolem.mp H, rcases this with ⟨𝔄, hyp_𝔄⟩,
          have := @ultrafilter_exists _ _ 𝔄 ex hyp_𝔄, rcases this with ⟨U, hyp_U⟩,
          refine ⟨Ult.product 𝔄 U, _⟩, intros p hyp_p, rw Ult.fundamental,
          have : {i | 𝔄 i ⊧ p} ∈ F 𝔄, { refine ⟨p, hyp_p, rfl⟩ },
          exact hyp_U this } }⟩

end compactness

end fol