/-
Copyright (c) 2021 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import data.matrix.basis
import data.matrix.dmatrix
import linear_algebra.matrix.determinant
import linear_algebra.matrix.reindex
import tactic.field_simp

/-!
# Transvections

Transvections are matrices of the form `1 + std_basis_matrix i j c`, where `std_basis_matrix i j c`
is the basic matrix with a `c` at position `(i, j)`. Multiplying by such a transvection on the left
(resp. on the right) amounts to adding `c` times the `j`-th row to to the `i`-th row
(resp `c` times the `i`-th column to the `j`-th column). Therefore, they are useful to present
algorithms operating on rows and columns.

Transvections are a special case of *elementary matrices* (according to most references, these also
contain the matrices exchanging rows, and the matrices multiplying a row by a constant).

We show that, over a field, any matrix can be written as `L ⬝ D ⬝ L'`, where `L` and `L'` are
products of transvections and `D` is diagonal. In other words, one can reduce a matrix to diagonal
form by operations on its rows and columns, a variant of Gauss' pivot algorithm.

## Main definitions and results

* `transvection i j c` is the matrix equal to `1 + std_basis_matrix i j c`.
* `transvection_struct n R` is a structure containing the data of `i, j, c` and a proof that
  `i ≠ j`. These are often easier to manipulate than straight matrices, especially in inductive
  arguments.

* `exists_list_transvec_mul_diagonal_mul_list_transvec` states that any matrix `M` over a field can
  be written in the form `t_1 ⬝ ... ⬝ t_k ⬝ D ⬝ t'_1 ⬝ ... ⬝ t'_l`, where `D` is diagonal and
  the `t_i`, `t'_j` are transvections.

* `diagonal_transvection_induction` shows that a property which is true for diagonal matrices and
  transvections, and invariant under product, is true for all matrices.
* `diagonal_transvection_induction_of_det_ne_zero` is the same statement over invertible matrices.

## Implementation details

The proof of the reduction results is done inductively on the size of the matrices, reducing an
`(r + 1) × (r + 1)` matrix to a matrix whose last row and column are zeroes, except possibly for
the last diagonal entry. This step is done as follows.

If all the coefficients on the last row and column are zero, there is nothing to do. Otherwise,
one can put a nonzero coefficient in the last diagonal entry by a row or column operation, and then
subtract this last diagonal entry from the other entries in the last row and column to make them
vanish.

This step is done in the type `fin r ⊕ unit`, where `fin r` is useful to choose arbitrarily some
order in which we cancel the coefficients, and the sum structure is useful to use the formalism of
block matrices.

To proceed with the induction, we reindex our matrices to reduce to the above situation.
-/

universes u₁ u₂

namespace matrix
open_locale matrix

variables (n p : Type*) (R : Type u₂) {𝕜 : Type*} [field 𝕜]
variables [decidable_eq n] [decidable_eq p]
variables [comm_ring R]

section transvection
variables {R n} (i j : n)

/-- The transvection matrix `transvection i j c` is equal to the identity plus `c` at position
`(i, j)`. Multiplying by it on the left (as in `transvection i j c ⬝ M`) corresponds to adding
`c` times the `j`-th line of `M` to its `i`-th line. Multiplying by it on the right corresponds
to adding `c` times the `i`-th column to the `j`-th column. -/
def transvection (c : R) : matrix n n R := 1 + matrix.std_basis_matrix i j c

@[simp] lemma transvection_zero : transvection i j (0 : R) = 1 :=
by simp [transvection]

section

/-- A transvection matrix is obtained from the identity by adding `c` times the `j`-th row to
the `i`-th row. -/
lemma update_row_eq_transvection [finite n] (c : R) :
  update_row (1 : matrix n n R) i (((1 : matrix n n R)) i + c • (1 : matrix n n R) j) =
    transvection i j c :=
begin
  casesI nonempty_fintype n,
  ext a b,
  by_cases ha : i = a, by_cases hb : j = b,
  { simp only [update_row, transvection, ha, hb, function.update_same, std_basis_matrix.apply_same,
      pi.add_apply, one_apply_eq, pi.smul_apply, mul_one, algebra.id.smul_eq_mul], },
  { simp only [update_row, transvection, ha, hb, std_basis_matrix.apply_of_ne, function.update_same,
      pi.add_apply, ne.def, not_false_iff, pi.smul_apply, and_false, one_apply_ne,
      algebra.id.smul_eq_mul, mul_zero] },
  { simp only [update_row, transvection, ha, ne.symm ha, std_basis_matrix.apply_of_ne, add_zero,
      algebra.id.smul_eq_mul, function.update_noteq, ne.def, not_false_iff, dmatrix.add_apply,
      pi.smul_apply, mul_zero, false_and] },
end

variables [fintype n]

lemma transvection_mul_transvection_same (h : i ≠ j) (c d : R) :
  transvection i j c ⬝ transvection i j d = transvection i j (c + d) :=
by simp [transvection, matrix.add_mul, matrix.mul_add, h, h.symm, add_smul, add_assoc,
    std_basis_matrix_add]

@[simp] lemma transvection_mul_apply_same (b : n) (c : R) (M : matrix n n R) :
  (transvection i j c ⬝ M) i b = M i b + c * M j b :=
by simp [transvection, matrix.add_mul]

@[simp] lemma mul_transvection_apply_same (a : n) (c : R) (M : matrix n n R) :
  (M ⬝ transvection i j c) a j = M a j + c * M a i :=
by simp [transvection, matrix.mul_add, mul_comm]

@[simp] lemma transvection_mul_apply_of_ne (a b : n) (ha : a ≠ i) (c : R) (M : matrix n n R) :
  (transvection i j c ⬝ M) a b = M a b :=
by simp [transvection, matrix.add_mul, ha]

@[simp]

@[simp] lemma det_transvection_of_ne (h : i ≠ j) (c : R) : det (transvection i j c) = 1 :=
by rw [← update_row_eq_transvection i j, det_update_row_add_smul_self _ h, det_one]

end

variables (R n)

/-- A structure containing all the information from which one can build a nontrivial transvection.
This structure is easier to manipulate than transvections as one has a direct access to all the
relevant fields. -/
@[nolint has_nonempty_instance]
structure transvection_struct :=
(i j : n)
(hij : i ≠ j)
(c : R)

instance [nontrivial n] : nonempty (transvection_struct n R) :=
by { choose x y hxy using exists_pair_ne n, exact ⟨⟨x, y, hxy, 0⟩⟩ }

namespace transvection_struct

variables {R n}

/-- Associating to a `transvection_struct` the corresponding transvection matrix. -/
def to_matrix (t : transvection_struct n R) : matrix n n R :=
transvection t.i t.j t.c

@[simp] lemma to_matrix_mk (i j : n) (hij : i ≠ j) (c : R) :
  transvection_struct.to_matrix ⟨i, j, hij, c⟩ = transvection i j c := rfl

@[simp] protected lemma det [fintype n] (t : transvection_struct n R) : det t.to_matrix = 1 :=
det_transvection_of_ne _ _ t.hij _

@[simp] lemma det_to_matrix_prod [fintype n] (L : list (transvection_struct n 𝕜)) :
  det ((L.map to_matrix).prod) = 1 :=
begin
  induction L with t L IH,
  { simp },
  { simp [IH], }
end

/-- The inverse of a `transvection_struct`, designed so that `t.inv.to_matrix` is the inverse of
`t.to_matrix`. -/
@[simps] protected def inv (t : transvection_struct n R) : transvection_struct n R :=
{ i := t.i,
  j := t.j,
  hij := t.hij,
  c := - t.c }

section
variable [fintype n]

lemma inv_mul (t : transvection_struct n R) :
  t.inv.to_matrix ⬝ t.to_matrix = 1 :=
by { rcases t, simp [to_matrix, transvection_mul_transvection_same, t_hij] }

lemma mul_inv (t : transvection_struct n R) :
  t.to_matrix ⬝ t.inv.to_matrix = 1 :=
by { rcases t, simp [to_matrix, transvection_mul_transvection_same, t_hij] }

lemma reverse_inv_prod_mul_prod (L : list (transvection_struct n R)) :
  (L.reverse.map (to_matrix ∘ transvection_struct.inv)).prod ⬝ (L.map to_matrix).prod = 1 :=
begin
  induction L with t L IH,
  { simp },
  { suffices : (L.reverse.map (to_matrix ∘ transvection_struct.inv)).prod ⬝
      (t.inv.to_matrix ⬝ t.to_matrix) ⬝ (L.map to_matrix).prod = 1, by simpa [matrix.mul_assoc],
    simpa [inv_mul] using IH, }
end

lemma prod_mul_reverse_inv_prod (L : list (transvection_struct n R)) :
  (L.map to_matrix).prod ⬝ (L.reverse.map (to_matrix ∘ transvection_struct.inv)).prod = 1 :=
begin
  induction L with t L IH,
  { simp },
  { suffices : t.to_matrix ⬝ ((L.map to_matrix).prod ⬝
      (L.reverse.map (to_matrix ∘ transvection_struct.inv)).prod) ⬝ t.inv.to_matrix = 1,
        by simpa [matrix.mul_assoc],
    simp_rw [IH, matrix.mul_one, t.mul_inv], }
end

end

variables (p)

open sum

/-- Given a `transvection_struct` on `n`, define the corresponding `transvection_struct` on `n ⊕ p`
using the identity on `p`. -/
def sum_inl (t : transvection_struct n R) : transvection_struct (n ⊕ p) R :=
{ i := inl t.i,
  j := inl t.j,
  hij := by simp [t.hij],
  c := t.c }

lemma to_matrix_sum_inl (t : transvection_struct n R) :
  (t.sum_inl p).to_matrix = from_blocks t.to_matrix 0 0 1 :=
begin
  cases t,
  ext a b,
  cases a; cases b,
  { by_cases h : a = b;
    simp [transvection_struct.sum_inl, transvection, h, std_basis_matrix], },
  { simp [transvection_struct.sum_inl, transvection] },
  { simp [transvection_struct.sum_inl, transvection] },
  { by_cases h : a = b;
    simp [transvection_struct.sum_inl, transvection, h] },
end

@[simp] lemma sum_inl_to_matrix_prod_mul [fintype n] [fintype p]
  (M : matrix n n R) (L : list (transvection_struct n R)) (N : matrix p p R) :
  (L.map (to_matrix ∘ sum_inl p)).prod ⬝ from_blocks M 0 0 N
  = from_blocks ((L.map to_matrix).prod ⬝ M) 0 0 N :=
begin
  induction L with t L IH,
  { simp },
  { simp [matrix.mul_assoc, IH, to_matrix_sum_inl, from_blocks_multiply], },
end

@[simp] lemma mul_sum_inl_to_matrix_prod [fintype n] [fintype p]
  (M : matrix n n R) (L : list (transvection_struct n R)) (N : matrix p p R) :
  (from_blocks M 0 0 N) ⬝ (L.map (to_matrix ∘ sum_inl p)).prod
  = from_blocks (M ⬝ (L.map to_matrix).prod) 0 0 N :=
begin
  induction L with t L IH generalizing M N,
  { simp },
  { simp [IH, to_matrix_sum_inl, from_blocks_multiply], },
end

variable {p}

/-- Given a `transvection_struct` on `n` and an equivalence between `n` and `p`, define the
corresponding `transvection_struct` on `p`. -/
def reindex_equiv (e : n ≃ p) (t : transvection_struct n R) : transvection_struct p R :=
{ i := e t.i,
  j := e t.j,
  hij := by simp [t.hij],
  c := t.c }

variables [fintype n] [fintype p]

lemma to_matrix_reindex_equiv (e : n ≃ p) (t : transvection_struct n R) :
  (t.reindex_equiv e).to_matrix = reindex_alg_equiv R e t.to_matrix :=
begin
  cases t,
  ext a b,
  simp only [reindex_equiv, transvection, mul_boole, algebra.id.smul_eq_mul, to_matrix_mk,
    submatrix_apply, reindex_apply, dmatrix.add_apply, pi.smul_apply, reindex_alg_equiv_apply],
  by_cases ha : e t_i = a; by_cases hb : e t_j = b; by_cases hab : a = b;
  simp [ha, hb, hab, ← e.apply_eq_iff_eq_symm_apply, std_basis_matrix]
end

lemma to_matrix_reindex_equiv_prod (e : n ≃ p) (L : list (transvection_struct n R)) :
  (L.map (to_matrix ∘ (reindex_equiv e))).prod = reindex_alg_equiv R e (L.map to_matrix).prod :=
begin
  induction L with t L IH,
  { simp },
  { simp only [to_matrix_reindex_equiv, IH, function.comp_app, list.prod_cons, mul_eq_mul,
      reindex_alg_equiv_apply, list.map],
    exact (reindex_alg_equiv_mul _ _ _ _).symm }
end

end transvection_struct

end transvection

/-!
# Reducing matrices by left and right multiplication by transvections

In this section, we show that any matrix can be reduced to diagonal form by left and right
multiplication by transvections (or, equivalently, by elementary operations on lines and columns).
The main step is to kill the last row and column of a matrix in `fin r ⊕ unit` with nonzero last
coefficient, by subtracting this coefficient from the other ones. The list of these operations is
recorded in `list_transvec_col M` and `list_transvec_row M`. We have to analyze inductively how
these operations affect the coefficients in the last row and the last column to conclude that they
have the desired effect.

Once this is done, one concludes the reduction by induction on the size
of the matrices, through a suitable reindexing to identify any fintype with `fin r ⊕ unit`.
-/

namespace pivot

variables {R} {r : ℕ} (M : matrix (fin r ⊕ unit) (fin r ⊕ unit) 𝕜)

open sum unit fin transvection_struct

/-- A list of transvections such that multiplying on the left with these transvections will replace
the last column with zeroes. -/
def list_transvec_col : list (matrix (fin r ⊕ unit) (fin r ⊕ unit) 𝕜) :=
list.of_fn $ λ i : fin r, transvection (inl i) (inr star) $
  -M (inl i) (inr star) / M (inr star) (inr star)

/-- A list of transvections such that multiplying on the right with these transvections will replace
the last row with zeroes. -/
def list_transvec_row : list (matrix (fin r ⊕ unit) (fin r ⊕ unit) 𝕜) :=
list.of_fn $ λ i : fin r, transvection (inr star) (inl i) $
  -M (inr star) (inl i) / M (inr star) (inr star)

/-- Multiplying by some of the matrices in `list_transvec_col M` does not change the last row. -/
lemma list_transvec_col_mul_last_row_drop (i : fin r ⊕ unit) {k : ℕ} (hk : k ≤ r) :
  (((list_transvec_col M).drop k).prod ⬝ M) (inr star) i = M (inr star) i :=
begin
  apply nat.decreasing_induction' _ hk,
  { simp only [list_transvec_col, list.length_of_fn, matrix.one_mul, list.drop_eq_nil_of_le,
      list.prod_nil], },
  { assume n hn hk IH,
    have hn' : n < (list_transvec_col M).length, by simpa [list_transvec_col] using hn,
    rw ← list.cons_nth_le_drop_succ hn',
    simpa [list_transvec_col, matrix.mul_assoc] }
end

/-- Multiplying by all the matrices in `list_transvec_col M` does not change the last row. -/
lemma list_transvec_col_mul_last_row (i : fin r ⊕ unit) :
  ((list_transvec_col M).prod ⬝ M) (inr star) i = M (inr star) i :=
by simpa using list_transvec_col_mul_last_row_drop M i (zero_le _)

/-- Multiplying by all the matrices in `list_transvec_col M` kills all the coefficients in the
last column but the last one. -/
lemma list_transvec_col_mul_last_col (hM : M (inr star) (inr star) ≠ 0) (i : fin r) :
  ((list_transvec_col M).prod ⬝ M) (inl i) (inr star) = 0 :=
begin
  suffices H : ∀ (k : ℕ), k ≤ r → (((list_transvec_col M).drop k).prod ⬝ M) (inl i) (inr star) =
    if k ≤ i then 0 else M (inl i) (inr star),
      by simpa only [if_true, list.drop.equations._eqn_1] using H 0 (zero_le _),
  assume k hk,
  apply nat.decreasing_induction' _ hk,
  { simp only [list_transvec_col, list.length_of_fn, matrix.one_mul, list.drop_eq_nil_of_le,
      list.prod_nil],
    rw if_neg,
    simpa only [not_le] using i.2 },
  { assume n hn hk IH,
    have hn' : n < (list_transvec_col M).length, by simpa [list_transvec_col] using hn,
    let n' : fin r := ⟨n, hn⟩,
    rw ← list.cons_nth_le_drop_succ hn',
    have A : (list_transvec_col M).nth_le n hn' = transvection (inl n') (inr star)
      (-M (inl n') (inr star) / M (inr star) (inr star)), by simp [list_transvec_col],
    simp only [matrix.mul_assoc, A, matrix.mul_eq_mul, list.prod_cons],
    by_cases h : n' = i,
    { have hni : n = i,
      { cases i, simp only [fin.mk_eq_mk] at h, simp [h] },
      rw [h, transvection_mul_apply_same, IH, list_transvec_col_mul_last_row_drop _ _ hn, ← hni],
      field_simp [hM] },
    { have hni : n ≠ i,
      { rintros rfl, cases i, simpa using h },
      simp only [transvection_mul_apply_of_ne, ne.def, not_false_iff, ne.symm h],
      rw IH,
      rcases le_or_lt (n+1) i with hi|hi,
      { simp only [hi, n.le_succ.trans hi, if_true] },
      { rw [if_neg, if_neg],
        { simpa only [hni.symm, not_le, or_false] using nat.lt_succ_iff_lt_or_eq.1 hi },
        { simpa only [not_le] using hi } } } }
end

/-- Multiplying by some of the matrices in `list_transvec_row M` does not change the last column. -/
lemma mul_list_transvec_row_last_col_take (i : fin r ⊕ unit) {k : ℕ} (hk : k ≤ r) :
  (M ⬝ ((list_transvec_row M).take k).prod) i (inr star) = M i (inr star) :=
begin
  induction k with k IH,
  { simp only [matrix.mul_one, list.take_zero, list.prod_nil], },
  { have hkr : k < r := hk,
    let k' : fin r := ⟨k, hkr⟩,
    have : (list_transvec_row M).nth k = ↑(transvection (inr unit.star) (inl k')
      (-M (inr unit.star) (inl k') / M (inr unit.star) (inr unit.star))),
    { simp only [list_transvec_row, list.of_fn_nth_val, hkr, dif_pos, list.nth_of_fn], refl },
    simp only [list.take_succ, ← matrix.mul_assoc, this, list.prod_append, matrix.mul_one,
      matrix.mul_eq_mul, list.prod_cons, list.prod_nil, option.to_list_some],
    rw [mul_transvection_apply_of_ne, IH hkr.le],
    simp only [ne.def, not_false_iff], }
end

/-- Multiplying by all the matrices in `list_transvec_row M` does not change the last column. -/
lemma mul_list_transvec_row_last_col (i : fin r ⊕ unit) :
  (M ⬝ (list_transvec_row M).prod) i (inr star) = M i (inr star) :=
begin
  have A : (list_transvec_row M).length = r, by simp [list_transvec_row],
  rw [← list.take_length (list_transvec_row M), A],
  simpa using mul_list_transvec_row_last_col_take M i le_rfl,
end

/-- Multiplying by all the matrices in `list_transvec_row M` kills all the coefficients in the
last row but the last one. -/
lemma mul_list_transvec_row_last_row (hM : M (inr star) (inr star) ≠ 0) (i : fin r) :
  (M ⬝ (list_transvec_row M).prod) (inr star) (inl i) = 0 :=
begin
  suffices H : ∀ (k : ℕ), k ≤ r → (M ⬝ ((list_transvec_row M).take k).prod) (inr star) (inl i) =
    if k ≤ i then M (inr star) (inl i) else 0,
  { have A : (list_transvec_row M).length = r, by simp [list_transvec_row],
    rw [← list.take_length (list_transvec_row M), A],
    have : ¬ (r ≤ i), by simp,
    simpa only [this, ite_eq_right_iff] using H r le_rfl },
  assume k hk,
  induction k with n IH,
  { simp only [if_true, matrix.mul_one, list.take_zero, zero_le', list.prod_nil] },
  { have hnr : n < r := hk,
    let n' : fin r := ⟨n, hnr⟩,
    have A : (list_transvec_row M).nth n = ↑(transvection (inr unit.star) (inl n')
      (-M (inr unit.star) (inl n') / M (inr unit.star) (inr unit.star))),
    { simp only [list_transvec_row, list.of_fn_nth_val, hnr, dif_pos, list.nth_of_fn], refl },
    simp only [list.take_succ, A, ← matrix.mul_assoc, list.prod_append, matrix.mul_one,
      matrix.mul_eq_mul, list.prod_cons, list.prod_nil, option.to_list_some],
    by_cases h : n' = i,
    { have hni : n = i,
      { cases i, simp only [fin.mk_eq_mk] at h, simp only [h, coe_mk] },
      have : ¬ (n.succ ≤ i), by simp only [← hni, n.lt_succ_self, not_le],
      simp only [h, mul_transvection_apply_same, list.take, if_false,
        mul_list_transvec_row_last_col_take _ _ hnr.le, hni.le, this, if_true, IH hnr.le],
      field_simp [hM] },
    { have hni : n ≠ i,
      { rintros rfl, cases i, simpa using h },
      simp only [IH hnr.le, ne.def, mul_transvection_apply_of_ne, not_false_iff, ne.symm h],
      rcases le_or_lt (n+1) i with hi|hi,
      { simp [hi, n.le_succ.trans hi, if_true], },
      { rw [if_neg, if_neg],
        { simpa only [not_le] using hi },
        { simpa only [hni.symm, not_le, or_false] using nat.lt_succ_iff_lt_or_eq.1 hi } } } }
end

/-- Multiplying by all the matrices either in `list_transvec_col M` and `list_transvec_row M` kills
all the coefficients in the last row but the last one. -/
lemma list_transvec_col_mul_mul_list_transvec_row_last_col
  (hM : M (inr star) (inr star) ≠ 0) (i : fin r) :
  ((list_transvec_col M).prod ⬝ M ⬝ (list_transvec_row M).prod) (inr star) (inl i) = 0 :=
begin
  have : list_transvec_row M = list_transvec_row ((list_transvec_col M).prod ⬝ M),
    by simp [list_transvec_row, list_transvec_col_mul_last_row],
  rw this,
  apply mul_list_transvec_row_last_row,
  simpa [list_transvec_col_mul_last_row] using hM
end

/-- Multiplying by all the matrices either in `list_transvec_col M` and `list_transvec_row M` kills
all the coefficients in the last column but the last one. -/
lemma list_transvec_col_mul_mul_list_transvec_row_last_row
  (hM : M (inr star) (inr star) ≠ 0) (i : fin r) :
  ((list_transvec_col M).prod ⬝ M ⬝ (list_transvec_row M).prod) (inl i) (inr star) = 0 :=
begin
  have : list_transvec_col M = list_transvec_col (M ⬝ (list_transvec_row M).prod),
    by simp [list_transvec_col, mul_list_transvec_row_last_col],
  rw [this, matrix.mul_assoc],
  apply list_transvec_col_mul_last_col,
  simpa [mul_list_transvec_row_last_col] using hM
end

/-- Multiplying by all the matrices either in `list_transvec_col M` and `list_transvec_row M` turns
the matrix in block-diagonal form. -/
lemma is_two_block_diagonal_list_transvec_col_mul_mul_list_transvec_row
  (hM : M (inr star) (inr star) ≠ 0) :
  is_two_block_diagonal ((list_transvec_col M).prod ⬝ M ⬝ (list_transvec_row M).prod) :=
begin
  split,
  { ext i j,
    have : j = star, by simp only [eq_iff_true_of_subsingleton],
    simp [to_blocks₁₂, this, list_transvec_col_mul_mul_list_transvec_row_last_row M hM] },
  { ext i j,
    have : i = star, by simp only [eq_iff_true_of_subsingleton],
    simp [to_blocks₂₁, this, list_transvec_col_mul_mul_list_transvec_row_last_col M hM] },
end

/-- There exist two lists of `transvection_struct` such that multiplying by them on the left and
on the right makes a matrix block-diagonal, when the last coefficient is nonzero. -/
lemma exists_is_two_block_diagonal_of_ne_zero (hM : M (inr star) (inr star) ≠ 0) :
  ∃ (L L' : list (transvection_struct (fin r ⊕ unit) 𝕜)),
  is_two_block_diagonal ((L.map to_matrix).prod ⬝ M ⬝ (L'.map to_matrix).prod) :=
begin
  let L : list (transvection_struct (fin r ⊕ unit) 𝕜) :=
    list.of_fn (λ i : fin r, ⟨inl i, inr star, by simp,
      -M (inl i) (inr star) / M (inr star) (inr star)⟩),
  let L' : list (transvection_struct (fin r ⊕ unit) 𝕜) :=
    list.of_fn (λ i : fin r, ⟨inr star, inl i, by simp,
      -M (inr star) (inl i)  / M (inr star) (inr star)⟩),
  refine ⟨L, L', _⟩,
  have A : L.map to_matrix = list_transvec_col M, by simp [L, list_transvec_col, (∘)],
  have B : L'.map to_matrix = list_transvec_row M, by simp [L, list_transvec_row, (∘)],
  rw [A, B],
  exact is_two_block_diagonal_list_transvec_col_mul_mul_list_transvec_row M hM
end

/-- There exist two lists of `transvection_struct` such that multiplying by them on the left and
on the right makes a matrix block-diagonal. -/
lemma exists_is_two_block_diagonal_list_transvec_mul_mul_list_transvec
  (M : matrix (fin r ⊕ unit) (fin r ⊕ unit) 𝕜) :
  ∃ (L L' : list (transvection_struct (fin r ⊕ unit) 𝕜)),
  is_two_block_diagonal ((L.map to_matrix).prod ⬝ M ⬝ (L'.map to_matrix).prod) :=
begin
  by_cases H : is_two_block_diagonal M, { refine ⟨list.nil, list.nil, by simpa using H⟩ },
  -- we have already proved this when the last coefficient is nonzero
  by_cases hM : M (inr star) (inr star) ≠ 0,
  { exact exists_is_two_block_diagonal_of_ne_zero M hM },
  -- when the last coefficient is zero but there is a nonzero coefficient on the last row or the
  -- last column, we will first put this nonzero coefficient in last position, and then argue as
  -- above.
  push_neg at hM,
  simp [not_and_distrib, is_two_block_diagonal, to_blocks₁₂, to_blocks₂₁, ←matrix.ext_iff] at H,
  have : ∃ (i : fin r), M (inl i) (inr star) ≠ 0 ∨ M (inr star) (inl i) ≠ 0,
  { cases H,
    { contrapose! H,
      rintros i ⟨⟩,
      exact (H i).1 },
    { contrapose! H,
      rintros ⟨⟩ j,
      exact (H j).2, } },
  rcases this with ⟨i, h|h⟩,
  { let M' := transvection (inr unit.star) (inl i) 1 ⬝ M,
    have hM' : M' (inr star) (inr star) ≠ 0, by simpa [M', hM],
    rcases exists_is_two_block_diagonal_of_ne_zero M' hM' with ⟨L, L', hLL'⟩,
    rw matrix.mul_assoc at hLL',
    refine ⟨L ++ [⟨inr star, inl i, by simp, 1⟩], L', _⟩,
    simp only [list.map_append, list.prod_append, matrix.mul_one, to_matrix_mk, list.prod_cons,
      list.prod_nil, mul_eq_mul, list.map, matrix.mul_assoc (L.map to_matrix).prod],
    exact hLL' },
  { let M' := M ⬝ transvection (inl i) (inr star) 1,
    have hM' : M' (inr star) (inr star) ≠ 0, by simpa [M', hM],
    rcases exists_is_two_block_diagonal_of_ne_zero M' hM' with ⟨L, L', hLL'⟩,
    refine ⟨L, ⟨inl i, inr star, by simp, 1⟩ :: L', _⟩,
    simp only [←matrix.mul_assoc, to_matrix_mk, list.prod_cons, mul_eq_mul, list.map],
    rw [matrix.mul_assoc (L.map to_matrix).prod],
    exact hLL' }
end

/-- Inductive step for the reduction: if one knows that any size `r` matrix can be reduced to
diagonal form by elementary operations, then one deduces it for matrices over `fin r ⊕ unit`. -/
lemma exists_list_transvec_mul_mul_list_transvec_eq_diagonal_induction
  (IH : ∀ (M : matrix (fin r) (fin r) 𝕜),
    ∃ (L₀ L₀' : list (transvection_struct (fin r) 𝕜)) (D₀ : (fin r) → 𝕜),
      (L₀.map to_matrix).prod ⬝ M ⬝ (L₀'.map to_matrix).prod = diagonal D₀)
  (M : matrix (fin r ⊕ unit) (fin r ⊕ unit) 𝕜) :
  ∃ (L L' : list (transvection_struct (fin r ⊕ unit) 𝕜)) (D : fin r ⊕ unit → 𝕜),
    (L.map to_matrix).prod ⬝ M ⬝ (L'.map to_matrix).prod = diagonal D :=
begin
  rcases exists_is_two_block_diagonal_list_transvec_mul_mul_list_transvec M with ⟨L₁, L₁', hM⟩,
  let M' := (L₁.map to_matrix).prod ⬝ M ⬝ (L₁'.map to_matrix).prod,
  let M'' := to_blocks₁₁ M',
  rcases IH M'' with ⟨L₀, L₀', D₀, h₀⟩,
  set c := M' (inr star) (inr star) with hc,
  refine ⟨L₀.map (sum_inl unit) ++ L₁, L₁' ++ L₀'.map (sum_inl unit),
    sum.elim D₀ (λ _, M' (inr star) (inr star)), _⟩,
  suffices :
    (L₀.map (to_matrix ∘ sum_inl unit)).prod ⬝ M' ⬝ (L₀'.map (to_matrix ∘ sum_inl unit)).prod =
      diagonal (sum.elim D₀ (λ _, c)), by simpa [M', matrix.mul_assoc, c],
  have : M' = from_blocks M'' 0 0 (diagonal (λ _, c)),
  { rw ← from_blocks_to_blocks M',
    congr,
    { exact hM.1 },
    { exact hM.2 },
    { ext ⟨⟩ ⟨⟩, rw [hc, to_blocks₂₂, of_apply], refl, } },
  rw this,
  simp [h₀],
end

variables {n p} [fintype n] [fintype p]

/-- Reduction to diagonal form by elementary operations is invariant under reindexing. -/
lemma reindex_exists_list_transvec_mul_mul_list_transvec_eq_diagonal (M : matrix p p 𝕜) (e : p ≃ n)
  (H : ∃ (L L' : list (transvection_struct n 𝕜)) (D : n → 𝕜),
    (L.map to_matrix).prod ⬝ (matrix.reindex_alg_equiv 𝕜 e M) ⬝ (L'.map to_matrix).prod
      = diagonal D) :
  ∃ (L L' : list (transvection_struct p 𝕜)) (D : p → 𝕜),
    (L.map to_matrix).prod ⬝ M ⬝ (L'.map to_matrix).prod = diagonal D :=
begin
  rcases H with ⟨L₀, L₀', D₀, h₀⟩,
  refine ⟨L₀.map (reindex_equiv e.symm), L₀'.map (reindex_equiv e.symm), D₀ ∘ e, _⟩,
  have : M = reindex_alg_equiv 𝕜 e.symm (reindex_alg_equiv 𝕜 e M),
    by simp only [equiv.symm_symm, submatrix_submatrix, reindex_apply, submatrix_id_id,
      equiv.symm_comp_self, reindex_alg_equiv_apply],
  rw this,
  simp only [to_matrix_reindex_equiv_prod, list.map_map, reindex_alg_equiv_apply],
  simp only [← reindex_alg_equiv_apply, ← reindex_alg_equiv_mul, h₀],
  simp only [equiv.symm_symm, reindex_apply, submatrix_diagonal_equiv, reindex_alg_equiv_apply],
end

/-- Any matrix can be reduced to diagonal form by elementary operations. Formulated here on `Type 0`
because we will make an induction using `fin r`.
See `exists_list_transvec_mul_mul_list_transvec_eq_diagonal` for the general version (which follows
from this one and reindexing). -/
lemma exists_list_transvec_mul_mul_list_transvec_eq_diagonal_aux
  (n : Type) [fintype n] [decidable_eq n]
  (M : matrix n n 𝕜) : ∃ (L L' : list (transvection_struct n 𝕜)) (D : n → 𝕜),
  (L.map to_matrix).prod ⬝ M ⬝ (L'.map to_matrix).prod = diagonal D :=
begin
  unfreezingI { induction hn : fintype.card n with r IH generalizing n M },
  { refine ⟨list.nil, list.nil, λ _, 1, _⟩,
    ext i j,
    rw fintype.card_eq_zero_iff at hn,
    exact hn.elim' i },
  { have e : n ≃ fin r ⊕ unit,
    { refine fintype.equiv_of_card_eq _,
      rw hn,
      convert (@fintype.card_sum (fin r) unit _ _).symm,
      simp },
    apply reindex_exists_list_transvec_mul_mul_list_transvec_eq_diagonal M e,
    apply exists_list_transvec_mul_mul_list_transvec_eq_diagonal_induction
      (λ N, IH (fin r) N (by simp)) }
end

/-- Any matrix can be reduced to diagonal form by elementary operations. -/
theorem exists_list_transvec_mul_mul_list_transvec_eq_diagonal
  (M : matrix n n 𝕜) : ∃ (L L' : list (transvection_struct n 𝕜)) (D : n → 𝕜),
  (L.map to_matrix).prod ⬝ M ⬝ (L'.map to_matrix).prod = diagonal D :=
begin
  have e : n ≃ fin (fintype.card n) := fintype.equiv_of_card_eq (by simp),
  apply reindex_exists_list_transvec_mul_mul_list_transvec_eq_diagonal M e,
  apply exists_list_transvec_mul_mul_list_transvec_eq_diagonal_aux
end

/-- Any matrix can be written as the product of transvections, a diagonal matrix, and
transvections.-/
theorem exists_list_transvec_mul_diagonal_mul_list_transvec
  (M : matrix n n 𝕜) : ∃ (L L' : list (transvection_struct n 𝕜)) (D : n → 𝕜),
  M = (L.map to_matrix).prod ⬝ diagonal D ⬝ (L'.map to_matrix).prod :=
begin
  rcases exists_list_transvec_mul_mul_list_transvec_eq_diagonal M with ⟨L, L', D, h⟩,
  refine ⟨L.reverse.map transvection_struct.inv, L'.reverse.map transvection_struct.inv, D, _⟩,
  suffices : M =
    ((L.reverse.map (to_matrix ∘ transvection_struct.inv)).prod ⬝ (L.map to_matrix).prod) ⬝ M ⬝
    ((L'.map to_matrix).prod ⬝ (L'.reverse.map (to_matrix ∘ transvection_struct.inv)).prod),
      by simpa [← h, matrix.mul_assoc],
  rw [reverse_inv_prod_mul_prod, prod_mul_reverse_inv_prod, matrix.one_mul, matrix.mul_one],
end

end pivot

open pivot transvection_struct

variables {n} [fintype n]

/-- Induction principle for matrices based on transvections: if a property is true for all diagonal
matrices, all transvections, and is stable under product, then it is true for all matrices. This is
the useful way to say that matrices are generated by diagonal matrices and transvections.

We state a slightly more general version: to prove a property for a matrix `M`, it suffices to
assume that the diagonal matrices we consider have the same determinant as `M`. This is useful to
obtain similar principles for `SLₙ` or `GLₙ`. -/
lemma diagonal_transvection_induction (P : matrix n n 𝕜 → Prop) (M : matrix n n 𝕜)
  (hdiag : ∀ D : n → 𝕜, det (diagonal D) = det M → P (diagonal D))
  (htransvec : ∀ (t : transvection_struct n 𝕜), P t.to_matrix)
  (hmul : ∀ A B, P A → P B → P (A ⬝ B)) :
  P M :=
begin
  rcases exists_list_transvec_mul_diagonal_mul_list_transvec M with ⟨L, L', D, h⟩,
  have PD : P (diagonal D) := hdiag D (by simp [h]),
  suffices H : ∀ (L₁ L₂ : list (transvection_struct n 𝕜)) (E : matrix n n 𝕜),
    P E → P ((L₁.map to_matrix).prod ⬝ E ⬝ (L₂.map to_matrix).prod),
      by { rw h, apply H L L', exact PD },
  assume L₁ L₂ E PE,
  induction L₁ with t L₁ IH,
  { simp only [matrix.one_mul, list.prod_nil, list.map],
    induction L₂ with t L₂ IH generalizing E,
    { simpa },
    { simp only [←matrix.mul_assoc, list.prod_cons, mul_eq_mul, list.map],
      apply IH,
      exact hmul _ _ PE (htransvec _) } },
  { simp only [matrix.mul_assoc, list.prod_cons, mul_eq_mul, list.map] at ⊢ IH,
    exact hmul _ _ (htransvec _) IH }
end

/-- Induction principle for invertible matrices based on transvections: if a property is true for
all invertible diagonal matrices, all transvections, and is stable under product of invertible
matrices, then it is true for all invertible matrices. This is the useful way to say that
invertible matrices are generated by invertible diagonal matrices and transvections. -/
lemma diagonal_transvection_induction_of_det_ne_zero (P : matrix n n 𝕜 → Prop)
  (M : matrix n n 𝕜) (hMdet : det M ≠ 0)
  (hdiag : ∀ D : n → 𝕜, det (diagonal D) ≠ 0 → P (diagonal D))
  (htransvec : ∀ (t : transvection_struct n 𝕜), P t.to_matrix)
  (hmul : ∀ A B, det A ≠ 0 → det B ≠ 0 → P A → P B → P (A ⬝ B)) :
  P M :=
begin
  let Q : matrix n n 𝕜 → Prop := λ N, det N ≠ 0 ∧ P N,
  have : Q M,
  { apply diagonal_transvection_induction Q M,
    { assume D hD,
      have detD : det (diagonal D) ≠ 0, by { rw hD, exact hMdet },
      exact ⟨detD, hdiag _ detD⟩ },
    { assume t,
      exact ⟨by simp, htransvec t⟩ },
    { assume A B QA QB,
      exact ⟨by simp [QA.1, QB.1], hmul A B QA.1 QB.1 QA.2 QB.2⟩ } },
  exact this.2
end

end matrix


import ring_theory.matrix
import .finset_sum

universes u
variables {m n : ℕ}
variable (α : Type u)
variable [ring α]
variable [decidable_eq α]

inductive elementary (m : ℕ)
| scale : Π (i₁ : fin m) (s : α) (hs : s ≠ 0), elementary
| swap : Π (i₁ i₂ : fin m), elementary
| linear_add : Π (i₁ : fin m) (s : α) (i₂ : fin m) (h : i₁ ≠ i₂), elementary

variable {α}
def elementary.to_matrix {m : ℕ} : elementary α m → matrix (fin m) (fin m) α
| (elementary.scale i₁ s hs) := λ i j, if (i = j) then (if (i = i₁) then s else 1) else 0
| (elementary.swap _ i₁ i₂) :=  λ i j, if (i = i₁) then (if i₂ = j then 1 else 0) else if (i = i₂) then (if i₁ = j then 1 else 0) else if (i = j) then 1 else 0--if (i ≠i₁ ∧i ≠i₂) then (if i = j then 1 else 0) else (if i = i₁ then (if i₂ = j then 1 else 0) else (if i₁ = j then 1 else 0))
| (elementary.linear_add i₁ s i₂ h) := λ i j, if (i = j) then 1 else if (i = i₁) then if (j = i₂) then s else 0 else 0
-- λ i j, if (i = j) then (if i = i₁ then s else 1) else 0
--λ i j, if (i ≠ i) then (if i = j then 1 else 0) else (if j = i₁ then 1 else if j = i₂ then s else 0)

def elementary.apply :  elementary α m →  (matrix (fin m) (fin n) α) →  matrix (fin m) (fin n) α
| (elementary.scale i₁ s hs) M := λ i j, if (i = i₁) then s * M i j else M i j
| (elementary.swap _ i₁ i₂) M := λ i j, if (i = i₁) then M i₂ j else if (i = i₂) then M i₁ j else M i j
| (elementary.linear_add i₁ s i₂ h) M := λ i j, if (i = i₁) then M i j + s * M i₂ j else M i j

structure row_equivalent_step (M N : matrix (fin m) (fin n) α) :=
(elem : elementary α m)
(implements : matrix.mul (elem.to_matrix) M = N)

@[simp] lemma mul_scale_scaled {i : fin m} {j : fin n} {s : α} {h : s ≠ 0} {M : matrix (fin m) (fin n) α} :
  (matrix.mul (elementary.scale i s h).to_matrix M) i j = s * M i j :=
begin
  dsimp [matrix.mul],
  dsimp [elementary.to_matrix],
  simp,
  rw finset.sum_ite_zero,
end

@[simp] lemma mul_swap_swapped_1 {i₁ i₂ : fin m} {j : fin n} {M : matrix (fin m) (fin n) α} :
  (matrix.mul (elementary.swap _ i₁ i₂).to_matrix M) i₁ j = M i₂ j :=
begin
  rw matrix.mul,
  dsimp [elementary.to_matrix],
  simp,
  rw finset.sum_ite_zero,
end

#check decidable_of_decidable_of_iff

@[simp] lemma decidable_of_decidable_of_iff_refl {p : Prop} (hp : decidable p) (h : p ↔ p) :
  decidable_of_decidable_of_iff hp h = hp :=
begin
  dsimp [decidable_of_decidable_of_iff],
  tactic.unfreeze_local_instances,
  cases hp,
  dsimp [dite],
  refl,
  dsimp [dite],
  refl,
end

-- set_option pp.implicit true
@[simp] lemma mul_swap_swapped_2 {i₁ i₂ : fin m} {j : fin n} {M : matrix (fin m) (fin n) α} :
  (matrix.mul (elementary.swap _ i₁ i₂).to_matrix M) i₂ j = M i₁ j :=
begin
  dsimp [matrix.mul],
  dsimp [elementary.to_matrix],
  simp,
  by_cases h : (i₂ = i₁);
  simp[h],
    swap,
    rw finset.sum_ite_zero,
    -- simp,
    cases h,
    conv { -- This is still gross, and we should ask for help...
      congr,congr,skip,funext,
      rw decidable_of_decidable_of_iff_refl,
      rw decidable_of_decidable_of_iff_refl,
    },
    rw finset.sum_ite_zero,
  -- can't believe this is necessary
  -- have H₁ : (@finset.sum (fin m) α (@semiring.to_add_comm_monoid α (@ring.to_semiring α _inst_1))
  --     (@finset.univ (fin m) (fin.fintype m))
  --     (λ (x : fin m),
  --        @ite (i₁ = x)
  --          (@decidable_of_decidable_of_iff (i₂ = x) (i₁ = x)
  --             (@decidable_of_decidable_of_iff (i₂ = x) (i₂ = x) (fin.decidable_eq m i₂ x) _)
  --             _)
  --          α
  --          (M x j)
  --          0) =
  --   M i₁ j) = (@finset.sum (fin m) α (@semiring.to_add_comm_monoid α (@ring.to_semiring α _inst_1))
  --     (@finset.univ (fin m) (fin.fintype m))
  --     (λ (x : fin m),
  --        @ite (i₁ = x) (@decidable_of_decidable_of_iff (i₁ = x) (i₁ = x) (fin.decidable_eq m i₁ x) _) α (M x j)
  --          0) =
  --   M i₁ j),
  --   congr,
  --   funext,
  --   by_cases h₂ : (i₁ = x);
  --   simp[h₂],
  --   rw H₁,
  --   show i₁ = x ↔ i₁ = x, refl,
  -- --   --
  --   repeat{rw finset.sum_ite_zero},
end

  -- set_option pp.all true
@[simp] lemma mul_linear_add_added {i₁ i₂ : fin m} {s : α} {j : fin n} {h : i₁ ≠ i₂} {M : matrix (fin m) (fin n) α} : (matrix.mul (elementary.linear_add i₁ s i₂ h).to_matrix M) i₁ j = M i₁ j + s * M i₂ j :=
begin
  dsimp[matrix.mul],
  dsimp[elementary.to_matrix],
  simp,
  -- have H₁ : (λ (x : fin m), ite (i₁ = x) (M x j) (ite (x = i₂) (s * M x j) 0)) = (λ (x : fin m), ite (i₁ = x) (M x j) (ite (i₂ = x) (s * M x j) 0)),
  -- funext,
  -- by_cases h₁ : (i₁ = x); simp[h₁],
  -- by_cases h₂ : (x = i₂); simp[h₂],
  -- simp[λ x, h₂ (eq.symm x)],
  have H₁ : finset.sum finset.univ (λ (x : fin m), ite (i₁ = x) (M x j) (ite (x = i₂) (s * M x j) 0)) = finset.sum finset.univ (λ (x : fin m), ite (i₁ = x) (M x j) (ite (i₂ = x) (s * M x j) 0)),
  congr,
  funext,
  by_cases h₁ : (i₁ = x); simp[h₁],
  by_cases h₂ : (x = i₂); simp[h₂],
  simp[λ x, h₂ (eq.symm x)],
  apply eq.trans,
  show α, from finset.sum finset.univ (λ (x : fin m), ite (i₁ = x) (M x j) (ite (i₂ = x) (s * M x j) 0)),

  -- from H₁,
-- erw H₁,

  have H₂ : (@finset.sum (fin m) α
      (@semimodule.to_add_comm_monoid α α (@ring.to_semiring α _inst_1)
         (@semiring.to_semimodule α (@ring.to_semiring α _inst_1)))
      (@finset.univ (fin m) (fin.fintype m))
      (λ (x : fin m),
         @ite (i₁ = x) (fin.decidable_eq m i₁ x) α (M x j)
           (@ite (x = i₂) (fin.decidable_eq m x i₂) α (s * M x j) 0)) =
    @finset.sum (fin m) α
      (@semimodule.to_add_comm_monoid α α (@ring.to_semiring α _inst_1)
         (@semiring.to_semimodule α (@ring.to_semiring α _inst_1)))
      (@finset.univ (fin m) (fin.fintype m))
      (λ (x : fin m),
         @ite (i₁ = x) (fin.decidable_eq m i₁ x) α (M x j)
           (@ite (i₂ = x) (fin.decidable_eq m i₂ x) α (s * M x j) 0))
)=(
  @finset.sum (fin m) α
      (@semimodule.to_add_comm_monoid α α (@ring.to_semiring α _inst_1)
         (@semiring.to_semimodule α (@ring.to_semiring α _inst_1)))
      (@finset.univ (fin m) (fin.fintype m))
      (λ (x : fin m),
         @ite (i₁ = x)
           (@decidable_of_decidable_of_iff (i₁ = x) (i₁ = x)
              (@decidable_of_decidable_of_iff (i₁ = x) (i₁ = x) (fin.decidable_eq m i₁ x) _)
              _)
           α
           (M x j)
           (@ite (x = i₂) (@decidable_of_decidable_of_iff (x = i₂) (x = i₂) (fin.decidable_eq m x i₂) _) α
              (s * M x j)
              0)) =
    @finset.sum (fin m) α
      (@semimodule.to_add_comm_monoid α α (@ring.to_semiring α _inst_1)
         (@semiring.to_semimodule α (@ring.to_semiring α _inst_1)))
      (@finset.univ (fin m) (fin.fintype m))
      (λ (x : fin m),
         @ite (i₁ = x) (fin.decidable_eq m i₁ x) α (M x j)
           (@ite (i₂ = x) (fin.decidable_eq m i₂ x) α (s * M x j) 0))),

  congr,
  funext,
  by_cases h₁ : (i₁ = x); simp[h₁],
  by_cases h₂ : (x = i₂); simp[h₂],
  simp[H₂] at H₁,
  from H₁,
  clear H₁,
  have H₁, from @finset.sum_ite_zero₂ (fin m) _ _ i₁ i₂ α _ _ (λ i, M i j) (λ i, s * (M i j)) h,
  simp at H₁,
  apply eq.trans,
  from H₁,
  simp,
end

lemma elementary.mul_eq_apply : Π {M : matrix (fin m) (fin n) α} (e : elementary α m), ((e.to_matrix).mul M) =  (e.apply M) :=
begin
  intros,
  cases e with i₁ s hs i₁ i₂ i₁ s i₂,
  -- scale case
  by {
    funext i j,
    simp[matrix.mul,elementary.apply,elementary.to_matrix,finset.sum_ite_zero],
    by_cases h : (i = i₁); simp[h],
  },

  -- swap case
  by {
    funext i j,
    by_cases h : (i = i₁),
    simp[h, elementary.apply],
    by_cases h₁ : (i = i₂),
    simp[h₁, elementary.apply],
    rw ←h₁,
    repeat{simp[h, h₁, matrix.mul, elementary.apply,elementary.to_matrix, finset.sum_ite_zero]}
  },

 -- linear_add case
 by {
  funext i j,
  by_cases h : (i = i₁),
  simp[h,elementary.apply],
  simp[matrix.mul, elementary.apply, elementary.to_matrix, h,finset.sum_ite_zero],
 }
end

def row_equivalent_step.of_elementary :
  Π {M : matrix (fin m) (fin n) α} (e : elementary α m), row_equivalent_step M ((e.to_matrix).mul M) :=
begin
  intros,
  cases e;
  {constructor,
  refl}
end

def row_equivalent_step.of_elementary_apply :
  Π {M : matrix (fin m) (fin n) α} (e : elementary α m), row_equivalent_step M (e.apply M) :=
begin
  intros,
  have H₃ : row_equivalent_step M (elementary.apply e M) = row_equivalent_step M (matrix.mul (elementary.to_matrix e) M),
  congr,
  from eq.symm(@elementary.mul_eq_apply m n α _ _ M e),
  rw H₃,
  from @row_equivalent_step.of_elementary m n α _ _ M e,
end

def row_equivalent_step.to_matrix :
  Π {M N : matrix (fin m) (fin n) α} (r : row_equivalent_step M N), matrix (fin m) (fin m) α :=
λ M N r, r.elem.to_matrix

def row_equivalent_step.apply :
  Π (L : matrix (fin m) (fin n) α) {M N : matrix (fin m) (fin n) α} (r : row_equivalent_step M N), matrix (fin m) (fin n) α :=
λ L M N r, r.elem.apply L

-- def row_equivalent_step.of_elementary : Π

@[simp] lemma row_equivalent_step.matrix_implements : Π {M N : matrix (fin m) (fin n) α} (r : row_equivalent_step M N), (r.to_matrix).mul M = N :=
begin
  intros,
  cases r with elem implements,
  unfold row_equivalent_step.to_matrix,
  simp,
  assumption
end

@[simp] lemma row_equivalent_step.apply_implements : Π {M N : matrix (fin m) (fin n) α} (r : row_equivalent_step M N), r.apply M = N :=
begin
  intros,
  cases r with elem implements,
  unfold row_equivalent_step.apply,
  simp,
  rw ←elementary.mul_eq_apply,
  assumption,
end

inductive row_equivalent : matrix (fin m) (fin n) α → matrix (fin m) (fin n) α → Type u
| nil : Π {N : matrix (fin m) (fin n) α}, row_equivalent N N
| cons : Π {N M L : matrix (fin m) (fin n) α} (h₁ : row_equivalent N M) (h₂ : row_equivalent_step M L), row_equivalent N L

def row_equivalent.of_step : Π {M N : matrix (fin m) (fin n) α} (r : row_equivalent_step M N), row_equivalent M N := λ _ _ r, row_equivalent.cons (row_equivalent.nil) r

instance row_equivalent_step.has_coe_row_equivalent : Π {M N : matrix (fin m) (fin n) α}, has_coe (row_equivalent_step M N) (row_equivalent M N) := λ M N, ⟨λ r, row_equivalent.of_step r⟩

def row_equivalent.to_matrix : Π {M N : matrix (fin m) (fin n) α} (r : row_equivalent M N), matrix (fin m) (fin m) α
| M N (row_equivalent.nil) := (1  : matrix (fin m) (fin m) α)
| M N (row_equivalent.cons r₁ r₂) := (row_equivalent_step.to_matrix r₂).mul (row_equivalent.to_matrix r₁)

def row_equivalent.apply (L : matrix (fin m) (fin n) α) : Π {M N : matrix (fin m) (fin n) α} (r : row_equivalent M N), matrix (fin m) (fin n) α
| M N (row_equivalent.nil) := L
| M N (row_equivalent.cons r₁ r₂) := (@elementary.apply m n α _ _ (row_equivalent_step.elem r₂)) (row_equivalent.apply r₁)

@[simp] lemma row_equiv_nil {M : matrix (fin m) (fin n) α} : row_equivalent.to_matrix (@row_equivalent.nil m n α _ _ M) = (1  : matrix (fin m) (fin m) α) := by simp[row_equivalent.to_matrix]

@[simp] lemma row_equiv_cons {M N L : matrix (fin m) (fin n) α} {r₁ : row_equivalent N M} {r₂ : row_equivalent_step M L}: row_equivalent.to_matrix (@row_equivalent.cons m n α _ _ N M L r₁ r₂) = (row_equivalent_step.to_matrix r₂).mul (row_equivalent.to_matrix r₁) := by simp[row_equivalent.to_matrix]

@[simp] lemma row_equivalent.matrix_implements : Π {M N : matrix (fin m) (fin n) α} (r : row_equivalent M N), (r.to_matrix).mul M = N
| M N (row_equivalent.nil) := by simp[row_equiv_nil, matrix.one_mul]
| M N (row_equivalent.cons r₁ r₂) := begin
  rw row_equiv_cons,
  rw matrix.mul_assoc,
  rw row_equivalent.matrix_implements,
  apply row_equivalent_step.matrix_implements,
end

-- set_option pp.all true
@[simp] lemma row_equivalent.apply_implements : Π {M N : matrix (fin m) (fin n) α} (r : row_equivalent M N), r.apply M = N
| M N (row_equivalent.nil) := by simp[row_equivalent.apply]
| M N (@row_equivalent.cons _ _ _ _ _ _ L _ r₁ r₂) := begin
  simp[row_equivalent.apply],
  have H₁, from row_equivalent.apply_implements r₁,
  have H₂ : elementary.apply (r₂.elem) (row_equivalent.apply M r₁) = elementary.apply (r₂.elem) L,
  congr,
  from H₁,
  rw H₂,
  apply row_equivalent_step.apply_implements,
end

theorem row_equivalent.mul_eq_apply : Π {M N : matrix (fin m) (fin n) α} (r₁ : row_equivalent M N), r₁.to_matrix.mul M = r₁.apply M :=
begin
  intros,
  cases r₁,
  simp[row_equivalent.to_matrix, row_equivalent.apply, matrix.one_mul],
  simp[row_equivalent.to_matrix, matrix.mul_assoc],
end

def row_equivalent.trans {M N L : (matrix (fin m) (fin n) α)} : (row_equivalent M N) → (row_equivalent N L) → row_equivalent M L :=
begin
  intros r₁ r₂,
  induction r₂ with M₁ M₁ N₁ L₁ h₁ h₂ h₃,
  from r₁,
  from row_equivalent.cons (h₃ r₁) h₂,
end

def row_equivalent.precons : Π {M N L : matrix (fin m) (fin n) α}, row_equivalent_step M N → row_equivalent N L → row_equivalent M L :=
begin
  intros M N L r₀ r₁,
  induction r₁ with M₁ M₁ N₁ L₁ h₁ h₂ h₃,
  from r₀,
  from row_equivalent.cons (h₃ r₀) h₂,
end


import logic.nontrivial
import algebra.order.ring
import data.nat.basic

/-! ### Test `nontriviality` with inequality hypotheses -/

example {R : Type} [ordered_ring R] {a : R} (h : 0 < a) : 0 < a :=
begin
  nontriviality,
  guard_hyp _inst : nontrivial R,
  assumption,
end

/-! ### Test `nontriviality` with equality or non-strict inequality goals -/

example {R : Type} [comm_ring R] {r s : R} : r * s = s * r :=
begin
  nontriviality,
  guard_hyp _inst : nontrivial R,
  apply mul_comm,
end

/-! ### Test deducing `nontriviality` by instance search -/

example {R : Type} [ordered_ring R] : 0 ≤ (1 : R) :=
begin
  nontriviality R,
  guard_hyp _inst : nontrivial R,
  exact zero_le_one,
end

example {R : Type} [ordered_ring R] : 0 ≤ (1 : R) :=
begin
  nontriviality ℕ,
  guard_hyp _inst : nontrivial ℕ,
  exact zero_le_one,
end

example {R : Type} [ordered_ring R] : 0 ≤ (2 : R) :=
begin
  success_if_fail { nontriviality punit },
  exact zero_le_two,
end

example {R : Type} [ordered_ring R] {a : R} (h : 0 < a) : 2 ∣ 4 :=
begin
  nontriviality R,
  guard_hyp _inst : nontrivial R,
  dec_trivial
end

/-! Test using `@[nontriviality]` lemmas in `nontriviality and custom `simp` lemmas -/

def empty_or_univ {α : Type*} (s : set α) : Prop := s = ∅ ∨ s = set.univ

lemma subsingleton.set_empty_or_univ {α} [subsingleton α] (s : set α) :
  s = ∅ ∨ s = set.univ :=
subsingleton.set_cases (or.inl rfl) (or.inr rfl) s

lemma subsingleton.set_empty_or_univ' {α} [subsingleton α] (s : set α) :
  empty_or_univ s :=
subsingleton.set_empty_or_univ s

example {α : Type*} (s : set α) (hs : s = ∅ ∪ set.univ) : empty_or_univ s :=
begin
  success_if_fail { nontriviality α },
  rw [set.empty_union] at hs,
  exact or.inr hs
end

section

local attribute [nontriviality] subsingleton.set_empty_or_univ

example {α : Type*} (s : set α) (hs : s = ∅ ∪ set.univ) : empty_or_univ s :=
begin
  success_if_fail { nontriviality α },
  nontriviality α using [subsingleton.set_empty_or_univ'],
  rw [set.empty_union] at hs,
  exact or.inr hs
end

end

local attribute [nontriviality] subsingleton.set_empty_or_univ'

example {α : Type*} (s : set α) (hs : s = ∅ ∪ set.univ) : empty_or_univ s :=
begin
  nontriviality α,
  rw [set.empty_union] at hs,
  exact or.inr hs
end

/-! Test with nonatomic type argument -/

example (α : ℕ → Type) (a b : α 0) (h : a = b) : a = b :=
begin
  nontriviality α 0 using [nat.zero_lt_one],
  guard_hyp _inst : nontrivial (α 0),
  exact h
end