import data.matrix.pequiv data.rat.basic tactic.fin_cases data.list.min_max partition

open matrix fintype finset function pequiv

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

section
universes u v
variables {l m n o : Type u} [fintype l] [fintype m] [fintype n] [fintype o] {R : Type v}

/- Belongs in mathlib -/
lemma mul_right_eq_of_mul_eq [semiring R] {M : matrix l m R} {N : matrix m n R} {O : matrix l n R}
  {P : matrix n o R} (h : M ⬝ N = O) : M ⬝ (N ⬝ P) = O ⬝ P :=
by rw [← matrix.mul_assoc, h]

end

variables {m n : ℕ}

/-- The tableau consists of a matrix and a kant `const` column.
  `to_partition` stores the indices of the current row and column variables.
  `restricted` is the set of variables that are restricted to be nonnegative  -/
structure tableau (m n : ℕ) extends partition m n :=
(to_matrix  : matrix (fin m) (fin n) ℚ)
(const      : cvec m)
(restricted : finset (fin (m + n)))
(dead       : finset (fin n))

namespace tableau
open partition

section predicates
variable (T : tableau m n)

/-- The affine subspace represented by the tableau ignoring nonnegativity restrictiions -/
def flat : set (cvec (m + n)) :=
{ x | T.to_partition.rowp.to_matrixᵀ ⬝ x = T.to_matrix ⬝ T.to_partition.colp.to_matrixᵀ ⬝ x + T.const }

/-- The res_set is the subset of ℚ^(m+n) that satisifies the nonnegativity constraints of
  the tableau, and the affine conditions -/
def res_set : set (cvec (m + n)) := flat T ∩ { x | ∀ i, i ∈ T.restricted → 0 ≤ x i 0 }

/-- The dead_set is the subset of ℚ^(m+n) such that all dead variables are zero, and satisfies
  the affine conditions -/
def dead_set : set (cvec (m + n)) :=
flat T ∩ { x | ∀ j, j ∈ T.dead → x (T.to_partition.colg j) 0 = 0 }

/-- The `sol_set` is the set of vector that satisfy the affine constraints the dead variable
  constraints, and the nonnegativity constraints. -/
def sol_set : set (cvec (m + n)) :=
res_set T ∩ { x | ∀ j, j ∈ T.dead → x (T.to_partition.colg j) 0 = 0 }

lemma sol_set_eq_res_set_inter :
  T.sol_set = res_set T ∩ { x | ∀ j, j ∈ T.dead → x (T.to_partition.colg j) 0 = 0 } := rfl

lemma sol_set_eq_dead_set_inter :
   T.sol_set = dead_set T ∩ { x | ∀ i, i ∈ T.restricted → 0 ≤ x i 0 } :=
set.inter_right_comm _ _ _

lemma sol_set_eq_res_set_inter_dead_set : T.sol_set = T.res_set ∩ T.dead_set :=
by simp [sol_set, res_set, dead_set, set.ext_iff]; tauto

/-- Predicate for a variable being unbounded above in the `res_set` -/
def is_unbounded_above (i : fin (m + n)) : Prop :=
∀ q : ℚ, ∃ x : cvec (m + n), x ∈ sol_set T ∧ q ≤ x i 0

/-- Predicate for a variable being unbounded below in the `res_set` -/
def is_unbounded_below (i : fin (m + n)) : Prop :=
∀ q : ℚ, ∃ x : cvec (m + n), x ∈ sol_set T ∧ x i 0 ≤ q

def is_optimal (x : cvec (m + n)) (i : fin (m + n)) : Prop :=
x ∈ T.sol_set ∧ ∀ y : cvec (m + n), y ∈ sol_set T → y i 0 ≤ x i 0

/-- Is this equivalent to `∀ (x : cvec (m + n)), x ∈ res_set T → x i 0 = x j 0`? No -/
def equal_in_flat (i j : fin (m + n)) : Prop :=
∀ (x : cvec (m + n)), x ∈ flat T → x i 0 = x j 0

/-- Returns an element of the `flat` after assigning values to the column variables -/
def of_col (T : tableau m n) (x : cvec n) : cvec (m + n) :=
T.to_partition.colp.to_matrix ⬝ x + T.to_partition.rowp.to_matrix ⬝ (T.to_matrix ⬝ x + T.const)

/-- A `tableau` is feasible if its `const` column is nonnegative in restricted rows -/
def feasible : Prop :=
∀ i, T.to_partition.rowg i ∈ T.restricted → 0 ≤ T.const i 0

instance : decidable_pred (@feasible m n) := λ _, by dunfold feasible; apply_instance

/-- Given a row index `r` and a column index `s` it returns a tableau with `r` and `s` switched,
  but with the same `res_set` -/
def pivot (i : fin m) (j : fin n) : tableau m n :=
let p := (T.to_matrix i j)⁻¹ in
{ to_matrix := λ i' j',
    if i' = i
      then if j' = j
        then p
        else -T.to_matrix i' j' * p
      else if j' = j
        then T.to_matrix i' j * p
        else T.to_matrix i' j' - T.to_matrix i' j * T.to_matrix i j' * p,
  to_partition := T.to_partition.swap i j,
  const := λ i' k,
    if i' = i
      then -T.const i k * p
      else T.const i' k - T.to_matrix i' j * T.const i k * p,
  restricted := T.restricted,
  dead := T.dead }

def restrict (T : tableau m n) (v : fin (m + n)) : tableau m n :=
{ restricted := insert v T.restricted,
  ..T }

-- def kill_col (T : tableau m n) (j : fin n) : tableau m n :=
-- { dead := insert c T.dead,
--   ..T }

end predicates

section predicate_lemmas
variable {T : tableau m n}

@[simp] lemma eta : tableau.mk T.to_partition T.to_matrix T.const T.restricted T.dead = T :=
by cases T; refl

lemma mem_flat_iff {x : cvec (m + n)} : x ∈ T.flat ↔
  ∀ i, x (T.to_partition.rowg i) 0 = univ.sum
    (λ j : fin n, T.to_matrix i j * x (T.to_partition.colg j) 0) +
  T.const i 0 :=
have hx : x ∈ T.flat ↔ ∀ i, (T.to_partition.rowp.to_matrixᵀ ⬝ x) i 0 =
    (T.to_matrix ⬝ T.to_partition.colp.to_matrixᵀ ⬝ x + T.const) i 0,
  by rw [flat, set.mem_set_of_eq, matrix.ext_iff.symm, forall_swap,
      unique.forall_iff];
    refl,
begin
  rw hx,
  refine forall_congr (λ i, _),
  rw [← to_matrix_symm, mul_matrix_apply, add_val, rowp_symm_eq_some_rowg,
    matrix.mul_assoc, matrix.mul],
  conv in (T.to_matrix _ _ * (T.to_partition.colp.to_matrixᵀ ⬝ x) _ _)
  { rw [← to_matrix_symm, mul_matrix_apply, colp_symm_eq_some_colg] }
end

variable (T)

@[simp] lemma colp_mul_of_col (x : cvec n) :
  T.to_partition.colp.to_matrixᵀ ⬝ of_col T x = x :=
by simp [matrix.mul_assoc, matrix.mul_add, of_col, flat,
    mul_right_eq_of_mul_eq (rowp_transpose_mul_colp _),
    mul_right_eq_of_mul_eq (rowp_transpose_mul_rowp _),
    mul_right_eq_of_mul_eq (colp_transpose_mul_colp _),
    mul_right_eq_of_mul_eq (colp_transpose_mul_rowp _)]

@[simp] lemma rowp_mul_of_col (x : cvec n) :
  T.to_partition.rowp.to_matrixᵀ ⬝ of_col T x = T.to_matrix ⬝ x + T.const :=
by simp [matrix.mul_assoc, matrix.mul_add, of_col, flat,
    mul_right_eq_of_mul_eq (rowp_transpose_mul_colp _),
    mul_right_eq_of_mul_eq (rowp_transpose_mul_rowp _),
    mul_right_eq_of_mul_eq (colp_transpose_mul_colp _),
    mul_right_eq_of_mul_eq (colp_transpose_mul_rowp _)]

lemma of_col_mem_flat (x : cvec n) : T.of_col x ∈ T.flat :=
by simp [matrix.mul_assoc, matrix.mul_add, flat]

@[simp] lemma of_col_colg (x : cvec n) (j : fin n) :
  of_col T x (T.to_partition.colg j) = x j :=
funext $ λ v,
  calc of_col T x (T.to_partition.colg j) v =
      (T.to_partition.colp.to_matrixᵀ ⬝ of_col T x) j v :
    by rw [← to_matrix_symm, mul_matrix_apply, colp_symm_eq_some_colg]
  ... = x j v : by rw [colp_mul_of_col]

lemma of_col_rowg (c : cvec n) (i : fin m) :
  of_col T c (T.to_partition.rowg i) = (T.to_matrix ⬝ c + T.const) i :=
funext $ λ v,
  calc of_col T c (T.to_partition.rowg i) v =
      (T.to_partition.rowp.to_matrixᵀ ⬝ of_col T c) i v :
     by rw [← to_matrix_symm, mul_matrix_apply, rowp_symm_eq_some_rowg]
  ... = (T.to_matrix ⬝ c + T.const) i v : by rw [rowp_mul_of_col]

variable {T}

lemma of_col_single_rowg {q : ℚ} {i j} {k} :
  T.of_col (q • (single j 0).to_matrix) (T.to_partition.rowg i) k =
    q * T.to_matrix i j + T.const i k:=
begin
  fin_cases k,
  erw [of_col_rowg, matrix.mul_smul, matrix.add_val, matrix.smul_val,
    matrix_mul_apply, pequiv.symm_single_apply]
end

/-- Condition for the solution given by setting column index `j` to `q` and all other columns to
  zero being in the `res_set` -/
lemma of_col_single_mem_res_set {q : ℚ} {j : fin n} (hT : T.feasible)
  (hi : ∀ i, T.to_partition.rowg i ∈ T.restricted → 0 ≤ q * T.to_matrix i j)
  (hj : T.to_partition.colg j ∉ T.restricted ∨ 0 ≤ q) :
  T.of_col (q • (single j 0).to_matrix) ∈ T.res_set :=
⟨of_col_mem_flat _ _,
  λ v, (T.to_partition.eq_rowg_or_colg v).elim
    begin
      rintros ⟨i', hi'⟩ hres,
      subst hi',
      rw [of_col_single_rowg],
      exact add_nonneg (hi _ hres) (hT _ hres)
    end
    begin
      rintros ⟨j', hj'⟩ hres,
      subst hj',
      simp [of_col_colg, smul_val, pequiv.single, pequiv.to_matrix],
      by_cases hjc : j' = j; simp [*, le_refl] at *
    end⟩

lemma of_col_single_mem_sol_set {q : ℚ} {j : fin n} (hT : T.feasible)
  (hi : ∀ i, T.to_partition.rowg i ∈ T.restricted → 0 ≤ q * T.to_matrix i j)
  (hj : T.to_partition.colg j ∉ T.restricted ∨ 0 ≤ q) (hdead : j ∉ T.dead ∨ q = 0):
  T.of_col (q • (single j 0).to_matrix) ∈ T.sol_set :=
⟨of_col_single_mem_res_set hT hi hj,
  λ j' hj', classical.by_cases
    (λ hjj' : j' = j, by subst hjj'; simp * at *)
    (λ hjj' : j' ≠ j, by simp [smul_val, pequiv.single, pequiv.to_matrix, hjj'])⟩

@[simp] lemma of_col_zero_mem_res_set_iff : T.of_col 0 ∈ T.res_set ↔ T.feasible :=
suffices (∀ v : fin (m + n), v ∈ T.restricted → (0 : ℚ) ≤ T.of_col 0 v 0) ↔
    (∀ i : fin m, T.to_partition.rowg i ∈ T.restricted → 0 ≤ T.const i 0),
  by simpa [res_set, feasible, of_col_mem_flat],
⟨λ h i hi, by simpa [of_col_rowg] using h _ hi,
  λ h v hv, (T.to_partition.eq_rowg_or_colg v).elim
    (by rintros ⟨i, hi⟩; subst hi; simp [of_col_rowg]; tauto)
    (by rintros ⟨j, hj⟩; subst hj; simp)⟩

@[simp] lemma of_col_zero_mem_sol_set_iff : T.of_col 0 ∈ T.sol_set ↔ T.feasible :=
by simp [sol_set,  of_col_zero_mem_res_set_iff]

@[simp] lemma to_matrix_restrict (v : fin (m + n)) : (T.restrict v).to_matrix = T.to_matrix := rfl

@[simp] lemma const_restrict (v : fin (m + n)) : (T.restrict v).const = T.const := rfl

@[simp] lemma to_partition_restrict (v : fin (m + n)) :
  (T.restrict v).to_partition = T.to_partition := rfl

@[simp] lemma dead_restrict (v : fin (m + n)) : (T.restrict v).dead = T.dead := rfl

@[simp] lemma restricted_restrict (v : fin (m + n)) :
  (T.restrict v).restricted = insert v T.restricted := rfl

@[simp] lemma flat_restrict (v : fin (m + n)) : (T.restrict v).flat = T.flat := by simp [flat]

@[simp] lemma dead_set_restrict (v : fin (m + n)) : (T.restrict v).dead_set = T.dead_set :=
by simp [dead_set]

lemma res_set_restrict (v : fin (m + n)) : (T.restrict v).res_set =
  T.res_set ∩ {x | 0 ≤ x v 0} :=
begin
  simp only [res_set, flat_restrict, set.inter_assoc],
  ext x,
  exact ⟨λ h, ⟨h.1, λ i hi, h.2 _ $ by simp [hi], h.2 _ $ by simp⟩,
    λ h, ⟨h.1, λ i hi, (mem_insert.1 hi).elim (λ hv, hv.symm ▸ h.2.2) $ h.2.1 _⟩⟩
end

lemma sol_set_restrict (v : fin (m + n)) : (T.restrict v).sol_set =
  T.sol_set ∩ {x | 0 ≤ x v 0} :=
by simp [sol_set_eq_res_set_inter_dead_set, res_set_restrict, set.inter_comm, set.inter_assoc,
  set.inter_left_comm]

lemma feasible_restrict {v : fin (m + n)} (hfT : T.feasible)
  (h : (∃ c, v = T.to_partition.colg c) ∨ ∃ i, v = T.to_partition.rowg i ∧ 0 ≤ T.const i 0) :
  (T.restrict v).feasible :=
h.elim
  (λ ⟨c, hc⟩, hc.symm ▸ λ i hi, hfT _ $ by simpa using hi)
  (λ ⟨i, hiv, hi⟩, hiv.symm ▸ λ i' hi', (mem_insert.1 hi').elim
    (λ h, by simp [T.to_partition.injective_rowg.eq_iff, *] at *)
    (λ hres, hfT _ $ by simpa using hres))

lemma is_unbounded_above_colg_aux {j : fin n} (hT : T.feasible) (hdead : j ∉ T.dead)
  (h : ∀ i : fin m, T.to_partition.rowg i ∈ T.restricted → 0 ≤ T.to_matrix i j) (q : ℚ) :
  of_col T (max q 0 • (single j 0).to_matrix) ∈ sol_set T ∧
    q ≤ of_col T (max q 0 • (single j 0).to_matrix) (T.to_partition.colg j) 0 :=
⟨of_col_single_mem_sol_set hT (λ i hi, mul_nonneg (le_max_right _ _) (h _ hi))
    (or.inr (le_max_right _ _)) (or.inl hdead),
  by simp [of_col_colg, smul_val, pequiv.single, pequiv.to_matrix, le_refl q]⟩

/-- A column variable is unbounded above if it is in a column where every negative entry is
  in a row owned by an unrestricted variable -/
lemma is_unbounded_above_colg {j : fin n} (hT : T.feasible) (hdead : j ∉ T.dead)
  (h : ∀ i : fin m, T.to_partition.rowg i ∈ T.restricted → 0 ≤ T.to_matrix i j) :
  T.is_unbounded_above (T.to_partition.colg j) :=
λ q, ⟨_, is_unbounded_above_colg_aux hT hdead h q⟩

lemma is_unbounded_below_colg_aux {j : fin n} (hT : T.feasible)
  (hres : T.to_partition.colg j ∉ T.restricted) (hdead : j ∉ T.dead)
  (h : ∀ i : fin m, T.to_partition.rowg i ∈ T.restricted → T.to_matrix i j ≤ 0) (q : ℚ) :
  of_col T (min q 0 • (single j 0).to_matrix) ∈ sol_set T ∧
    of_col T (min q 0 • (single j 0).to_matrix) (T.to_partition.colg j) 0 ≤ q :=
⟨of_col_single_mem_sol_set hT
    (λ i hi, mul_nonneg_of_nonpos_of_nonpos (min_le_right _ _) (h _ hi))
    (or.inl hres) (or.inl hdead),
  by simp [of_col_colg, smul_val, pequiv.single, pequiv.to_matrix, le_refl q]⟩

/-- A column variable is unbounded below if it is unrestricted and it is in a column where every
  positive entry is in a row owned by an unrestricted variable -/
lemma is_unbounded_below_colg {j : fin n} (hT : T.feasible)
  (hres : T.to_partition.colg j ∉ T.restricted) (hdead : j ∉ T.dead)
  (h : ∀ i : fin m, T.to_partition.rowg i ∈ T.restricted → T.to_matrix i j ≤ 0) :
  T.is_unbounded_below (T.to_partition.colg j) :=
λ q, ⟨_, is_unbounded_below_colg_aux hT hres hdead h q⟩

/-- A row variable `r` is unbounded above if it is unrestricted and there is a column `s`
  where every restricted row variable has a nonpositive entry in that column, and
  `r` has a negative entry in that column. -/
lemma is_unbounded_above_rowg_of_nonpos {i : fin m} (hT : T.feasible) (j : fin n)
  (hres : T.to_partition.colg j ∉ T.restricted) (hdead : j ∉ T.dead)
  (h : ∀ i : fin m, T.to_partition.rowg i ∈ T.restricted → T.to_matrix i j ≤ 0)
  (his : T.to_matrix i j < 0) : is_unbounded_above T (T.to_partition.rowg i) :=
λ q, ⟨T.of_col (min ((q - T.const i 0) / T.to_matrix i j) 0 • (single j 0).to_matrix),
  of_col_single_mem_sol_set hT
    (λ i' hi', mul_nonneg_of_nonpos_of_nonpos (min_le_right _ _) (h _ hi'))
    (or.inl hres) (or.inl hdead),
  begin
    rw [of_col_rowg, add_val, matrix.mul_smul, smul_val, matrix_mul_apply,
      symm_single_apply],
    cases le_total 0 ((q - T.const i 0) / T.to_matrix i j) with hq hq,
    { rw [min_eq_right hq],
      rw [le_div_iff_of_neg his, zero_mul, sub_nonpos] at hq,
      simpa },
    { rw [min_eq_left hq, div_mul_cancel _ (ne_of_lt his)],
      simp }
  end⟩

/-- A row variable `i` is unbounded above if there is a column `s`
  where every restricted row variable has a nonpositive entry in that column, and
  `i` has a positive entry in that column. -/
lemma is_unbounded_above_rowg_of_nonneg {i : fin m} (hT : T.feasible) (j : fin n)
  (hs : ∀ i' : fin m, T.to_partition.rowg i' ∈ T.restricted → 0 ≤ T.to_matrix i' j) (hdead : j ∉ T.dead)
  (his : 0 < T.to_matrix i j) : is_unbounded_above T (T.to_partition.rowg i) :=
λ q, ⟨T.of_col (max ((q - T.const i 0) / T.to_matrix i j) 0 • (single j 0).to_matrix),
  of_col_single_mem_sol_set hT
    (λ i hi, mul_nonneg (le_max_right _ _) (hs i hi))
    (or.inr (le_max_right _ _)) (or.inl hdead),
  begin
    rw [of_col_rowg, add_val, matrix.mul_smul, smul_val, matrix_mul_apply,
      symm_single_apply],
    cases le_total ((q - T.const i 0) / T.to_matrix i j) 0 with hq hq,
    { rw [max_eq_right hq],
      rw [div_le_iff his, zero_mul, sub_nonpos] at hq,
      simpa },
    { rw [max_eq_left hq, div_mul_cancel _ (ne_of_gt his)],
      simp }
  end⟩

/-- The sample solution of a feasible tableau maximises the variable in row `r`,
  if every entry in that row is nonpositive and every entry in that row owned by a restricted
  variable is `0`  -/
lemma is_optimal_of_col_zero {obj : fin m} (hf : T.feasible)
  (h : ∀ j, j ∉ T.dead → T.to_matrix obj j ≤ 0 ∧
    (T.to_partition.colg j ∉ T.restricted → T.to_matrix obj j = 0)) :
  T.is_optimal (T.of_col 0) (T.to_partition.rowg obj) :=
⟨of_col_zero_mem_sol_set_iff.2 hf, λ x hx, begin
  rw [of_col_rowg, matrix.mul_zero, zero_add, mem_flat_iff.1 hx.1.1],
  refine add_le_of_nonpos_of_le _ (le_refl _),
  refine sum_nonpos (λ j _, _),
  by_cases hj : (T.to_partition.colg j) ∈ T.restricted,
  { by_cases hdead : j ∈ T.dead,
    { simp [hx.2 _ hdead] },
    { exact mul_nonpos_of_nonpos_of_nonneg (h _ hdead).1 (hx.1.2 _ hj) } },
  { by_cases hdead : j ∈ T.dead,
    { simp [hx.2 _ hdead] },
    { rw [(h _ hdead).2 hj, zero_mul] } }
end⟩

lemma not_optimal_of_unbounded_above {v : fin (m + n)} {x : cvec (m + n)}
  (hu : is_unbounded_above T v) : ¬is_optimal T x v :=
λ hm, let ⟨y, hy⟩ := hu (x v 0 + 1) in
  not_le_of_gt (lt_add_one (x v 0)) (le_trans hy.2 (hm.2 y hy.1))

/-- Expression for the sum of all but one entries in the a row of a tableau. -/
lemma row_sum_erase_eq {x : cvec (m + n)} (hx : x ∈ T.flat) {i : fin m} {j : fin n} :
  (univ.erase j).sum (λ j' : fin n, T.to_matrix i j' * x (T.to_partition.colg j') 0) =
    x (T.to_partition.rowg i) 0 - T.const i 0 - T.to_matrix i j * x (T.to_partition.colg j) 0 :=
begin
  rw [mem_flat_iff] at hx,
  conv_rhs { rw [hx i, ← insert_erase (mem_univ j), sum_insert (not_mem_erase _ _)] },
  simp
end

/-- An expression for a column variable in terms of row variables. -/
lemma colg_eq {x : cvec (m + n)} (hx : x ∈ T.flat) {i : fin m} {j : fin n}
  (his : T.to_matrix i j ≠ 0) : x (T.to_partition.colg j) 0 =
    (x (T.to_partition.rowg i) 0
    -(univ.erase j).sum (λ j' : fin n, T.to_matrix i j' * x (T.to_partition.colg j') 0)
        - T.const i 0) * (T.to_matrix i j)⁻¹ :=
by simp [row_sum_erase_eq hx, mul_left_comm (T.to_matrix i j)⁻¹, mul_assoc,
    mul_left_comm (T.to_matrix i j), mul_inv_cancel his]

/-- Another expression for a column variable in terms of row variables. -/
lemma colg_eq' {x : cvec (m + n)} (hx : x ∈ T.flat) {i : fin m} {j : fin n}
  (his : T.to_matrix i j ≠ 0) : x (T.to_partition.colg j) 0 =
  univ.sum (λ j' : fin n, (if j' = j then (T.to_matrix i j)⁻¹
    else (-(T.to_matrix i j' * (T.to_matrix i j)⁻¹))) *
      x (colg (swap (T.to_partition) i j) j') 0) -
  (T.const i 0) * (T.to_matrix i j)⁻¹ :=
have (univ.erase j).sum
    (λ j' : fin n, ite (j' = j) (T.to_matrix i j)⁻¹ (-(T.to_matrix i j' * (T.to_matrix i j)⁻¹)) *
      x (colg (swap (T.to_partition) i j) j') 0) =
    (univ.erase j).sum (λ j' : fin n,
      -T.to_matrix i j' * x (T.to_partition.colg j') 0 * (T.to_matrix i j)⁻¹),
  from finset.sum_congr rfl $ λ j' hj',
    by simp [if_neg (mem_erase.1 hj').1, colg_swap_of_ne _ (mem_erase.1 hj').1,
      mul_comm, mul_assoc, mul_left_comm],
by rw [← finset.insert_erase (mem_univ j), finset.sum_insert (not_mem_erase _ _),
    if_pos rfl, colg_swap, colg_eq hx his, this, ← finset.sum_mul];
  simp [_root_.add_mul, mul_comm, _root_.mul_add]

/-- Pivoting twice in the same place does nothing -/
@[simp] lemma pivot_pivot {i : fin m} {j : fin n} (his : T.to_matrix i j ≠ 0) :
  (T.pivot i j).pivot i j = T :=
begin
  cases T,
  simp [pivot, function.funext_iff],
  split; intros; split_ifs;
  simp [*, mul_assoc, mul_left_comm (T_to_matrix i j), mul_left_comm (T_to_matrix i j)⁻¹,
    mul_comm (T_to_matrix i j), inv_mul_cancel his]
end

/- These two sets are equal_in_flat, the stronger lemma is `flat_pivot` -/
private lemma subset_flat_pivot {i : fin m} {j : fin n} (h : T.to_matrix i j ≠ 0) :
  T.flat ⊆ (T.pivot i j).flat :=
λ x hx,
have ∀ i' : fin m, (univ.erase j).sum (λ j' : fin n,
  ite (j' = j) (T.to_matrix i' j * (T.to_matrix i j)⁻¹)
    (T.to_matrix i' j' + -(T.to_matrix i' j * T.to_matrix i j' * (T.to_matrix i j)⁻¹))
      * x ((T.to_partition.swap i j).colg j') 0) =
  (univ.erase j).sum (λ j' : fin n, T.to_matrix i' j' * x (T.to_partition.colg j') 0 -
    T.to_matrix i j' *
      x (T.to_partition.colg j') 0 * T.to_matrix i' j * (T.to_matrix i j)⁻¹),
  from λ i', finset.sum_congr rfl (λ j' hj',
    by rw [if_neg (mem_erase.1 hj').1, colg_swap_of_ne _ (mem_erase.1 hj').1];
      simp [mul_add, add_mul, mul_comm, mul_assoc, mul_left_comm]),
begin
  rw mem_flat_iff,
  assume i',
  by_cases hi'i : i' = i,
  { rw eq_comm at hi'i,
    subst hi'i,
    dsimp [pivot],
    simp [mul_inv_cancel h, neg_mul_eq_neg_mul_symm, if_true,
      add_comm, mul_inv_cancel, rowg_swap, eq_self_iff_true, colg_eq' hx h],
    congr, funext, congr },
  { dsimp [pivot],
    simp only [if_neg hi'i],
    rw [← insert_erase (mem_univ j), sum_insert (not_mem_erase _ _),
      if_pos rfl, colg_swap, this, sum_sub_distrib, ← sum_mul, ← sum_mul,
      row_sum_erase_eq hx, rowg_swap_of_ne _ hi'i],
    simp [row_sum_erase_eq hx, mul_add, add_mul,
      mul_comm, mul_left_comm, mul_assoc],
    simp [mul_assoc, mul_left_comm (T.to_matrix i j), mul_left_comm (T.to_matrix i j)⁻¹,
      mul_comm (T.to_matrix i j), inv_mul_cancel h] }
end

variable (T)

@[simp] lemma pivot_pivot_element (i : fin m) (j : fin n) :
  (T.pivot i j).to_matrix i j = (T.to_matrix i j)⁻¹ :=
by simp [pivot, if_pos rfl]

@[simp] lemma pivot_pivot_row {i : fin m} {j j' : fin n} (h : j' ≠ j) :
  (T.pivot i j).to_matrix i j' = -T.to_matrix i j' / T.to_matrix i j :=
by dsimp [pivot]; rw [if_pos rfl, if_neg h, div_eq_mul_inv]

@[simp] lemma pivot_pivot_column {i' i : fin m} {j : fin n} (h : i' ≠ i) :
  (T.pivot i j).to_matrix i' j = T.to_matrix i' j / T.to_matrix i j :=
by dsimp [pivot]; rw [if_neg h, if_pos rfl, div_eq_mul_inv]

@[simp] lemma pivot_of_ne_of_ne {i i' : fin m} {j j' : fin n} (hi'i : i' ≠ i)
  (hjs : j' ≠ j) : (T.pivot i j).to_matrix i' j' =
  T.to_matrix i' j' - T.to_matrix i' j * T.to_matrix i j' / T.to_matrix i j :=
by dsimp [pivot]; rw [if_neg hi'i, if_neg hjs, div_eq_mul_inv]

@[simp] lemma const_pivot_row {i : fin m} {j : fin n} : (T.pivot i j).const i 0 =
  -T.const i 0 / T.to_matrix i j :=
by simp [pivot, if_pos rfl, div_eq_mul_inv]

@[simp] lemma const_pivot_of_ne {i i' : fin m} {j : fin n} (hi'i : i' ≠ i) : (T.pivot i j).const i' 0
  = T.const i' 0 - T.to_matrix i' j * T.const i 0 / T.to_matrix i j :=
by dsimp [pivot]; rw [if_neg hi'i, div_eq_mul_inv]

@[simp] lemma restricted_pivot (i s) : (T.pivot i s).restricted = T.restricted := rfl

@[simp] lemma to_partition_pivot (i s) : (T.pivot i s).to_partition = T.to_partition.swap i s := rfl

@[simp] lemma dead_pivot (i c) : (T.pivot i c).dead = T.dead := rfl

variable {T}

@[simp] lemma flat_pivot {i : fin m} {j : fin n} (hij : T.to_matrix i j ≠ 0) :
  (T.pivot i j).flat = T.flat :=
set.subset.antisymm
  (by conv_rhs { rw ← pivot_pivot hij };
    exact subset_flat_pivot (by simp [hij]))
  (subset_flat_pivot hij)

@[simp] lemma res_set_pivot {i : fin m} {j : fin n} (hij : T.to_matrix i j ≠ 0) :
  (T.pivot i j).res_set = T.res_set :=
by rw [res_set, flat_pivot hij]; refl

@[simp] lemma dead_set_pivot {i : fin m} {j : fin n} (hij : T.to_matrix i j ≠ 0)
  (hdead : j ∉ T.dead) : (T.pivot i j).dead_set = T.dead_set :=
begin
  rw [dead_set, dead_set, flat_pivot hij],
  congr,
  funext x,
  refine forall_congr_eq (λ j', forall_congr_eq (λ hj', _)),
  have hjj' : j' ≠ j, from λ hjj', by simp * at *,
  simp [colg_swap_of_ne _ hjj']
end

@[simp] lemma sol_set_pivot {i : fin m} {j : fin n} (hij : T.to_matrix i j ≠ 0)
  (hdead : j ∉ T.dead) : (T.pivot i j).sol_set = T.sol_set :=
by simp [sol_set_eq_dead_set_inter, dead_set_pivot hij hdead, flat_pivot hij]

/-- Two row variables are `equal_in_flat` iff the corresponding rows of the tableau are equal -/
lemma equal_in_flat_row_row {i i' : fin m} :
  T.equal_in_flat (T.to_partition.rowg i) (T.to_partition.rowg i')
  ↔ (T.const i 0 = T.const i' 0 ∧ ∀ j : fin n, T.to_matrix i j = T.to_matrix i' j) :=
⟨λ h, have Hconst : T.const i 0 = T.const i' 0,
    by simpa [of_col_rowg] using h (T.of_col 0) (of_col_mem_flat _ _),
  ⟨Hconst,
    λ j, begin
      have := h (T.of_col (single j (0 : fin 1)).to_matrix) (of_col_mem_flat _ _),
      rwa [of_col_rowg, of_col_rowg, add_val, add_val, matrix_mul_apply, matrix_mul_apply,
        symm_single_apply, Hconst, add_right_cancel_iff] at this,
    end⟩,
λ h x hx, by simp [mem_flat_iff.1 hx, h.1, h.2]⟩

/-- A row variable is equal_in_flat to a column variable iff its row has zeros, and a single
  one in that column. -/
lemma equal_in_flat_row_col {i : fin m} {j : fin n} :
  T.equal_in_flat (T.to_partition.rowg i) (T.to_partition.colg j)
  ↔ (∀ j', j' ≠ j → T.to_matrix i j' = 0) ∧ T.const i 0 = 0 ∧ T.to_matrix i j = 1 :=
⟨λ h, have Hconst : T.const i 0 = 0,
    by simpa [of_col_rowg] using h (T.of_col 0) (of_col_mem_flat _ _),
  ⟨assume j' hj', begin
      have := h (T.of_col (single j' (0 : fin 1)).to_matrix) (of_col_mem_flat _ _),
      rwa [of_col_rowg, of_col_colg, add_val, Hconst, add_zero, matrix_mul_apply,
        symm_single_apply, pequiv.to_matrix, single_apply_of_ne hj',
        if_neg (option.not_mem_none _)] at this
    end,
  Hconst,
  begin
    have := h (T.of_col (single j (0 : fin 1)).to_matrix) (of_col_mem_flat _ _),
    rwa [of_col_rowg, of_col_colg, add_val, Hconst, add_zero, matrix_mul_apply,
        symm_single_apply, pequiv.to_matrix, single_apply] at this
  end⟩,
by rintros ⟨h₁, h₂, h₃⟩ x hx;
  rw [mem_flat_iff.1 hx, h₂, sum_eq_single j]; simp *; tauto⟩

lemma mul_single_ext {R : Type*} {m n : ℕ} [semiring R]
  {A B : matrix (fin m) (fin n) R} (h : ∀ j : fin n, A ⬝ (single j (0 : fin 1)).to_matrix = B ⬝
    (single j (0 : fin 1)).to_matrix) : A = B :=
by ext i j; simpa [matrix_mul_apply] using congr_fun (congr_fun (h j) i) 0

lemma single_mul_ext {R : Type*} {m n : ℕ} [semiring R]
  {A B : matrix (fin m) (fin n) R} (h : ∀ i, (single (0 : fin 1) i).to_matrix ⬝ A =
    (single (0 : fin 1) i).to_matrix ⬝ B) : A = B :=
by ext i j; simpa [mul_matrix_apply] using congr_fun (congr_fun (h i) 0) j

lemma ext {T₁ T₂ : tableau m n} (hflat : T₁.flat = T₂.flat)
  (hpartition : T₁.to_partition = T₂.to_partition)
  (hdead : T₁.dead = T₂.dead)
  (hres : T₁.restricted = T₂.restricted) : T₁ = T₂ :=
have hconst : T₁.const = T₂.const,
  by rw [set.ext_iff] at hflat; simpa [of_col, flat, hpartition, matrix.mul_assoc,
    mul_right_eq_of_mul_eq (rowp_transpose_mul_rowp _),
    mul_right_eq_of_mul_eq (colp_transpose_mul_rowp _)] using
  (hflat (T₁.of_col 0)).1 (of_col_mem_flat _ _),
have hmatrix : T₁.to_matrix = T₂.to_matrix,
  from mul_single_ext $ λ j, begin
    rw [set.ext_iff] at hflat,
    have := (hflat (T₁.of_col (single j 0).to_matrix)).1 (of_col_mem_flat _ _),
    simpa [of_col, hconst, hpartition, flat, matrix.mul_add, matrix.mul_assoc,
        mul_right_eq_of_mul_eq (rowp_transpose_mul_colp _),
        mul_right_eq_of_mul_eq (rowp_transpose_mul_rowp _),
        mul_right_eq_of_mul_eq (colp_transpose_mul_colp _),
        mul_right_eq_of_mul_eq (colp_transpose_mul_rowp _)] using
      (hflat (T₁.of_col (single j 0).to_matrix)).1 (of_col_mem_flat _ _)
  end,
by cases T₁; cases T₂; simp * at *

end predicate_lemmas

/-- Conditions for unboundedness based on reading the tableau. The conditions are equivalent to the
  simplex pivot rule failing to find a pivot row. -/
lemma unbounded_of_tableau {T : tableau m n} {obj : fin m} {j : fin n} (hT : T.feasible)
  (hdead : j ∉ T.dead)
  (hrow : ∀ i, obj ≠ i → T.to_partition.rowg i ∈ T.restricted →
    0 ≤ T.to_matrix obj j / T.to_matrix i j)
  (hc : (T.to_matrix obj j ≠ 0 ∧ T.to_partition.colg j ∉ T.restricted)
    ∨ (0 < T.to_matrix obj j ∧ T.to_partition.colg j ∈ T.restricted)) :
  T.is_unbounded_above (T.to_partition.rowg obj) :=
have hToj : T.to_matrix obj j ≠ 0, from λ h, by simpa [h, lt_irrefl] using hc,
(lt_or_gt_of_ne hToj).elim
  (λ hToj : T.to_matrix obj j < 0, is_unbounded_above_rowg_of_nonpos hT j
    (hc.elim and.right (λ h, (not_lt_of_gt hToj h.1).elim)) hdead
    (λ i hi, classical.by_cases
      (λ hoi : obj = i, le_of_lt (hoi ▸ hToj))
      (λ hoi : obj ≠ i, inv_nonpos.1 $ nonpos_of_mul_nonneg_right (hrow _ hoi hi) hToj))
    hToj)
  (λ hToj : 0 < T.to_matrix obj j, is_unbounded_above_rowg_of_nonneg hT j
    (λ i hi, classical.by_cases
      (λ hoi : obj = i, le_of_lt (hoi ▸ hToj))
      (λ hoi : obj ≠ i, inv_nonneg.1 $ nonneg_of_mul_nonneg_left (hrow _ hoi hi) hToj))
    hdead hToj)

/-- Conditions for the tableau being feasible, that must be satisified by a simplex pivot rule -/
lemma feasible_pivot {T : tableau m n} (hT : T.feasible) {i j}
  (hres : T.to_partition.rowg i ∈ T.restricted)
  (hpos : T.to_partition.colg j ∈ T.restricted → T.to_matrix i j < 0)
  (himin : ∀ (i' : fin m), T.to_partition.rowg i' ∈ T.restricted →
    0 < T.to_matrix i' j / T.to_matrix i j →
    abs (T.const i 0 / T.to_matrix i j) ≤ abs (T.const i' 0 / T.to_matrix i' j)) :
  (T.pivot i j).feasible :=
begin
  assume i' hi',
  dsimp only [pivot],
  by_cases hii : i' = i,
  { subst i',
    rw [if_pos rfl, neg_mul_eq_neg_mul_symm, neg_nonneg],
    exact mul_nonpos_of_nonneg_of_nonpos (hT _ hres) (inv_nonpos.2 $ le_of_lt (by simp * at *)) },
  { rw if_neg hii,
    rw [to_partition_pivot, rowg_swap_of_ne _ hii, restricted_pivot] at hi',
    by_cases hTii : 0 < T.to_matrix i' j / T.to_matrix i j,
    { have hTi'c0 : T.to_matrix i' j ≠ 0, from λ h, by simpa [h, lt_irrefl] using hTii,
      have hTic0 : T.to_matrix i j ≠ 0, from λ h, by simpa [h, lt_irrefl] using hTii,
      have := himin _ hi' hTii,
      rwa [abs_div, abs_div, abs_of_nonneg (hT _ hres), abs_of_nonneg (hT _ hi'),
        le_div_iff (abs_pos_iff.2 hTi'c0), div_eq_mul_inv, mul_right_comm, ← abs_inv, mul_assoc,
        ← abs_mul, ← div_eq_mul_inv, abs_of_nonneg (le_of_lt hTii), ← sub_nonneg,
        ← mul_div_assoc, div_eq_mul_inv, mul_comm (T.const i 0)] at this },
    { refine add_nonneg (hT _ hi') (neg_nonneg.2 _),
      rw [mul_assoc, mul_left_comm],
      exact mul_nonpos_of_nonneg_of_nonpos (hT _ hres) (le_of_not_gt hTii) } }
end

lemma feasible_simplex_pivot {T : tableau m n} {obj : fin m} (hT : T.feasible) {i j}
  (hres : T.to_partition.rowg i ∈ T.restricted)
  (hineg : T.to_matrix obj j / T.to_matrix i j < 0)
  (himin : ∀ (i' : fin m), obj ≠ i' → T.to_partition.rowg i' ∈ T.restricted →
          T.to_matrix obj j / T.to_matrix i' j < 0 →
          abs (T.const i 0 / T.to_matrix i j) ≤ abs (T.const i' 0 / T.to_matrix i' j))
  (hc : T.to_partition.colg j ∈ T.restricted → 0 < T.to_matrix obj j) :
  (T.pivot i j).feasible :=
feasible_pivot hT hres (λ hcres, inv_neg'.1 (neg_of_mul_neg_left hineg (le_of_lt (hc hcres))))
  (λ i' hi'res hii,
    have hobji : obj ≠ i',
      from λ hobji, not_lt_of_gt hii (hobji ▸ hineg),
    (himin _ hobji hi'res $
      have hTrc0 : T.to_matrix i j ≠ 0, from λ _, by simp [*, lt_irrefl] at *,
      suffices (T.to_matrix obj j / T.to_matrix i j) / (T.to_matrix i' j / T.to_matrix i j) < 0,
        by rwa [div_div_div_cancel_right _ _ hTrc0] at this,
      div_neg_of_neg_of_pos hineg hii))

/-- Used in sign_of_max -/
lemma feasible_pivot_obj_of_nonpos {T : tableau m n} {obj : fin m} (hT : T.feasible) {j}
  (hc : T.to_partition.colg j ∈ T.restricted → 0 < T.to_matrix obj j)
  (hr : ∀ i, obj ≠ i → T.to_partition.rowg i ∈ T.restricted →
    0 ≤ T.to_matrix obj j / T.to_matrix i j)
  (hobj : T.const obj 0 ≤ 0) : feasible (T.pivot obj j) :=
λ i hi,
if hiobj : i = obj
then by rw [hiobj, const_pivot_row, neg_div, neg_nonneg];
  exact mul_nonpos_of_nonpos_of_nonneg hobj (le_of_lt $ by simp [*, inv_pos'] at *)
else begin
  rw [const_pivot_of_ne _ hiobj],
  rw [to_partition_pivot, rowg_swap_of_ne _ hiobj, restricted_pivot] at hi,
  refine add_nonneg (hT _ hi) (neg_nonneg.2 _),
  rw [div_eq_mul_inv, mul_right_comm],
  exact mul_nonpos_of_nonneg_of_nonpos
    (inv_nonneg.1 (by simpa [mul_inv'] using hr _ (ne.symm hiobj) hi))
    hobj
end

lemma simplex_const_obj_le {T : tableau m n} {obj : fin m} (hT : T.feasible) {i j}
  (hres : T.to_partition.rowg i ∈ T.restricted)
  (hineg : T.to_matrix obj j / T.to_matrix i j < 0) :
  T.const obj 0 ≤ (T.pivot i j).const obj 0 :=
have obj ≠ i, from λ hor, begin
  subst hor,
  by_cases h0 : T.to_matrix obj j = 0,
  { simp [lt_irrefl, *] at * },
  { simp [div_self h0, not_lt_of_le zero_le_one, *] at * }
end,
by simp only [le_add_iff_nonneg_right, sub_eq_add_neg, neg_nonneg, mul_assoc, div_eq_mul_inv,
    mul_left_comm (T.to_matrix obj j), const_pivot_of_ne _ this];
  exact mul_nonpos_of_nonneg_of_nonpos (hT _ hres) (le_of_lt hineg)

lemma const_eq_zero_of_const_obj_eq {T : tableau m n} {obj : fin m} (hT : T.feasible) {i j}
  (hc : T.to_matrix obj j ≠ 0) (hrc : T.to_matrix i j ≠ 0) (hobjr : obj ≠ i)
  (hobj : (T.pivot i j).const obj 0 = T.const obj 0) :
  T.const i 0 = 0 :=
by rw [const_pivot_of_ne _ hobjr, sub_eq_iff_eq_add, ← sub_eq_iff_eq_add', sub_self,
    eq_comm, div_eq_mul_inv, mul_eq_zero, mul_eq_zero, inv_eq_zero] at hobj; tauto

end tableau


/-
Copyright (c) 2020 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser, Utensil Song
-/

import algebra.ring_quot
import linear_algebra.tensor_algebra.basic
import linear_algebra.exterior_algebra.basic
import linear_algebra.quadratic_form.basic

/-!
# Clifford Algebras

We construct the Clifford algebra of a module `M` over a commutative ring `R`, equipped with
a quadratic_form `Q`.

## Notation

The Clifford algebra of the `R`-module `M` equipped with a quadratic_form `Q` is denoted as
`clifford_algebra Q`.

Given a linear morphism `f : M → A` from a module `M` to another `R`-algebra `A`, such that
`cond : ∀ m, f m * f m = algebra_map _ _ (Q m)`, there is a (unique) lift of `f` to an `R`-algebra
morphism, which is denoted `clifford_algebra.lift Q f cond`.

The canonical linear map `M → clifford_algebra Q` is denoted `clifford_algebra.ι Q`.

## Theorems

The main theorems proved ensure that `clifford_algebra Q` satisfies the universal property
of the Clifford algebra.
1. `ι_comp_lift` is the fact that the composition of `ι Q` with `lift Q f cond` agrees with `f`.
2. `lift_unique` ensures the uniqueness of `lift Q f cond` with respect to 1.

Additionally, when `Q = 0` an `alg_equiv` to the `exterior_algebra` is provided as `as_exterior`.

## Implementation details

The Clifford algebra of `M` is constructed as a quotient of the tensor algebra, as follows.
1. We define a relation `clifford_algebra.rel Q` on `tensor_algebra R M`.
   This is the smallest relation which identifies squares of elements of `M` with `Q m`.
2. The Clifford algebra is the quotient of the tensor algebra by this relation.

This file is almost identical to `linear_algebra/exterior_algebra.lean`.
-/

variables {R : Type*} [comm_ring R]
variables {M : Type*} [add_comm_group M] [module R M]
variables (Q : quadratic_form R M)

variable {n : ℕ}

namespace clifford_algebra
open tensor_algebra

/-- `rel` relates each `ι m * ι m`, for `m : M`, with `Q m`.

The Clifford algebra of `M` is defined as the quotient modulo this relation.
-/
inductive rel : tensor_algebra R M → tensor_algebra R M → Prop
| of (m : M) : rel (ι R m * ι R m) (algebra_map R _ (Q m))

end clifford_algebra

/--
The Clifford algebra of an `R`-module `M` equipped with a quadratic_form `Q`.
-/
@[derive [inhabited, ring, algebra R]]
def clifford_algebra := ring_quot (clifford_algebra.rel Q)

namespace clifford_algebra

/--
The canonical linear map `M →ₗ[R] clifford_algebra Q`.
-/
def ι : M →ₗ[R] clifford_algebra Q :=
(ring_quot.mk_alg_hom R _).to_linear_map.comp (tensor_algebra.ι R)

/-- As well as being linear, `ι Q` squares to the quadratic form -/
@[simp]
theorem ι_sq_scalar (m : M) : ι Q m * ι Q m = algebra_map R _ (Q m) :=
begin
  erw [←alg_hom.map_mul, ring_quot.mk_alg_hom_rel R (rel.of m), alg_hom.commutes],
  refl,
end

variables {Q} {A : Type*} [semiring A] [algebra R A]

@[simp]
theorem comp_ι_sq_scalar (g : clifford_algebra Q →ₐ[R] A) (m : M) :
  g (ι Q m) * g (ι Q m) = algebra_map _ _ (Q m) :=
by rw [←alg_hom.map_mul, ι_sq_scalar, alg_hom.commutes]

variables (Q)

/--
Given a linear map `f : M →ₗ[R] A` into an `R`-algebra `A`, which satisfies the condition:
`cond : ∀ m : M, f m * f m = Q(m)`, this is the canonical lift of `f` to a morphism of `R`-algebras
from `clifford_algebra Q` to `A`.
-/
@[simps symm_apply]
def lift :
  {f : M →ₗ[R] A // ∀ m, f m * f m = algebra_map _ _ (Q m)} ≃ (clifford_algebra Q →ₐ[R] A) :=
{ to_fun := λ f,
  ring_quot.lift_alg_hom R ⟨tensor_algebra.lift R (f : M →ₗ[R] A),
    (λ x y (h : rel Q x y), by
    { induction h,
      rw [alg_hom.commutes, alg_hom.map_mul, tensor_algebra.lift_ι_apply, f.prop], })⟩,
  inv_fun := λ F, ⟨F.to_linear_map.comp (ι Q), λ m, by rw [
    linear_map.comp_apply, alg_hom.to_linear_map_apply, comp_ι_sq_scalar]⟩,
  left_inv := λ f, by { ext,
    simp only [ι, alg_hom.to_linear_map_apply, function.comp_app, linear_map.coe_comp,
               subtype.coe_mk, ring_quot.lift_alg_hom_mk_alg_hom_apply,
               tensor_algebra.lift_ι_apply] },
  right_inv := λ F, by { ext,
    simp only [ι, alg_hom.comp_to_linear_map, alg_hom.to_linear_map_apply, function.comp_app,
               linear_map.coe_comp, subtype.coe_mk, ring_quot.lift_alg_hom_mk_alg_hom_apply,
               tensor_algebra.lift_ι_apply] } }

variables {Q}

@[simp]
theorem ι_comp_lift (f : M →ₗ[R] A) (cond : ∀ m, f m * f m = algebra_map _ _ (Q m)) :
  (lift Q ⟨f, cond⟩).to_linear_map.comp (ι Q) = f :=
(subtype.mk_eq_mk.mp $ (lift Q).symm_apply_apply ⟨f, cond⟩)

@[simp]
theorem lift_ι_apply (f : M →ₗ[R] A) (cond : ∀ m, f m * f m = algebra_map _ _ (Q m)) (x) :
  lift Q ⟨f, cond⟩ (ι Q x) = f x :=
(linear_map.ext_iff.mp $ ι_comp_lift f cond) x

@[simp]
theorem lift_unique (f : M →ₗ[R] A) (cond : ∀ m : M, f m * f m = algebra_map _ _ (Q m))
  (g : clifford_algebra Q →ₐ[R] A) :
  g.to_linear_map.comp (ι Q) = f ↔ g = lift Q ⟨f, cond⟩ :=
begin
  convert (lift Q).symm_apply_eq,
  rw lift_symm_apply,
  simp only,
end

attribute [irreducible] clifford_algebra ι lift

@[simp]
theorem lift_comp_ι (g : clifford_algebra Q →ₐ[R] A) :
  lift Q ⟨g.to_linear_map.comp (ι Q), comp_ι_sq_scalar _⟩ = g :=
begin
  convert (lift Q).apply_symm_apply g,
  rw lift_symm_apply,
  refl,
end

/-- See note [partially-applied ext lemmas]. -/
@[ext]
theorem hom_ext {A : Type*} [semiring A] [algebra R A] {f g : clifford_algebra Q →ₐ[R] A} :
  f.to_linear_map.comp (ι Q) = g.to_linear_map.comp (ι Q) → f = g :=
begin
  intro h,
  apply (lift Q).symm.injective,
  rw [lift_symm_apply, lift_symm_apply],
  simp only [h],
end

/-- If `C` holds for the `algebra_map` of `r : R` into `clifford_algebra Q`, the `ι` of `x : M`,
and is preserved under addition and muliplication, then it holds for all of `clifford_algebra Q`.
-/
-- This proof closely follows `tensor_algebra.induction`
@[elab_as_eliminator]
lemma induction {C : clifford_algebra Q → Prop}
  (h_grade0 : ∀ r, C (algebra_map R (clifford_algebra Q) r))
  (h_grade1 : ∀ x, C (ι Q x))
  (h_mul : ∀ a b, C a → C b → C (a * b))
  (h_add : ∀ a b, C a → C b → C (a + b))
  (a : clifford_algebra Q) :
  C a :=
begin
  -- the arguments are enough to construct a subalgebra, and a mapping into it from M
  let s : subalgebra R (clifford_algebra Q) :=
  { carrier := C,
    mul_mem' := h_mul,
    add_mem' := h_add,
    algebra_map_mem' := h_grade0, },
  let of : { f : M →ₗ[R] s // ∀ m, f m * f m = algebra_map _ _ (Q m) } :=
  ⟨(ι Q).cod_restrict s.to_submodule h_grade1,
    λ m, subtype.eq $ ι_sq_scalar Q m ⟩,
  -- the mapping through the subalgebra is the identity
  have of_id : alg_hom.id R (clifford_algebra Q) = s.val.comp (lift Q of),
  { ext,
    simp [of], },
  -- finding a proof is finding an element of the subalgebra
  convert subtype.prop (lift Q of a),
  exact alg_hom.congr_fun of_id a,
end

/-- A Clifford algebra with a zero quadratic form is isomorphic to an `exterior_algebra` -/
def as_exterior : clifford_algebra (0 : quadratic_form R M) ≃ₐ[R] exterior_algebra R M :=
alg_equiv.of_alg_hom
  (clifford_algebra.lift 0 ⟨(exterior_algebra.ι R),
    by simp only [forall_const, ring_hom.map_zero,
                  exterior_algebra.ι_sq_zero, quadratic_form.zero_apply]⟩)
  (exterior_algebra.lift R ⟨(ι (0 : quadratic_form R M)),
    by simp only [forall_const, ring_hom.map_zero,
                  quadratic_form.zero_apply, ι_sq_scalar]⟩)
  (exterior_algebra.hom_ext $ linear_map.ext $
    by simp only [alg_hom.comp_to_linear_map, linear_map.coe_comp,
                  function.comp_app, alg_hom.to_linear_map_apply,
                  exterior_algebra.lift_ι_apply, clifford_algebra.lift_ι_apply,
                  alg_hom.to_linear_map_id, linear_map.id_comp, eq_self_iff_true, forall_const])
  (clifford_algebra.hom_ext $ linear_map.ext $
    by simp only [alg_hom.comp_to_linear_map, linear_map.coe_comp,
                  function.comp_app, alg_hom.to_linear_map_apply,
                  clifford_algebra.lift_ι_apply, exterior_algebra.lift_ι_apply,
                  alg_hom.to_linear_map_id, linear_map.id_comp, eq_self_iff_true, forall_const])

/-- The symmetric product of vectors is a scalar -/
lemma ι_mul_ι_add_swap (a b : M) :
  ι Q a * ι Q b + ι Q b * ι Q a = algebra_map R _ (quadratic_form.polar Q a b) :=
calc  ι Q a * ι Q b + ι Q b * ι Q a
    = ι Q (a + b) * ι Q (a + b) - ι Q a * ι Q a - ι Q b * ι Q b :
        by { rw [(ι Q).map_add, mul_add, add_mul, add_mul], abel, }
... = algebra_map R _ (Q (a + b)) - algebra_map R _ (Q a) - algebra_map R _ (Q b) :
        by rw [ι_sq_scalar, ι_sq_scalar, ι_sq_scalar]
... = algebra_map R _ (Q (a + b) - Q a - Q b) :
        by rw [←ring_hom.map_sub, ←ring_hom.map_sub]
... = algebra_map R _ (quadratic_form.polar Q a b) : rfl

section map

variables {M₁ M₂ M₃ : Type*}
variables [add_comm_group M₁] [add_comm_group M₂] [add_comm_group M₃]
variables [module R M₁] [module R M₂] [module R M₃]
variables (Q₁ : quadratic_form R M₁) (Q₂ : quadratic_form R M₂) (Q₃ : quadratic_form R M₃)

/-- Any linear map that preserves the quadratic form lifts to an `alg_hom` between algebras.

See `clifford_algebra.equiv_of_isometry` for the case when `f` is a `quadratic_form.isometry`. -/
def map (f : M₁ →ₗ[R] M₂) (hf : ∀ m, Q₂ (f m) = Q₁ m) :
  clifford_algebra Q₁ →ₐ[R] clifford_algebra Q₂ :=
clifford_algebra.lift Q₁ ⟨(clifford_algebra.ι Q₂).comp f,
  λ m, (ι_sq_scalar _ _).trans $ ring_hom.congr_arg _ $ hf m⟩

@[simp]
lemma map_comp_ι (f : M₁ →ₗ[R] M₂) (hf) :
  (map Q₁ Q₂ f hf).to_linear_map.comp (ι Q₁) = (ι Q₂).comp f :=
ι_comp_lift _ _

@[simp]
lemma map_apply_ι (f : M₁ →ₗ[R] M₂) (hf) (m : M₁):
  map Q₁ Q₂ f hf (ι Q₁ m) = ι Q₂ (f m) :=
lift_ι_apply _ _ m

@[simp]
lemma map_id :
  map Q₁ Q₁ (linear_map.id : M₁ →ₗ[R] M₁) (λ m, rfl) = alg_hom.id R (clifford_algebra Q₁) :=
by { ext m, exact map_apply_ι _ _ _ _ m }

@[simp]
lemma map_comp_map (f : M₂ →ₗ[R] M₃) (hf) (g : M₁ →ₗ[R] M₂) (hg) :
  (map Q₂ Q₃ f hf).comp (map Q₁ Q₂ g hg) = map Q₁ Q₃ (f.comp g) (λ m, (hf _).trans $ hg m) :=
begin
  ext m,
  dsimp only [linear_map.comp_apply, alg_hom.comp_apply, alg_hom.to_linear_map_apply,
    alg_hom.id_apply],
  rw [map_apply_ι, map_apply_ι, map_apply_ι, linear_map.comp_apply],
end

variables {Q₁ Q₂ Q₃}

/-- Two `clifford_algebra`s are equivalent as algebras if their quadratic forms are
equivalent. -/
@[simps apply]
def equiv_of_isometry (e : Q₁.isometry Q₂) :
  clifford_algebra Q₁ ≃ₐ[R] clifford_algebra Q₂ :=
alg_equiv.of_alg_hom
  (map Q₁ Q₂ e e.map_app)
  (map Q₂ Q₁ e.symm e.symm.map_app)
  ((map_comp_map _ _ _ _ _ _ _).trans $ begin
    convert map_id _ using 2,
    ext m,
    exact e.to_linear_equiv.apply_symm_apply m,
  end)
  ((map_comp_map _ _ _ _ _ _ _).trans $ begin
    convert map_id _ using 2,
    ext m,
    exact e.to_linear_equiv.symm_apply_apply m,
  end)

@[simp]
lemma equiv_of_isometry_symm (e : Q₁.isometry Q₂) :
  (equiv_of_isometry e).symm = equiv_of_isometry e.symm := rfl

@[simp]
lemma equiv_of_isometry_trans (e₁₂ : Q₁.isometry Q₂) (e₂₃ : Q₂.isometry Q₃) :
  (equiv_of_isometry e₁₂).trans (equiv_of_isometry e₂₃) = equiv_of_isometry (e₁₂.trans e₂₃) :=
by { ext x, exact alg_hom.congr_fun (map_comp_map Q₁ Q₂ Q₃ _ _ _ _) x }

@[simp]
lemma equiv_of_isometry_refl :
  (equiv_of_isometry $ quadratic_form.isometry.refl Q₁) = alg_equiv.refl :=
by { ext x, exact alg_hom.congr_fun (map_id Q₁) x }

end map

end clifford_algebra

namespace tensor_algebra

variables {Q}

/-- The canonical image of the `tensor_algebra` in the `clifford_algebra`, which maps
`tensor_algebra.ι R x` to `clifford_algebra.ι Q x`. -/
def to_clifford : tensor_algebra R M →ₐ[R] clifford_algebra Q :=
tensor_algebra.lift R (clifford_algebra.ι Q)

@[simp] lemma to_clifford_ι (m : M) : (tensor_algebra.ι R m).to_clifford = clifford_algebra.ι Q m :=
by simp [to_clifford]

end tensor_algebra


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

import group_theory.quotient_group
import ring_theory.dedekind_domain.ideal

/-!
# The ideal class group

This file defines the ideal class group `class_group R K` of fractional ideals of `R`
inside `A`'s field of fractions `K`.

## Main definitions
 - `to_principal_ideal` sends an invertible `x : K` to an invertible fractional ideal
 - `class_group` is the quotient of invertible fractional ideals modulo `to_principal_ideal.range`
 - `class_group.mk0` sends a nonzero integral ideal in a Dedekind domain to its class

## Main results
 - `class_group.mk0_eq_mk0_iff` shows the equivalence with the "classical" definition,
   where `I ~ J` iff `x I = y J` for `x y ≠ (0 : R)`
-/

variables {R K L : Type*} [comm_ring R]
variables [field K] [field L] [decidable_eq L]
variables [algebra R K] [is_fraction_ring R K]
variables [algebra K L] [finite_dimensional K L]
variables [algebra R L] [is_scalar_tower R K L]

open_locale non_zero_divisors

open is_localization is_fraction_ring fractional_ideal units

section

variables (R K)

/-- `to_principal_ideal R K x` sends `x ≠ 0 : K` to the fractional `R`-ideal generated by `x` -/
@[irreducible]
def to_principal_ideal : Kˣ →* (fractional_ideal R⁰ K)ˣ :=
{ to_fun := λ x,
  ⟨span_singleton _ x,
   span_singleton _ x⁻¹,
   by simp only [span_singleton_one, units.mul_inv', span_singleton_mul_span_singleton],
   by simp only [span_singleton_one, units.inv_mul', span_singleton_mul_span_singleton]⟩,
  map_mul' := λ x y, ext
    (by simp only [units.coe_mk, units.coe_mul, span_singleton_mul_span_singleton]),
  map_one' := ext (by simp only [span_singleton_one, units.coe_mk, units.coe_one]) }

local attribute [semireducible] to_principal_ideal

variables {R K}

@[simp] lemma coe_to_principal_ideal (x : Kˣ) :
  (to_principal_ideal R K x : fractional_ideal R⁰ K) = span_singleton _ x :=
rfl

@[simp] lemma to_principal_ideal_eq_iff {I : (fractional_ideal R⁰ K)ˣ} {x : Kˣ} :
  to_principal_ideal R K x = I ↔ span_singleton R⁰ (x : K) = I :=
units.ext_iff

end

instance principal_ideals.normal : (to_principal_ideal R K).range.normal :=
subgroup.normal_of_comm _

section

variables (R K)

/-- The ideal class group of `R` in a field of fractions `K`
is the group of invertible fractional ideals modulo the principal ideals. -/
@[derive(comm_group)]
def class_group := (fractional_ideal R⁰ K)ˣ ⧸ (to_principal_ideal R K).range

instance : inhabited (class_group R K) := ⟨1⟩

variables {R} [is_domain R]

/-- Send a nonzero integral ideal to an invertible fractional ideal. -/
@[simps]
noncomputable def fractional_ideal.mk0 [is_dedekind_domain R] :
  (ideal R)⁰ →* (fractional_ideal R⁰ K)ˣ :=
{ to_fun := λ I, units.mk0 I ((fractional_ideal.coe_to_fractional_ideal_ne_zero (le_refl R⁰)).mpr
    (mem_non_zero_divisors_iff_ne_zero.mp I.2)),
  map_one' := by simp,
  map_mul' := λ x y, by simp }

/-- Send a nonzero ideal to the corresponding class in the class group. -/
@[simps]
noncomputable def class_group.mk0 [is_dedekind_domain R] :
  (ideal R)⁰ →* class_group R K :=
(quotient_group.mk' _).comp (fractional_ideal.mk0 K)

variables {K}

lemma quotient_group.mk'_eq_mk' {G : Type*} [group G] {N : subgroup G} [hN : N.normal] {x y : G} :
  quotient_group.mk' N x = quotient_group.mk' N y ↔ ∃ z ∈ N, x * z = y :=
(@quotient.eq _ (quotient_group.left_rel _) _ _).trans
  ⟨λ (h : x⁻¹ * y ∈ N), ⟨_, h, by rw [← mul_assoc, mul_right_inv, one_mul]⟩,
   λ ⟨z, z_mem, eq_y⟩,
     by { rw ← eq_y, show x⁻¹ * (x * z) ∈ N, rwa [← mul_assoc, mul_left_inv, one_mul] }⟩

lemma class_group.mk0_eq_mk0_iff_exists_fraction_ring [is_dedekind_domain R] {I J : (ideal R)⁰} :
  class_group.mk0 K I = class_group.mk0 K J ↔
    ∃ (x ≠ (0 : K)), span_singleton R⁰ x * I = J :=
begin
  simp only [class_group.mk0, monoid_hom.comp_apply, quotient_group.mk'_eq_mk'],
  split,
  { rintros ⟨_, ⟨x, rfl⟩, hx⟩,
    refine ⟨x, x.ne_zero, _⟩,
    simpa only [mul_comm, coe_mk0, monoid_hom.to_fun_eq_coe, coe_to_principal_ideal, units.coe_mul]
      using congr_arg (coe : _ → fractional_ideal R⁰ K) hx },
  { rintros ⟨x, hx, eq_J⟩,
    refine ⟨_, ⟨units.mk0 x hx, rfl⟩, units.ext _⟩,
    simpa only [fractional_ideal.mk0_apply, units.coe_mk0, mul_comm, coe_to_principal_ideal,
        coe_coe, units.coe_mul] using eq_J }
end

lemma class_group.mk0_eq_mk0_iff [is_dedekind_domain R] {I J : (ideal R)⁰} :
  class_group.mk0 K I = class_group.mk0 K J ↔
    ∃ (x y : R) (hx : x ≠ 0) (hy : y ≠ 0), ideal.span {x} * (I : ideal R) = ideal.span {y} * J :=
begin
  refine class_group.mk0_eq_mk0_iff_exists_fraction_ring.trans ⟨_, _⟩,
  { rintros ⟨z, hz, h⟩,
    obtain ⟨x, ⟨y, hy⟩, rfl⟩ := is_localization.mk'_surjective R⁰ z,
    refine ⟨x, y, _, mem_non_zero_divisors_iff_ne_zero.mp hy, _⟩,
    { rintro hx, apply hz,
      rw [hx, is_fraction_ring.mk'_eq_div, (algebra_map R K).map_zero, zero_div] },
    { exact (fractional_ideal.mk'_mul_coe_ideal_eq_coe_ideal K hy).mp h } },
  { rintros ⟨x, y, hx, hy, h⟩,
    have hy' : y ∈ R⁰ := mem_non_zero_divisors_iff_ne_zero.mpr hy,
    refine ⟨is_localization.mk' K x ⟨y, hy'⟩, _, _⟩,
    { contrapose! hx,
      rwa [is_localization.mk'_eq_iff_eq_mul, zero_mul, ← (algebra_map R K).map_zero,
           (is_fraction_ring.injective R K).eq_iff] at hx },
    { exact (fractional_ideal.mk'_mul_coe_ideal_eq_coe_ideal K hy').mpr h } },
end

lemma class_group.mk0_surjective [is_dedekind_domain R] :
  function.surjective (class_group.mk0 K : (ideal R)⁰ → class_group R K) :=
begin
  rintros ⟨I⟩,
  obtain ⟨a, a_ne_zero', ha⟩ := I.1.2,
  have a_ne_zero := mem_non_zero_divisors_iff_ne_zero.mp a_ne_zero',
  have fa_ne_zero : (algebra_map R K) a ≠ 0 :=
    is_fraction_ring.to_map_ne_zero_of_mem_non_zero_divisors a_ne_zero',
  refine ⟨⟨{ carrier := { x | (algebra_map R K a)⁻¹ * algebra_map R K x ∈ I.1 }, .. }, _⟩, _⟩,
  { simp only [ring_hom.map_add, set.mem_set_of_eq, mul_zero, ring_hom.map_mul, mul_add],
    exact λ _ _ ha hb, submodule.add_mem I ha hb },
  { simp only [ring_hom.map_zero, set.mem_set_of_eq, mul_zero, ring_hom.map_mul],
    exact submodule.zero_mem I },
  { intros c _ hb,
    simp only [smul_eq_mul, set.mem_set_of_eq, mul_zero, ring_hom.map_mul, mul_add,
               mul_left_comm ((algebra_map R K) a)⁻¹],
    rw ← algebra.smul_def c,
    exact submodule.smul_mem I c hb },
  { rw [mem_non_zero_divisors_iff_ne_zero, submodule.zero_eq_bot, submodule.ne_bot_iff],
    obtain ⟨x, x_ne, x_mem⟩ := exists_ne_zero_mem_is_integer I.ne_zero,
    refine ⟨a * x, _, mul_ne_zero a_ne_zero x_ne⟩,
    change ((algebra_map R K) a)⁻¹ * (algebra_map R K) (a * x) ∈ I.1,
    rwa [ring_hom.map_mul, ← mul_assoc, inv_mul_cancel fa_ne_zero, one_mul] },
  { symmetry,
    apply quotient.sound,
    refine ⟨units.mk0 (algebra_map R K a) fa_ne_zero, _⟩,
    apply @mul_left_cancel _ _ I,
    rw [← mul_assoc, mul_right_inv, one_mul, eq_comm, mul_comm I],
    apply units.ext,
    simp only [monoid_hom.coe_mk, subtype.coe_mk, ring_hom.map_mul, coe_coe,
               units.coe_mul, coe_to_principal_ideal, coe_mk0,
               fractional_ideal.eq_span_singleton_mul],
    split,
    { intros zJ' hzJ',
      obtain ⟨zJ, hzJ : (algebra_map R K a)⁻¹ * algebra_map R K zJ ∈ ↑I, rfl⟩ :=
        (mem_coe_ideal R⁰).mp hzJ',
      refine ⟨_, hzJ, _⟩,
      rw [← mul_assoc, mul_inv_cancel fa_ne_zero, one_mul] },
    { intros zI' hzI',
      obtain ⟨y, hy⟩ := ha zI' hzI',
      rw [← algebra.smul_def, fractional_ideal.mk0_apply, coe_mk0, coe_coe, mem_coe_ideal],
      refine ⟨y, _, hy⟩,
      show (algebra_map R K a)⁻¹ * algebra_map R K y ∈ (I : fractional_ideal R⁰ K),
      rwa [hy, algebra.smul_def, ← mul_assoc, inv_mul_cancel fa_ne_zero, one_mul] } }
end

end

lemma class_group.mk_eq_one_iff
  {I : (fractional_ideal R⁰ K)ˣ} :
  quotient_group.mk' (to_principal_ideal R K).range I = 1 ↔
    (I : submodule R K).is_principal :=
begin
  rw [← (quotient_group.mk' _).map_one, eq_comm, quotient_group.mk'_eq_mk'],
  simp only [exists_prop, one_mul, exists_eq_right, to_principal_ideal_eq_iff,
             monoid_hom.mem_range, coe_coe],
  refine ⟨λ ⟨x, hx⟩, ⟨⟨x, by rw [← hx, coe_span_singleton]⟩⟩, _⟩,
  unfreezingI { intros hI },
  obtain ⟨x, hx⟩ := @submodule.is_principal.principal _ _ _ _ _ _ hI,
  have hx' : (I : fractional_ideal R⁰ K) = span_singleton R⁰ x,
  { apply subtype.coe_injective, rw [hx, coe_span_singleton] },
  refine ⟨units.mk0 x _, _⟩,
  { intro x_eq, apply units.ne_zero I, simp [hx', x_eq] },
  simp [hx']
end

variables [is_domain R]

lemma class_group.mk0_eq_one_iff [is_dedekind_domain R]
  {I : ideal R} (hI : I ∈ (ideal R)⁰) :
  class_group.mk0 K ⟨I, hI⟩ = 1 ↔ I.is_principal :=
class_group.mk_eq_one_iff.trans (coe_submodule_is_principal R K)

/-- The class group of principal ideal domain is finite (in fact a singleton).
TODO: generalize to Dedekind domains -/
instance [is_principal_ideal_ring R] :
  fintype (class_group R K) :=
{ elems := {1},
  complete :=
  begin
    rintros ⟨I⟩,
    rw [finset.mem_singleton],
    exact class_group.mk_eq_one_iff.mpr (I : fractional_ideal R⁰ K).is_principal
  end }

/-- The class number of a principal ideal domain is `1`. -/
lemma card_class_group_eq_one [is_principal_ideal_ring R] :
  fintype.card (class_group R K) = 1 :=
begin
  rw fintype.card_eq_one_iff,
  use 1,
  rintros ⟨I⟩,
  exact class_group.mk_eq_one_iff.mpr (I : fractional_ideal R⁰ K).is_principal
end

/-- The class number is `1` iff the ring of integers is a principal ideal domain. -/
lemma card_class_group_eq_one_iff [is_dedekind_domain R] [fintype (class_group R K)] :
  fintype.card (class_group R K) = 1 ↔ is_principal_ideal_ring R :=
begin
  split, swap, { introsI, convert card_class_group_eq_one, assumption, assumption, },
  rw fintype.card_eq_one_iff,
  rintros ⟨I, hI⟩,
  have eq_one : ∀ J : class_group R K, J = 1 := λ J, trans (hI J) (hI 1).symm,
  refine ⟨λ I, _⟩,
  by_cases hI : I = ⊥,
  { rw hI, exact bot_is_principal },
  exact (class_group.mk0_eq_one_iff (mem_non_zero_divisors_iff_ne_zero.mpr hI)).mp (eq_one _),
end


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

! This file was ported from Lean 3 source module testing.slim_check.gen
! leanprover-community/mathlib commit 23f67f2fd1b092739d7fbfcdfaab65ea2783a39d
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Control.Random
import Mathbin.Control.Uliftable
import Mathbin.Data.List.BigOperators.Lemmas
import Mathbin.Data.List.Perm

/-!
# `gen` Monad

This monad is used to formulate randomized computations with a parameter
to specify the desired size of the result.

This is a port of the Haskell QuickCheck library.

## Main definitions
  * `gen` monad

## Local notation

 * `i .. j` : `Icc i j`, the set of values between `i` and `j` inclusively;

## Tags

random testing

## References

  * https://hackage.haskell.org/package/QuickCheck

-/

universe u v

namespace SlimCheck

#print SlimCheck.Gen /-
/-- Monad to generate random examples to test properties with.
It has a `nat` parameter so that the caller can decide on the
size of the examples. -/
@[reducible]
def Gen (α : Type u) :=
  ReaderT (ULift ℕ) Rand α deriving Monad, LawfulMonad
#align slim_check.gen SlimCheck.Gen
-/

variable (α : Type u)

-- mathport name: «expr .. »
local infixl:41 " .. " => Set.Icc

/-- Execute a `gen` inside the `io` monad using `i` as the example
size and with a fresh random number generator. -/
def Io.runGen {α} (x : Gen α) (i : ℕ) : Io α :=
  Io.runRand (x.run ⟨i⟩)
#align slim_check.io.run_gen SlimCheck.Io.runGen

namespace Gen

section Rand

#print SlimCheck.Gen.chooseAny /-
/-- Lift `random.random` to the `gen` monad. -/
def chooseAny [Random α] : Gen α :=
  ⟨fun _ => Rand.random α⟩
#align slim_check.gen.choose_any SlimCheck.Gen.chooseAny
-/

variable {α} [Preorder α]

#print SlimCheck.Gen.choose /-
/-- Lift `random.random_r` to the `gen` monad. -/
def choose [BoundedRandom α] (x y : α) (p : x ≤ y) : Gen (x .. y) :=
  ⟨fun _ => Rand.randomR x y p⟩
#align slim_check.gen.choose SlimCheck.Gen.choose
-/

end Rand

open Nat

/-- Generate a `nat` example between `x` and `y`. -/
def chooseNat (x y : ℕ) (p : x ≤ y) : Gen (x .. y) :=
  choose x y p
#align slim_check.gen.choose_nat SlimCheck.Gen.chooseNat

/-- Generate a `nat` example between `x` and `y`. -/
def chooseNat' (x y : ℕ) (p : x < y) : Gen (Set.Ico x y) :=
  have : ∀ i, x < i → i ≤ y → i.pred < y := fun i h₀ h₁ =>
    show i.pred.succ ≤ y by rwa [succ_pred_eq_of_pos] <;> apply lt_of_le_of_lt (Nat.zero_le _) h₀
  (Subtype.map pred fun i (h : x + 1 ≤ i ∧ i ≤ y) => ⟨le_pred_of_lt h.1, this _ h.1 h.2⟩) <$>
    choose (x + 1) y p
#align slim_check.gen.choose_nat' SlimCheck.Gen.chooseNat'

open Nat

instance : Uliftable Gen.{u} Gen.{v} :=
  ReaderT.uliftable' (Equiv.ulift.trans Equiv.ulift.symm)

instance : HasOrelse Gen.{u} :=
  ⟨fun α x y => do
    let b ← Uliftable.up <| chooseAny Bool
    if b then x else y⟩

variable {α}

/-- Get access to the size parameter of the `gen` monad. For
reasons of universe polymorphism, it is specified in
continuation passing style. -/
def sized (cmd : ℕ → Gen α) : Gen α :=
  ⟨fun ⟨sz⟩ => ReaderT.run (cmd sz) ⟨sz⟩⟩
#align slim_check.gen.sized SlimCheck.Gen.sized

#print SlimCheck.Gen.resize /-
/-- Apply a function to the size parameter. -/
def resize (f : ℕ → ℕ) (cmd : Gen α) : Gen α :=
  ⟨fun ⟨sz⟩ => ReaderT.run cmd ⟨f sz⟩⟩
#align slim_check.gen.resize SlimCheck.Gen.resize
-/

/-- Create `n` examples using `cmd`. -/
def vectorOf : ∀ (n : ℕ) (cmd : Gen α), Gen (Vector α n)
  | 0, _ => return Vector.nil
  | succ n, cmd => Vector.cons <$> cmd <*> vector_of n cmd
#align slim_check.gen.vector_of SlimCheck.Gen.vectorOf

/- warning: slim_check.gen.list_of -> SlimCheck.Gen.listOf is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u}}, (SlimCheck.Gen.{u} α) -> (SlimCheck.Gen.{u} (List.{u} α))
but is expected to have type
  forall {α : Type}, (SlimCheck.Gen.{0} α) -> (SlimCheck.Gen.{0} (List.{0} α))
Case conversion may be inaccurate. Consider using '#align slim_check.gen.list_of SlimCheck.Gen.listOfₓ'. -/
/-- Create a list of examples using `cmd`. The size is controlled
by the size parameter of `gen`. -/
def listOf (cmd : Gen α) : Gen (List α) :=
  sized fun sz => do
    do
      let ⟨n⟩ ← Uliftable.up <| choose_nat 0 (sz + 1) (by decide)
      let v ← vector_of n cmd
      return v
#align slim_check.gen.list_of SlimCheck.Gen.listOf

open ULift

/- warning: slim_check.gen.one_of -> SlimCheck.Gen.oneOf is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u}} (xs : List.{u} (SlimCheck.Gen.{u} α)), (LT.lt.{0} Nat Nat.hasLt (OfNat.ofNat.{0} Nat 0 (OfNat.mk.{0} Nat 0 (Zero.zero.{0} Nat Nat.hasZero))) (List.length.{u} (SlimCheck.Gen.{u} α) xs)) -> (SlimCheck.Gen.{u} α)
but is expected to have type
  forall {α : Type} (xs : Array.{0} (SlimCheck.Gen.{0} α)), (autoParam.{0} (LT.lt.{0} Nat instLTNat (OfNat.ofNat.{0} Nat 0 (instOfNatNat 0)) (Array.size.{0} (SlimCheck.Gen.{0} α) xs)) _auto._@.Mathlib.Testing.SlimCheck.Gen._hyg.572) -> (SlimCheck.Gen.{0} α)
Case conversion may be inaccurate. Consider using '#align slim_check.gen.one_of SlimCheck.Gen.oneOfₓ'. -/
/-- Given a list of example generators, choose one to create an example. -/
def oneOf (xs : List (Gen α)) (pos : 0 < xs.length) : Gen α := do
  let ⟨⟨n, h, h'⟩⟩ ← Uliftable.up <| chooseNat' 0 xs.length Pos
  List.nthLe xs n h'
#align slim_check.gen.one_of SlimCheck.Gen.oneOf

/- warning: slim_check.gen.elements -> SlimCheck.Gen.elements is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u}} (xs : List.{u} α), (LT.lt.{0} Nat Nat.hasLt (OfNat.ofNat.{0} Nat 0 (OfNat.mk.{0} Nat 0 (Zero.zero.{0} Nat Nat.hasZero))) (List.length.{u} α xs)) -> (SlimCheck.Gen.{u} α)
but is expected to have type
  forall {α : Type} (xs : List.{0} α), (LT.lt.{0} Nat instLTNat (OfNat.ofNat.{0} Nat 0 (instOfNatNat 0)) (List.length.{0} α xs)) -> (SlimCheck.Gen.{0} α)
Case conversion may be inaccurate. Consider using '#align slim_check.gen.elements SlimCheck.Gen.elementsₓ'. -/
/-- Given a list of example generators, choose one to create an example. -/
def elements (xs : List α) (pos : 0 < xs.length) : Gen α := do
  let ⟨⟨n, h₀, h₁⟩⟩ ← Uliftable.up <| chooseNat' 0 xs.length Pos
  pure <| List.nthLe xs n h₁
#align slim_check.gen.elements SlimCheck.Gen.elements

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- `freq_aux xs i _` takes a weighted list of generator and a number meant to select one of the
generators.

If we consider `freq_aux [(1, gena), (3, genb), (5, genc)] 4 _`, we choose a generator by splitting
the interval 1-9 into 1-1, 2-4, 5-9 so that the width of each interval corresponds to one of the
number in the list of generators. Then, we check which interval 4 falls into: it selects `genb`.
-/
def freqAux : ∀ (xs : List (ℕ+ × Gen α)) (i), i < (xs.map (Subtype.val ∘ Prod.fst)).Sum → Gen α
  | [], i, h => False.elim (Nat.not_lt_zero _ h)
  | (i, x)::xs, j, h =>
    if h' : j < i then x
    else
      freq_aux xs (j - i)
        (by
          rw [tsub_lt_iff_right (le_of_not_gt h')]
          simpa [List.sum_cons, add_comm] using h)
#align slim_check.gen.freq_aux SlimCheck.Gen.freqAux

/-- `freq [(1, gena), (3, genb), (5, genc)] _` will choose one of `gena`, `genb`, `genc` with
probabilities proportional to the number accompanying them. In this example, the sum of
those numbers is 9, `gena` will be chosen with probability ~1/9, `genb` with ~3/9 (i.e. 1/3)
and `genc` with probability 5/9.
-/
def freq (xs : List (ℕ+ × Gen α)) (pos : 0 < xs.length) : Gen α :=
  let s := (xs.map (Subtype.val ∘ Prod.fst)).Sum
  have ha : 1 ≤ s :=
    le_trans Pos <|
      List.length_map (Subtype.val ∘ Prod.fst) xs ▸
        List.length_le_sum_of_one_le _ fun i => by
          simp
          intros
          assumption
  have : 0 ≤ s - 1 := le_tsub_of_add_le_right ha
  Uliftable.adaptUp Gen.{0} Gen.{u} (chooseNat 0 (s - 1) this) fun i =>
    freqAux xs i.1 (by rcases i with ⟨i, h₀, h₁⟩ <;> rwa [le_tsub_iff_right] at h₁ <;> exact ha)
#align slim_check.gen.freq SlimCheck.Gen.freq

/- warning: slim_check.gen.permutation_of -> SlimCheck.Gen.permutationOf is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u}} (xs : List.{u} α), SlimCheck.Gen.{u} (Subtype.{succ u} (List.{u} α) (List.Perm.{u} α xs))
but is expected to have type
  forall {α : Type} (xs : List.{0} α), SlimCheck.Gen.{0} (Subtype.{1} (List.{0} α) (fun (ys : List.{0} α) => List.Perm.{0} α ys xs))
Case conversion may be inaccurate. Consider using '#align slim_check.gen.permutation_of SlimCheck.Gen.permutationOfₓ'. -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- Generate a random permutation of a given list. -/
def permutationOf {α : Type u} : ∀ xs : List α, Gen (Subtype <| List.Perm xs)
  | [] => pure ⟨[], List.Perm.nil⟩
  | x::xs => do
    let ⟨xs', h⟩ ← permutation_of xs
    let ⟨⟨n, _, h'⟩⟩ ← Uliftable.up <| chooseNat 0 xs'.length (by decide)
    pure
        ⟨List.insertNth n x xs',
          List.Perm.trans (List.Perm.cons _ h) (List.perm_insertNth _ _ h').symm⟩
#align slim_check.gen.permutation_of SlimCheck.Gen.permutationOf

end Gen

end SlimCheck


/-
Copyright (c) 2020 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import algebra.char_p.invertible
import linear_algebra.affine_space.affine_equiv

/-!
# Midpoint of a segment

## Main definitions

* `midpoint R x y`: midpoint of the segment `[x, y]`. We define it for `x` and `y`
  in a module over a ring `R` with invertible `2`.
* `add_monoid_hom.of_map_midpoint`: construct an `add_monoid_hom` given a map `f` such that
  `f` sends zero to zero and midpoints to midpoints.

## Main theorems

* `midpoint_eq_iff`: `z` is the midpoint of `[x, y]` if and only if `x + y = z + z`,
* `midpoint_unique`: `midpoint R x y` does not depend on `R`;
* `midpoint x y` is linear both in `x` and `y`;
* `point_reflection_midpoint_left`, `point_reflection_midpoint_right`:
  `equiv.point_reflection (midpoint R x y)` swaps `x` and `y`.

We do not mark most lemmas as `@[simp]` because it is hard to tell which side is simpler.

## Tags

midpoint, add_monoid_hom
-/

open affine_map affine_equiv

section

variables (R : Type*) {V V' P P' : Type*} [ring R] [invertible (2:R)]
  [add_comm_group V] [module R V] [add_torsor V P]
  [add_comm_group V'] [module R V'] [add_torsor V' P']

include V

/-- `midpoint x y` is the midpoint of the segment `[x, y]`. -/
def midpoint (x y : P) : P := line_map x y (⅟2:R)

variables {R} {x y z : P}
include V'

@[simp] lemma affine_map.map_midpoint (f : P →ᵃ[R] P') (a b : P) :
  f (midpoint R a b) = midpoint R (f a) (f b) :=
f.apply_line_map a b _

@[simp] lemma affine_equiv.map_midpoint (f : P ≃ᵃ[R] P') (a b : P) :
  f (midpoint R a b) = midpoint R (f a) (f b) :=
f.apply_line_map a b _

omit V'

@[simp] lemma affine_equiv.point_reflection_midpoint_left (x y : P) :
  point_reflection R (midpoint R x y) x = y :=
by rw [midpoint, point_reflection_apply, line_map_apply, vadd_vsub,
  vadd_vadd, ← add_smul, ← two_mul, mul_inv_of_self, one_smul, vsub_vadd]

lemma midpoint_comm (x y : P) : midpoint R x y = midpoint R y x :=
by rw [midpoint, ← line_map_apply_one_sub, one_sub_inv_of_two, midpoint]

@[simp] lemma affine_equiv.point_reflection_midpoint_right (x y : P) :
  point_reflection R (midpoint R x y) y = x :=
by rw [midpoint_comm, affine_equiv.point_reflection_midpoint_left]

lemma midpoint_vsub_midpoint (p₁ p₂ p₃ p₄ : P) :
  midpoint R p₁ p₂ -ᵥ midpoint R p₃ p₄ = midpoint R (p₁ -ᵥ p₃) (p₂ -ᵥ p₄) :=
line_map_vsub_line_map _ _ _ _ _

lemma midpoint_vadd_midpoint (v v' : V) (p p' : P) :
  midpoint R v v' +ᵥ midpoint R p p' = midpoint R (v +ᵥ p) (v' +ᵥ p') :=
line_map_vadd_line_map _ _ _ _ _

lemma midpoint_eq_iff {x y z : P} : midpoint R x y = z ↔ point_reflection R z x = y :=
eq_comm.trans ((injective_point_reflection_left_of_module R x).eq_iff'
  (affine_equiv.point_reflection_midpoint_left x y)).symm

@[simp] lemma midpoint_vsub_left (p₁ p₂ : P) : midpoint R p₁ p₂ -ᵥ p₁ = (⅟2:R) • (p₂ -ᵥ p₁) :=
line_map_vsub_left _ _ _

@[simp] lemma midpoint_vsub_right (p₁ p₂ : P) : midpoint R p₁ p₂ -ᵥ p₂ = (⅟2:R) • (p₁ -ᵥ p₂) :=
by rw [midpoint_comm, midpoint_vsub_left]

@[simp] lemma left_vsub_midpoint (p₁ p₂ : P) : p₁ -ᵥ midpoint R p₁ p₂ = (⅟2:R) • (p₁ -ᵥ p₂) :=
left_vsub_line_map _ _ _

@[simp] lemma right_vsub_midpoint (p₁ p₂ : P) : p₂ -ᵥ midpoint R p₁ p₂ = (⅟2:R) • (p₂ -ᵥ p₁) :=
by rw [midpoint_comm, left_vsub_midpoint]

@[simp] lemma midpoint_sub_left (v₁ v₂ : V) : midpoint R v₁ v₂ - v₁ = (⅟2:R) • (v₂ - v₁) :=
midpoint_vsub_left v₁ v₂

@[simp] lemma midpoint_sub_right (v₁ v₂ : V) : midpoint R v₁ v₂ - v₂ = (⅟2:R) • (v₁ - v₂) :=
midpoint_vsub_right v₁ v₂

@[simp] lemma left_sub_midpoint (v₁ v₂ : V) : v₁ - midpoint R v₁ v₂ = (⅟2:R) • (v₁ - v₂) :=
left_vsub_midpoint v₁ v₂

@[simp] lemma right_sub_midpoint (v₁ v₂ : V) : v₂ - midpoint R v₁ v₂ = (⅟2:R) • (v₂ - v₁) :=
right_vsub_midpoint v₁ v₂

variable (R)

lemma midpoint_eq_midpoint_iff_vsub_eq_vsub {x x' y y' : P} :
  midpoint R x y = midpoint R x' y' ↔ x -ᵥ x' = y' -ᵥ y :=
by rw [← @vsub_eq_zero_iff_eq V, midpoint_vsub_midpoint, midpoint_eq_iff, point_reflection_apply,
  vsub_eq_sub, zero_sub, vadd_eq_add, add_zero, neg_eq_iff_neg_eq, neg_vsub_eq_vsub_rev, eq_comm]

lemma midpoint_eq_iff' {x y z : P} : midpoint R x y = z ↔ equiv.point_reflection z x = y :=
midpoint_eq_iff

/-- `midpoint` does not depend on the ring `R`. -/
lemma midpoint_unique (R' : Type*) [ring R'] [invertible (2:R')] [module R' V] (x y : P) :
  midpoint R x y = midpoint R' x y :=
(midpoint_eq_iff' R).2 $ (midpoint_eq_iff' R').1 rfl

@[simp] lemma midpoint_self (x : P) : midpoint R x x = x :=
line_map_same_apply _ _

@[simp] lemma midpoint_add_self (x y : V) : midpoint R x y + midpoint R x y = x + y :=
calc midpoint R x y +ᵥ midpoint R x y = midpoint R x y +ᵥ midpoint R y x : by rw midpoint_comm
... = x + y : by rw [midpoint_vadd_midpoint, vadd_eq_add, vadd_eq_add, add_comm, midpoint_self]

lemma midpoint_zero_add (x y : V) : midpoint R 0 (x + y) = midpoint R x y :=
(midpoint_eq_midpoint_iff_vsub_eq_vsub R).2 $ by simp [sub_add_eq_sub_sub_swap]

lemma midpoint_eq_smul_add (x y : V) : midpoint R x y = (⅟2 : R) • (x + y) :=
by rw [midpoint_eq_iff, point_reflection_apply, vsub_eq_sub, vadd_eq_add, sub_add_eq_add_sub,
  ← two_smul R, smul_smul, mul_inv_of_self, one_smul, add_sub_cancel']

end

lemma line_map_inv_two {R : Type*} {V P : Type*} [division_ring R] [char_zero R]
  [add_comm_group V] [module R V] [add_torsor V P] (a b : P) :
  line_map a b (2⁻¹:R) = midpoint R a b :=
rfl

lemma line_map_one_half {R : Type*} {V P : Type*} [division_ring R] [char_zero R]
  [add_comm_group V] [module R V] [add_torsor V P] (a b : P) :
  line_map a b (1/2:R) = midpoint R a b :=
by rw [one_div, line_map_inv_two]

lemma homothety_inv_of_two {R : Type*} {V P : Type*} [comm_ring R] [invertible (2:R)]
  [add_comm_group V] [module R V] [add_torsor V P] (a b : P) :
  homothety a (⅟2:R) b = midpoint R a b :=
rfl

lemma homothety_inv_two {k : Type*} {V P : Type*} [field k] [char_zero k]
  [add_comm_group V] [module k V] [add_torsor V P] (a b : P) :
  homothety a (2⁻¹:k) b = midpoint k a b :=
rfl

lemma homothety_one_half {k : Type*} {V P : Type*} [field k] [char_zero k]
  [add_comm_group V] [module k V] [add_torsor V P] (a b : P) :
  homothety a (1/2:k) b = midpoint k a b :=
by rw [one_div, homothety_inv_two]

@[simp] lemma pi_midpoint_apply {k ι : Type*} {V : Π i : ι, Type*} {P : Π i : ι, Type*} [field k]
  [invertible (2:k)] [Π i, add_comm_group (V i)] [Π i, module k (V i)]
  [Π i, add_torsor (V i) (P i)] (f g : Π i, P i) (i : ι) :
  midpoint k f g i = midpoint k (f i) (g i) := rfl

namespace add_monoid_hom

variables (R R' : Type*) {E F : Type*}
  [ring R] [invertible (2:R)] [add_comm_group E] [module R E]
  [ring R'] [invertible (2:R')] [add_comm_group F] [module R' F]

/-- A map `f : E → F` sending zero to zero and midpoints to midpoints is an `add_monoid_hom`. -/
def of_map_midpoint (f : E → F) (h0 : f 0 = 0)
  (hm : ∀ x y, f (midpoint R x y) = midpoint R' (f x) (f y)) :
  E →+ F :=
{ to_fun := f,
  map_zero' := h0,
  map_add' := λ x y,
    calc f (x + y) = f 0 + f (x + y) : by rw [h0, zero_add]
    ... = midpoint R' (f 0) (f (x + y)) + midpoint R' (f 0) (f (x + y)) :
      (midpoint_add_self _ _ _).symm
    ... = f (midpoint R x y) + f (midpoint R x y) : by rw [← hm, midpoint_zero_add]
    ... = f x + f y : by rw [hm, midpoint_add_self] }

@[simp] lemma coe_of_map_midpoint (f : E → F) (h0 : f 0 = 0)
  (hm : ∀ x y, f (midpoint R x y) = midpoint R' (f x) (f y)) :
  ⇑(of_map_midpoint R R' f h0 hm) = f := rfl

end add_monoid_hom


import analysis.convex.hull
import data.real.basic
import topology.connected
import topology.path_connected
import topology.algebra.affine
import linear_algebra.dimension
import linear_algebra.affine_space.midpoint
import data.matrix.notation
import analysis.convex.topology

import to_mathlib.topology.misc

/-!
# Ample subsets of real vector spaces

In this file we study ample set in real vector spaces. A set is ample if all its connected
component have full convex hull. We then prove this property is invariant under a number of affine
geometric operations.

As trivial examples, the empty set and the univ set are ample. After proving those fact,
the second part of the file proves that a linear subspace with codimension at least 2 has a
ample complement. This is the crucial geometric ingredient which allows to apply convex integration
to the theory of immersions in positive codimension.

All vector spaces in the file (and more generally in this folder) are real vector spaces.

## Implementation notes

The definition of ample subset asks for a vector space structure and a topology on the ambiant type
without any link between those structures, but we will only be using these for finite dimensional
vector spaces with their natural topology.
-/

/-! ## Definition and invariance -/
open set affine_map

open_locale convex matrix

variables {E F : Type*} [add_comm_group F] [module ℝ F] [topological_space F]
variables [add_comm_group E] [module ℝ E] [topological_space E]

/-- A subset of a topological real vector space is ample if the convex hull of each of its
connected components is the full space. -/
def ample_set (s : set F) : Prop :=
∀ x ∈ s, convex_hull ℝ (connected_component_in s x) = univ

/-- images of ample sets under continuous linear equivalences are ample. -/
lemma ample_set.image {s : set E} (h : ample_set s) (L : E ≃L[ℝ] F) : ample_set (L '' s) :=
begin
  intros x hx,
  rw [L.image_eq_preimage] at hx,
  have : L '' connected_component_in s (L.symm x) = connected_component_in (L '' s) x,
  { conv_rhs { rw [← L.apply_symm_apply x] },
    exact L.to_homeomorph.image_connected_component_in hx },
  rw [← this],
  refine (L.to_linear_equiv.to_linear_map.convex_hull_image _).trans _,
  rw [h (L.symm x) hx, image_univ],
  exact L.to_linear_equiv.to_equiv.range_eq_univ,
end

/-- preimages of ample sets under continuous linear equivalences are ample. -/
-- unused
lemma ample_set.preimage {s : set F} (h : ample_set s) (L : E ≃L[ℝ] F) : ample_set (L ⁻¹' s) :=
by { rw [← L.image_symm_eq_preimage], exact h.image L.symm }

open_locale pointwise
/-- Translating a ample set is ample.
We basically mimic `ample_set.image`. We could prove the common generalization using
continuous affine equivalences -/
lemma ample_set.vadd [has_continuous_add E] {s : set E} (h : ample_set s) {y : E} :
  ample_set (y +ᵥ s) :=
begin
  intros x hx,
  simp_rw [mem_vadd_set] at hx,
  obtain ⟨x, hx, rfl⟩ := hx,
  have : y +ᵥ connected_component_in s x = connected_component_in (y +ᵥ s) (y +ᵥ x),
  { exact (homeomorph.add_left y).image_connected_component_in hx },
  rw [← this],
  refine ((affine_equiv.const_vadd ℝ E y).to_affine_map.image_convex_hull _).symm.trans _,
  rw [h x hx, image_univ],
  exact (affine_equiv.to_equiv _).range_eq_univ,
end

/-! ## Trivial examples -/

/-- A whole vector space is ample. -/
lemma ample_set_univ {F : Type*} [normed_add_comm_group F] [normed_space ℝ F] :
  ample_set (univ : set F) :=
begin
  intros x _,
  rw [connected_component_in_univ, preconnected_space.connected_component_eq_univ, convex_hull_univ]
end

/-- The empty set in a vector space is ample. -/
-- unused
lemma ample_set_empty {F : Type*} [add_comm_group F] [module ℝ F] [topological_space F] :
  ample_set (∅ : set F) :=
λ _ h, false.elim h

/-! ## Codimension at least 2 subspaces have ample complement. -/

section lemma_2_13

local notation `π` := submodule.linear_proj_of_is_compl _ _
local attribute [instance, priority 100] topological_add_group.path_connected

/-- Given two complementary subspaces `p` and `q` in `F`, if the complement of `{0}`
is path connected in `p` then the complement of `q` is path connected in `F`. -/
lemma is_path_connected_compl_of_is_path_connected_compl_zero [topological_add_group F]
  [has_continuous_smul ℝ F] {p q : submodule ℝ F} (hpq : is_compl p q)
  (hpc : is_path_connected ({0}ᶜ : set p)) : is_path_connected (qᶜ : set F) :=
begin
  rw is_path_connected_iff at ⊢ hpc,
  split,
  { rcases hpc.1 with ⟨a, ha⟩,
    exact ⟨a, mt (submodule.eq_zero_of_coe_mem_of_disjoint hpq.disjoint) ha⟩ },
  { intros x hx y hy,
    have : π hpq x ≠ 0 ∧ π hpq y ≠ 0,
    { split;
      intro h;
      rw submodule.linear_proj_of_is_compl_apply_eq_zero_iff hpq at h;
      [exact hx h, exact hy h] },
    rcases hpc.2 (π hpq x) this.1 (π hpq y) this.2 with ⟨γ₁, hγ₁⟩,
    let γ₂ := path_connected_space.some_path (π hpq.symm x) (π hpq.symm y),
    let γ₁' : path (_ : F) _ := γ₁.map continuous_subtype_coe,
    let γ₂' : path (_ : F) _ := γ₂.map continuous_subtype_coe,
    refine ⟨(γ₁'.add γ₂').cast
      (submodule.linear_proj_add_linear_proj_of_is_compl_eq_self hpq x).symm
      (submodule.linear_proj_add_linear_proj_of_is_compl_eq_self hpq y).symm, _⟩,
    intros t,
    rw [path.cast_coe, path.add_apply],
    change (γ₁ t : F) + (γ₂ t : F) ∉ q,
    rw [← submodule.linear_proj_of_is_compl_apply_eq_zero_iff hpq, linear_map.map_add,
        submodule.linear_proj_of_is_compl_apply_right hpq, add_zero,
        submodule.linear_proj_of_is_compl_apply_eq_zero_iff hpq],
    exact mt (submodule.eq_zero_of_coe_mem_of_disjoint hpq.disjoint) (hγ₁ t) }
end

/-- For `x` and `y` in a real vector space, if `x ≠ 0` and `0` is in the segment from
`x` to `y` then `y` is on the line spanned by `x`.  -/
lemma mem_span_of_zero_mem_segment {F : Type*} [add_comm_group F] [module ℝ F]
  {x y : F} (hx : x ≠ 0) (h : (0 : F) ∈ [x -[ℝ] y]) :
  y ∈ submodule.span ℝ ({x} : set F) :=
begin
  rw segment_eq_image at h,
  rcases h with ⟨t, ht, htxy⟩,
  rw submodule.mem_span_singleton,
  dsimp only at htxy,
  use (t-1)/t,
  have : t ≠ 0,
  { intro h,
    rw h at htxy,
    refine hx _,
    simpa using htxy },
  rw [← smul_eq_zero_iff_eq' (neg_ne_zero.mpr $ inv_ne_zero this),
      smul_add, smul_smul, smul_smul, ← neg_one_mul, mul_assoc, mul_assoc,
      inv_mul_cancel this, mul_one, neg_one_smul, add_neg_eq_zero] at htxy,
  convert htxy,
  ring
end

variables [topological_add_group F] [has_continuous_smul ℝ F]

/-- For `x` and `y` in a real vector space, if `x ≠ 0` and `y` is not on the line
spanned by `x` then `x` and `y` can be joined by a path in the complement of `{0}`.  -/
lemma joined_in_compl_zero_of_not_mem_span
  {x y : F} (hx : x ≠ 0) (hy : y ∉ submodule.span ℝ ({x} : set F)) :
  joined_in ({0}ᶜ : set F) x y :=
begin
  refine joined_in.of_line line_map_continuous.continuous_on
    (line_map_apply_zero _ _) (line_map_apply_one _ _) _,
  rw ← segment_eq_image_line_map,
  exact λ t ht (h' : t = 0), (mt (mem_span_of_zero_mem_segment hx) hy) (h' ▸ ht)
end

/-- In a vector space whose dimension is at least 2, the complement of
`{0}` is ample. -/
lemma is_path_connected_compl_zero_of_two_le_dim
  (hdim : 2 ≤ module.rank ℝ F) : is_path_connected ({0}ᶜ : set F) :=
begin
  rw is_path_connected_iff,
  split,
  { suffices : 0 < module.rank ℝ F,
      by rwa dim_pos_iff_exists_ne_zero at this,
    exact lt_of_lt_of_le (by norm_num) hdim },
  { intros x hx y hy,
    by_cases h : y ∈ submodule.span ℝ ({x} : set F),
    { suffices : ∃ z, z ∉ submodule.span ℝ ({x} : set F),
      { rcases this with ⟨z, hzx⟩,
        have hzy : z ∉ submodule.span ℝ ({y} : set F),
          from λ h', hzx (submodule.mem_span_singleton_trans h' h),
        exact (joined_in_compl_zero_of_not_mem_span hx hzx).trans
          (joined_in_compl_zero_of_not_mem_span hy hzy).symm },
      by_contra h',
      push_neg at h',
      rw ← submodule.eq_top_iff' at h',
      rw [← dim_top ℝ, ← h'] at hdim,
      suffices : (2 : cardinal) ≤ 1,
        from not_le_of_lt (by norm_num) this,
      have := hdim.trans (dim_span_le _),
      rwa cardinal.mk_singleton at this },
    { exact joined_in_compl_zero_of_not_mem_span hx h } }
end

/-- Let `E` be a linear subspace in a real vector space. If `E` has codimension at
least two then its complement is path-connected. -/
lemma is_path_connected_compl_of_two_le_codim
  {E : submodule ℝ F} (hcodim : 2 ≤ module.rank ℝ (F⧸E)) :
  is_path_connected (Eᶜ : set F) :=
begin
  rcases E.exists_is_compl with ⟨E', hE'⟩,
  refine is_path_connected_compl_of_is_path_connected_compl_zero hE'.symm _,
  refine is_path_connected_compl_zero_of_two_le_dim _,
  rwa ← (E.quotient_equiv_of_is_compl E' hE').dim_eq
end

/-- Let `E` be a linear subspace in a real vector space. If `E` has codimension at
least two then its complement is connected. -/
lemma is_connected_compl_of_two_le_codim
  {E : submodule ℝ F} (hcodim : 2 ≤ module.rank ℝ (F⧸E)) :
  is_connected (Eᶜ : set F) :=
(is_path_connected_compl_of_two_le_codim hcodim).is_connected

lemma submodule.connected_component_in_eq_self_of_two_le_codim (E : submodule ℝ F)
  (hcodim : 2 ≤ module.rank ℝ (F⧸E)) {x : F} (hx : x ∉ E) :
  connected_component_in (E : set F)ᶜ x = Eᶜ :=
is_preconnected.connected_component_in (is_connected_compl_of_two_le_codim hcodim).2 hx

/-- Let `E` be a linear subspace in a real vector space. If `E` has codimension at
least two then its complement is ample. -/
lemma ample_of_two_le_codim {E : submodule ℝ F} (hcodim : 2 ≤ module.rank ℝ (F⧸E)) :
  ample_set (Eᶜ : set F) :=
begin
  intros x hx,
  rw [E.connected_component_in_eq_self_of_two_le_codim hcodim hx, eq_univ_iff_forall],
  intro y,
  by_cases h : y ∈ E,
  { rcases E.exists_is_compl with ⟨E', hE'⟩,
    rw (E.quotient_equiv_of_is_compl E' hE').dim_eq at hcodim,
    have hcodim' : 0 < module.rank ℝ E' := lt_of_lt_of_le (by norm_num) hcodim,
    rw dim_pos_iff_exists_ne_zero at hcodim',
    rcases hcodim' with ⟨z, hz⟩,
    have : y ∈ [y+(-z) -[ℝ] y+z],
    { rw ← sub_eq_add_neg,
      exact mem_segment_sub_add y z },
    refine (convex_convex_hull ℝ (Eᶜ : set F)).segment_subset _ _ this ;
    refine subset_convex_hull ℝ (Eᶜ : set F) _;
    change _ ∉ E;
    rw submodule.add_mem_iff_right _ h;
    try {rw submodule.neg_mem_iff};
    exact mt (submodule.eq_zero_of_coe_mem_of_disjoint hE'.symm.disjoint) hz },
  { exact subset_convex_hull ℝ (Eᶜ : set F) h }
end

end lemma_2_13


import algebra.ofe.basic

universes u v

instance {α : Type u} {β : Type v} [ofe α] [ofe β] : ofe (α ⊕ β) := {
  eq_at := λ n x y, sum.elim
    (λ a, sum.elim (λ b, a =[n] b) (λ _, false) y)
    (λ a, sum.elim (λ _, false) (λ b, a =[n] b) y) x,
  eq_at_reflexive := begin
    intros n x,
    cases x;
    simp only [sum.elim_inl, sum.elim_inr],
  end,
  eq_at_symmetric := begin
    intros n x y h,
    cases x; cases y;
    simp only [sum.elim_inl, sum.elim_inr] at h ⊢;
    try { exact h, };
    exact eq_at_symmetric n h,
  end,
  eq_at_transitive := begin
    intros n x y z hxy hyz,
    cases x; cases y; cases z;
    simp only [sum.elim_inl, sum.elim_inr] at hxy hyz ⊢;
    try { cases hyz, };
    try { cases hxy, };
    transitivity y;
    assumption,
  end,
  eq_at_mono' := begin
    intros m n hmn x y h,
    cases x; cases y;
    simp only [sum.elim_inl, sum.elim_inr] at h ⊢;
    try { exact h, };
    exact eq_at_mono hmn h,
  end,
  eq_at_limit' := begin
    intros x y h,
    cases x; cases y;
    simp only [sum.elim_inl, sum.elim_inr] at h ⊢;
    try { exact (h 0), };
    rw eq_at_limit;
    exact h,
  end,
}

/-- TODO: Make nicer versions of this lemma. -/
@[simp] lemma sum.eq_at {α : Type u} {β : Type v} [ofe α] [ofe β] (n : ℕ) (x y : α ⊕ β) :
  x =[n] y ↔ sum.elim
    (λ a, sum.elim (λ b, a =[n] b) (λ _, false) y)
    (λ a, sum.elim (λ _, false) (λ b, a =[n] b) y) x := iff.rfl


/-
Copyright (c) 2020 Joseph Myers. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joseph Myers, Yury Kudryashov
-/
import analysis.normed_space.basic
import analysis.normed.group.add_torsor
import linear_algebra.affine_space.midpoint
import linear_algebra.affine_space.affine_subspace
import topology.instances.real_vector_space

/-!
# Torsors of normed space actions.

This file contains lemmas about normed additive torsors over normed spaces.
-/

noncomputable theory
open_locale nnreal topological_space
open filter

variables {α V P : Type*} [semi_normed_group V] [pseudo_metric_space P] [normed_add_torsor V P]
variables {W Q : Type*} [normed_group W] [metric_space Q] [normed_add_torsor W Q]

section normed_space

variables {𝕜 : Type*} [normed_field 𝕜] [normed_space 𝕜 V] [normed_space 𝕜 W]

open affine_map

lemma affine_subspace.is_closed_direction_iff (s : affine_subspace 𝕜 Q) :
  is_closed (s.direction : set W) ↔ is_closed (s : set Q) :=
begin
  rcases s.eq_bot_or_nonempty with rfl|⟨x, hx⟩, { simp [is_closed_singleton] },
  rw [← (isometric.vadd_const x).to_homeomorph.symm.is_closed_image,
    affine_subspace.coe_direction_eq_vsub_set_right hx],
  refl
end

include V

@[simp] lemma dist_center_homothety (p₁ p₂ : P) (c : 𝕜) :
  dist p₁ (homothety p₁ c p₂) = ∥c∥ * dist p₁ p₂ :=
by simp [homothety_def, norm_smul, ← dist_eq_norm_vsub, dist_comm]

@[simp] lemma dist_homothety_center (p₁ p₂ : P) (c : 𝕜) :
  dist (homothety p₁ c p₂) p₁ = ∥c∥ * dist p₁ p₂ :=
by rw [dist_comm, dist_center_homothety]

@[simp] lemma dist_line_map_line_map (p₁ p₂ : P) (c₁ c₂ : 𝕜) :
  dist (line_map p₁ p₂ c₁) (line_map p₁ p₂ c₂) = dist c₁ c₂ * dist p₁ p₂ :=
begin
  rw dist_comm p₁ p₂,
  simp only [line_map_apply, dist_eq_norm_vsub, vadd_vsub_vadd_cancel_right, ← sub_smul, norm_smul,
    vsub_eq_sub],
end

lemma lipschitz_with_line_map (p₁ p₂ : P) :
  lipschitz_with (nndist p₁ p₂) (line_map p₁ p₂ : 𝕜 → P) :=
lipschitz_with.of_dist_le_mul $ λ c₁ c₂,
  ((dist_line_map_line_map p₁ p₂ c₁ c₂).trans (mul_comm _ _)).le

@[simp] lemma dist_line_map_left (p₁ p₂ : P) (c : 𝕜) :
  dist (line_map p₁ p₂ c) p₁ = ∥c∥ * dist p₁ p₂ :=
by simpa only [line_map_apply_zero, dist_zero_right] using dist_line_map_line_map p₁ p₂ c 0

@[simp] lemma dist_left_line_map (p₁ p₂ : P) (c : 𝕜) :
  dist p₁ (line_map p₁ p₂ c) = ∥c∥ * dist p₁ p₂ :=
(dist_comm _ _).trans (dist_line_map_left _ _ _)

@[simp] lemma dist_line_map_right (p₁ p₂ : P) (c : 𝕜) :
  dist (line_map p₁ p₂ c) p₂ = ∥1 - c∥ * dist p₁ p₂ :=
by simpa only [line_map_apply_one, dist_eq_norm'] using dist_line_map_line_map p₁ p₂ c 1

@[simp] lemma dist_right_line_map (p₁ p₂ : P) (c : 𝕜) :
  dist p₂ (line_map p₁ p₂ c) = ∥1 - c∥ * dist p₁ p₂ :=
(dist_comm _ _).trans (dist_line_map_right _ _ _)

@[simp] lemma dist_homothety_self (p₁ p₂ : P) (c : 𝕜) :
  dist (homothety p₁ c p₂) p₂ = ∥1 - c∥ * dist p₁ p₂ :=
by rw [homothety_eq_line_map, dist_line_map_right]

@[simp] lemma dist_self_homothety (p₁ p₂ : P) (c : 𝕜) :
  dist p₂ (homothety p₁ c p₂) = ∥1 - c∥ * dist p₁ p₂ :=
by rw [dist_comm, dist_homothety_self]

section invertible_two

variables [invertible (2:𝕜)]

@[simp] lemma dist_left_midpoint (p₁ p₂ : P) :
  dist p₁ (midpoint 𝕜 p₁ p₂) = ∥(2:𝕜)∥⁻¹ * dist p₁ p₂ :=
by rw [midpoint, dist_comm, dist_line_map_left, inv_of_eq_inv, ← norm_inv]

@[simp] lemma dist_midpoint_left (p₁ p₂ : P) :
  dist (midpoint 𝕜 p₁ p₂) p₁ = ∥(2:𝕜)∥⁻¹ * dist p₁ p₂ :=
by rw [dist_comm, dist_left_midpoint]

@[simp] lemma dist_midpoint_right (p₁ p₂ : P) :
  dist (midpoint 𝕜 p₁ p₂) p₂ = ∥(2:𝕜)∥⁻¹ * dist p₁ p₂ :=
by rw [midpoint_comm, dist_midpoint_left, dist_comm]

@[simp] lemma dist_right_midpoint (p₁ p₂ : P) :
  dist p₂ (midpoint 𝕜 p₁ p₂) = ∥(2:𝕜)∥⁻¹ * dist p₁ p₂ :=
by rw [dist_comm, dist_midpoint_right]

lemma dist_midpoint_midpoint_le' (p₁ p₂ p₃ p₄ : P) :
  dist (midpoint 𝕜 p₁ p₂) (midpoint 𝕜 p₃ p₄) ≤ (dist p₁ p₃ + dist p₂ p₄) / ∥(2 : 𝕜)∥ :=
begin
  rw [dist_eq_norm_vsub V, dist_eq_norm_vsub V, dist_eq_norm_vsub V, midpoint_vsub_midpoint];
    try { apply_instance },
  rw [midpoint_eq_smul_add, norm_smul, inv_of_eq_inv, norm_inv, ← div_eq_inv_mul],
  exact div_le_div_of_le_of_nonneg (norm_add_le _ _) (norm_nonneg _),
end

end invertible_two

omit V
include W

lemma antilipschitz_with_line_map {p₁ p₂ : Q} (h : p₁ ≠ p₂) :
  antilipschitz_with (nndist p₁ p₂)⁻¹ (line_map p₁ p₂ : 𝕜 → Q) :=
antilipschitz_with.of_le_mul_dist $ λ c₁ c₂, by rw [dist_line_map_line_map, nnreal.coe_inv,
  ← dist_nndist, mul_left_comm, inv_mul_cancel (dist_ne_zero.2 h), mul_one]

variables (𝕜)

lemma eventually_homothety_mem_of_mem_interior (x : Q) {s : set Q} {y : Q} (hy : y ∈ interior s) :
  ∀ᶠ δ in 𝓝 (1 : 𝕜), homothety x δ y ∈ s :=
begin
  rw (normed_group.nhds_basis_norm_lt (1 : 𝕜)).eventually_iff,
  cases eq_or_ne y x with h h, { use 1, simp [h.symm, interior_subset hy], },
  have hxy : 0 < ∥y -ᵥ x∥, { rwa [norm_pos_iff, vsub_ne_zero], },
  obtain ⟨u, hu₁, hu₂, hu₃⟩ := mem_interior.mp hy,
  obtain ⟨ε, hε, hyε⟩ := metric.is_open_iff.mp hu₂ y hu₃,
  refine ⟨ε / ∥y -ᵥ x∥, div_pos hε hxy, λ δ (hδ : ∥δ - 1∥ < ε / ∥y -ᵥ x∥), hu₁ (hyε _)⟩,
  rw [lt_div_iff hxy, ← norm_smul, sub_smul, one_smul] at hδ,
  rwa [homothety_apply, metric.mem_ball, dist_eq_norm_vsub W, vadd_vsub_eq_sub_vsub],
end

lemma eventually_homothety_image_subset_of_finite_subset_interior
  (x : Q) {s : set Q} {t : set Q} (ht : t.finite) (h : t ⊆ interior s) :
  ∀ᶠ δ in 𝓝 (1 : 𝕜), homothety x δ '' t ⊆ s :=
begin
  suffices : ∀ y ∈ t, ∀ᶠ δ in 𝓝 (1 : 𝕜), homothety x δ y ∈ s,
  { simp_rw set.image_subset_iff,
    exact (filter.eventually_all_finite ht).mpr this, },
  intros y hy,
  exact eventually_homothety_mem_of_mem_interior 𝕜 x (h hy),
end

end normed_space

variables [normed_space ℝ V] [normed_space ℝ W]

lemma dist_midpoint_midpoint_le (p₁ p₂ p₃ p₄ : V) :
  dist (midpoint ℝ p₁ p₂) (midpoint ℝ p₃ p₄) ≤ (dist p₁ p₃ + dist p₂ p₄) / 2 :=
by simpa using dist_midpoint_midpoint_le' p₁ p₂ p₃ p₄

include V W

/-- A continuous map between two normed affine spaces is an affine map provided that
it sends midpoints to midpoints. -/
def affine_map.of_map_midpoint (f : P → Q)
  (h : ∀ x y, f (midpoint ℝ x y) = midpoint ℝ (f x) (f y))
  (hfc : continuous f) :
  P →ᵃ[ℝ] Q :=
affine_map.mk' f
  ↑((add_monoid_hom.of_map_midpoint ℝ ℝ
    ((affine_equiv.vadd_const ℝ (f $ classical.arbitrary P)).symm ∘ f ∘
      (affine_equiv.vadd_const ℝ (classical.arbitrary P))) (by simp)
      (λ x y, by simp [h])).to_real_linear_map $ by apply_rules [continuous.vadd, continuous.vsub,
        continuous_const, hfc.comp, continuous_id])
  (classical.arbitrary P)
  (λ p, by simp)


import data.mv_polynomial.basic

universes u v
variables {R : Type u}

namespace mv_polynomial

variables {σ : Type*}

section comm_semiring

variables [comm_semiring R]

section eval

theorem eval_add (f g : mv_polynomial σ R) (x : σ → R) : eval x (f + g) = eval x f + eval x g :=
(eval x).map_add _ _

theorem eval_mul (f g : mv_polynomial σ R) (x : σ → R) : eval x (f * g) = eval x f * eval x g :=
(eval x).map_mul _ _

theorem eval_pow (f : mv_polynomial σ R) (n : ℕ) (x : σ → R) : eval x (f ^ n) = eval x f ^ n :=
(eval x).map_pow _ _

theorem eval_multiset_sum (s : multiset (mv_polynomial σ R)) (g : σ → R) :
	eval g (s.sum) = (s.map (eval g)).sum :=
(eval g).map_multiset_sum _

theorem eval_list_sum (l : list (mv_polynomial σ R)) (g : σ → R) :
	eval g (l.sum) = (l.map (eval g)).sum :=
(eval g).map_list_sum _

theorem eval_zip_with_mul (l₁ l₂ : list (mv_polynomial σ R)) (g : σ → R) :
	list.map (eval g) (list.zip_with (*) l₁ l₂) = list.zip_with (*) (l₁.map (eval g)) (l₂.map (eval g)) :=
begin
	induction l₁ with hd₁ tl₁ ih₁ generalizing l₂, { simp },
	induction l₂ with hd₂ tl₂ ih₂, { simp },
	simp only [list.map_cons, list.zip_with_cons_cons], split,
	{	rw eval_mul },
	exact ih₁ tl₂,
end

end eval
end comm_semiring
end mv_polynomial


section
variables (x y z : ℕ)
variables (h₁ : x = y) (h₂ : y = z)

section
variables {x y z}
include h₁ h₂
theorem foo : x = z :=
begin
  rw [h₁, h₂]
end
end

theorem bar : x = z :=
eq.trans h₁ h₂

variable {x}
theorem baz : x = x := rfl

#check @foo
#check @bar
#check @baz

end

section
parameters {α : Type*} (r : α → α → Prop)
parameter transr : ∀ {x y z}, r x y → r y z → r x z

variables {a b c d e : α}

theorem t1 (h₁ : r a b) (h₂ : r b c) (h₃ : r c d) : r a d :=
transr (transr h₁ h₂) h₃

theorem t2 (h₁ : r a b) (h₂ : r b c) (h₃ : r c d) (h₄ : r d e): r a e :=
transr h₁ (t1 h₂ h₃ h₄)

#check t1
#check t2
end

#check t1
#check t2


import algebra.ofe.prod

universes u v

instance pi.ofe {α : Type u} {β : α → Type v} [Π (a : α), ofe (β a)] :
  ofe (Π (a : α), β a) := {
  eq_at := λ n x y, ∀ a, x a =[n] y a,
  eq_at_reflexive := begin
    intros n x a,
    refl,
  end,
  eq_at_symmetric := begin
    intros n x y h a,
    rw eq_at_symm_iff,
    exact h a,
  end,
  eq_at_transitive := begin
    intros n x y z hxy hyz a,
    transitivity y a,
    exact hxy a,
    exact hyz a,
  end,
  eq_at_mono' := begin
    intros m n hmn x y h a,
    refine eq_at_mono hmn _,
    exact h a,
  end,
  eq_at_limit' := begin
    intros x y h,
    ext a,
    rw eq_at_limit,
    intro n,
    exact h n a,
  end,
}

@[simp] lemma pi.eq_at {α : Type u} {β : α → Type v} [Π (a : α), ofe (β a)]
  (n : ℕ) (x y : Π (a : α), β a) :
  x =[n] y ↔ ∀ a, x a =[n] y a := iff.rfl

def pi.ofe_bifunctor : ofe_bifunctor := {
  obj := λ α β [ofe α] [ofe β], by exactI α →ₙₑ β,
  map := λ α β γ δ [ofe α] [ofe β] [ofe γ] [ofe δ] f g,
    by exactI ⟨λ h, g.comp (h.comp f), begin
      intros n g h hgh,
      refine nonexpansive_fun.comp_left_eq_at _,
      refine nonexpansive_fun.comp_right_eq_at _,
      exact hgh,
    end⟩,
  map_id := by intros; ext; refl,
  map_comp := by intros; refl,
}

lemma pi.ofe_bifunctor_locally_nonexpansive : locally_nonexpansive_bifunctor pi.ofe_bifunctor :=
begin
  introsI α β γ δ _ _ _ _ _ _ n f₁ f₂ h g a,
  refine nonexpansive_fun.congr_fun_comp _ h.2 _,
  exact nonexpansive_fun.comp_left_eq_at h.1,
end


import data.fin.basic
import data.fintype.basic
import data.list
import ..automata_typeclass

variables {Sigma : Type} [decidable_eq Sigma]

def epsilon_lang : lang Sigma
:= λ w, w = []

def epsilon_ε_nfa {Sigma : Type*} : ε_nfa Sigma :=
  {
    Q := fin 1,
    finQ := by apply_instance,
    decQ := by apply_instance,
    inits := λ _ , true,
    decI := by apply_instance,
    final := λ _ , true,
    decF := by apply_instance,
    δ := λ _ _ _ , false,
    decD := λ _, by {dsimp[sigma.uncurry], apply_instance,},
  }

lemma epsilon_ε_nfa_lang : ∀ w : word Sigma, ε_nfa_lang epsilon_ε_nfa w ↔ epsilon_lang w :=
begin
  assume w,
  dsimp [ε_nfa_lang, epsilon_lang],
  constructor,
  {
    assume h,
    cases h with q0 h, cases h with q1 h,
    cases (and.elim_left (and.elim_right h)),
    refl,
    cases ᾰ,
    cases ᾰ,
  },
  {
    assume h,
    let z : fin 1,
      exact 0,
    existsi z, existsi z,
    constructor,
    trivial,
    constructor,
    rw h,
    fconstructor,
    trivial,
  }
end


/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Johannes Hölzl
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.linear_algebra.finsupp
import Mathlib.linear_algebra.direct_sum.tensor_product
import Mathlib.PostPort

universes u u_1 v u_2 u_3 u_4 u_5

namespace Mathlib

/-!
# Results on direct sums and finitely supported functions.

1. The linear equivalence between finitely supported functions `ι →₀ M` and
the direct sum of copies of `M` indexed by `ι`.

2. The tensor product of ι →₀ M and κ →₀ N is linearly equivalent to (ι × κ) →₀ (M ⊗ N).
-/

/-- The finitely supported functions ι →₀ M are in linear equivalence with the direct sum of
copies of M indexed by ι. -/
def finsupp_lequiv_direct_sum (R : Type u) (M : Type v) [ring R] [add_comm_group M] [module R M] (ι : Type u_1) [DecidableEq ι] : linear_equiv R (ι →₀ M) (direct_sum ι fun (i : ι) => M) :=
  linear_equiv.of_linear
    (coe_fn finsupp.lsum
      ((fun (this : ι → linear_map R M (direct_sum ι fun (i : ι) => M)) => this) (direct_sum.lof R ι fun (i : ι) => M)))
    (direct_sum.to_module R ι (ι →₀ M) finsupp.lsingle) sorry sorry

@[simp] theorem finsupp_lequiv_direct_sum_single (R : Type u) (M : Type v) [ring R] [add_comm_group M] [module R M] (ι : Type u_1) [DecidableEq ι] (i : ι) (m : M) : coe_fn (finsupp_lequiv_direct_sum R M ι) (finsupp.single i m) = coe_fn (direct_sum.lof R ι (fun (i : ι) => M) i) m :=
  finsupp.sum_single_index
    (linear_map.map_zero
      ((fun (this : ι → linear_map R M (direct_sum ι fun (i : ι) => M)) => this) (direct_sum.lof R ι fun (i : ι) => M) i))

@[simp] theorem finsupp_lequiv_direct_sum_symm_lof (R : Type u) (M : Type v) [ring R] [add_comm_group M] [module R M] (ι : Type u_1) [DecidableEq ι] (i : ι) (m : M) : coe_fn (linear_equiv.symm (finsupp_lequiv_direct_sum R M ι)) (coe_fn (direct_sum.lof R ι (fun (i : ι) => M) i) m) =
  finsupp.single i m :=
  direct_sum.to_module_lof R i m

/-- The tensor product of ι →₀ M and κ →₀ N is linearly equivalent to (ι × κ) →₀ (M ⊗ N). -/
def finsupp_tensor_finsupp (R : Type u_1) (M : Type u_2) (N : Type u_3) (ι : Type u_4) (κ : Type u_5) [comm_ring R] [add_comm_group M] [module R M] [add_comm_group N] [module R N] : linear_equiv R (tensor_product R (ι →₀ M) (κ →₀ N)) (ι × κ →₀ tensor_product R M N) :=
  linear_equiv.trans (tensor_product.congr (finsupp_lequiv_direct_sum R M ι) (finsupp_lequiv_direct_sum R N κ))
    (linear_equiv.trans (tensor_product.direct_sum R ι κ (fun (i : ι) => M) fun (i : κ) => N)
      (linear_equiv.symm (finsupp_lequiv_direct_sum R (tensor_product R M N) (ι × κ))))

@[simp] theorem finsupp_tensor_finsupp_single (R : Type u_1) (M : Type u_2) (N : Type u_3) (ι : Type u_4) (κ : Type u_5) [comm_ring R] [add_comm_group M] [module R M] [add_comm_group N] [module R N] (i : ι) (m : M) (k : κ) (n : N) : coe_fn (finsupp_tensor_finsupp R M N ι κ) (tensor_product.tmul R (finsupp.single i m) (finsupp.single k n)) =
  finsupp.single (i, k) (tensor_product.tmul R m n) := sorry

@[simp] theorem finsupp_tensor_finsupp_symm_single (R : Type u_1) (M : Type u_2) (N : Type u_3) (ι : Type u_4) (κ : Type u_5) [comm_ring R] [add_comm_group M] [module R M] [add_comm_group N] [module R N] (i : ι × κ) (m : M) (n : N) : coe_fn (linear_equiv.symm (finsupp_tensor_finsupp R M N ι κ)) (finsupp.single i (tensor_product.tmul R m n)) =
  tensor_product.tmul R (finsupp.single (prod.fst i) m) (finsupp.single (prod.snd i) n) := sorry


import .LDLT .mat

variables {α β : Type}
variables {k m n : nat}

open mat tactic

meta instance int.has_reflect : has_reflect ℤ :=
by tactic.mk_has_reflect_instance

meta def rat.to_expr : rat → expr
| ⟨i,n,_,_⟩ := `(rat.mk %%`(i) (int.of_nat %%`(n)))

def array₂.to_mat [ring α] (A : array₂ m n α) : mat α m n := A.read

meta def array.to_list_expr (a₁ : array n rat) : expr :=
a₁.iterate
 `(@list.nil rat)
  (λ i a x₁, let x := a.to_expr in
    `(@list.cons rat %%x %%x₁))

meta def array₂.to_lists_expr (a₂ : array₂ m n rat) : expr :=
a₂.iterate `(@list.nil (list rat))
  (λ i a₁ x₂, let x₁ := a₁.to_list_expr in
    `(@list.append (list rat) %%x₂ [@list.reverse rat %%x₁]))

def mat.write_to_row [ring α] (A : mat α m n)
(i : fin m) (a₁ : array n α) : array n α :=
a₁.foreach (λ j _, A i j)

def mat.write_to_array₂ [ring α] (A : mat α m n)
(a₂ : array₂ m n α) : array₂ m n α :=
array.foreach a₂ (mat.write_to_row A)

def mat.to_array₂ [ring α] (A : mat α m n) : array₂ m n α :=
let a₂ := array₂.mk m n (0 : α) in
mat.write_to_array₂ A a₂

instance mat.has_repr [ring α] [has_repr α] : has_repr (mat α m n) :=
⟨λ A, repr A.to_array₂⟩

lemma pos_semidef_of_eq_LDLT (A L D : mat rat m m) :
   A = L * D * Lᵀ → pos_semidef A := sorry

meta def show_psd : tactic unit :=
do `(@pos_semidef %%mx rat _ %%Ax) ← target,
   m ← eval_expr nat mx,
   A ← eval_expr (mat rat m m) Ax,
   a₂ ← return (LDLT 0 A.to_array₂),
   llx ← return a₂.to_lists_expr,
   A'x ← to_expr ``(@lists_to_mat rat _ %%mx %%mx %%llx),
   Lx ← to_expr ``(mat.lower_triangle %%A'x),
   Dx ← to_expr ``(mat.get_diagonal %%A'x),
   to_expr ``(pos_semidef_of_eq_LDLT %%Ax %%Lx %%Dx) >>= apply,
   exact_dec_trivial

meta def trace_rhs : tactic unit :=
do `(@eq (mat rat %%mx _) %%lx %%rx) ← target,
   m ← eval_expr nat mx,
   rhs ← eval_expr (mat rat m m) rx,
   trace (repr rhs)

meta def trace_lhs : tactic unit :=
do `(@eq (mat rat %%mx _) %%lx %%rx) ← target,
   m ← eval_expr nat mx,
   lhs ← eval_expr (mat rat m m) lx,
   trace (repr lhs)

def foo_1 : array 3 rat := ([2,-1,0] : list rat).to_array
def foo_2 : array 3 rat := ([-1,2,-1] : list rat).to_array
def foo_3 : array 3 rat := ([0,-1,1] : list rat).to_array
def foo : array₂ 3 3 rat := [foo_1, foo_2, foo_3].to_array
def bar : mat rat 3 3 := foo.to_mat

example : pos_semidef bar := by show_psd