(* determinant *)

Set Nested Proofs Allowed.
Set Implicit Arguments.

Require Import Utf8 Arith.
Import List List.ListNotations.
Import Init.Nat.

Require Import Misc RingLike IterAdd IterMul.
Require Import PermutationFun SortingFun SortRank.
Require Import MyVector Matrix PermutSeq Signature.
Require Import NatRingLike.
Import matrix_Notations.

Definition set_minus {A} (eqb : A → _) E F :=
  filter (λ e, negb (member eqb e F)) E.

Section a.

Context {T : Type}.
Context (ro : ring_like_op T).
Context (rp : ring_like_prop T).

(*
 * three definitions of determinant
 *)

(*
   definition 1
   det n M recursively computes determinant

      0     n-1
      |     |
      v     v
     ---------    ---------   ---------   ---------
0    |x      |    | x     |   |  x    |   |   x   |
     | ......| -  |. .....| + |.. ....| - |... ...| + etc.
     | ......|    |. .....|   |.. ....|   |... ...|
n-1  | ......|    |. .....|   |.. ....|   |... ...|
     ---------    ---------   ---------   ---------

   each term is the term "x" multiplied by det (n-1) of
   the sub-matrix represented by the dots. The "x" goes through
   the first row.
*)

Fixpoint determinant_loop n (M : matrix T) :=
  match n with
  | 0 => 1%L
  | S n' =>
      ∑ (j = 1, n),
      minus_one_pow (S j) * mat_el M 1 j *
      determinant_loop n' (subm 1 j M)
  end.

Definition det M := determinant_loop (mat_nrows M) M.
Arguments det M%M.

(* definition 2
   determinant by sum of products involving all permutations of columns,
   aka "Leibniz formula";
   sum of product of the factors a_{i,σ(i)} where σ goes through all
   permutations of the naturals of the interval [0, n-1].
   The permutations generated are in the same order as the
   terms generated by the determinant defined by induction on
   the size of the matrix.
     The order happens to be the canonical (alphabetical) order.
   Example for n=3
     = [[0; 1; 2]; [0; 2; 1]; [1; 0; 2]; [1; 2; 0]; [2; 0; 1]; [2; 1; 0]]
   Having the same terms order, the proof of equality of both definitions
   of both determinants is easy.
   This definitions holds n! terms.
   See PermutSeq.v *)

Definition det' (M : matrix T) :=
  let n := mat_nrows M in
  ∑ (k = 0, fact n - 1),
    ε (canon_sym_gr_list n k) *
    ∏ (i = 1, n), mat_el M i ((canon_sym_gr_list n k).(i) + 1).

Arguments det' M%M.

(* definition 3
   determinant by sum of products like in definition 2, but running with all
   combinations of columns, even with repetitions; the signatures ε of the
   terms using twice the same column are 0 by definition of ε; the
   remaining terms, whose ε is not 0, i.e. 1 or -1, are the ones when all
   selected columns are different. It holds n^n terms *)

Definition cart_prod_rep_seq n := cart_prod (repeat (seq 1 n) n).

(*
Compute (cart_prod_rep_seq 3).
Compute (cart_prod (repeat (seq 0 10) 2)).
*)

Definition det'' (M : matrix T) :=
  let n := mat_nrows M in
  ∑ (l ∈ cart_prod_rep_seq n), ε l * ∏ (i = 1, n), mat_el M i l.(i).

(* *)

Theorem fold_det : ∀ M, determinant_loop (mat_nrows M) M = det M.
Proof. easy. Qed.

Theorem determinant_zero : ∀ (M : matrix T),
  determinant_loop 0 M = 1%L.
Proof. easy. Qed.

Theorem determinant_succ : ∀ n (M : matrix T),
  determinant_loop (S n) M =
     ∑ (j = 1, S n),
     minus_one_pow (S j) * mat_el M 1 j *
     determinant_loop n (subm 1 j M).
Proof. easy. Qed.

(*
End a.
Compute (length (cart_prod [[2;3];[5;7;2];[8;3];[7;2]])).
Compute (length (cart_prod [[3;7;4;1];[0;6;2;7];[1;3;1;1];[18;3;2;1]])).
Compute (length (cart_prod [[3;7;4;1];[0;6;2;7];[1;3;1;1];[18;3;1]])).
Compute (length (cart_prod [[7;4;1];[0;6;2;7];[1;3;1;1];[18;3;1]])).
Compute (length (cart_prod [[7;4;1];[2;7];[1;3;1;1];[18;3;1]])).
Arguments det {T ro} M%M.
Arguments det' {T ro} M%M.
Arguments det'' {T ro} M%M.
Require Import RnglAlg.Qrl.
Require Import RnglAlg.Rational.
Import Q.Notations.
Open Scope Q_scope.
Compute (let M := mk_mat [[3;7;4;1];[0;6;2;7];[1;3;1;1];[18;3;2;1]] in det M).
Compute (let M := mk_mat [[3;7;4;1];[0;6;2;7];[1;3;1;1];[18;3;2;1]] in det' M).
Compute (let M := mk_mat [[3;7;4;1];[0;6;2;7];[1;3;1;1];[18;3;2;1]] in det'' M).
Compute (let M := mk_mat [] in det M).
Compute (let M := mk_mat [] in det' M).
Compute (let M := mk_mat [] in det'' M).
Compute (let M := mk_mat [[3]] in det M).
Compute (let M := mk_mat [[3]] in det' M).
Compute (let M := mk_mat [[3]] in det'' M).
*)

Theorem rngl_summation_list_incl : ∀ A eqd la lb (f : A → T),
  NoDup la
  → NoDup lb
  → la ⊂ lb
  → ∑ (a ∈ la), f a =
    ∑ (a ∈ lb), if ListDec.In_dec eqd a la then f a else 0.
Proof.
intros * Hnda Hndb Hlab.
induction la as [| a]. {
  cbn.
  rewrite rngl_summation_list_empty; [ | easy ].
  symmetry.
  now apply all_0_rngl_summation_list_0.
}
rewrite rngl_summation_list_cons.
specialize (NoDup_remove [] la a Hnda) as H1.
cbn in H1.
destruct H1 as (Hnd1, Hala).
specialize (IHla Hnd1).
rewrite IHla; [ | now intros i Hi; apply Hlab; right ].
assert (Ha : a ∈ lb) by now apply Hlab; left.
apply In_split in Ha.
destruct Ha as (lb1 & lb2 & Hlb); rewrite Hlb.
do 2 rewrite rngl_summation_list_app.
do 2 rewrite rngl_summation_list_cons.
destruct (ListDec.In_dec eqd a la) as [H| H]; [ easy | clear H ].
rewrite rngl_add_0_l.
destruct (ListDec.In_dec eqd a (a :: la)) as [H| H]; [ clear H | ]. 2: {
  now exfalso; apply H; left.
}
symmetry; rewrite rngl_add_comm, rngl_add_assoc.
rewrite rngl_add_add_swap.
f_equal; [ f_equal | ]. {
  apply rngl_summation_list_eq_compat.
  intros i Hi.
  destruct (ListDec.In_dec eqd i (a :: la)) as [H1| H1]. {
    destruct (ListDec.In_dec eqd i la) as [H| H]; [ easy | ].
    destruct H1 as [H1| H1]; [ clear H | easy ].
    subst i.
    rewrite Hlb in Hndb.
    apply NoDup_remove_2 in Hndb.
    exfalso; apply Hndb.
    now apply in_or_app; left.
  }
  destruct (ListDec.In_dec eqd i la) as [H2| H2]; [ | easy ].
  now exfalso; apply H1; right.
} {
  apply rngl_summation_list_eq_compat.
  intros i Hi.
  destruct (ListDec.In_dec eqd i (a :: la)) as [H1| H1]. {
    destruct (ListDec.In_dec eqd i la) as [H| H]; [ easy | ].
    destruct H1 as [H1| H1]; [ clear H | easy ].
    subst i.
    rewrite Hlb in Hndb.
    apply NoDup_remove_2 in Hndb.
    exfalso; apply Hndb.
    now apply in_or_app; right.
  }
  destruct (ListDec.In_dec eqd i la) as [H2| H2]; [ | easy ].
  now exfalso; apply H1; right.
}
Qed.

Theorem iter_list_mul_same_length : ∀ A (ll : list (list A)) n,
  (∀ l, l ∈ ll → length l = n)
  → iter_list ll (λ c l, c * length l) 1 = n ^ length ll.
Proof.
intros * Hll.
induction ll as [| l]; [ now rewrite iter_list_empty | ].
rewrite iter_list_cons; cbn; cycle 1.
  apply Nat.add_0_r.
  apply Nat.mul_1_r.
  apply Nat.mul_assoc.
rewrite Hll; [ f_equal | now left ].
apply IHll.
intros l1 Hl1.
now apply Hll; right.
Qed.

Theorem cart_prod_rep_seq_length : ∀ n, n ≠ 0 → length (cart_prod_rep_seq n) = n ^ n.
Proof.
intros * Hnz.
unfold cart_prod_rep_seq.
rewrite cart_prod_length; [ | now destruct n ].
rewrite iter_list_mul_same_length with (n := n). 2: {
  intros l Hl.
  apply repeat_spec in Hl; subst l.
  apply seq_length.
}
f_equal; apply repeat_length.
Qed.

Fixpoint cart_prod_rep_seq_inv n l :=
  match l with
  | [] => 0
  | a :: l' => pred a * n ^ length l' + cart_prod_rep_seq_inv n l'
  end.

Fixpoint old_cart_prod_rep_seq_inv_loop n l :=
  match l with
  | [] => 0
  | a :: l' => pred a + n * old_cart_prod_rep_seq_inv_loop n l'
  end.

Definition old_cart_prod_rep_seq_inv n l := old_cart_prod_rep_seq_inv_loop n (rev l).

(*
Compute (
  let n := 3 in
  map (λ l, (cart_prod_rep_seq_inv n l, old_cart_prod_rep_seq_inv n l)) (cart_prod_rep_seq n)
).
*)

Theorem in_cart_prod_repeat_iff : ∀ m n l,
  n = 0 ∧ l = [] ∨
  n ≠ 0 ∧ length l = n ∧ (∀ i : nat, i ∈ l → 1 ≤ i ≤ m)
  ↔ l ∈ cart_prod (repeat (seq 1 m) n).
Proof.
intros.
split. {
  intros [(Hnz, H1)| (Hnz & Hn & Hm)]; [ now subst n l; left | ].
  apply (in_cart_prod_iff 0).
  rewrite repeat_length.
  split; [ easy | ].
  intros i Hi.
  rewrite List_nth_repeat.
  rewrite Hn in Hi.
  destruct (lt_dec i n) as [H| H]; [ clear H | easy ].
  apply in_seq.
  specialize (Hm (nth i l 0)) as H1.
  assert (H : nth i l 0 ∈ l) by now apply nth_In; rewrite Hn.
  specialize (H1 H); clear H.
  split; [ easy | ].
  now apply Nat.lt_succ_r.
} {
  intros Hl.
  apply (in_cart_prod_iff 0) in Hl.
  rewrite repeat_length in Hl.
  destruct Hl as (Hln, Hl).
  destruct (Nat.eq_dec n 0) as [Hnz| Hnz]. {
    left; subst n.
    split; [ easy | now apply length_zero_iff_nil in Hnz ].
  }
  right.
  split; [ easy | ].
  split; [ easy | ].
  intros i Hi.
  apply (In_nth _ _ 0) in Hi.
  destruct Hi as (j & Hjl & Hj); subst i.
  specialize (Hl j Hjl) as H1.
  rewrite List_nth_repeat in H1.
  rewrite Hln in Hjl.
  destruct (lt_dec j n) as [H| H]; [ clear H | easy ].
  apply in_seq in H1.
  split; [ easy | ].
  now apply Nat.lt_succ_r.
}
Qed.

Theorem in_cart_prod_rep_seq_iff : ∀ n l,
  n = 0 ∧ l = [] ∨
  n ≠ 0 ∧ length l = n ∧ (∀ i, i ∈ l → 1 ≤ i ≤ n)
  ↔ l ∈ cart_prod_rep_seq n.
Proof.
intros.
now apply in_cart_prod_repeat_iff.
Qed.

Theorem NoDup_cart_prod_repeat : ∀ m n,
  NoDup (cart_prod (repeat (seq 1 m) n)).
Proof.
intros.
revert m.
induction n; intros. {
  constructor; [ easy | constructor ].
}
cbn.
specialize (IHn m) as H1.
remember (cart_prod (repeat (seq 1 m) n)) as ll eqn:Hll.
rewrite flat_map_concat_map.
apply NoDup_concat_if. {
  intros l Hl.
  apply in_map_iff in Hl.
  destruct Hl as (i & Hl & Hi); subst l.
  apply FinFun.Injective_map_NoDup; [ | easy ].
  intros j k Hjk.
  now injection Hjk.
}
intros i j Hij a Ha.
destruct (lt_dec i m) as [Him| Him]. 2: {
  apply Nat.nlt_ge in Him.
  rewrite nth_overflow in Ha; [ easy | now rewrite List_map_seq_length ].
}
rewrite (List_map_nth' 0) in Ha; [ | now rewrite seq_length ].
destruct (lt_dec j m) as [Hjm| Hjm]. 2: {
  apply Nat.nlt_ge in Hjm.
  rewrite nth_overflow; [ easy | now rewrite List_map_seq_length ].
}
rewrite (List_map_nth' 0); [ | now rewrite seq_length ].
intros Hb.
apply in_map_iff in Ha.
apply in_map_iff in Hb.
destruct Ha as (u & H & Ha); subst a.
destruct Hb as (v & H & Hb).
injection H; clear H; intros H Hji; subst v.
rewrite seq_nth in Hji; [ | easy ].
rewrite seq_nth in Hji; [ | easy ].
now apply Nat.succ_inj in Hji; symmetry in Hji.
Qed.

Theorem NoDup_cart_prod_rep_seq : ∀ n, NoDup (cart_prod_rep_seq n).
Proof.
intros n.
unfold cart_prod_rep_seq.
apply NoDup_cart_prod_repeat.
Qed.

Theorem cart_prod_rep_seq_inj : ∀ n i j,
  n ≠ 0
  → i < n ^ n
  → j < n ^ n
  → nth i (cart_prod_rep_seq n) [] = nth j (cart_prod_rep_seq n) []
  → i = j.
Proof.
intros * Hnz Hi Hj Hij.
apply (NoDup_nth (cart_prod_rep_seq n) []); [ | | | easy ]. {
  apply NoDup_cart_prod_rep_seq.
} {
  now rewrite cart_prod_rep_seq_length.
} {
  now rewrite cart_prod_rep_seq_length.
}
Qed.

(* det and det' are equal *)

Theorem det_is_det' :
  rngl_has_opp = true →
  ∀ (M : matrix T),
  is_square_matrix M = true
  → det M = det' M.
Proof.
intros Hop * Hm.
specialize (proj2 rngl_has_opp_or_subt_iff) as Hos.
specialize (Hos (or_introl Hop)).
move Hos before Hop.
unfold det'.
remember (mat_nrows M) as n eqn:Hr; symmetry in Hr.
unfold det.
rewrite Hr.
revert M Hm Hr.
induction n; intros. {
  cbn.
  rewrite rngl_summation_only_one.
  rewrite all_1_rngl_product_1; [ | intros * Hi; flia Hi ].
  unfold ε, iter_seq, iter_list; unfold "<?"; cbn.
  symmetry; apply rngl_mul_1_l.
}
rewrite determinant_succ.
destruct (Nat.eq_dec n 0) as [Hnz| Hnz]. {
  subst n; cbn.
  rewrite rngl_summation_only_one; cbn.
  rewrite rngl_summation_only_one; cbn.
  rewrite rngl_product_only_one; cbn.
  now do 2 rewrite rngl_mul_1_r.
}
erewrite rngl_summation_eq_compat. 2: {
  intros i Hi.
  rewrite IHn; cycle 1. {
    apply is_squ_mat_subm; [ rewrite Hr | rewrite Hr; flia Hi | easy ].
    split; [ easy | now apply -> Nat.succ_le_mono ].
  } {
    rewrite mat_nrows_subm, Hr; cbn.
    apply Nat.sub_0_r.
  }
  easy.
}
cbn - [ canon_sym_gr_list fact nth ].
clear IHn.
erewrite rngl_summation_eq_compat. 2: {
  intros i Hi.
  rewrite rngl_mul_summation_distr_l; [ | easy ].
  easy.
}
cbn - [ canon_sym_gr_list fact nth ].
rewrite (rngl_summation_shift 1); [ | flia ].
rewrite Nat.sub_diag, Nat_sub_succ_1.
rewrite rngl_summation_summation_distr.
rewrite <- Nat.sub_succ_l; [ | apply Nat.neq_0_lt_0, fact_neq_0 ].
rewrite Nat_sub_succ_1.
rewrite <- Nat_fact_succ.
apply rngl_summation_eq_compat.
intros k Hk.
(* elimination of "mat_el M 1 (1 + k / (n!)" *)
symmetry.
rewrite rngl_product_split_first; [ | flia ].
rewrite Nat.sub_diag.
rewrite Nat.add_1_r.
cbn - [ canon_sym_gr_list nth ].
remember (mat_el M 1 _) as x eqn:Hx.
rewrite (ε_mul_comm Hop).
symmetry.
rewrite <- rngl_mul_assoc.
rewrite (minus_one_pow_mul_comm Hop).
do 3 rewrite <- rngl_mul_assoc.
f_equal.
(* elimination done *)
(* separation factors "∏" and "ε" *)
rewrite (ε_mul_comm Hop).
rewrite <- rngl_mul_assoc.
f_equal. {
  (* equality of the two "∏" *)
  rewrite (rngl_product_shift 1); [ | flia Hnz ].
  rewrite Nat.sub_diag.
  rewrite (rngl_product_shift 2 2); [ | flia Hnz ].
  rewrite Nat.sub_diag.
  rewrite Nat.sub_succ.
  apply rngl_product_eq_compat.
  intros i Hi.
  rewrite Nat.add_comm, Nat.add_sub.
  unfold mat_el.
  do 3 rewrite Nat.add_sub.
  replace (2 + i - 1) with (S i) by flia.
  cbn - [ subm fact ].
  rewrite (List_map_nth' 0). 2: {
    rewrite canon_sym_gr_list_length; flia Hi Hnz.
  }
  cbn - [ butn ].
  rewrite (List_map_nth' []). 2: {
    apply is_scm_mat_iff in Hm.
    destruct Hm as (Hcr & Hc).
    rewrite butn_length, fold_mat_nrows, Hr.
    unfold "<?"; cbn; flia Hi Hnz.
  }
  rewrite Nat.sub_0_r.
  unfold succ_when_ge, Nat.b2n.
  rewrite if_leb_le_dec.
  destruct (le_dec (k / n!) _) as [H1| H1]. {
    rewrite nth_butn_before; [ | easy ].
    rewrite nth_butn_before; [ | easy ].
    now rewrite (Nat.add_1_r i).
  } {
    apply Nat.nle_gt in H1.
    rewrite Nat.add_0_r.
    rewrite nth_butn_after; [ | easy ].
    rewrite nth_butn_before; [ | easy ].
    now rewrite Nat.add_1_r.
  }
  (* end proof equality of the two "∏" *)
}
(* equality of the two "ε" *)
symmetry.
rewrite minus_one_pow_succ; [ | easy ].
rewrite minus_one_pow_succ; [ | easy ].
rewrite rngl_opp_involutive; [ | easy ].
apply ε_of_sym_gr_permut_succ; [ easy | ].
apply (le_lt_trans _ ((S n)! - 1)); [ easy | ].
apply Nat.sub_lt; [ | easy ].
apply Nat.le_succ_l, Nat.neq_0_lt_0, fact_neq_0.
Qed.

(* det' and det'' are equal *)

Theorem det'_is_det'' :
  rngl_has_opp = true →
  ∀ (M : matrix T), det' M = det'' M.
Proof.
intros Hop *.
specialize (proj2 rngl_has_opp_or_subt_iff) as Hos.
specialize (Hos (or_introl Hop)).
move Hos before Hop.
destruct (Nat.eq_dec (mat_nrows M) 0) as [Hrz| Hrz]. {
  unfold det', det''.
  now rewrite Hrz.
}
unfold det''.
remember (mat_nrows M) as n eqn:Hn.
unfold det'.
rewrite <- Hn.
specialize (fact_neq_0 n) as Hfnz.
specialize (Nat.pow_nonzero n n Hrz) as Hpnz.
erewrite rngl_summation_change_var. 2: {
  intros i Hi.
  apply canon_sym_gr_list_inv_canon_sym_gr_list with (n := n).
  flia Hi Hfnz.
}
rewrite Nat.sub_0_r.
replace (λ i, canon_sym_gr_list n i) with (canon_sym_gr_list n) by easy.
rewrite <- Nat.sub_succ_l; [ | flia Hfnz ].
rewrite Nat.sub_succ, Nat.sub_0_r.
replace (map _ _) with (canon_sym_gr_list_list n) by easy.
erewrite rngl_summation_list_eq_compat. 2: {
  intros i Hi.
  rewrite canon_sym_gr_list_canon_sym_gr_list_inv. 2: {
    apply in_map_iff in Hi.
    destruct Hi as (j & Hji & Hj); subst i.
    apply in_seq in Hj.
    now apply canon_sym_gr_list_permut_seq_with_len.
  }
  easy.
}
cbn.
assert (Hincl : canon_sym_gr_list_list n ⊂ map (map pred) (cart_prod_rep_seq n)). {
  intros l Hl.
  apply in_map_iff in Hl.
  apply in_map_iff.
  destruct Hl as (i & Hil & Hi).
  subst l.
  apply in_seq in Hi; cbn in Hi; destruct Hi as (_, Hi).
  exists (map S (canon_sym_gr_list n i)).
  rewrite map_map.
  erewrite map_ext_in. 2: {
    intros j Hj.
    now rewrite Nat.pred_succ.
  }
  rewrite map_id.
  split; [ easy | ].
  apply in_cart_prod_rep_seq_iff.
  right.
  split; [ easy | ].
  split; [ now rewrite map_length, canon_sym_gr_list_length | ].
  intros j Hj.
  apply in_map_iff in Hj.
  destruct Hj as (k & Hkj & Hk).
  subst j.
  split; [ flia | ].
  apply Nat.le_succ_l.
  apply (In_nth _ _ 0) in Hk.
  destruct Hk as (j & Hj & Hjk).
  rewrite canon_sym_gr_list_length in Hj; subst k.
  now apply canon_sym_gr_list_ub.
}
symmetry.
replace (cart_prod_rep_seq n) with (map (λ l, map S (map pred l)) (cart_prod_rep_seq n)). 2: {
  erewrite map_ext_in. 2: {
    intros l Hl.
    rewrite map_map.
    apply in_cart_prod_rep_seq_iff in Hl.
    destruct Hl as [Hl| Hl]; [ now exfalso | ].
    destruct Hl as (_ & _ & Hl).
    erewrite map_ext_in. 2: {
      intros i Hi.
      specialize (Hl i Hi).
      rewrite Nat.succ_pred_pos; [ | flia Hl ].
      easy.
    }
    now rewrite map_id.
  }
  apply map_id.
}
rewrite <- map_map.
rewrite rngl_summation_list_map.
assert (H1 :
  ∑ (l ∈ map (map pred) (cart_prod_rep_seq n)),
  ε l * ∏ (j = 1, n), mat_el M j (l.(j) + 1) =
  ∑ (l ∈ map (map pred) (cart_prod_rep_seq n)),
  if ListDec.In_dec (list_eq_dec Nat.eq_dec) l (canon_sym_gr_list_list n) then
    ε l * ∏ (j = 1, n), mat_el M j (l.(j) + 1)
  else 0). {
  apply rngl_summation_list_eq_compat.
  intros l Hl.
  destruct (ListDec.In_dec (list_eq_dec Nat.eq_dec)) as [H1| H1]; [ easy | ].
  assert (H : ε l = 0%L). {
    apply ε_when_dup; [ easy | ].
    intros Hnd.
    apply H1; clear H1.
    apply in_map_iff.
    apply in_map_iff in Hl.
    destruct Hl as (l1 & H & Hl); subst l; rename l1 into l.
    apply in_cart_prod_rep_seq_iff in Hl.
    destruct Hl as [Hl| Hl]; [ easy | ].
    destruct Hl as (_ & Hln & Hin).
    exists (canon_sym_gr_list_inv n (map pred l)).
    assert (Hp : permut_seq_with_len n (map pred l)). {
      unfold permut_seq_with_len.
      rewrite map_length.
      split; [ | easy ].
      apply permut_seq_iff.
      split; [ | easy ].
      intros j Hj.
      rewrite map_length, Hln.
      apply in_map_iff in Hj.
      destruct Hj as (a & Hj & Ha); subst j.
      specialize (Hin _ Ha).
      flia Hin.
    }
    split; [ now apply canon_sym_gr_list_canon_sym_gr_list_inv | ].
    apply in_seq.
    split; [ easy | ].
    rewrite Nat.add_0_l.
    now apply canon_sym_gr_list_inv_ub.
  }
  rewrite H.
  now apply rngl_mul_0_l.
}
erewrite rngl_summation_list_eq_compat. 2: {
  intros l Hl.
  rewrite ε_map_S.
  erewrite rngl_product_eq_compat. 2: {
    intros i Hi.
    rewrite (List_map_nth' 0). 2: {
      apply in_map_iff in Hl.
      destruct Hl as (l1 & H & Hl); subst l.
      rename l1 into l.
      rewrite map_length.
      apply in_cart_prod_rep_seq_iff in Hl.
      destruct Hl as [Hl| Hl]; [ easy | ].
      destruct Hl as (_ & Hln & Hin).
      rewrite Hln; flia Hi.
    }
    rewrite <- Nat.add_1_r.
    easy.
  }
  easy.
}
cbn.
rewrite H1.
symmetry.
apply rngl_summation_list_incl; [ | | easy ]. {
  unfold canon_sym_gr_list_list.
  apply (NoDup_map_iff 0).
  rewrite seq_length.
  intros * Hi Hj Hij.
  rewrite seq_nth in Hij; [ | easy ].
  rewrite seq_nth in Hij; [ | easy ].
  cbn in Hij.
  now apply (canon_sym_gr_list_inj n).
} {
  apply NoDup_map_inv with (f := map S).
  rewrite map_map.
  erewrite map_ext_in. 2: {
    intros l Hl.
    rewrite map_map.
    erewrite map_ext_in. 2: {
      intros i Hi.
      apply in_cart_prod_rep_seq_iff in Hl.
      destruct Hl as [Hl| Hl]; [ now exfalso | ].
      destruct Hl as (_ & _ & Hl).
      specialize (Hl i Hi).
      rewrite Nat.succ_pred_pos; [ | flia Hl ].
      easy.
    }
    now rewrite map_id.
  }
  rewrite map_id.
  apply NoDup_cart_prod_rep_seq.
}
Qed.

(* det and det'' are equal *)

Theorem det_is_det'' :
  rngl_has_opp = true →
  ∀ (M : matrix T),
  is_square_matrix M = true
  → det M = det'' M.
Proof.
intros Hop * Hm.
rewrite (det_is_det' Hop); [ | easy ].
apply (det'_is_det'' Hop).
Qed.

(* multilinearity *)

Theorem determinant_multilinear :
  rngl_mul_is_comm = true →
  rngl_has_opp = true →
  ∀ n (M : matrix T) i a b U V,
  is_square_matrix M = true
  → mat_nrows M = n
  → vect_size U = n
  → vect_size V = n
  → 1 ≤ i ≤ n
  → det (mat_repl_vect i M (a × U + b × V)%V) =
       (a * det (mat_repl_vect i M U) +
        b * det (mat_repl_vect i M V))%L.
Proof.
intros Hic Hop * Hsm Hr Hu Hv Hi.
specialize (proj2 rngl_has_opp_or_subt_iff) as Hos.
specialize (Hos (or_introl Hop)).
move Hos before Hop.
specialize (squ_mat_ncols _ Hsm) as Hcn.
(* using the snd version of determinants: determinant' *)
rewrite det_is_det'; try easy. 2: {
  apply mat_repl_vect_is_square; [ congruence | cbn | easy ].
  rewrite map2_length.
  do 2 rewrite map_length, fold_vect_size.
  rewrite Hu, Hv.
  now rewrite Nat.min_id.
}
rewrite det_is_det'; try easy. 2: {
  apply mat_repl_vect_is_square; [ congruence | congruence | easy ].
}
rewrite det_is_det'; try easy. 2: {
  apply mat_repl_vect_is_square; [ congruence | congruence | easy ].
}
unfold det'.
(* simplification of the lhs *)
remember (a × U + b × V)%V as UV eqn:HUV.
assert (Hvm : vect_size UV = mat_nrows M). {
  rewrite Hr, HUV; cbn.
  rewrite map2_length.
  do 2 rewrite map_length.
  do 2 rewrite fold_vect_size.
  rewrite Hu, Hv.
  apply Nat.min_id.
}
rewrite mat_repl_vect_nrows; [ | easy ].
rewrite mat_repl_vect_nrows; [ | congruence ].
rewrite mat_repl_vect_nrows; [ | congruence ].
rewrite Hr.
erewrite rngl_summation_eq_compat. 2: {
  intros k Hk.
  assert (Hkn : k < n!). {
    eapply le_lt_trans; [ apply Hk | ].
    apply Nat.sub_lt; [ | flia ].
    apply Nat.neq_0_lt_0, fact_neq_0.
  }
  erewrite rngl_product_eq_compat. 2: {
    intros j Hj.
    rewrite mat_el_repl_vect; cycle 1. {
      now apply squ_mat_is_corr.
    } {
      subst UV; cbn.
      rewrite map2_length.
      do 2 rewrite map_length.
      do 2 rewrite fold_vect_size.
      rewrite Hu, Hv, Nat.min_id.
      flia Hj.
    } {
      rewrite Hr; flia Hj.
    } {
      rewrite Hcn, Hr.
      rewrite Nat.add_1_r.
      split; [ flia | ].
      apply canon_sym_gr_list_ub; [ easy | flia Hj ].
    } {
      now rewrite Hcn, Hr.
    }
    unfold vect_el.
    cbn - [ Nat.eq_dec ].
    easy.
  }
  easy.
}
cbn - [ mat_el ].
(* put a and b inside the sigma in the rhs *)
rewrite rngl_mul_summation_distr_l; [ | easy ].
rewrite rngl_mul_summation_distr_l; [ | easy ].
symmetry.
erewrite rngl_summation_eq_compat. 2: {
  intros k Hk.
  assert (Hkn : k < fact n). {
    specialize (fact_neq_0 n) as Hnz.
    flia Hk Hnz.
  }
  rewrite rngl_mul_assoc.
  rewrite <- (ε_mul_comm Hop).
  erewrite rngl_product_eq_compat. 2: {
    intros j Hj.
    rewrite mat_el_repl_vect; cycle 1. {
      now apply squ_mat_is_corr.
    } {
      rewrite Hu; flia Hj.
    } {
      rewrite Hr; flia Hj.
    } {
      cbn.
      rewrite Hcn, Hr, Nat.add_1_r.
      split; [ flia | ].
      apply canon_sym_gr_list_ub; [ easy | flia Hj ].
    } {
      now rewrite Hcn, Hr.
    }
    now unfold vect_el; cbn.
  }
  easy.
}
rewrite rngl_add_comm.
erewrite rngl_summation_eq_compat. 2: {
  intros k Hk.
  assert (Hkn : k < fact n). {
    specialize (fact_neq_0 n) as Hnz.
    flia Hk Hnz.
  }
  rewrite rngl_mul_assoc.
  rewrite <- (ε_mul_comm Hop).
  erewrite rngl_product_eq_compat. 2: {
    intros j Hj.
    rewrite mat_el_repl_vect; cycle 1. {
      now apply squ_mat_is_corr.
    } {
      rewrite Hv; flia Hj.
    } {
      rewrite Hr; flia Hj.
    } {
      rewrite Hcn, Hr, Nat.add_1_r.
      split; [ flia | ].
      apply canon_sym_gr_list_ub; [ easy | flia Hj ].
    } {
      now rewrite Hcn, Hr.
    }
    now unfold vect_el; cbn.
  }
  easy.
}
rewrite rngl_add_comm.
(* make one summation *)
rewrite <- rngl_summation_add_distr.
apply rngl_summation_eq_compat.
intros k Hk.
do 2 rewrite <- rngl_mul_assoc.
rewrite <- rngl_mul_add_distr_l.
(* elimination of the ε-s *)
f_equal.
(* *)
assert (Hkn : k < fact n). {
  specialize (fact_neq_0 n) as Hnz.
  flia Hk Hnz.
}
assert (H : i - 1 < n) by flia Hi.
specialize (canon_sym_gr_surjective Hkn H) as Hp; clear H.
destruct Hp as (p & Hp & Hpp).
rewrite (rngl_product_split (p + 1)); [ | flia Hp ].
rewrite rngl_product_split_last; [ | flia ].
erewrite rngl_product_eq_compat. 2: {
  intros j Hj.
  replace (j - 1 - 1) with (j - 2) by flia.
  destruct (Nat.eq_dec (nth (j - 2) (canon_sym_gr_list n k) 0 + 1) i)
    as [Hpj| Hpj]. {
    exfalso.
    rewrite <- Hpj in Hpp.
    rewrite Nat.add_sub in Hpp.
    symmetry in Hpp.
    apply nth_canon_sym_gr_list_inj1 in Hpp; [ | easy | flia Hp Hj | easy ].
    flia Hj Hpp.
  }
  easy.
}
rewrite rngl_add_comm.
rewrite (rngl_product_split (p + 1)); [ | flia Hp ].
rewrite rngl_product_split_last; [ | flia ].
erewrite rngl_product_eq_compat. 2: {
  intros j Hj.
  replace (j - 1 - 1) with (j - 2) by flia.
  destruct (Nat.eq_dec (nth (j - 2) (canon_sym_gr_list n k) 0 + 1) i)
    as [Hpj| Hpj]. {
    exfalso.
    rewrite <- Hpj, Nat.add_sub in Hpp.
    symmetry in Hpp.
    apply nth_canon_sym_gr_list_inj1 in Hpp; [ | easy | flia Hp Hj | easy ].
    flia Hj Hpp.
  }
  easy.
}
rewrite rngl_add_comm.
symmetry.
rewrite (rngl_product_split (p + 1)); [ | flia Hp ].
rewrite rngl_product_split_last; [ | flia ].
erewrite rngl_product_eq_compat. 2: {
  intros j Hj.
  replace (j - 1 - 1) with (j - 2) by flia.
  destruct (Nat.eq_dec (nth (j - 2) (canon_sym_gr_list n k) 0 + 1) i)
    as [Hpj| Hpj]. {
    exfalso.
    rewrite <- Hpj, Nat.add_sub in Hpp.
    symmetry in Hpp.
    apply nth_canon_sym_gr_list_inj1 in Hpp; [ | easy | flia Hp Hj | easy ].
    flia Hj Hpp.
  }
  easy.
}
rewrite Nat.add_sub.
rewrite Hpp.
destruct (Nat.eq_dec i i) as [H| H]; [ clear H | easy ].
do 4 rewrite rngl_mul_assoc.
subst UV.
cbn - [ mat_el ].
rewrite map2_nth with (a := 0%L) (b := 0%L); cycle 1. {
  now rewrite map_length, fold_vect_size, Hu.
} {
  now rewrite map_length, fold_vect_size, Hv.
}
rewrite (List_map_nth' 0%L); [ | now rewrite fold_vect_size, Hu ].
rewrite (List_map_nth' 0%L); [ | now rewrite fold_vect_size, Hv ].
do 2 rewrite fold_vect_el.
rewrite Nat.sub_add; [ | flia Hi ].
rewrite <- if_eqb_eq_dec, Nat.eqb_refl.
rewrite <- if_eqb_eq_dec, Nat.eqb_refl.
rewrite <- if_eqb_eq_dec, Nat.eqb_refl.
(* elimination of the following term (q) *)
remember
  (∏ (i0 = 2, p + 1),
   mat_el M (i0 - 1) (nth (i0 - 2) (canon_sym_gr_list n k) O + 1))
  as q eqn:Hq.
symmetry.
rewrite (rngl_mul_comm Hic a).
rewrite (rngl_mul_comm Hic b).
do 5 rewrite <- rngl_mul_assoc.
rewrite <- rngl_mul_add_distr_l.
f_equal.
clear q Hq.
erewrite rngl_product_eq_compat. 2: {
  intros j Hj.
  destruct (Nat.eq_dec (nth (j - 1) (canon_sym_gr_list n k) 0 + 1) i)
    as [Hpj| Hpj]. {
    rewrite <- Hpj, Nat.add_sub in Hpp.
    symmetry in Hpp.
    apply nth_canon_sym_gr_list_inj1 in Hpp; [ | easy | flia Hp Hj | easy ].
    flia Hj Hpp.
  }
  easy.
}
symmetry.
erewrite rngl_product_eq_compat. 2: {
  intros j Hj.
  destruct (Nat.eq_dec (nth (j - 1) (canon_sym_gr_list n k) 0 + 1) i)
    as [Hpj| Hpj]. {
    rewrite <- Hpj, Nat.add_sub in Hpp.
    symmetry in Hpp.
    apply nth_canon_sym_gr_list_inj1 in Hpp; [ | easy | flia Hp Hj | easy ].
    flia Hj Hpp.
  }
  easy.
}
symmetry.
rewrite rngl_add_comm.
erewrite rngl_product_eq_compat. 2: {
  intros j Hj.
  destruct (Nat.eq_dec (nth (j - 1) (canon_sym_gr_list n k) 0 + 1) i)
    as [Hpj| Hpj]. {
    rewrite <- Hpj, Nat.add_sub in Hpp.
    symmetry in Hpp.
    apply nth_canon_sym_gr_list_inj1 in Hpp; [ | easy | flia Hp Hj | easy ].
    flia Hj Hpp.
  }
  easy.
}
cbn.
rewrite rngl_add_comm.
do 2 rewrite rngl_mul_assoc.
now rewrite <- rngl_mul_add_distr_r.
Qed.

Definition mat_swap_rows i1 i2 (M : matrix T) :=
  mk_mat (list_swap_elem [] (mat_list_list M) (i1 - 1) (i2 - 1)).

Theorem mat_swap_rows_is_square : ∀ (M : matrix T) p q,
  1 ≤ p ≤ mat_nrows M
  → 1 ≤ q ≤ mat_nrows M
  → is_square_matrix M = true
  → is_square_matrix (mat_swap_rows p q M) = true.
Proof.
intros * Hp Hq Hsm.
remember (mat_nrows M) as n eqn:Hr.
symmetry in Hr.
specialize (squ_mat_ncols _ Hsm) as Hcn.
specialize (squ_mat_is_corr M Hsm) as Hco.
apply is_scm_mat_iff in Hsm.
apply is_scm_mat_iff.
destruct Hsm as (Hcr & Hc).
cbn; unfold list_swap_elem.
rewrite List_map_seq_length.
unfold mat_swap_rows, list_swap_elem; cbn.
split. {
  unfold mat_ncols; cbn.
  rewrite fold_mat_nrows; rewrite Hr.
  rewrite (List_map_hd 0); [ | rewrite seq_length; flia Hp ].
  rewrite List_seq_hd; [ | flia Hp ].
  rewrite Hc; [ now intros Hn; subst n | ].
  apply nth_In; rewrite fold_mat_nrows; rewrite Hr.
  unfold transposition.
  do 2 rewrite if_eqb_eq_dec.
  destruct (Nat.eq_dec 0 (p - 1)); [ flia Hq | ].
  destruct (Nat.eq_dec 0 (q - 1)); [ flia Hp | ].
  flia Hp.
} {
  intros la Hla.
  apply in_map_iff in Hla.
  rewrite fold_mat_nrows, Hr in Hla.
  destruct Hla as (a & Ha & Hla).
  apply in_seq in Hla; subst la.
  rewrite fold_corr_mat_ncols; [ easy | easy | rewrite Hr ].
  unfold transposition.
  do 2 rewrite if_eqb_eq_dec.
  destruct (Nat.eq_dec a (p - 1)); [ flia Hq | ].
  destruct (Nat.eq_dec a (q - 1)); [ flia Hp | ].
  easy.
}
Qed.

Theorem mat_swap_rows_nrows : ∀ (M : matrix T) p q,
  mat_nrows (mat_swap_rows p q M) = mat_nrows M.
Proof.
intros.
unfold mat_swap_rows; cbn.
unfold list_swap_elem.
rewrite map_length.
now rewrite seq_length.
Qed.

Theorem mat_swap_rows_ncols : ∀ (M : matrix T),
  is_correct_matrix M = true
  → ∀ p q, 1 ≤ p ≤ mat_nrows M → 1 ≤ q ≤ mat_nrows M →
  mat_ncols (mat_swap_rows p q M) = mat_ncols M.
Proof.
intros * Hcm * Hp Hq.
generalize Hcm; intros H.
apply is_scm_mat_iff in H.
destruct H as (Hcr, Hc).
destruct (Nat.eq_dec (mat_nrows M) 0) as [Hrz| Hrz]. {
  destruct M as (ll); cbn in Hrz.
  now apply length_zero_iff_nil in Hrz; subst ll.
}
apply Nat.neq_0_lt_0 in Hrz.
unfold mat_swap_rows; cbn.
unfold list_swap_elem.
unfold mat_ncols; cbn.
do 2 rewrite List_hd_nth_0.
rewrite fold_corr_mat_ncols; [ | easy | easy ].
destruct M as (ll); cbn.
destruct ll as [| la]; [ easy | cbn ].
unfold transposition.
do 2 rewrite if_eqb_eq_dec.
destruct (Nat.eq_dec 0 (p - 1)) as [Hpz| Hpz]. {
  destruct q; [ easy | ].
  destruct q; [ easy | ].
  rewrite Nat_sub_succ_1.
  cbn - [ In ] in Hcr, Hc, Hq.
  apply Hc; right.
  apply nth_In; flia Hq.
}
destruct (Nat.eq_dec 0 (q - 1)) as [Hqz| Hqz]. {
  destruct p; [ easy | ].
  destruct p; [ easy | ].
  rewrite Nat_sub_succ_1.
  cbn - [ In ] in Hcr, Hc, Hp.
  apply Hc; right.
  apply nth_In; flia Hp.
}
easy.
Qed.

Theorem nth_transposition_canon_sym_gr_list_inj : ∀ n k p q i j,
  k < n!
  → p < n
  → q < n
  → i < n
  → j < n
  → nth (transposition p q i) (canon_sym_gr_list n k) 0 =
    nth (transposition p q j) (canon_sym_gr_list n k) 0
  → i = j.
Proof.
intros * Hkn Hpn Hqn Hin Hjn Hij.
unfold transposition in Hij.
do 4 rewrite if_eqb_eq_dec in Hij.
destruct (Nat.eq_dec i p) as [Hip| Hip]. {
  destruct (Nat.eq_dec j p) as [Hjp| Hjp]; [ congruence | ].
  destruct (Nat.eq_dec j q) as [Hjq| Hjq]. {
    apply nth_canon_sym_gr_list_inj1 in Hij; [ | easy | easy | easy ].
    congruence.
  }
  apply Nat.neq_sym in Hjq.
  now apply nth_canon_sym_gr_list_inj1 in Hij.
}
destruct (Nat.eq_dec i q) as [Hiq| Hiq]. {
  destruct (Nat.eq_dec j p) as [Hjp| Hjp]. {
    apply nth_canon_sym_gr_list_inj1 in Hij; [ | easy | easy | easy ].
    congruence.
  }
  destruct (Nat.eq_dec j q) as [Hjq| Hjq]; [ congruence | ].
  apply Nat.neq_sym in Hjp.
  now apply nth_canon_sym_gr_list_inj1 in Hij.
}
destruct (Nat.eq_dec j p) as [Hjp| Hjp]. {
  now apply nth_canon_sym_gr_list_inj1 in Hij.
}
destruct (Nat.eq_dec j q) as [Hjq| Hjq]. {
  now apply nth_canon_sym_gr_list_inj1 in Hij.
}
now apply nth_canon_sym_gr_list_inj1 in Hij.
Qed.

Theorem determinant_alternating :
  rngl_mul_is_comm = true →
  rngl_has_opp = true →
  ∀ (M : matrix T) p q,
  p ≠ q
  → 1 ≤ p ≤ mat_nrows M
  → 1 ≤ q ≤ mat_nrows M
  → is_square_matrix M = true
  → det (mat_swap_rows p q M) = (- det M)%L.
Proof.
intros Hic Hop * Hpq Hp Hq Hsm.
specialize (proj2 rngl_has_opp_or_subt_iff) as Hos.
specialize (Hos (or_introl Hop)).
remember (mat_nrows M) as n eqn:Hr; symmetry in Hr.
rewrite (det_is_det' Hop). 2: {
  rewrite <- Hr in Hp, Hq.
  now apply mat_swap_rows_is_square.
}
unfold det'.
rewrite mat_swap_rows_nrows.
rewrite Hr.
erewrite rngl_summation_eq_compat. 2: {
  intros k Hk.
  rewrite (rngl_product_shift 1); [ | flia Hp ].
  rewrite Nat.sub_diag.
  erewrite rngl_product_eq_compat. 2: {
    intros i Hi.
    now rewrite Nat.add_comm, Nat.add_sub.
  }
  easy.
}
cbn - [ mat_swap_rows ].
erewrite rngl_summation_eq_compat. 2: {
  intros k Hk.
  rewrite rngl_product_change_var with
    (g := transposition (p - 1) (q - 1)) (h := transposition (p - 1) (q - 1)).
  2: {
    intros i Hi.
    apply transposition_involutive.
  }
  rewrite Nat.sub_0_r.
  rewrite <- Nat.sub_succ_l; [ | flia Hp ].
  rewrite Nat_sub_succ_1.
  easy.
}
cbn - [ mat_swap_rows ].
assert (Hp' : p - 1 < n) by flia Hp.
assert (Hq' : q - 1 < n) by flia Hq.
erewrite rngl_summation_eq_compat. 2: {
  intros k Hk.
  rewrite (rngl_product_list_permut _ Nat.eqb_eq) with
      (lb := seq 0 n); [ | easy | ]. 2: {
    remember (map _ _) as la eqn:Hla.
    replace n with (length la) by now rewrite Hla, List_map_seq_length.
    subst la.
    now apply transposition_permut_seq_with_len.
  }
  easy.
}
cbn - [ mat_swap_rows ].
erewrite rngl_summation_eq_compat. 2: {
  intros k Hk.
  assert (Hkn : k < n!). {
    specialize (fact_neq_0 n) as Hn.
    flia Hk Hn.
  }
  erewrite rngl_product_list_eq_compat. 2: {
    intros i Hi.
    replace (mat_el _ _ _) with
      (mat_el M (i + 1)
         (nth (transposition (p - 1) (q - 1) i) (canon_sym_gr_list n k) 0 + 1)).
    2: {
      cbn.
      unfold mat_el; f_equal.
      unfold list_swap_elem.
      do 2 rewrite Nat.add_sub.
      rewrite (List_map_nth' 0). 2: {
        rewrite seq_length.
        rewrite fold_mat_nrows, Hr.
        apply in_seq in Hi.
        now apply transposition_lt.
      }
      rewrite fold_mat_nrows, Hr.
      unfold transposition.
      do 2 rewrite if_eqb_eq_dec.
      destruct (Nat.eq_dec i (p - 1)) as [Hip| Hip]. {
        subst i.
        rewrite seq_nth; [ | easy ].
        rewrite Nat.add_0_l.
        rewrite Nat.eqb_refl.
        apply Nat.neq_sym in Hpq.
        destruct (Nat.eq_dec (q - 1) (p - 1)) as [H| H]; [ | easy ].
        now rewrite H.
      }
      rewrite if_eqb_eq_dec.
      destruct (Nat.eq_dec i (q - 1)) as [Hiq| Hiq]. {
        subst i.
        rewrite seq_nth; [ | easy ].
        rewrite Nat.add_0_l.
        rewrite <- if_eqb_eq_dec.
        now rewrite Nat.eqb_refl.
      }
      apply in_seq in Hi.
      rewrite seq_nth; [ | easy ].
      rewrite Nat.add_0_l.
      rewrite if_eqb_eq_dec.
      destruct (Nat.eq_dec i (p - 1)) as [H| H]; [ easy | clear H ].
      now destruct (Nat.eq_dec i (q - 1)).
    }
    easy.
  }
  easy.
}
cbn.
set (f := λ k, list_swap_elem 0 (canon_sym_gr_list n k) (p - 1) (q - 1)).
erewrite rngl_summation_eq_compat. 2: {
  intros k Hk.
  erewrite rngl_product_list_eq_compat. 2: {
    intros i Hi.
    apply in_seq in Hi.
    replace (nth _ _ 0) with
       (nth i (list_swap_elem 0 (canon_sym_gr_list n k) (p - 1) (q - 1)) 0).
    2: {
(* lemme à faire *)
      unfold list_swap_elem.
      rewrite (List_map_nth' 0). 2: {
        now rewrite seq_length, canon_sym_gr_list_length.
      }
      rewrite seq_nth; [ easy | now rewrite canon_sym_gr_list_length ].
    }
    fold (f k).
    easy.
  }
  easy.
}
cbn.
erewrite rngl_summation_eq_compat. 2: {
  intros k Hk.
  assert (Hkn : k < n!). {
    specialize (fact_neq_0 n) as Hn.
    flia Hk Hn.
  }
  erewrite rngl_product_seq_product; [ | flia Hp ].
  rewrite Nat.add_0_l.
  replace (canon_sym_gr_list n k) with
     (map (λ i, nth (transposition (p - 1) (q - 1) i) (f k) 0) (seq 0 n)).
  2: {
    rewrite List_map_nth_seq with (d := 0).
    rewrite canon_sym_gr_list_length.
    apply map_ext_in.
    intros i Hi; cbn.
    apply in_seq in Hi.
    unfold f, list_swap_elem.
    rewrite (List_map_nth' 0). 2: {
      rewrite seq_length, canon_sym_gr_list_length.
      now apply transposition_lt.
    }
    rewrite seq_nth. 2: {
      rewrite canon_sym_gr_list_length.
      now apply transposition_lt.
    }
    rewrite Nat.add_0_l.
    now rewrite transposition_involutive.
  }
  replace (map (λ i, nth (transposition (p - 1) (q - 1) i) (f k) 0) (seq 0 n))
  with (f k ° map (λ i, transposition (p - 1) (q - 1) i) (seq 0 n)). 2: {
    unfold "°"; cbn.
    now rewrite map_map.
  }
  rewrite sign_comp; [ | easy | ]. 2: {
    split. 2: {
      rewrite List_map_seq_length.
      unfold f.
      rewrite list_swap_elem_length.
      symmetry.
      apply canon_sym_gr_list_length.
    }
    apply permut_seq_iff.
    split. {
      intros i Hi.
      rewrite List_map_seq_length.
      apply In_nth with (d := 0) in Hi.
      rewrite List_map_seq_length in Hi.
      destruct Hi as (j & Hj & Hji).
      rewrite (List_map_nth' 0) in Hji; [ | now rewrite seq_length ].
      rewrite seq_nth in Hji; [ | easy ].
      rewrite <- Hji.
      now apply transposition_lt.
    }
    apply (NoDup_map_iff 0).
    rewrite seq_length.
    intros i j Hi Hj Hij.
    rewrite seq_nth in Hij; [ | easy ].
    rewrite seq_nth in Hij; [ | easy ].
    cbn in Hij.
    unfold transposition in Hij.
    do 4 rewrite if_eqb_eq_dec in Hij.
    destruct (Nat.eq_dec i (p - 1)) as [Hip| Hip]. {
      subst i.
      destruct (Nat.eq_dec j (p - 1)) as [Hjp| Hjp]; [ easy | ].
      symmetry in Hij.
      destruct (Nat.eq_dec j (q - 1)); [ | easy ].
      congruence.
    }
    destruct (Nat.eq_dec i (q - 1)) as [Hiq| Hiq]. {
      subst i.
      symmetry in Hij.
      destruct (Nat.eq_dec j (p - 1)) as [Hjp| Hjp]; [ easy | ].
      now destruct (Nat.eq_dec j (q - 1)).
    }
    destruct (Nat.eq_dec j (p - 1)) as [Hjp| Hjp]; [ easy | ].
    now destruct (Nat.eq_dec j (q - 1)).
  }
  easy.
}
cbn.
erewrite rngl_summation_eq_compat. 2: {
  intros k (_, Hk).
  rewrite (rngl_mul_comm Hic (ε (f k))).
  rewrite <- rngl_mul_assoc.
  rewrite (transposition_signature Hop); [ easy | | easy | easy ].
  flia Hp Hq Hpq.
}
cbn - [ f ].
rewrite <- rngl_mul_summation_distr_l; [ | easy ].
rewrite rngl_mul_opp_l; [ | easy ].
f_equal.
rewrite rngl_mul_1_l.
symmetry.
set (g := λ k, canon_sym_gr_list_inv n (f k)).
rewrite rngl_summation_change_var with (g := g) (h := g). 2: {
  intros k (_, Hk).
  assert (Hkn : k < n!). {
    specialize (fact_neq_0 n) as Hn.
    flia Hk Hn.
  }
  unfold g, f.
  unfold list_swap_elem.
  do 2 rewrite canon_sym_gr_list_length.
  erewrite map_ext_in. 2: {
    intros i Hi; apply in_seq in Hi.
    rewrite canon_sym_gr_list_canon_sym_gr_list_inv. 2: {
(* lemme à faire ? *)
      split; [ | now rewrite map_length, seq_length ].
      apply permut_seq_iff.
      split. {
        intros j Hj.
        rewrite map_length, seq_length.
        apply in_map_iff in Hj.
        destruct Hj as (m & Hmj & Hm).
        apply in_seq in Hm.
        rewrite <- Hmj.
        apply canon_sym_gr_list_ub; [ easy | ].
        apply transposition_lt; [ flia Hp | flia Hq | easy ].
      } {
        apply (NoDup_map_iff 0).
        rewrite seq_length.
        intros u v Hu Hv Huv.
        rewrite seq_nth in Huv; [ | easy ].
        rewrite seq_nth in Huv; [ | easy ].
        cbn in Huv.
        now apply nth_transposition_canon_sym_gr_list_inj in Huv.
      }
    }
    rewrite (List_map_nth' 0). 2: {
      rewrite seq_length.
      now apply transposition_lt.
    }
    rewrite seq_nth. 2: {
      now apply transposition_lt.
    }
    rewrite Nat.add_0_l.
    rewrite transposition_involutive.
    easy.
  }
  rewrite <- List_map_nth_seq'; [ | now rewrite canon_sym_gr_list_length ].
  now apply canon_sym_gr_list_inv_canon_sym_gr_list.
}
rewrite Nat.sub_0_r.
rewrite <- Nat.sub_succ_l; [ | apply Nat.neq_0_lt_0, fact_neq_0 ].
rewrite Nat_sub_succ_1.
rewrite (rngl_summation_list_permut _ Nat.eqb_eq) with (lb := seq 0 n!);
    cycle 1. {
  remember (map _ _) as la eqn:Hla.
  replace n! with (length la) by now rewrite Hla, List_map_seq_length.
  subst la.
(* lemma to do? *)
  unfold g, f.
  apply permut_seq_iff.
  split. {
    intros i Hi.
    rewrite map_length, seq_length.
    apply in_map_iff in Hi.
    destruct Hi as (j & Hji & Hj).
    apply in_seq in Hj.
    rewrite <- Hji.
    apply canon_sym_gr_list_inv_ub.
    apply list_swap_elem_permut_seq_with_len; [ easy | easy | ].
    now apply canon_sym_gr_list_permut_seq_with_len.
  } {
    apply (NoDup_map_iff 0).
    rewrite seq_length.
    intros i j Hi Hj Hij.
    rewrite seq_nth in Hij; [ | easy ].
    rewrite seq_nth in Hij; [ | easy ].
    do 2 rewrite Nat.add_0_l in Hij.
    apply rank_of_permut_in_canon_gr_list_inj in Hij; cycle 1. {
      apply list_swap_elem_permut_seq_with_len; [ easy | easy | ].
      now apply canon_sym_gr_list_permut_seq_with_len.
    } {
      apply list_swap_elem_permut_seq_with_len; [ easy | easy | ].
      now apply canon_sym_gr_list_permut_seq_with_len.
    }
(* lemme à faire ? *)
    unfold list_swap_elem in Hij.
    do 2 rewrite canon_sym_gr_list_length in Hij.
    apply nth_canon_sym_gr_list_inj2 with (n := n); [ easy | easy | ].
    intros k Hkn.
    apply ext_in_map with (a := transposition (p - 1) (q - 1) k) in Hij. 2: {
      apply in_seq.
      split; [ flia | ].
      now apply transposition_lt.
    }
    now rewrite transposition_involutive in Hij.
  }
}
rewrite det_is_det'; [ | easy | easy ].
unfold det'.
rewrite rngl_summation_seq_summation; [ | apply fact_neq_0 ].
rewrite Nat.add_0_l.
rewrite Hr.
apply rngl_summation_eq_compat.
intros k Hk.
assert (Hkn : k < n!). {
  specialize (fact_neq_0 n) as Hn.
  flia Hk Hn.
}
assert (Hc : canon_sym_gr_list n k = f (g k)). {
  unfold g, f.
  rewrite canon_sym_gr_list_canon_sym_gr_list_inv. 2: {
    apply list_swap_elem_permut_seq_with_len; [ easy | easy | ].
    now apply canon_sym_gr_list_permut_seq_with_len.
  }
  rewrite list_swap_elem_involutive; [ easy | | ]. {
    now rewrite canon_sym_gr_list_length.
  } {
    now rewrite canon_sym_gr_list_length.
  }
}
f_equal; [ now rewrite Hc | ].
rewrite (rngl_product_shift 1); [ | flia Hp ].
apply rngl_product_eq_compat.
intros i Hi.
rewrite Nat.add_comm, Nat.add_sub.
now rewrite Hc.
Qed.

Theorem determinant_same_rows :
  rngl_mul_is_comm = true →
  rngl_has_opp = true →
  rngl_characteristic = 0 →
  (rngl_is_integral || rngl_has_inv_or_quot)%bool = true →
  ∀ (M : matrix T) p q,
  is_square_matrix M = true
  → p ≠ q
  → 1 ≤ p ≤ mat_nrows M
  → 1 ≤ q ≤ mat_nrows M
  → (∀ j, 1 ≤ j → mat_el M p j = mat_el M q j)
  → det M = 0%L.
Proof.
intros Hic Hop Hch Hii * Hsm Hpq Hpn Hqn Hjpq.
specialize (proj2 rngl_has_opp_or_subt_iff) as Hos.
specialize (Hos (or_introl Hop)).
move Hos before Hop.
remember (mat_nrows M) as n eqn:Hr; symmetry in Hr.
specialize (squ_mat_ncols M Hsm) as Hc.
assert (HM : det M = (- det M)%L). {
  rewrite <- Hr in Hpn, Hqn.
  rewrite <- determinant_alternating with (p := p) (q := q); try easy.
  f_equal.
  destruct M as (ll); cbn in *.
  unfold mat_swap_rows; cbn; f_equal.
  rewrite (List_map_nth_seq ll) with (d := []) at 1.
  apply map_ext_in.
  intros i Hi; apply in_seq in Hi.
  unfold transposition.
  do 2 rewrite if_eqb_eq_dec.
  destruct (Nat.eq_dec i (p - 1)) as [Hip| Hip]. {
    subst i.
    rewrite List_map_nth_seq with (d := 0%L); symmetry.
    rewrite List_map_nth_seq with (d := 0%L); symmetry.
    apply is_scm_mat_iff in Hsm.
    cbn in Hsm.
    destruct Hsm as (Hcz, Hsm).
    rewrite Hsm; [ | now apply nth_In ].
    rewrite Hsm; [ | apply nth_In; flia Hqn ].
    apply map_ext_in.
    intros j Hj.
    specialize (Hjpq (S j)).
    rewrite Nat_sub_succ_1 in Hjpq.
    apply Hjpq; flia.
  }
  destruct (Nat.eq_dec i (q - 1)) as [Hiq| Hiq]. {
    subst i.
    rewrite List_map_nth_seq with (d := 0%L); symmetry.
    rewrite List_map_nth_seq with (d := 0%L); symmetry.
    apply is_scm_mat_iff in Hsm.
    cbn in Hsm.
    destruct Hsm as (Hcz, Hsm).
    rewrite Hsm; [ | now apply nth_In ].
    rewrite Hsm; [ | apply nth_In; flia Hpn ].
    apply map_ext_in.
    intros j Hj.
    specialize (Hjpq (S j)).
    rewrite Nat_sub_succ_1 in Hjpq.
    symmetry; apply Hjpq; flia.
  }
  easy.
}
apply rngl_add_move_0_r in HM; [ | easy ].
now apply (eq_rngl_add_same_0 Hos Hii Hch) in HM.
Qed.

(* transpositions list of permutation *)

Fixpoint first_non_fixpoint it i σ :=
  match it with
  | 0 => None
  | S it' => if i =? σ i then first_non_fixpoint it' (i + 1) σ else Some i
  end.

Fixpoint tlopf_loop it n (σ : nat → nat) :=
  match it with
  | 0 => []
  | S it' =>
      match first_non_fixpoint n 0 σ with
      | None => []
      | Some i =>
          let σ' := comp (transposition i (σ i)) σ in
          (i, σ i) :: tlopf_loop it' n σ'
      end
  end.

(* *)

Definition mat_mul_row_by_scal n k (M : matrix T) s :=
  mk_mat
    (map
       (λ i,
        map
          (λ j, if Nat.eq_dec i k then (s * mat_el M i j)%L else mat_el M i j)
          (seq 1 n))
       (seq 1 n)).

(* If we multiply a row (column) of A by a number, the determinant of
   A will be multiplied by the same number. *)
(* https://math.vanderbilt.edu/sapirmv/msapir/proofdet1.html
   point 1 *)

(* If the i-th row (column) in A is a sum of the i-th row (column) of
   a matrix B and the i-th row (column) of a matrix C and all other
   rows in B and C are equal to the corresponding rows in A (that is B
   and C differ from A by one row only), then det(A)=det(B)+det(C). *)
(* https://math.vanderbilt.edu/sapirmv/msapir/proofdet1.html
   point 2 *)

(* Well, since my definition of the discriminant only covers the
   row 0, we can prove that only when i=0; this will able us to
   prove the next theorem, swapping rows by going via row 0 *)

Theorem det_add_row_row : ∀ n (A B C : matrix T),
  n ≠ 0
  → mat_nrows A = n
  → mat_nrows B = n
  → mat_nrows C = n
  → is_square_matrix A = true
  → is_square_matrix B = true
  → is_square_matrix C = true
  → (∀ j, mat_el A 1 j = (mat_el B 1 j + mat_el C 1 j)%L)
  → (∀ i j, i ≠ 1 → mat_el B i j = mat_el A i j)
  → (∀ i j, i ≠ 1 → mat_el C i j = mat_el A i j)
  → det A = (det B + det C)%L.
Proof.
intros * Hnz Hra Hrb Hrc Hsma Hsmb Hsmc Hbc Hb Hc.
specialize (squ_mat_ncols _ Hsma) as Hca.
specialize (squ_mat_ncols _ Hsmb) as Hcb.
rewrite Hra in Hca.
rewrite Hrb in Hcb.
destruct n; [ easy | clear Hnz; cbn ].
assert (Hab : ∀ j, subm 1 j A = subm 1 j B). {
  intros.
  destruct A as (lla).
  destruct B as (llb).
  cbn in *.
  unfold subm; f_equal.
  cbn - [ butn ].
  rewrite (List_map_nth_seq lla []).
  rewrite (List_map_nth_seq llb []).
  rewrite Hra, Hrb.
  do 2 rewrite <- map_butn.
  do 2 rewrite map_map.
  apply map_ext_in.
  intros u Hu.
  destruct (Nat.eq_dec u 0) as [Huz| Huz]. {
    subst u; cbn in Hu.
    now apply in_seq in Hu.
  }
  rewrite (List_map_nth_seq (nth u lla []) 0%L).
  rewrite (List_map_nth_seq (nth u llb []) 0%L).
  apply is_scm_mat_iff in Hsma.
  destruct Hsma as (_ & Hca').
  apply in_butn, in_seq in Hu.
  rewrite Hca'. 2: {
    cbn; apply nth_In.
    now rewrite Hra.
  }
  apply is_scm_mat_iff in Hsmb.
  destruct Hsmb as (_ & Hcb').
  rewrite Hcb'. 2: {
    cbn; apply nth_In.
    now rewrite Hrb.
  }
  f_equal; cbn; rewrite Hra, Hrb.
  apply map_ext_in.
  intros v Hv.
  apply in_seq in Hv.
  specialize (Hb (S u) (S v)).
  do 2 rewrite Nat_sub_succ_1 in Hb.
  symmetry; apply Hb; intros H; apply Huz.
  now apply Nat.succ_inj in H.
}
assert (Hac : ∀ j, subm 1 j A = subm 1 j C). {
  intros.
  destruct A as (lla).
  destruct C as (llc).
  cbn in *.
  unfold subm; f_equal.
  cbn - [ butn ].
  rewrite (List_map_nth_seq lla []).
  rewrite (List_map_nth_seq llc []).
  rewrite Hra, Hrc.
  do 2 rewrite <- map_butn.
  do 2 rewrite map_map.
  apply map_ext_in.
  intros u Hu.
  destruct (Nat.eq_dec u 0) as [Huz| Huz]. {
    subst u; cbn in Hu.
    now apply in_seq in Hu.
  }
  rewrite (List_map_nth_seq (nth u lla []) 0%L).
  rewrite (List_map_nth_seq (nth u llc []) 0%L).
  apply is_scm_mat_iff in Hsma.
  destruct Hsma as (_ & Hca').
  apply in_butn, in_seq in Hu.
  rewrite Hca'. 2: {
    cbn; apply nth_In.
    now rewrite Hra.
  }
  apply is_scm_mat_iff in Hsmc.
  destruct Hsmc as (_ & Hcc').
  rewrite Hcc'. 2: {
    cbn; apply nth_In.
    now rewrite Hrc.
  }
  f_equal; cbn; rewrite Hra, Hrc.
  apply map_ext_in.
  intros v Hv.
  apply in_seq in Hv.
  specialize (Hc (S u) (S v)).
  do 2 rewrite Nat_sub_succ_1 in Hc.
  symmetry; apply Hc; intros H; apply Huz.
  now apply Nat.succ_inj in H.
}
unfold det; rewrite Hra, Hrb, Hrc.
cbn.
erewrite rngl_summation_eq_compat. 2: {
  intros j Hj.
  rewrite Hbc.
  rewrite rngl_mul_add_distr_l.
  rewrite rngl_mul_add_distr_r.
  rewrite Hab at 1.
  rewrite Hac at 1.
  easy.
}
cbn.
now apply rngl_summation_add_distr.
Qed.

Theorem rngl_product_map_permut :
  rngl_mul_is_comm = true →
   ∀ n f σ,
  permut_seq_with_len n σ
  → ∏ (i ∈ map (λ i, nth i σ 0) (seq 0 n)), f i = ∏ (i = 1, n), f (i - 1)%nat.
Proof.
intros Hic * Hσ.
destruct (Nat.eq_dec n 0) as [Hnz| Hnz]; [ now subst n | ].
rewrite (rngl_product_list_permut _ Nat.eqb_eq) with
    (lb := seq 0 n); [ | easy | ]. 2: {
  destruct Hσ as (H1, H2).
  rewrite <- H2 at 1.
  now rewrite <- List_map_nth_seq, <- H2.
}
unfold iter_seq.
rewrite Nat_sub_succ_1.
rewrite <- seq_shift.
replace n with (S (n - 1) - 0) by flia Hnz.
rewrite <- rngl_product_change_var; [ easy | ].
intros i Hi.
now rewrite Nat.sub_succ, Nat.sub_0_r.
Qed.

Theorem det_by_any_sym_gr :
  rngl_has_opp = true →
  rngl_characteristic ≠ 1 →
  ∀ n (M : matrix T) (sg : list (list nat)),
  n ≠ 0
  → mat_nrows M = n
  → is_square_matrix M = true
  → is_sym_gr_list n sg
  → det M =
      ∑ (k = 0, n! - 1),
        ε (nth k sg []) * ∏ (i = 1, n), mat_el M i ((nth k sg []).(i) + 1).
Proof.
intros Hop H10 * Hnz Hr Hsm Hsg.
rewrite (det_is_det' Hop); [ | easy ].
unfold det'.
rewrite Hr.
set (g := λ i, canon_sym_gr_list_inv n (nth i sg [])).
set (h := λ i, sym_gr_inv sg (canon_sym_gr_list n i)).
rewrite rngl_summation_change_var with (g := g) (h := h). 2: {
  intros i (_, Hi).
  unfold g, h.
  rewrite (nth_sym_gr_inv_sym_gr Hsg). 2: {
    apply canon_sym_gr_list_permut_seq_with_len.
    specialize (fact_neq_0 n) as H.
    flia Hi H.
  }
  apply canon_sym_gr_list_inv_canon_sym_gr_list.
  specialize (fact_neq_0 n) as H.
  flia Hi H.
}
rewrite Nat.sub_0_r.
rewrite <- Nat.sub_succ_l; [ | apply Nat.neq_0_lt_0, fact_neq_0 ].
rewrite Nat_sub_succ_1.
erewrite rngl_summation_list_eq_compat. 2: {
  intros i Hi.
  apply in_map_iff in Hi.
  destruct Hi as (j & Hji & Hj).
  apply in_seq in Hj.
  unfold g.
  rewrite canon_sym_gr_list_canon_sym_gr_list_inv. 2: {
    split. {
      apply Hsg; rewrite <- Hji.
      now apply (sym_gr_inv_lt _ Hnz).
    } {
      destruct Hsg as (H1 & H2 & H3).
      apply H1; rewrite <- Hji.
      now apply (sym_gr_inv_lt _ Hnz).
    }
  }
  easy.
}
cbn.
apply (rngl_summation_list_permut _ Nat.eqb_eq).
rewrite Nat.sub_0_r.
rewrite <- Nat.sub_succ_l; [ | apply Nat.neq_0_lt_0, fact_neq_0 ].
rewrite Nat_sub_succ_1.
remember (map _ _) as la eqn:Hla.
replace n! with (length la) by now rewrite Hla, List_map_seq_length.
subst la.
(* lemma to do? *)
unfold h.
apply permut_seq_iff.
split. {
  intros i Hi.
  rewrite List_map_seq_length.
  apply in_map_iff in Hi.
  destruct Hi as (j & Hji & Hj).
  apply in_seq in Hj.
  rewrite <- Hji.
  rewrite <- sym_gr_size with (sg := sg); [ | easy ].
  now apply (sym_gr_inv_lt _ Hnz).
} {
  apply (NoDup_map_iff 0).
  rewrite seq_length.
  intros i j Hi Hj Hij.
  rewrite seq_nth in Hij; [ | easy ].
  rewrite seq_nth in Hij; [ | easy ].
  do 2 rewrite Nat.add_0_l in Hij.
  apply (@sym_gr_inv_inj n) in Hij; [ | easy | | ]; cycle 1. {
    now apply canon_sym_gr_list_permut_seq_with_len.
  } {
    now apply canon_sym_gr_list_permut_seq_with_len.
  }
  now apply canon_sym_gr_list_inj in Hij.
}
Qed.

Theorem map_nth_permut_permut_permut_seq_with_len : ∀ n l1 l2,
  permut_seq_with_len n l1
  → permut_seq_with_len n l2
  → permut_seq_with_len n (map (λ i, nth i l1 0) l2).
Proof.
intros n l σ (Hl1, Hl2) (Hσ1, Hσ2).
split; [ | now rewrite map_length ].
apply permut_seq_iff.
split. {
  intros i Hi; apply in_map_iff in Hi.
  destruct Hi as (j & Hji & Hj).
  rewrite map_length.
  rewrite <- Hji.
  rewrite Hσ2, <- Hl2.
  apply permut_seq_ub; [ easy | ].
  apply nth_In.
  rewrite Hl2, <- Hσ2.
  apply permut_seq_iff in Hσ1.
  now apply Hσ1.
} {
  apply (NoDup_map_iff 0).
  intros u v Hu Hv Huv.
  apply permut_seq_iff in Hl1.
  destruct Hl1 as (Ha1, Hn1).
  apply (NoDup_nat _ Hn1) in Huv; cycle 1. {
    rewrite Hl2, <- Hσ2.
    apply permut_seq_iff in Hσ1.
    now apply Hσ1, nth_In.
  } {
    rewrite Hl2, <- Hσ2.
    apply permut_seq_iff in Hσ1.
    now apply Hσ1, nth_In.
  }
  apply permut_seq_iff in Hσ1.
  destruct Hσ1 as (Hσa1, Hσn1).
  now apply (NoDup_nat _ Hσn1) in Huv.
}
Qed.

Theorem det_any_permut_l :
  let ron := nat_ring_like_op in
  rngl_mul_is_comm = true →
  @rngl_has_opp T ro = true →
  rngl_characteristic ≠ 1 →
  ∀ n (M : matrix T) (σ : list nat),
  n ≠ 0
  → mat_nrows M = n
  → is_square_matrix M = true
  → permut_seq_with_len n σ
  → det M =
    (∑ (μ ∈ canon_sym_gr_list_list n), ε μ * ε σ *
     ∏ (k = 0, n - 1), mat_el M (nth k σ 0 + 1) (nth k μ 0 + 1)).
Proof.
intros ron Hic Hop H10 * Hnz Hr Hsm Hσ.
subst ron.
erewrite rngl_summation_list_eq_compat. 2: {
  intros μ Hμ.
  assert (Hpμ : permut_seq_with_len n μ). {
    apply in_map_iff in Hμ.
    destruct Hμ as (i & Hiμ & Hi).
    apply in_seq in Hi.
    rewrite <- Hiμ.
    now apply canon_sym_gr_list_permut_seq_with_len.
  }
  remember (μ ° isort_rank Nat.leb σ) as ν eqn:Hν.
  assert (Hσν : ν ° σ = μ). {
    rewrite Hν.
    assert (H : length (isort_rank Nat.leb σ) = n). {
      rewrite isort_rank_length; apply Hσ.
    }
    destruct Hσ.
    rewrite <- (permut_comp_assoc _ H); clear H; [ | easy | easy ].
    rewrite permut_comp_isort_rank_l; [ | easy ].
    apply comp_1_r.
    destruct Hpμ; congruence.
  }
  subst ν.
  rewrite <- Hσν at 1.
  replace (ε ((μ ° isort_rank Nat.leb σ) ° σ)) with
      (ε (μ ° isort_rank Nat.leb σ) * ε σ)%L. 2: {
    destruct Hσ.
    rewrite <- sign_comp; [ easy | easy | ].
    now rewrite comp_length, isort_rank_length.
  }
  rewrite <- (rngl_mul_assoc _ (ε σ) (ε σ)).
  rewrite NoDup_ε_square; [ | easy | ]. 2: {
    destruct Hσ as (Hσ, _).
    now apply permut_seq_iff in Hσ.
  }
  rewrite rngl_mul_1_r.
  easy.
}
cbn.
unfold canon_sym_gr_list_list.
rewrite rngl_summation_list_map.
rewrite rngl_summation_seq_summation; [ | apply fact_neq_0 ].
rewrite Nat.add_0_l.
erewrite rngl_summation_eq_compat. 2: {
  intros i (_, Hi).
  rewrite rngl_product_change_var with
      (g := λ i, nth i (isort_rank Nat.leb σ) 0) (h := λ i, nth i σ 0). 2: {
    intros j Hj.
    apply permut_isort_permut; [ now destruct Hσ | ].
    destruct Hσ as (Hσp, Hσl); rewrite Hσl.
    flia Hj Hnz.
  }
  rewrite Nat.sub_0_r.
  rewrite <- Nat.sub_succ_l; [ | flia Hnz ].
  rewrite Nat_sub_succ_1.
  erewrite rngl_product_list_eq_compat. 2: {
    intros j Hj.
    apply in_map_iff in Hj.
    destruct Hj as (k & Hkj & Hk).
    apply in_seq in Hk.
    rewrite permut_permut_isort; [ | now destruct Hσ | ]. 2: {
      rewrite <- Hkj.
      destruct Hσ as (H1, H2).
      rewrite <- H2 in Hk.
      apply permut_seq_ub; [ easy | ].
      now apply nth_In.
    }
    easy.
  }
  cbn.
  rewrite rngl_product_map_permut; [ | easy | easy ].
  easy.
}
cbn.
set
  (sg := map (λ k, canon_sym_gr_list n k ° isort_rank Nat.leb σ) (seq 0 n!)).
erewrite rngl_summation_eq_compat. 2: {
  intros k Hk.
  assert (Hkn : k < n!). {
    specialize (fact_neq_0 n) as H.
    flia Hk H.
  }
  replace (_ ° _) with (nth k sg []). 2: {
    unfold sg.
    rewrite (List_map_nth' 0); [ | now rewrite seq_length ].
    now rewrite seq_nth.
  }
  erewrite rngl_product_eq_compat. 2: {
    intros i Hi.
    rewrite Nat.sub_add; [ | flia Hi ].
    replace (nth _ _ 0) with (nth (i - 1) (nth k sg []) 0). 2: {
      unfold sg.
      rewrite (List_map_nth' 0); [ | now rewrite seq_length ].
      rewrite seq_nth; [ | easy ].
      rewrite Nat.add_0_l.
      unfold "°".
      rewrite (List_map_nth' 0). 2: {
        rewrite isort_rank_length.
        destruct Hσ as (H1, H2); rewrite H2.
        flia Hi.
      }
      easy.
    }
    easy.
  }
  easy.
}
cbn.
apply (det_by_any_sym_gr Hop H10); [ easy | easy | easy | ].
unfold sg.
split. {
  rewrite List_map_seq_length.
  intros i Hi.
  rewrite (List_map_nth' 0); [ | now rewrite seq_length ].
  rewrite seq_nth; [ | easy ].
  rewrite Nat.add_0_l.
  split. {
    unfold "°"; cbn.
    rewrite map_length.
    rewrite isort_rank_length.
    now destruct Hσ.
  } {
    apply (comp_permut_seq n). {
      now apply canon_sym_gr_list_permut_seq_with_len.
    } {
      now apply isort_rank_permut_seq_with_len; destruct Hσ.
    }
  }
}
split. {
  rewrite List_map_seq_length.
  intros i j Hi Hj Hij.
  rewrite (List_map_nth' 0) in Hij; [ | now rewrite seq_length ].
  rewrite (List_map_nth' 0) in Hij; [ | now rewrite seq_length ].
  rewrite seq_nth in Hij; [ | easy ].
  rewrite seq_nth in Hij; [ | easy ].
  do 2 rewrite Nat.add_0_l in Hij.
  unfold "°" in Hij.
  specialize (ext_in_map Hij) as H1.
  apply (nth_canon_sym_gr_list_inj2 n); [ easy | easy | ].
  intros k Hk.
  apply H1.
  apply (permutation_in_iff Nat.eqb_eq) with (lb := seq 0 n). 2: {
    clear - Hk.
    induction n; intros; [ easy | ].
    rewrite seq_S; cbn.
    apply in_or_app.
    destruct (Nat.eq_dec k n) as [Hkn| Hkn]. {
      now subst k; right; left.
    }
    left; apply IHn; flia Hk Hkn.
  }
  replace n with (length (isort_rank Nat.leb σ)). 2: {
    rewrite isort_rank_length.
    now destruct Hσ.
  }
  apply isort_rank_permut_seq.
} {
  intros l Hl.
  apply in_map_iff.
  destruct Hl as (Hl1, Hl2).
  destruct Hσ as (Hσ1, Hσ2).
  exists (canon_sym_gr_list_inv n (l ° σ)).
  rewrite canon_sym_gr_list_canon_sym_gr_list_inv. 2: {
    now apply map_nth_permut_permut_permut_seq_with_len.
  }
  split. {
    rewrite <- (permut_comp_assoc n); [ | easy | | ]; cycle 1. {
      now rewrite isort_rank_length.
    } {
      apply isort_rank_permut_seq.
    }
    rewrite permut_comp_isort_rank_r; [ | easy ].
    apply comp_1_r.
    congruence.
  }
  apply in_seq.
  split; [ easy | ].
  rewrite Nat.add_0_l.
  apply canon_sym_gr_list_inv_ub.
  now apply map_nth_permut_permut_permut_seq_with_len.
}
Qed.

Theorem isort_rank_inj2 : ∀ l1 l2,
  permut_seq l1
  → permut_seq l2
  → isort_rank Nat.leb l1 = isort_rank Nat.leb l2
  → l1 = l2.
Proof.
intros * Hpl1 Hpl2 Hill.
assert (Hll : length l1 = length l2). {
  apply List_eq_iff in Hill.
  now do 2 rewrite isort_rank_length in Hill.
}
apply (f_equal (comp_list l1)) in Hill.
rewrite comp_isort_rank_r in Hill.
rewrite permut_isort_leb in Hill; [ | easy ].
apply (f_equal (λ l, comp_list l l2)) in Hill.
rewrite comp_1_l in Hill. 2: {
  now rewrite Hll; apply permut_seq_iff in Hpl2.
}
rewrite <- (@permut_comp_assoc (length l2)) in Hill; [ | | easy | easy ]. 2: {
  apply isort_rank_length.
}
rewrite permut_comp_isort_rank_l in Hill; [ | easy ].
now rewrite comp_1_r in Hill.
Qed.

Theorem det_any_permut_r :
  let ron := nat_ring_like_op in
  rngl_mul_is_comm = true →
  @rngl_has_opp T ro = true →
  rngl_characteristic ≠ 1 →
  ∀ n (M : matrix T) (σ : list nat),
  n ≠ 0
  → mat_nrows M = n
  → is_square_matrix M = true
  → permut_seq_with_len n σ
  → det M =
    (∑ (μ ∈ canon_sym_gr_list_list n), ε μ * ε σ *
     ∏ (k = 0, n - 1), mat_el M (nth k μ 0 + 1) (nth k σ 0 + 1))%L.
Proof.
intros ron Hic Hop H10 * Hnz Hr Hsm Hσ; subst ron.
erewrite rngl_summation_list_eq_compat. 2: {
  intros μ Hμ.
  assert (Hpμ : permut_seq_with_len n μ). {
    apply in_map_iff in Hμ.
    destruct Hμ as (i & Hiμ & Hi).
    apply in_seq in Hi.
    rewrite <- Hiμ.
    now apply canon_sym_gr_list_permut_seq_with_len.
  }
  remember (σ ° isort_rank Nat.leb μ) as ν eqn:Hν.
  assert (Hσν : ν ° μ = σ). {
    rewrite Hν.
    assert (H : length (isort_rank Nat.leb μ) = n). {
      rewrite isort_rank_length.
      apply Hpμ.
    }
    rewrite <- (permut_comp_assoc _ H); clear H; [ | apply Hpμ | ]. 2: {
      now destruct Hpμ.
    }
    rewrite permut_comp_isort_rank_l; [ | now destruct Hpμ ].
    apply comp_1_r.
    destruct Hσ, Hpμ; congruence.
  }
  subst ν.
  rewrite <- Hσν at 1.
  replace (ε ((σ ° isort_rank Nat.leb μ) ° μ)) with
      (ε (σ ° isort_rank Nat.leb μ) * ε μ)%L. 2: {
    rewrite <- sign_comp; [ easy | easy | ].
    rewrite comp_length, isort_rank_length.
    now destruct Hpμ.
  }
  rewrite (rngl_mul_comm Hic _ (ε μ)).
  rewrite rngl_mul_assoc.
  rewrite NoDup_ε_square; [ | easy | ]. 2: {
    apply permut_seq_NoDup.
    now destruct Hpμ.
  }
  rewrite rngl_mul_1_l.
  easy.
}
cbn.
unfold canon_sym_gr_list_list.
rewrite rngl_summation_list_map.
rewrite rngl_summation_seq_summation; [ | apply fact_neq_0 ].
rewrite Nat.add_0_l.
erewrite rngl_summation_eq_compat. 2: {
  intros i (_, Hi).
  assert (Hc : permut_seq_with_len n (canon_sym_gr_list n i)). {
    apply canon_sym_gr_list_permut_seq_with_len.
    specialize (fact_neq_0 n) as H.
    flia Hi H.
  }
  rewrite rngl_product_change_var with
      (g := λ j, nth j (isort_rank Nat.leb (canon_sym_gr_list n i)) 0)
      (h := λ j, nth j (canon_sym_gr_list n i) 0). 2: {
    intros j (_, Hj).
    apply permut_isort_permut. 2: {
      rewrite canon_sym_gr_list_length; flia Hj Hnz.
    }
    apply canon_sym_gr_list_permut_seq_with_len.
    specialize (fact_neq_0 n) as H.
    flia Hi H.
  }
  rewrite Nat.sub_0_r.
  rewrite <- Nat.sub_succ_l; [ | flia Hnz ].
  rewrite Nat_sub_succ_1.
  erewrite rngl_product_list_eq_compat. 2: {
    intros j Hj.
    apply in_map_iff in Hj.
    destruct Hj as (k & Hkj & Hk).
    apply in_seq in Hk.
    rewrite permut_permut_isort; [ easy | | ]. {
      apply canon_sym_gr_list_permut_seq.
      specialize (fact_neq_0 n) as H.
      flia Hi H.
    }
    rewrite <- Hkj.
    apply permut_seq_ub; [ apply Hc | ].
    apply nth_In.
    now rewrite canon_sym_gr_list_length.
  }
  cbn.
  rewrite rngl_product_map_permut; [ | easy | easy ].
  easy.
}
cbn.
set
  (sg :=
     map (λ k, σ ° isort_rank Nat.leb (canon_sym_gr_list n k)) (seq 0 n!)).
erewrite rngl_summation_eq_compat. 2: {
  intros k Hk.
  assert (Hkn : k < n!). {
    specialize (fact_neq_0 n) as H.
    flia Hk H.
  }
  replace (_ ° _) with (nth k sg []). 2: {
    unfold sg.
    rewrite (List_map_nth' 0); [ | now rewrite seq_length ].
    now rewrite seq_nth.
  }
  erewrite rngl_product_eq_compat. 2: {
    intros i Hi.
    rewrite Nat.sub_add; [ | flia Hi ].
    replace (nth _ _ 0) with (nth (i - 1) (nth k sg []) 0). 2: {
      unfold sg.
      rewrite (List_map_nth' 0); [ | now rewrite seq_length ].
      rewrite seq_nth; [ | easy ].
      rewrite Nat.add_0_l.
      unfold "°".
      rewrite (List_map_nth' 0). 2: {
        rewrite isort_rank_length.
        rewrite canon_sym_gr_list_length.
        flia Hi.
      }
      easy.
    }
    easy.
  }
  easy.
}
cbn.
apply (det_by_any_sym_gr Hop H10); [ easy | easy | easy | ].
unfold sg.
split. {
  rewrite List_map_seq_length.
  intros i Hi.
  rewrite (List_map_nth' 0); [ | now rewrite seq_length ].
  rewrite seq_nth; [ | easy ].
  rewrite Nat.add_0_l.
  split. {
    unfold "°"; cbn.
    rewrite map_length.
    rewrite isort_rank_length.
    apply canon_sym_gr_list_length.
  } {
    apply (comp_permut_seq n); [ easy | ].
    apply isort_rank_permut_seq_with_len.
    now apply canon_sym_gr_list_permut_seq_with_len.
  }
}
split. {
  rewrite List_map_seq_length.
  intros i j Hi Hj Hij.
  rewrite (List_map_nth' 0) in Hij; [ | now rewrite seq_length ].
  rewrite (List_map_nth' 0) in Hij; [ | now rewrite seq_length ].
  rewrite seq_nth in Hij; [ | easy ].
  rewrite seq_nth in Hij; [ | easy ].
  do 2 rewrite Nat.add_0_l in Hij.
  unfold "°" in Hij.
  apply (f_equal (map (λ i, nth i (isort_rank Nat.leb σ) 0))) in Hij.
  do 2 rewrite map_map in Hij.
  erewrite map_ext_in in Hij. 2: {
    intros k Hk.
    apply (In_nth _ _ 0) in Hk.
    destruct Hk as (u & Hu1 & Hu2).
    rewrite permut_isort_permut; [ | now destruct Hσ | ]. 2: {
      rewrite <- Hu2.
      eapply Nat.lt_le_trans. {
        apply permut_seq_ub; [ | now apply nth_In ].
        apply isort_rank_permut_seq.
      }
      rewrite isort_rank_length.
      rewrite canon_sym_gr_list_length.
      now destruct Hσ as (_, Hσl); rewrite Hσl.
    }
    easy.
  }
  symmetry in Hij.
  erewrite map_ext_in in Hij. 2: {
    intros k Hk.
    apply (In_nth _ _ 0) in Hk.
    destruct Hk as (u & Hu1 & Hu2).
    rewrite permut_isort_permut; [ | now destruct Hσ | ]. 2: {
      rewrite <- Hu2.
      eapply Nat.lt_le_trans. {
        apply permut_seq_ub; [ | now apply nth_In ].
        apply isort_rank_permut_seq.
      }
      rewrite isort_rank_length.
      rewrite canon_sym_gr_list_length.
      now destruct Hσ as (_, Hσl); rewrite Hσl.
    }
    easy.
  }
  symmetry in Hij.
  do 2 rewrite map_id in Hij.
  apply isort_rank_inj2 in Hij; cycle 1. {
    now apply canon_sym_gr_list_permut_seq.
  } {
    now apply canon_sym_gr_list_permut_seq.
  }
  now apply canon_sym_gr_list_inj in Hij.
} {
  intros l Hl.
  apply in_map_iff.
  exists (canon_sym_gr_list_inv n (isort_rank Nat.leb l ° σ)).
  rewrite canon_sym_gr_list_canon_sym_gr_list_inv. 2: {
   apply comp_permut_seq_with_len; [ | easy ].
    apply isort_rank_permut_seq_with_len.
    now destruct Hl.
  }
  rewrite (permut_isort_rank_comp n); [ | | | easy ]; cycle 1. {
    apply NoDup_isort_rank.
  } {
    rewrite isort_rank_length.
    now destruct Hl.
  }
  rewrite (permut_comp_assoc n); cycle 1. {
    rewrite isort_rank_length.
    now destruct Hσ.
  } {
    do 2 apply isort_rank_permut_seq_with_len.
    now destruct Hl.
  } {
    apply isort_rank_permut_seq.
  }
  rewrite permut_comp_isort_rank_r; [ | now destruct Hσ ].
  rewrite comp_1_l. 2: {
    intros i Hi.
    apply in_isort_rank in Hi.
    rewrite isort_rank_length in Hi.
    destruct Hσ, Hl; congruence.
  }
  rewrite permut_isort_rank_involutive; [ | now destruct Hl ].
  split; [ easy | ].
  apply in_seq.
  split; [ easy | ].
  apply canon_sym_gr_list_inv_ub.
  apply comp_permut_seq_with_len; [ | easy ].
  apply isort_rank_permut_seq_with_len.
  now destruct Hl.
}
Qed.

Theorem determinant_transpose :
  rngl_mul_is_comm = true →
  rngl_has_opp = true →
  rngl_characteristic ≠ 1 →
  ∀ (M : matrix T),
  is_square_matrix M = true
  → det M⁺ = det M.
Proof.
intros Hic Hop H10 * Hsm.
remember (mat_nrows M) as n eqn:Hr; symmetry in Hr.
destruct (Nat.eq_dec n 0) as [Hnz| Hnz]. {
  unfold det.
  rewrite mat_transp_nrows, Hr.
  rewrite squ_mat_ncols; [ | easy ].
  now rewrite Hr, Hnz.
}
specialize (mat_transp_is_square M Hsm) as Hts.
assert (Hs : permut_seq_with_len n (seq 0 n)) by apply seq_permut_seq_with_len.
assert (Hr' : mat_nrows M⁺ = n). {
  now rewrite mat_transp_nrows, squ_mat_ncols.
}
rewrite (det_any_permut_l Hic Hop H10 M Hnz Hr Hsm Hs).
rewrite (det_any_permut_r Hic Hop H10 (M⁺)%M Hnz Hr' Hts Hs).
apply rngl_summation_list_eq_compat.
intros p Hp.
f_equal.
apply rngl_product_eq_compat.
intros k Hk.
unfold mat_transp; cbn.
do 2 rewrite Nat.add_sub.
rewrite seq_nth; [ | flia Hk Hnz ].
assert (Hpr : nth k p 0 < mat_nrows M). {
  apply in_map_iff in Hp.
  destruct Hp as (i & Hi & His).
  apply in_seq in His.
  rewrite <- Hi.
  rewrite Hr.
  apply canon_sym_gr_list_ub; [ easy | ].
  flia Hnz Hk.
}
rewrite (List_map_nth' 0). 2: {
  now rewrite seq_length, squ_mat_ncols.
}
rewrite (List_map_nth' 0); [ | rewrite seq_length, Hr; flia Hk Hnz ].
rewrite seq_nth; [ | rewrite Hr; flia Hk Hnz ].
rewrite Nat.add_0_l.
rewrite seq_nth; [ | now rewrite squ_mat_ncols ].
now do 2 rewrite Nat.add_1_r.
Qed.

Theorem det_subm_transp :
  rngl_mul_is_comm = true →
  rngl_has_opp = true →
  rngl_characteristic ≠ 1 →
  ∀ i j (M : matrix T),
  is_square_matrix M = true
  → 1 ≤ i ≤ mat_ncols M
  → 1 ≤ j ≤ mat_nrows M
  → det (subm j i M) = det (subm i j M⁺).
Proof.
intros Hic Hop H10 * Hsm Hi Hj.
rewrite <- (determinant_transpose Hic Hop H10). 2: {
  rewrite squ_mat_ncols in Hi; [ | easy ].
  now apply is_squ_mat_subm.
}
now rewrite mat_subm_transp.
Qed.

Theorem det_mI :
  rngl_has_opp_or_subt = true →
  ∀ n, det (mI n) = 1%L.
Proof.
intros Hop *; cbn.
rewrite List_map_seq_length.
induction n; intros; [ easy | ].
rewrite determinant_succ.
rewrite rngl_summation_split_first; [ | flia ].
replace (minus_one_pow 2) with 1%L by easy.
rewrite rngl_mul_1_l.
rewrite mat_el_mI_diag; [ | flia ].
rewrite rngl_mul_1_l.
rewrite all_0_rngl_summation_0. 2: {
  intros i Hi.
  rewrite mat_el_mI_ndiag; [ | easy | flia Hi | flia Hi ].
  rewrite rngl_mul_0_r; [ | easy ].
  now apply rngl_mul_0_l.
}
rewrite rngl_add_0_r.
unfold subm, mI; cbn.
rewrite map_map; cbn.
now rewrite (mI_any_seq_start 1) in IHn.
Qed.

End a.

Arguments det {T ro} M%M.
Arguments det' {T}%type {ro} M%M.
Arguments det'' {T}%type {ro} M%M.
Arguments determinant_alternating {T}%type {ro rp} Hic Hop M%M [p q]%nat.
Arguments determinant_loop {T}%type {ro} n%nat M%M.
Arguments determinant_same_rows {T ro rp} Hic Hop Hch Hit M [p q]%nat.
Arguments determinant_transpose {T ro rp} _ M%M.
Arguments det_is_det' {T ro rp} Hop M%M Hsm.
Arguments det'_is_det'' {T ro rp} Hop M%M.
Arguments det_is_det'' {T ro rp} Hop M%M Hsm.
Arguments det_mI {T ro rp} _ n%nat.
Arguments det_subm_transp {T ro rp} _ [i j]%nat.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

(** This file contains a library for encoding binary trees into
    lists of Boolean values in {Zero,One}

    The proofs contain holes that have to be filled by students
*)

Require Import List Arith Omega Wellfounded.

Set Implicit Arguments.

(** To reason or compute by induction on a measure *)

Theorem measure_rect X (m : X -> nat) (P : X -> Type) :
      (forall x, (forall y, m y < m x -> P y) -> P x) -> forall x, P x.
Proof. apply well_founded_induction_type, wf_inverse_image, lt_wf. Qed.

(** To reason by induction on the length of lists *)

Definition list_length_rect X := measure_rect (@length X).

(* And a friendly notation for this induction principle on lists *)

Tactic Notation "induction" "on" "length" "of" ident(x) "as" simple_intropattern(H) :=
  induction x as H using list_length_rect.

(* A small library with a tactic to rewrite length *)

Section length.

  Variables (X : Type) (x : X) (l : list X).

  Fact length_nil  : length (@nil X) = 0.             Proof. auto. Qed.
  Fact length_cons : length (x::l)   = S (length l).  Proof. auto. Qed.

End length.

Create HintDb length_db.

Tactic Notation "rew" "length" := autorewrite with length_db.
Tactic Notation "rew" "length" "in" hyp(H) := autorewrite with length_db in H.
Hint Rewrite length_nil length_cons app_length map_length : length_db.

(** A small complement for the list library *)

(* If a list is cut in half in two different way l1 ++ r1 = l2 ++ r2
   and the cut is at the same place then l1 = l2 and r1 = r2 *)

Fact list_app_inj X (l1 l2 r1 r2 : list X) : length l1 = length l2 -> l1++r1 = l2++r2 -> l1 = l2 /\ r1 = r2.
Proof.
  revert l2; induction l1 as [ | x l1 IH ]; intros [ | y l2 ].
Admitted.

Section flat_map.

  Variable (X Y : Type) (f : X -> list Y).

  Fact flat_map_app l1 l2 : flat_map f (l1++l2) = flat_map f l1 ++ flat_map f l2.
  Proof.
  Admitted.

  Hypothesis Hf : forall x, f x <> nil.

  Fact flat_map_nil l : nil = flat_map f l -> l = nil.
  Proof.
  Admitted.

End flat_map.

(** Definition of the notion of prefix

        l is a prefix of l++r

    which is denoted by l <p l++r
    together with a small library
*)

Definition prefix X (l ll : list X) := exists r, ll = l++r.

Infix "<p" := (@prefix _) (at level 70, no associativity).

Section prefix. (* as an inductive predicate *)

  Variable X : Type.

  Implicit Types (l ll : list X).

  Fact in_prefix_0 ll : nil <p ll.
  Proof. exists ll; auto. Qed.

  Fact in_prefix_1 x l ll : l <p ll -> x::l <p x::ll.
  Proof. intros (r & ?); subst; exists r; auto. Qed.

  Fact prefix_right l r : l <p l ++ r.
  Proof. exists r; auto. Qed.

  Fact prefix_length l m : l <p m -> length l <= length m.
  Proof. intros (? & ?); subst; rew length; omega. Qed.

  Fact prefix_app_lft l r1 r2 : r1 <p r2 -> l++r1 <p l++r2.
  Proof.
    intros (a & ?); subst.
    exists a; rewrite app_ass; auto.
  Qed.

  Fact prefix_inv x y l ll : x::l <p y::ll -> x = y /\ l <p ll.
  Proof.
    intros (r & Hr).
    inversion Hr; split; auto.
    exists r; auto.
  Qed.

  Fact prefix_list_inv l r rr : l++r <p l++rr -> r <p rr.
  Proof.
    induction l as [ | x l IHl ]; simpl; auto.
    intros H; apply prefix_inv, proj2, IHl in H; auto.
  Qed.

  Fact prefix_refl l : l <p l.
  Proof. exists nil; rewrite <- app_nil_end; auto. Qed.

  Fact prefix_trans l1 l2 l3 : l1 <p l2 -> l2 <p l3 -> l1 <p l3.
  Proof. intros (m1 & H1) (m2 & H2); subst; exists (m1++m2); rewrite app_ass; auto. Qed.

  Section prefix_rect.

    Variables (P : list X -> list X -> Type)
              (HP0 : forall ll, P nil ll)
              (HP1 : forall x l ll, l <p ll -> P l ll -> P (x::l) (x::ll)).

    Definition prefix_rect l ll : l <p ll -> P l ll.
    Proof.
      revert l; induction ll as [ | x ll IHll ]; intros l H.

      replace l with (nil : list X).
      apply HP0.
      destruct H as (r & Hr).
      destruct l; auto; discriminate.

      destruct l as [ | y l ].
      apply HP0.
      apply prefix_inv in H.
      destruct H as (? & E); subst y.
      apply HP1; [ | apply IHll ]; trivial.
    Qed.

  End prefix_rect.

  Fact prefix_app_inv l1 l2 r1 r2 : l1++l2 <p r1++r2 -> { l1 <p r1 } + { r1 <p l1 }.
  Proof.
    revert l2 r1 r2; induction l1 as [ | x l1 IH ]; intros l2 r1 r2.
    admit.
    destruct r1 as [ | y r1 ].
  Admitted.

End prefix.

Definition prefix_spec X (l ll : list X) : l <p ll -> { r | ll = l ++ r }.
Proof.
  induction 1 as [ ll | x l ll _ (r & Hr) ] using prefix_rect.
Admitted.

Fact prefix_app_lft_inv X (l1 l2 m : list X) : l1++l2 <p m -> { m2 | m = l1++m2 /\ l2 <p m2 }.
Proof.
Admitted.

(** Binary trees *)

Inductive bt : Set := bt0 | bt1 : bt -> bt -> bt.

Delimit Scope bt_scope with bt.

Notation null := bt0.    (* typing that is easier *)
Notation ø := bt0.       (* for a nicer display *)

Notation " '<<' x ',' y '>>' " := (bt1 x y) (at level 0): bt_scope.
Notation " ⟨ x , y ⟩ " := (bt1 x y) (at level 0): bt_scope.

Reserved Notation "〈 t 〉" (at level 0, no associativity).
Reserved Notation " '[[' t ']]' " (at level 0, no associativity).

Open Scope bt_scope.

(* We can decide if two trees are equal or not *)

Definition bt_eq_dec (s t : bt) : { s = t } + { s <> t }.
Proof.
  revert t; induction s as [ | a Ha b Hb ]; intros [ | c d ].
Admitted.

Fact bt_pair_neq a1 b1 a2 b2 : <<a1,a2>> <> <<b1,b2>> -> { a1 <> b1 } + { a2 <> b2 }.
Proof.
Admitted.

Inductive bt_mirror : bt -> bt -> Prop :=
  | in_bt_mirror_0 : bt_mirror ø ø
  | in_bt_mirror_1 : forall a b c d, bt_mirror a b
                                  -> bt_mirror c d
                                  -> bt_mirror <<a,c>> <<d,b>>.

Definition bt_compute_mirror s : { t | bt_mirror s t }.
Proof.
Admitted.

Fixpoint bt_size t :=
  match t with
    | ø         => 1
    | <<t1,t2>> => 1 + 〈 t1 〉 + 〈 t2 〉
  end
where "〈 t 〉" := (bt_size t).

Fact bt_mirror_size s t : bt_mirror s t -> 〈 s 〉 = 〈 t 〉.
Proof.
Admitted.

(* Encoding of binary trees as list of Zero and One *)

Notation Zero := false.
Notation One  := true.

Fixpoint bt_bin t : list bool :=
  match t with
    | ø       => Zero :: nil
    | <<a,b>> => One :: [[a]] ++ [[b]]
  end
where "[[ t ]]" := (bt_bin t).

Eval compute in [[ <<ø,ø>> ]].
Eval compute in [[ <<ø,<<ø,ø>>>> ]].

Fact bt_bin_not_nil t : [[t]] <> nil.
Proof.
Admitted.

Hint Resolve bt_bin_not_nil.

(* The length of the encoding is the size of the tree *)

Fact bt_bin_length t : length [[t]] = 〈 t 〉.
Proof.
Admitted.

Fact bt_bin_length_geq t : 1 <= length [[t]].
Proof.
Admitted.

(** The essential lemma of non-ambiguity:

     if  [[s]] ++ l = [[t]] ++ m  then   s = t and l = m

*)

Lemma bt_bin_eq s : forall t l m, [[s]] ++ l = [[t]] ++ m -> s = t /\ l = m.
Proof.
  induction s as [ | s1 IH1 s2 IH2 ]; intros [ | t1 t2 ].
Admitted.

Corollary bt_bin_prefix_eq s t : [[s]] <p [[t]] -> s = t.
Proof.
  intros (l & Hl).
  rewrite (app_nil_end [[t]]) in Hl.
Admitted.

Corollary bt_bin_inj s t : [[s]] = [[t]] -> s = t.
Proof.
Admitted.

Corollary bt_bin_prefix_app_eq s t l m : [[s]]++l <p [[t]]++m -> s = t /\ l <p m.
Proof.
Admitted.

Corollary bt_bin_uniq ll t1 t2 : [[t1]] <p ll -> [[t2]] <p ll -> t1 = t2.
Proof.
Admitted.

Lemma flat_map_bt_bin_eq lt1 : forall lt2 l m,
     flat_map bt_bin lt1 ++ l = flat_map bt_bin lt2 ++ m
  -> { lt1 <p lt2 } + { lt2 <p lt1 }.
Proof.
  induction lt1 as [ | t1 lt1 IH ]; intros lt2 l m E;
    [ | destruct lt2 as [ | t2 lt2 ] ]; simpl in E.
Admitted.

(* [[[t1;...;tn]]] = [[t1]]++...++[[tn]] *)

Notation " '[[[' l ']]]' " := (flat_map bt_bin l) (at level 0, no associativity).

(* The encoding of a list of trees is unambiguous

     if [[s1]]++...++[[sk]] = [[t1]]++...++[[tp]] then [s1,...,sk] = [t1,...,tp]

*)

Theorem lbt_bin_inj lt1 lt2 : [[[lt1]]] = [[[lt2]]] -> lt1 = lt2.
Proof.
  intros H; generalize H; intros H1.
  rewrite (app_nil_end (_ _ lt2)), (app_nil_end (_ _ lt1)) in H.
  apply flat_map_bt_bin_eq in H.
  destruct H as [ (r & H) | (r & H) ]; subst; rewrite flat_map_app in H1.
Admitted.

(** Now the decoders, beware that bt_bin is injective but not surjective !!
    Indeed, no binary tree encodes into One :: nil for instance *)

(* Given a sequence of boolean value lb, either

     1/ computes a prefix of lb which encodes some binary tree t
     2/ or show that no such tree exists.
*)

Definition bin_bt_dec (lb : list bool) : { t : bt & { r | lb = [[t]] ++ r } }
                                       + { forall t, ~ [[t]] <p lb }.
Proof.
  induction on length of lb as [ [ | [] lb1 ] IH ].

  (* lb = nil *)

  right; intros [] (r & Hr); discriminate.

  (* lb = One :: lb1  >>>> call the induction hypothesis on lb1 (shorter than lb) *)

  destruct (IH lb1) as [ (t1 & lb2 & H1) | C ].
  admit.

  (* lb1 = [[t1]] ++ lb2  >>>> call the induction hypothesis on lb2 (shorter than lb1, and thus of lb) *)

  destruct (IH lb2) as [ (t2 & lb' & H2) | C ].
  admit.

  (* lb2 = [[t2]] ++ lb' *)

  admit.

  (* ~ [[t]] <p lb2 *)

  admit.

  (* ~ [[t]] <p lb1,  *)

  admit.

  (* lb = Zero :: lb1 *)

  left; exists ø, lb1; simpl; auto.

Admitted.

(* Given a list of boolean values lb, computes a maximal list of trees [t1;...;tk]
   such that lb = [[t1]]++...++[[tk]]++r where r is not prefixed by a bt *)

Definition bin_lbt_decode (lb : list bool) :
        { lt : _ &  { r | lb = [[[lt]]] ++ r /\ forall t, ~ [[t]] <p r } }.
Proof.
  induction on length of lb as [ lb IH ].
  destruct (bin_bt_dec lb) as [ (t & r & H) | H ].
Admitted.

(* lb is not of the form [[t]]++... for any t *)

Definition not_prefixed lb := forall t, ~ [[t]] <p lb.

Fact not_prefixed_0 : not_prefixed nil.
Proof. intros [] []; discriminate. Qed.

Fact not_prefixed_1 lb : ~ not_prefixed (Zero::lb).
Proof.
  intros H; apply (H ø); apply in_prefix_1, in_prefix_0.
Qed.

(* If One::lb is not prefix by a tree then
   either lb = [[t]]++r where r is not prefixed by a tree
   or lb is not prefixed *)

Fact not_prefixed_2 lb :
        not_prefixed (One::lb)
     -> { t : _ & { r | lb = [[t]]++r /\ not_prefixed r } }
      + { not_prefixed lb }.
Proof.
  intros H.
  destruct (bin_bt_dec lb) as [ (t & r & H1) | H1 ].
Admitted.

(** However, every list which is not prefixed by a tree can be extended into (the encoding of) a tree *)

Theorem bin_bt_extend (lb : list bool) : (forall t, ~ [[t]] <p lb) -> { rb : _ & { t | lb ++ rb = [[t]] } }.
Proof.
  fold (not_prefixed lb).
  induction on length of lb as [ [ | [] lb ] IH ]; intros Hlb.

  admit.

  destruct (not_prefixed_2 Hlb) as [ (t & r & H1 & H2) | H1 ].
  admit.
  admit.

  exfalso; revert Hlb; apply not_prefixed_1.
Admitted.

(* Any sequence of 0s and 1s is the prefix of some encoded sequence of trees *)

Theorem bin_lbt_complete lb : { lt | lb <p [[[lt]]] }.
Proof.
  destruct (bin_lbt_decode lb) as (lt & r & H1 & H2).
  destruct (bin_bt_extend H2) as (rb & t & H3).
  exists (lt++t::nil), rb.
  rewrite H1, flat_map_app, app_ass; simpl.
  rewrite <- app_nil_end; f_equal; auto.
Qed.


(* ** Addition for [positive] numbers *)

From Undecidability.TM Require Import ProgrammingTools.
From Undecidability Require Import BinNumbers.EncodeBinNumbers.
From Undecidability Require Import BinNumbers.PosDefinitions.
From Undecidability Require Import BinNumbers.PosPointers.
From Undecidability Require Import BinNumbers.PosHelperMachines.
From Undecidability Require Import BinNumbers.PosIncrementTM.
From Undecidability Require Import BinNumbers.PosCompareTM.

Local Open Scope positive_scope.

(* ** Tail-recursive versions of [Pos.add] and [Pos.add_carry] *)

Fixpoint addTR_rec (a : list bool) (x y : positive) : list bool :=
  match x, y with
  | p~1, q~1 => addTR_rec_carry (false :: a) p q
  | p~1, q~0 => addTR_rec (true :: a) p q
  | p~1, 1 => pos_to_bits (Pos.succ p) ++ false :: a
  | p~0, q~1 => addTR_rec (true :: a) p q
  | p~0, q~0 => addTR_rec (false :: a) p q
  | p~0, 1 => pos_to_bits p ++ true :: a
  | 1, q~1 => pos_to_bits (Pos.succ q) ++ false :: a
  | 1, q~0 => pos_to_bits q ++ true :: a
  | 1, 1 => false :: a
  end

with addTR_rec_carry (a : list bool) (x y : positive) : list bool :=
  match x, y with
  | p~1, q~1 => addTR_rec_carry (true :: a) p q
  | p~1, q~0 => addTR_rec_carry (false :: a) p q
  | p~1, 1 => pos_to_bits (Pos.succ p) ++ true :: a
  | p~0, q~1 => addTR_rec_carry (false :: a) p q
  | p~0, q~0 => addTR_rec (true :: a) p q
  | p~0, 1 => pos_to_bits (Pos.succ p) ++ false :: a
  | 1, q~1 => pos_to_bits (Pos.succ q) ++ true :: a
  | 1, q~0 => pos_to_bits (Pos.succ q) ++ false :: a
  | 1, 1 => true :: a
  end.

Definition addTR_rec' (carry : bool) (a : list bool) (x y : positive) : list bool := if carry then addTR_rec_carry a x y else addTR_rec a x y.
Definition addTR (x y : positive) := bits_to_pos (addTR_rec nil x y).

(*
Compute addTR 42 1. (* 43 *)
Compute addTR 1 1. (* 2 *)
Compute addTR 1 2. (* 3 *)
Compute addTR 1 3. (* 4 *)
Compute addTR 7 3. (* 10 *)
Compute addTR 7 3. (* 10 *)
Compute addTR 3 1. (* 4 *)
Compute addTR 10 11. (* 21 *)
Compute addTR 42 42. (* 84 *)
Compute addTR 42 8. (* 50 *)
*)

Lemma addTR_rec_correct (a : list bool) (x y : positive) :
    addTR_rec a x y = pos_to_bits (Pos.add x y) ++ a /\
    addTR_rec_carry a x y = pos_to_bits (Pos.add_carry x y) ++ a.
Proof.
  revert a y. induction x; intros; cbn in *.
  - (* x = x ~ 1 *) destruct y as [ y' | y' | ] eqn:Ey; cbn; auto.
    all: try rewrite !(proj2 (IHx (_ :: a) y')); try rewrite !(proj1 (IHx (_ :: a) y')); simpl_list; cbn; auto.
  - (* x = x ~ 0 *) destruct y; cbn; auto.
    all: try rewrite !(proj2 (IHx (_ :: a) y)); try rewrite !(proj1 (IHx (_ :: a) y)); simpl_list; cbn; auto.
  - (* x = 1 *) destruct y; cbn; auto.
    all: simpl_list; cbn; auto.
Qed.

Lemma addTR_correct (x y : positive) :
  addTR x y = Pos.add x y.
Proof. unfold addTR. generalize (proj1 (addTR_rec_correct [] x y)). simpl_list. intros. rewrite H. now rewrite pos_to_bits_to_pos. Qed.

(* Full adder (computes "output bit" and "carry bit") *)
Definition fullAdder (x y c : bool) : bool*bool := (xorb (xorb x y) c, (x && y) || (x && c) || (y && c)).

(* Compute fullAdder false true true. *) (* (false, true) *)

(* ** Addition Machine *)

(* We maintain the invariant that tape 1 (the second tape) contains the smaller number. Otherwise, the base case woudn't work. *)
(* In the final machine, [Add], the first step is to determine the maximum and copy it to the output tape. *)

(* Some more lemmas that we need here *)

(* More general than [pushHFS_append1] *)
Lemma pushHFS_append1' c bits :
  pushHSB (append_bits (1~~c) bits) false = append_bits (2~~c) bits.
Proof.
  apply Encode_positive_injective. cbn.
  rewrite !encode_pushHSB, !encode_append_bits; cbn.
  destruct c; cbn; auto.
Qed.

Lemma pushHFS_append2' c bits :
  pushHSB (append_bits (2~~c) bits) false = append_bits (4~~c) bits.
Proof.
  apply Encode_positive_injective. cbn.
  rewrite !encode_pushHSB, !encode_append_bits; cbn.
  destruct c; cbn; auto.
Qed.

(* We use [StateWhile] to implement mutual recursion. The [bool] "state" corresponds to the carry. *)

(* This function is used in the base case: t0 contains [xH] and t1 contains [p ++ b :: bits] and the pointer is on [b]. In some cases, we need to increment [p]. *)
Definition add_baseCase (b carry : bool) (p : positive) :=
  if (b || carry) then (Pos.succ p) ~~ (negb (xorb b carry))
  else p ~~ (negb (xorb b carry)).

(* Compute add_baseCase true false 1. *)

(* This base case is complex enough that I write an auxilliary machine for this *)

Definition Add_BaseCase_Rel (carry : bool) (b : bool) : pRel sigPos^+ unit 1 :=
  fun tin '(_, tout) =>
    forall (p : positive) (bits : list bool),
      atBit tin[@Fin0] p b bits ->
      atHSB tout[@Fin0] (append_bits (add_baseCase b carry p) bits).

Definition Add_BaseCase (carry : bool) (b : bool) : pTM sigPos^+ unit 1 :=
  if (b || carry)
  then SetBitAndMoveLeft (negb (xorb b carry));; Increment_Loop
  else SetBitAndMoveLeft (negb (xorb b carry));; GoToHSB.

Lemma Add_BaseCase_Realise (carry : bool) (b : bool) : Add_BaseCase carry b ⊨ Add_BaseCase_Rel carry b.
Proof.
  unfold Add_BaseCase. destruct (b||carry) eqn:Eb.
  {
    eapply Realise_monotone.
    { TM_Correct.
      - eapply RealiseIn_Realise. apply SetBitAndMoveLeft_Sem.
      - apply Increment_Loop_Realise.
    }
    {
      intros tin ([], tout) H. intros p bits Hp. TMSimp.
      modpon H. destruct p; cbn in *.
      - modpon H0. atBit_ext; cbn in *. destruct b, carry; cbn in *; auto.
      - modpon H0. atBit_ext; cbn in *. destruct b, carry; cbn in *; auto.
      - modpon H1. atBit_ext; cbn in *. rewrite pushHFS_append1'. destruct b, carry; cbn in *; auto.
    }
  }
  {
    eapply Realise_monotone.
    { TM_Correct.
      + eapply RealiseIn_Realise. apply SetBitAndMoveLeft_Sem.
      + apply GoToHSB_Realise.
    }
    {
      intros tin ([], tout) H. intros p bits Hp. TMSimp.
      modpon H. destruct p; cbn in *.
      - modpon H0. atBit_ext; cbn in *. destruct b, carry; cbn in *; auto.
      - modpon H0. atBit_ext; cbn in *. destruct b, carry; cbn in *; auto.
      - modpon H1. atBit_ext; cbn in *. destruct b, carry; cbn in *; auto.
    }
  }
Qed.

Definition Add_Step_Rel (carry : bool) : pRel sigPos^+ (bool+unit) 2 :=
  fun tin '(yout, tout) =>
    (forall (p0 : positive) (b0 : bool) (bits0 : list bool) (p1 : positive) (b1 : bool) (bits1 : list bool),
        atBit tin[@Fin0] p0 b0 bits0 -> atBit tin[@Fin1] p1 b1 bits1 ->
        (* Pos.le (p0 ~~ b0) (p1 ~~ b1) -> *)
        movedToLeft tout[@Fin0] p0 b0 bits0 /\
        movedToLeft tout[@Fin1] p1 (fst (fullAdder b0 b1 carry)) bits1 /\
        yout = inl (snd (fullAdder b0 b1 carry))) /\
    (forall (p0 : positive) (p1 : positive) (b1 : bool) (bits1 : list bool),
        atHSB tin[@Fin0] p0 ->
        atBit tin[@Fin1] p1 b1 bits1 ->
        atHSB tout[@Fin0] p0 /\
        atHSB tout[@Fin1] (append_bits (add_baseCase b1 carry p1) bits1) /\
        yout = inr tt) /\
    (forall (p0 : positive) (p1 : positive),
        atHSB tin[@Fin0] p0 ->
        atHSB tin[@Fin1] p1 ->
        atHSB tout[@Fin0] p0 /\
        atHSB tout[@Fin1]  (pushHSB p1 carry) /\
        yout = inr tt).
(* The case, [atBit t0 ... /\ atHSB t1 ...] is not specified. *)

Definition Add_Step (carry : bool) : pTM sigPos^+ (bool+unit) 2 :=
  Switch (ReadPosSym2)
         (fun '(s0, s1) =>
            match s0, s1 with
            | Some b0, Some b1 => Return (SetBitAndMoveLeft b0 @ [|Fin0|];; SetBitAndMoveLeft (fst (fullAdder b0 b1 carry)) @ [|Fin1|]) (inl (snd (fullAdder b0 b1 carry)))
            | None,    Some b1 => Return ((Add_BaseCase carry b1)@[|Fin1|]) (inr tt)
            | None,    None    => Return (PushHSB carry @[|Fin1|]) (inr tt)
            | Some b0, None    => Return Nop default (* not specified *)
            end).

Lemma Add_Step_Realise (carry : bool) : Add_Step carry ⊨ Add_Step_Rel carry.
Proof.
  eapply Realise_monotone.
  { unfold Add_Step. cbn.
    (* [TM_Correct] actually should do this automatically *)
    eapply Switch_Realise with (R2 := fun '(s0, s1) => match s0, s1 with Some b0, Some b1 => _ | Some b0, None => _ | None, Some b1 => _ | None, None => _ end).
    - eapply RealiseIn_Realise. apply ReadPosSym2_Sem.
    - intros. destruct f as [s0 s1]. cbn. destruct s0 as [ b0 | ], s1 as [ b1 | ]; cbn; TM_Correct.
      + eapply RealiseIn_Realise. apply SetBitAndMoveLeft_Sem.
      + eapply RealiseIn_Realise. apply SetBitAndMoveLeft_Sem.
      + apply Add_BaseCase_Realise.
      + eapply RealiseIn_Realise. apply PushHSB_Sem. }
  {
    intros tin (yout, tout) H. TMSimp.
    rename H into HReadSymA, H1 into HReadSymB, H2 into HReadSymC, H3 into HReadSymD. rename H0 into HSwich. rename o into s0, o0 into s1.
    split; [ | split ]. (* Three obligations *)
    - intros. modpon HReadSymA. clear HReadSymB HReadSymC HReadSymD.
      destruct s0 as [ b0' | ], s1 as [ b1' | ]; cbn in *; auto.
      + destruct b0' eqn:Eb0', b1' eqn:Eb1', b0, b1; TMSimp; eauto.
      + destruct b0'; auto.
    - intros. modpon HReadSymC. clear HReadSymA HReadSymB HReadSymD.
      destruct s0 as [ b0' | ], s1 as [ b1' | ]; cbn in *; auto.
      TMSimp. destruct b1' eqn:Eb0', b1; TMSimp; eauto.
    - intros. modpon HReadSymD. clear HReadSymA HReadSymB HReadSymC. TMSimp. inv HReadSymD0. TMSimp. eauto.
  }
Qed.

Definition Add_Loop_Rel (carry : bool) : pRel sigPos^+ unit 2 :=
  fun tin '(_, tout) =>
    (forall (p0 : positive) (b0 : bool) (bits0 : list bool) (p1 : positive) (b1 : bool) (bits1 : list bool),
        atBit tin[@Fin0] p0 b0 bits0 -> atBit tin[@Fin1] p1 b1 bits1 ->
        Pos.le (p0 ~~ b0) (p1 ~~ b1) ->
        atHSB tout[@Fin0] (append_bits p0 (b0 :: bits0)) /\
        atHSB tout[@Fin1] (bits_to_pos (addTR_rec' carry bits1 (p0 ~~ b0) (p1 ~~ b1)))) /\
    (forall (p0 : positive) (p1 : positive) (b1 : bool) (bits1 : list bool),
        atHSB tin[@Fin0] p0 ->
        atBit tin[@Fin1] p1 b1 bits1 ->
        atHSB tout[@Fin0] p0 /\
        atHSB tout[@Fin1] (append_bits (add_baseCase b1 carry p1) bits1)) /\
    (forall (p0 : positive) (p1 : positive),
        atHSB tin[@Fin0] p0 ->
        atHSB tin[@Fin1] p1 ->
        atHSB tout[@Fin0] p0 /\
        atHSB tout[@Fin1] (pushHSB p1 carry)).

Definition Add_Loop : bool -> pTM sigPos^+ unit 2 := StateWhile Add_Step.

Lemma Add_Loop_Realise (carry : bool) : Add_Loop carry ⊨ Add_Loop_Rel carry.
Proof.
  eapply Realise_monotone.
  { unfold Add_Loop. TM_Correct. exact Add_Step_Realise. }
  {
    apply StateWhileInduction; intros.
    {
      destruct HLastStep as (HLastStepA&HLastStepB&HLastStepC). TMSimp. split; [ | split].
      - intros. modpon HLastStepA. congruence.
      - intros. modpon HLastStepB. repeat split; eauto.
      - intros. modpon HLastStepC. repeat split; eauto.
    }
    {
      destruct HStar as (HStarA&HStarB&HStarC). destruct HLastStep as (HLastStepA&HLastStepB&HLastStepC). TMSimp. split; [ | split].
      - intros. modpon HStarA. clear HStarB HStarC. inv HStarA1.
        destruct p0, p1; cbn in *.
        { modpon HLastStepA; cbn in *.
          { destruct b0, b1; cbn in *; auto; nia. }
          repeat split; eauto. atBit_ext.
          clear_all; destruct b0, b1, l; cbn; auto. }
        { modpon HLastStepA. cbn in *.
          { destruct b0, b1; cbn in *; auto; nia. }
          cbn in *; repeat split; eauto. atBit_ext.
          clear_all; destruct b0, b1, l; cbn; auto. }
        { destruct b0, b1; cbn in *; nia. }
        { modpon HLastStepA; cbn in *.
          { destruct b0, b1; cbn in *; auto; nia. }
          cbn in *; repeat split; eauto. atBit_ext.
          clear_all; destruct b0, b1, l; cbn; auto. }
        { modpon HLastStepA; cbn in *.
          { destruct b0, b1; cbn in *; auto; nia. }
          cbn in *; repeat split; eauto. atBit_ext.
          clear_all; destruct b0, b1, l; cbn; auto. }
        { destruct b0, b1; cbn in *; nia. }
        { modpon HLastStepB. cbn in *; repeat split; eauto. atBit_ext.
          clear_all; destruct b0, b1, l; cbn; auto.
          all: apply pos_to_bits_inj; rewrite bits_to_pos_to_bits; rewrite pos_to_bits_append_bits; cbn; simpl_list; cbn; auto.
        }
        { modpon HLastStepB. cbn in *; repeat split; eauto. atBit_ext.
          cbn in *. destruct b0, b1, l; cbn in *; auto; try nia.
          all: apply pos_to_bits_inj; rewrite bits_to_pos_to_bits; rewrite pos_to_bits_append_bits; cbn; simpl_list; cbn; auto. }
        { modpon HLastStepC. repeat split; eauto. atBit_ext.
          clear_all; destruct b0, b1, l; cbn; auto.
          all: apply pos_to_bits_inj; try rewrite pos_to_bits_pushHSB; try rewrite bits_to_pos_to_bits; try rewrite pos_to_bits_append_bits; cbn; auto.
        }
      - intros. modpon HStarB. congruence.
      - intros. modpon HStarC. congruence.
    }
  }
Qed.

(* We still assume that [p0<=p1] *)
Definition Add' : pTM sigPos^+ unit 2 :=
  GoToLSB_start@[|Fin0|];; GoToLSB_start@[|Fin1|];;
  (Add_Loop false)@[|Fin0; Fin1|];; (Move Lmove)@[|Fin0|];; (Move Lmove)@[|Fin1|].

Definition Add'_Rel : pRel sigPos^+ unit 2 :=
  fun tin '(_, tout) =>
    forall (p0 p1 : positive),
      tin[@Fin0] ≃ p0 ->
      tin[@Fin1] ≃ p1 ->
      p0 <= p1 ->
      tout[@Fin0] ≃ p0 /\
      tout[@Fin1] ≃ p0 + p1.

Lemma Add'_Realise : Add' ⊨ Add'_Rel.
Proof.
  eapply Realise_monotone.
  { unfold Add'. TM_Correct.
    - apply GoToLSB_start_Realise.
    - apply GoToLSB_start_Realise.
    - apply Add_Loop_Realise. }
  {
    intros tin ([], tout) H. intros p0 p1 Hp0 Hp1 HRight. TMSimp.
    rename H into HGoToHSB, H0 into HGoToHSB', H2 into HLoopA, H6 into HLoopB, H7 into HLoopC.
    modpon HGoToHSB. modpon HGoToHSB'.
    destruct p0; destruct p1; try nia.
    - modpon HLoopA; cbn in *.
      repeat split; eauto; apply atHSB_moveLeft_contains; eauto.
      rewrite (proj2 (@addTR_rec_correct _ _ _)) in HLoopA0.
      rewrite bits_to_pos_cons in HLoopA0.
      now setoid_rewrite pos_to_bits_to_pos in HLoopA0.
    - modpon HLoopA; cbn in *.
      repeat split; eauto; apply atHSB_moveLeft_contains; eauto.
      rewrite (proj1 (@addTR_rec_correct _ _ _)) in HLoopA0.
      rewrite bits_to_pos_cons in HLoopA0.
      now setoid_rewrite pos_to_bits_to_pos in HLoopA0.
    - modpon HLoopA; cbn in *.
      repeat split; eauto; apply atHSB_moveLeft_contains; eauto.
      rewrite (proj1 (@addTR_rec_correct _ _ _)) in HLoopA0.
      rewrite bits_to_pos_cons in HLoopA0.
      now setoid_rewrite pos_to_bits_to_pos in HLoopA0.
    - modpon HLoopA; cbn in *.
      repeat split; eauto; apply atHSB_moveLeft_contains; eauto.
      rewrite (proj1 (@addTR_rec_correct _ _ _)) in HLoopA0.
      rewrite bits_to_pos_cons in HLoopA0.
      now setoid_rewrite pos_to_bits_to_pos in HLoopA0.
    - modpon HLoopB; cbn in *.
      repeat split; eauto; apply atHSB_moveLeft_contains; eauto.
    - modpon HLoopB; cbn in *.
      repeat split; eauto; apply atHSB_moveLeft_contains; eauto.
    - modpon HLoopC; cbn in *.
      repeat split; eauto; apply atHSB_moveLeft_contains; eauto.
  }
Qed.

(* The final step: We find out which number is the maximum and copy the maximum to the output tape, before we start the actual computation *)

Definition Add : pTM sigPos^+ unit 3 :=
  Switch Max
         (fun (c : comparison) =>
            match c with
            | Gt => Add' @[|Fin1; Fin2|]
            | _ =>  Add' @[|Fin0; Fin2|]
            end).

Definition Add_Rel : pRel sigPos^+ unit 3 :=
  fun tin '(_, tout) =>
    forall (p0 p1 : positive),
      tin[@Fin0] ≃ p0 ->
      tin[@Fin1] ≃ p1 ->
      isVoid tin[@Fin2] ->
      tout[@Fin0] ≃ p0 /\
      tout[@Fin1] ≃ p1 /\
      tout[@Fin2] ≃ p0 + p1.

Lemma Add_Realise : Add ⊨ Add_Rel.
Proof.
  eapply Realise_monotone.
  { unfold Add. TM_Correct.
    - apply Max_Realise.
    - apply Add'_Realise.
    - apply Add'_Realise.
    - apply Add'_Realise. }
  {
    intros tin ([], tout) H. intros p0 p1 Hp0 Hp1 Hright. TMSimp.
    rename H into HMax, H0 into HSwitch.
    modpon HMax. destruct ymid; TMSimp.
    - modpon H. nia. repeat split; auto. unfold Pos.max in H0. rewrite <- HMax2 in H0. auto.
    - modpon H. nia. repeat split; auto. unfold Pos.max in H0. rewrite <- HMax2 in H0. auto.
    - modpon H. nia. repeat split; auto. unfold Pos.max in H0. rewrite <- HMax2 in H0. auto.
      now replace (p0 + p1) with (p1 + p0) by nia.
  }
Qed.

(* ** Add a number onto a register *)

(* t1 <- t0 + t1; use t3 as internal register *)
Definition Add_onto : pTM sigPos^+ unit 3 := Add;; MoveValue _ @[|Fin2; Fin1|].

Definition Add_onto_Rel : pRel sigPos^+ unit 3 :=
  fun tin '(_, tout) =>
    forall (p0 p1 : positive),
      tin[@Fin0] ≃ p0 ->
      tin[@Fin1] ≃ p1 ->
      isVoid tin[@Fin2] ->
      tout[@Fin0] ≃ p0 /\
      tout[@Fin1] ≃ p0 + p1 /\
      isVoid tout[@Fin2].

Lemma Add_onto_Realise : Add_onto ⊨ Add_onto_Rel.
Proof.
  eapply Realise_monotone.
  { unfold Add_onto. TM_Correct.
    - apply Add_Realise. }
  {
    intros tin ([], tout) H. intros p0 p1 Hp0 Hp1 Hright.
    TMSimp. modpon H. modpon H0. auto.
  }
Qed.