(* Copyright 2021 Joshua M. Cohen

Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License.
You may obtain a copy of the License at
    http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License.
*)

From mathcomp Require Import all_ssreflect.
Require Import mathcomp.algebra.matrix.
Require Import mathcomp.algebra.ssralg.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Bullet Behavior "Strict Subproofs".
Require Import Vandermonde.
Require Import Gaussian.
Require Import CommonSSR.
Require Import LinIndep. (*for summation*)

Section RS.

(*We prove that the encoder and decoder are correct for any field. We just happen to be using GF(2^n)*)

Variable F : fieldType.

Local Open Scope ring_scope.

(*The encoder takes the last h * k portion (reversed) of the weight matrix and multiplies it by a k * c matrix *)
Definition encoder (h k c max_h max_n : nat) (Hh: h <= max_h) (Hk: k <= max_n)
  (weights : 'M[F]_(max_h, max_n)) (input : 'M[F]_(k, c)) :=
    (mxsub (fun (x : 'I_h) => widen_ord Hh x) (fun (x : 'I_k) => rev_ord (widen_ord Hk x)) weights) *m input.

Section Decoder.

Definition minusmx {m n} (A B: 'M[F]_(m, n)) :=
  \matrix_(i < m, j < n) (A i j - B i j).

(*"Fill in" a matrix with missing data: let D be the original k x c matrix, let R be the recovered data, an
  xh x c matrix (where xh < k), and let locs be a list of 'I_k of length xh that has the missing locations.
  We want to fill in the locs[n] row of D with row n of R*)
Definition fill_row {k c xh} (D:'M[F]_(k, c)) (R:'M[F]_(xh, c)) (row_d: 'I_k) (row_r : 'I_xh) :=
  \matrix_(i < k, j < c) if i == row_d then R row_r j else D i j.

Definition fill_rows_aux {k c xh} (D:'M[F]_(k, c)) (R:'M[F]_(xh, c)) (locs: seq 'I_k) (xk: 'I_k) (l: seq 'I_xh) :=
  foldl (fun acc x => fill_row acc R (nth xk locs (nat_of_ord x)) x) D l.

Definition fill_rows {k c xh} (D:'M[F]_(k, c)) (R:'M[F]_(xh, c)) (locs: seq 'I_k) (xk: 'I_k) :=
  fill_rows_aux D R locs xk (ord_enum xh).

(*Build dependent type for the next lemma*)
Lemma index_ord_proof: forall {A: eqType} (k: nat) (l: seq A) (x: A),
  x \in l ->
  size l = k ->
  index x l < k.
Proof.
  move => A k l x Hx Hsz. by rewrite -Hsz index_mem.
Qed.

Lemma fill_rows_aux_notin:  forall k c xh (D:'M[F]_(k, c)) (R:'M[F]_(xh, c)) (locs: seq 'I_k) (Hsz: size locs = xh)
  x y (Hin: x \in locs) (xk: 'I_k) (l: seq 'I_xh),
  uniq locs ->
  (index x locs) \notin (map (@nat_of_ord xh) l) ->
  (fill_rows_aux D R locs xk l) x y = D x y.
Proof.
  move => k c xh D R locs Hsz x y Hxin xk l Hun. move : D. elim : l => [//= |/= h t IH D].
  rewrite in_cons negb_or => /andP[Hnoth Hnott].
  rewrite IH //. rewrite mxE. case Hx: (x == nth xk locs h).
  - apply (elimT eqP) in Hx. rewrite Hx in Hnoth. rewrite index_uniq in Hnoth. by rewrite eq_refl in Hnoth.
    by rewrite Hsz. by [].
  - by [].
Qed.

Lemma fill_rows_aux_spec: forall k c xh (D:'M[F]_(k, c)) (R:'M[F]_(xh, c)) (locs: seq 'I_k) (Hsz: size locs = xh)
  x y (Hin: x \in locs) (xk: 'I_k) (l: seq 'I_xh),
  uniq locs ->
  uniq l ->
  (index x locs) \in (map (@nat_of_ord xh) l) ->
  (fill_rows_aux D R locs xk l) x y = R (Ordinal (index_ord_proof Hin Hsz)) y.
Proof.
  move => k c xh A R locs Hsz x y Hin xk l Huniq. move: A. elim : l => [//= | /= h t IH A /andP [Hht Hul]].
  rewrite in_cons => /orP[/eqP Hxh | Hxt].
  - subst. rewrite fill_rows_aux_notin //.
    + rewrite mxE. rewrite -Hxh nth_index // eq_refl. f_equal.
      apply ord_inj. by rewrite -Hxh.
    + rewrite Hxh. rewrite mem_map //. apply ord_inj.
  - rewrite IH //.
Qed.

(*We can easily extend this to [fill_rows]*)
Lemma fill_rows_spec:forall k c xh (D:'M[F]_(k, c)) (R:'M[F]_(xh, c)) (locs: seq 'I_k) (Hsz: size locs = xh)
  x y (Hin: x \in locs) (xk: 'I_k),
  uniq locs ->
  (fill_rows D R locs xk) x y = R (Ordinal (index_ord_proof Hin Hsz)) y.
Proof.
  move => k c xh D R locs Hsz x y Hin xk Huniq.
  apply fill_rows_aux_spec. by []. apply ord_enum_uniq.
  have Hi: index x locs < xh by apply index_ord_proof.
  have->: index x locs = nat_of_ord (Ordinal Hi) by [].
  rewrite mem_map. apply mem_ord_enum. apply ord_inj.
Qed.

Lemma fill_rows_notin_spec: forall k c xh (D:'M[F]_(k, c)) (R:'M[F]_(xh, c)) (locs: seq 'I_k)
  x y (xk: 'I_k),
  xh <= size locs ->
  x \notin locs ->
  (fill_rows D R locs xk) x y = D x y.
Proof.
  move => k c xh D R locs x y xk Hsz Hnotin.  rewrite /fill_rows. move : D.
  elim : (ord_enum xh) => [//= | h t IH D //=].
  rewrite IH mxE. case Hx:  (x == nth xk locs h) =>[|//=].
  apply (elimT eqP) in Hx. move: Hnotin. rewrite Hx mem_nth //.
  have Hh: h < xh by []. by apply (ltn_leq_trans Hh).
Qed.

(*What we need to know about this: if we take B = submx_rows_cols' A miss_rows (ord_enum n), and fill the rows of C
  with B according to miss_rows, then C agrees with A on all rows in miss_rows*)
Lemma fill_rows_submx: forall {k c xh} (A C: 'M[F]_(k, c)) (locs: seq 'I_k) (xk: 'I_k) (xc: 'I_c),
  forall (x: 'I_k) (y: 'I_c), size locs = xh -> uniq locs -> x \in locs ->
    A x y = fill_rows C (submx_rows_cols xh c A locs (ord_enum c) xk xc) locs xk x y.
Proof.
  move => k c xh A C locs xk xc x y Hsz Hun Hin.
  rewrite fill_rows_spec // mxE. f_equal.
  - by rewrite nth_index.
  - by rewrite nth_ord_enum.
Qed.

(*Now we define the decoder*)

Variable k: nat.
Variable c : nat.
Variable max_h : nat.
Variable max_n : nat.
Variable max_size: max_h <= max_n.
Variable k_size: k <= max_n - max_h.
Variable l : list F.
Variable uniq_l: uniq l.
Variable size_l: size l = max_n.

Definition weights := gaussian_elim (vandermonde max_h max_n l).

Lemma k_leq_n: k <= max_n.
Proof.
  apply (leq_trans k_size). by rewrite leq_subr.
Qed.

(*Expand ords in a list*)
Definition widen_ord_seq {m n} (Hmn: m <= n) (a: seq 'I_m) : seq 'I_n :=
  map (widen_ord Hmn) a.

Variable x_max_h : 'I_(max_h).
Variable x_max_n : 'I_(max_n).
Variable x_k : 'I_k.
Variable x_c : 'I_c.

(*First, the generic decoder that uses a matrix subtraction instead of an extra (not really needed)
  multiplication. This works over any field*)

(*The input comes in 2 pieces: the k - xh received packets and the xh found parity packets. We will also
  know the xh missing packet locations and the xh found parity packet locations. To represent this in our
  mathematical model, we will have the decoder take in a full-size matrix (or else the dependent types
  get super annoying), and model the missing packets in the proof *)
Definition decoder (h xh: nat) (input: 'M[F]_(k, c)) (parities: 'M[F]_(h, c)) (missing: seq 'I_k)
  (found_parities : list 'I_(h)) (Hh: h <= max_h) (x_h : 'I_h) : 'M[F]_(k, c) :=
  (*each matrix is named the same as in the C code except that s' is defined by adding the parity vector to s
    (the natural way of decoding)*)
  let w' := invmx (submx_rows_cols_rev xh xh weights (widen_ord_seq Hh found_parities)
              (widen_ord_seq k_leq_n missing) x_max_h x_max_n) in
  let w'' := submx_rows_cols_rev xh (k-xh) weights (widen_ord_seq Hh found_parities)
             (widen_ord_seq k_leq_n (ord_comp missing)) x_max_h x_max_n in
  let s := w'' *m (submx_rows_cols (k-xh) c input (ord_comp missing) (ord_enum c) x_k x_c) in
  let s' := minusmx (submx_rows_cols xh c parities (found_parities) (ord_enum c) x_h x_c) s in
  let recovered := w' *m s' in
  (*need to build back the original matrix - put recovered in correct positions.*)
  fill_rows input recovered missing x_k.

(*Correctness of decoder: Let data be the original data and input be the input to the decoder.
  If data and input agree on all non-missing packets, and if parities and (encode data) agree
  at all the locations in [found_parities] (ie, the parity packets are valid), then
  decoding the input gives us the original data*)
Theorem decoder_correct: forall h xh (Hh: xh <= h) (data : 'M[F]_(k, c)) (input: 'M[F]_(k, c))
  (parities: 'M[F]_(h, c)) (missing_packets : seq 'I_k) (found_parities : seq 'I_h)
  (Hhh: h <= max_h) (x_h : 'I_h),
  (*Only the rows in [missing_packets] are incorrect*)
  (forall (x: 'I_k) (y: 'I_c), x \notin missing_packets -> data x y = input x y) ->
  (*All found parity packets were valid (produced by encoder)*)
  (forall (x: 'I_h) (y: 'I_c), x \in found_parities ->
    parities x y = (encoder Hhh k_leq_n weights data) x y) ->
  (*We have exactly xh unique missing packets and found parities*)
  uniq missing_packets ->
  uniq found_parities ->
  size missing_packets = xh ->
  size found_parities = xh ->
  (*Then, the decoder recovers the original data*)
  decoder xh input parities missing_packets found_parities Hhh x_h = data.
Proof.
  move => h xh Hxh data input parities missing_packets found_parities Hhh x_h
  Hnonmissing Hparities Hpackun Hparun Hpacksz Hparsz.
  rewrite /decoder.
  remember (submx_rows_cols_rev xh xh weights (widen_ord_seq Hhh found_parities)
        (widen_ord_seq k_leq_n missing_packets) x_max_h x_max_n) as w'.
  remember (submx_rows_cols_rev xh (k - xh) weights (widen_ord_seq Hhh found_parities)
             (widen_ord_seq k_leq_n (ord_comp missing_packets)) x_max_h x_max_n *m
              submx_rows_cols (k - xh) c input (ord_comp missing_packets) (ord_enum c) x_k x_c) as s.
  remember (submx_rows_cols xh c parities found_parities (ord_enum c) x_h x_c) as p.
  remember (minusmx p s) as s'.
  (*The key fact we want to prove: S' = (W')^-1 * x*, where x* is the missing data.*)
  have Hsyn: s' = w' *m (submx_rows_cols  xh c data missing_packets (ord_enum c) x_k x_c). {
    rewrite Heqs' Heqs Heqp Heqw'. rewrite -matrixP => i j. rewrite !mxE.
    rewrite Hparities. 2 : { apply mem_nth. by rewrite Hparsz. }
    rewrite !mxE. apply /eqP. rewrite GRing.subr_eq. apply /eqP.
    (*idea: we need to split into lost and found indices*)
    have Hperm: perm_eq (index_enum (ordinal_finType k)) (missing_packets ++ (ord_comp missing_packets)).
      by rewrite index_ord_enum perm_sym ord_comp_app_perm.
    rewrite (perm_big _ Hperm) big_cat /=. f_equal.
    - rewrite (big_nth x_k). rewrite (big_nat_widen 0 (size missing_packets) xh). 2: by rewrite Hpacksz leqnn.
      rewrite big_mkord. apply eq_big.
      + move => x. rewrite Hpacksz andTb. by have: x < xh by [].
      + move => x Htriv. rewrite !mxE. f_equal. f_equal. rewrite !(nth_map x_h) //=.
        by rewrite Hparsz. f_equal. rewrite (nth_map x_max_n) //=. f_equal.
        by rewrite (nth_map x_k). by rewrite size_map Hpacksz.
    - rewrite (big_nth x_k). have Hcompsz: (size (ord_comp missing_packets) = k - xh)%N
        by rewrite ord_comp_size_uniq // Hpacksz.
      rewrite (big_nat_widen 0 (size (ord_comp missing_packets)) (k - xh)).
      2: { by rewrite Hcompsz leqnn. }
      rewrite big_mkord. apply eq_big.
      + move => x. rewrite Hcompsz andTb. by have: x < k - xh by [].
      + move => x Htriv. rewrite !mxE. f_equal. f_equal. rewrite !(nth_map x_h) //.
        by rewrite Hparsz. rewrite (nth_map x_max_n). f_equal.
        by rewrite (nth_map x_k). by rewrite size_map Hcompsz.
        apply Hnonmissing.
        have: nth x_k (ord_comp missing_packets) x \in (ord_comp missing_packets). {
          apply mem_nth. by rewrite Hcompsz. }
        by rewrite in_ord_comp. }
  (*Part 2: w' is invertible*)
  have Hw': w' \in unitmx. rewrite Heqw'. { rewrite /submx_rows_cols_rev /weights.
    have Hmaxh: 0 < max_h by apply ord_nonzero.
    rewrite (@submx_rows_cols_default _ max_h max_n xh xh _ _ _ x_max_h x_max_n (Ordinal Hmaxh)
      (widen_ord max_size (Ordinal Hmaxh))). apply any_submx_unitmx.
    - by [].
    - by [].
    - rewrite map_inj_uniq //. move => x y. apply widen_ord_inj.
    - rewrite !map_inj_uniq //. move => x y. apply widen_ord_inj. apply rev_ord_inj.
    - by rewrite !size_map Hpacksz Hparsz.
    - by rewrite size_map.
    - move => x. move =>/mapP [y Hy Hxy]. subst.
      move : Hy => /mapP [z Hz Hzy]. subst. rewrite /=.
      have: z < max_n - max_h. have Hz': z < k by []. by apply (ltn_leq_trans Hz').
      rewrite ltn_subCr subnS ltn_pred // subn_gt0. have Hz': z < k by [].
      apply (ltn_leq_trans Hz'). apply k_leq_n.
    - by rewrite size_map Hparsz leqnn.
    - by rewrite !size_map Hpacksz leqnn. }
  (*Part 3: We get the original data back*)
  rewrite Hsyn mulmxA mulVmx // mul1mx. rewrite -matrixP => i j.
  case Hi: (i \in missing_packets).
  - by rewrite -fill_rows_submx.
  - have Hi': i \notin missing_packets by apply negbT. rewrite fill_rows_notin_spec //.
    by rewrite Hnonmissing. by rewrite Hpacksz leqnn.
Qed.

Section SpecializedDecoder.

(*For the matrix multiplication decoder to be correct, we need to be in a field of characteristic 2, so
  addition and subtraction are the same thing*)

Variable Hchar: 2%N \in [char F].

Lemma max_n_pos: 0 < max_n.
Proof.
  have: 0 <= k by []. rewrite leq_eqVlt => /orP[/eqP Hk0 | Hkpos].
  - subst. have: x_k < 0 by []. by rewrite ltn0.
  - have Hkn: k <= max_n. apply (leq_trans k_size). by rewrite leq_subr.
    apply (ltn_leq_trans Hkpos Hkn).
Qed.

(*We want to transform (x: 'I_h) into max_n - 1 - x and have the result be an I_(max_n)
Only -1 bc the size of the weight mx is FEC_MAX_N - 1*)
Lemma parity_loc_lt: forall h (x: 'I_h),
  max_n - 1 - x < max_n.
Proof.
  move => h x. rewrite -subnDA addnC addn1 ltn_psubLR.
  rewrite -{1}(add0n max_n) ltn_add2r //. apply max_n_pos.
Qed.

(*The only difference is that the "found" array includes the reversed locations of the parity packets and
  that we do a multiplication instead of a subtraction*)
Definition decoder_mult (h xh: nat) (input: 'M[F]_(k, c)) (parities: 'M[F]_(h, c)) (missing: seq 'I_k)
  (found_parities : list 'I_h) (Hh: h <= max_h) (x_h : 'I_h) (Hxhk: xh <= k) : 'M[F]_(k, c) :=
  (*each matrix is named the same as in the C code except that s' is defined by adding the parity vector to s
    (the natural way of decoding)*)
  let v := invmx (submx_rows_cols_rev xh xh weights (widen_ord_seq Hh found_parities)
              (widen_ord_seq k_leq_n missing) x_max_h x_max_n) in
  let w'' := submx_rows_cols_rev xh k weights (widen_ord_seq Hh found_parities)
             ((widen_ord_seq k_leq_n (ord_comp missing)) ++
             map (fun (i: 'I_h) => Ordinal (parity_loc_lt i)) found_parities) x_max_h x_max_n in
  (*need a cast bc we need to unify k - xh + xh and k*)
  let s := w'' *m (castmx (subnK Hxhk, Logic.eq_refl c) (col_mx (submx_rows_cols (k-xh) c input (ord_comp missing) (ord_enum c) x_k x_c)
                          (submx_rows_cols xh c parities found_parities (ord_enum c) x_h x_c))) in
  let recovered := v *m s in
  fill_rows input recovered missing x_k.

Lemma decoder_mult_0: forall (h xh: nat) (input: 'M[F]_(k, c)) (parities: 'M[F]_(h, c)) (missing: seq 'I_k)
  (found_parities : list 'I_h) (Hh: h <= max_h) (x_h : 'I_h) (Hxhk: xh <= k),
  size missing = 0%N ->
  xh = 0%N ->
  decoder_mult input parities missing found_parities Hh x_h Hxhk = input.
Proof.
  move => h xh input parities missing found_parities Hh x_h Hxhk Hsz Hxh. subst.
  rewrite /decoder_mult /=. rewrite (matrix_zero_rows (invmx _) 1%:M) mul1mx.
  rewrite -matrixP => x y. apply fill_rows_notin_spec. by rewrite Hsz.
  apply size0nil in Hsz. by rewrite Hsz.
Qed.

(*TODO: maybe separate out summation stuff*)
Lemma big_nat_widen_lt m1 m2 n (P : pred nat) (C: nat -> F) :
     m1 <= m2 ->
  \sum_(m2 <= i < n | P i) C i
      = \sum_(m1 <= i < n | P i && (m2 <= i)) C i.
Proof.
  move => Hm.
  case : (orP (ltn_leq_total n m2)) => [Hout | Hin].
  - rewrite big_geq. 2: by apply ltnW. rewrite (big_nat_cond _ _ m1 n) !big_hasC //.
    apply /hasP; move => [x Hin /andP[/andP[Hm1 Hn] /andP[Hp Hm2]]].
    have: x < m2. apply (ltn_trans Hn Hout). by rewrite ltnNge Hm2.
  - rewrite (big_cat_nat _ _ _ Hm) //= -(GRing.add0r (\sum_(m2 <= i < n | P i) C i)). f_equal.
    + rewrite big_nat_cond big_hasC //. apply /hasP.
      move => [x Hiota /andP[/andP[Hm1 Hm2] /andP[Hp Hm2']]].
      move: Hm2 Hm2'. rewrite (leqNgt m2 x). by move ->.
    + rewrite big_nat_cond (big_nat_cond _ _ m2 n (fun i => P i && (m2 <= i))).
      apply eq_big =>[x |//]. case Hbound: (m2 <= x < n) =>[|//].
      rewrite !andTb. move : Hbound => /andP[Hm2 Hn]. by rewrite Hm2 andbT.
Qed.

(*As long as the missing and found lists are unique and have size xh, the two decoders are equivalent
  in a field of characteristic 2*)
Lemma decoder_equivalent: forall (h xh: nat) (input: 'M[F]_(k, c)) (parities: 'M[F]_(h, c)) (missing: seq 'I_k)
  (found_parities : list 'I_h) (Hh: h <= max_h) (x_h : 'I_h) (Hxhk: xh <= k),
  size missing = xh ->
  size found_parities = xh ->
  uniq missing ->
  uniq found_parities ->
  decoder_mult input parities missing found_parities Hh x_h Hxhk =
  decoder xh input parities missing found_parities Hh x_h.
Proof.
  move => h xh input parities missing found_parities Hh x_h Hxkh Hpacksz Hparsz Hpackun Hparun.
  rewrite /decoder /decoder_mult. f_equal. f_equal. rewrite -matrixP => x y.
  rewrite !mxE /=. rewrite GRing.subr_char2 // GRing.addrC. (*need that addition = subtraction*)
  rewrite (big_nth x_k) /=. rewrite (big_nat_widen 0 _ k). 2:  by rewrite index_ord_enum size_ord_enum.
  rewrite (@big_cat_nat _ _ _ (k-xh)%N 0%N k) /=. f_equal.
  - (*The packets side of the multiplication is the same as before (this is nontrivial to
       show because we are multiplying bigger matrices and the ordinals are annoying)*)
    rewrite big_mkord. apply eq_big. move => i.
    rewrite index_ord_enum size_ord_enum. have Hi: i < k - xh by [].
    apply (ltn_leq_trans Hi). by rewrite leq_subr.
    move => i. rewrite !mxE !index_ord_enum nth_ord_enum size_ord_enum => Hik.
    have->: (nth x_k (ord_enum k) i) = (Ordinal Hik).
      have Hiord: (nat_of_ord i = nat_of_ord (Ordinal Hik)) by [].
      have->: nth x_k (ord_enum k) i = nth x_k (ord_enum k) (Ordinal Hik) by [].
      by rewrite nth_ord_enum.
    have Hsz: size (ord_comp missing) = (k - xh)%N by rewrite ord_comp_size_uniq // Hpacksz.
    rewrite /= !(nth_map x_max_n). rewrite nth_cat size_map Hsz.
    have->: i < (k - xh)%N by []. f_equal. rewrite castmxE !mxE /=.
    have Hik': i < (k - xh) + xh by rewrite subnK.
    have->: (cast_ord (esym (subnK Hxkh)) (Ordinal Hik)) = Ordinal Hik'. by apply ord_inj.
    pose proof (splitP (Ordinal Hik')). case : X => [j /= Hj | j /= Hj]. subst. rewrite mxE. f_equal.
    by rewrite Hj. by rewrite nth_ord_enum cast_ord_id. subst.
    (*in the other case, we have a contradiction - not dealing with parities here*)
    have: i < (k- size missing)%N by []. by rewrite Hj -{2}(addn0 (k- (size missing))%N) ltn_add2l ltn0.
    by rewrite size_map Hsz. by rewrite size_cat !size_map Hparsz Hsz subnK.
  - (*now need to show that the extra mattrix multiplication is equivalent to the sum - this is because we
      multiply with the portion of the matrix that is the identity*)
    rewrite nth_ord_enum.
    (*idea: the (k-xh +x)th entry is 1, rest are 0*)
    rewrite (@big_nat_widen_lt 0 (k-xh)%N) // big_mkord.
    have Hx: k - xh + x < k  by rewrite -ltn_subRL subKn.
    rewrite (@sum_remove_one _ _ _ _ (Ordinal Hx)) //=.
    (*First, a goal that comes up multiple times*)
    have Hinv: colsub (widen_ord max_size) (vandermonde max_h max_n l) \in unitmx. {
      have->:colsub (widen_ord max_size) (vandermonde max_h max_n l) =
             colsub (fun x : 'I_max_h => nth x_max_n (widen_ord_seq max_size (ord_enum max_h)) (widen_ord max_size x))
                (vandermonde max_h max_n l).
      rewrite -matrixP => a b. rewrite !mxE. rewrite (nth_map x_max_h) /=. by rewrite nth_ord_enum.
      by rewrite size_ord_enum.
      apply vandermonde_cols_unitmx; try by []. rewrite map_inj_uniq. by rewrite ord_enum_uniq.
      move => u v; apply widen_ord_inj. by rewrite size_map size_ord_enum. }
    (*First, we will show that the rest of sum is 0*)
    rewrite big1. 2: { rewrite index_ord_enum size_ord_enum => i /andP[ /andP[Hik Hikxh] Hix].
    have Hsz: size (ord_comp missing) = (k - xh)%N by rewrite ord_comp_size_uniq // Hpacksz.
    rewrite !mxE (nth_map x_max_n). rewrite nth_cat size_map Hsz.
    have->: nth x_k (ord_enum k) i = Ordinal Hik.
      have->: nth x_k (ord_enum k) i = nth x_k (ord_enum k) (Ordinal Hik) by [].
      by rewrite nth_ord_enum.
    have->:Ordinal Hik < k - xh = false. rewrite /=. move: Hikxh. rewrite ltnNge. by move ->.
    rewrite /= /weights.
    have Hxsz: x < size found_parities by rewrite Hparsz.
    have Hisz: i - (k - xh) < size found_parities. rewrite Hparsz subnBA // addnC -subnBA //.
      have Hpos: 0 < k - i by rewrite subn_gt0.
      rewrite ltn_psubCl //. by rewrite subnn. by apply ord_nonzero. by apply ltnW.
    have Hrev: nat_of_ord (rev_ord (nth x_max_n [seq Ordinal (parity_loc_lt i0) | i0 <- found_parities] (i - (k - xh))))
               = nat_of_ord (nth x_h found_parities (i - (k - xh))). {
      rewrite /= !(nth_map x_h) //= -subnDA subnS subKn. 2: { rewrite add1n.
      apply (ltn_leq_trans (ltn_ord _)). by apply (leq_trans Hh). }
      by rewrite addnC addn1. }
    rewrite gaussian_elim_identity_val //.
    - rewrite (nth_map x_h x_max_h). rewrite Hrev //=. apply /eqP. rewrite GRing.mulf_eq0 ifF.
      by rewrite eq_refl. rewrite nat_of_ord_eq nth_uniq //.
      case Hxi: (nat_of_ord x == (i - (k - xh))%N) =>[|//].
      apply (elimT eqP) in Hxi. have Hi: i = Ordinal Hx by apply ord_inj; rewrite /= Hxi subnKC.
      rewrite Hi in Hix. by rewrite eq_refl in Hix. by rewrite Hparsz.
    - by rewrite Hrev (ltn_leq_trans (ltn_ord _)).
    - by rewrite size_cat !size_map Hparsz ord_comp_size_uniq // Hpacksz subnK. }
    (*We proved that the rest of the sum is 0, now we need to show that the one term is 1*)
    rewrite GRing.add0r !mxE.
    have->:(nth x_k (index_enum (ordinal_finType k)) (k - xh + x)) = Ordinal Hx.
      have->: (nth x_k (index_enum (ordinal_finType k)) (k - xh + x)) =
               (nth x_k (index_enum (ordinal_finType k)) (Ordinal Hx)) by [].
      by rewrite index_ord_enum nth_ord_enum.
    rewrite (nth_map x_max_n). rewrite nth_cat.
    have->: Ordinal Hx < size (widen_ord_seq k_leq_n (ord_comp missing)) = false.
      by rewrite size_map ord_comp_size_uniq //= Hpacksz -{2}(addn0 (k-xh)%N) ltn_add2l ltn0.
    rewrite (nth_map x_h). rewrite size_map ord_comp_size_uniq //= Hpacksz.
    have->: (k - xh + x - (k - xh))%N = x. rewrite addnC -subnBA. by rewrite subnn subn0. by rewrite leqnn.
    have Hnth: (nat_of_ord (nth x_max_h (widen_ord_seq Hh found_parities) x) ==
                nat_of_ord (rev_ord (Ordinal (parity_loc_lt (nth x_h found_parities x))))). {
      rewrite /=.   rewrite /= !(nth_map x_h) //=. rewrite -subnDA subnS subKn add1n /=. by rewrite eq_refl.
      apply (ltn_leq_trans (ltn_ord _)). by apply (leq_trans Hh). by rewrite Hparsz. }
    rewrite /weights gaussian_elim_identity_val //.
    + rewrite Hnth GRing.mul1r.
      (*Now have to deal with other side - concatenated matrix*)
      rewrite castmxE mxE /=.
      have Hx': k - xh + x < k - xh + xh by rewrite subnK.
      have->:(cast_ord (esym (subnK Hxkh)) (Ordinal Hx)) = Ordinal Hx' by apply ord_inj.
      pose proof (splitP (Ordinal Hx')) as X. (*is there an ssreflect way to do this?*)
      case : X => [j /= Hj | j /= Hj].
      * have: (k - xh + x < k - xh) by rewrite Hj. by rewrite -{2}(addn0 (k-xh)%N) ltn_add2l ltn0.
      * rewrite mxE /=. rewrite nth_ord_enum.
        have Hjx: j = x. apply (introT eqP) in Hj; move : Hj. rewrite eqn_add2l => /eqP Hxj.
          apply ord_inj. by rewrite Hxj. by rewrite Hjx.
    + apply (elimT eqP) in Hnth. by rewrite -Hnth.
    + by rewrite size_map ord_comp_size_uniq //= Hpacksz Hparsz addnC -subnBA //= subnn subn0.
    + by rewrite size_cat !size_map Hparsz ord_comp_size_uniq //= Hpacksz ltn_add2l.
    + by rewrite index_ord_enum size_ord_enum Hx andTb -{1}(addn0 (k - xh)%N) leq_add2l.
  - by rewrite leq_subRL // addn0.
  - apply leq_subr.
Qed.

End SpecializedDecoder.

End Decoder.

End RS.


(* (c) Copyright 2006-2015 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp
Require Import ssrfun ssrbool eqtype ssrnat seq choice fintype.
From mathcomp
Require Import bigop ssralg ssrint div ssrnum rat poly closed_field polyrcf.
From mathcomp
Require Import matrix mxalgebra tuple mxpoly zmodp binomial realalg.

(**********************************************************************)
(*   This files defines the extension R[i] of a real field R,         *)
(* and provide it a structure of numeric field with a norm operator.  *)
(* When R is a real closed field, it also provides a structure of     *)
(* algebraically closed field for R[i], using a proof by Derksen      *)
(* (cf comments below, thanks to Pierre Lairez for finding the paper) *)
(**********************************************************************)

Import GRing.Theory Num.Theory.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Obligation Tactic := idtac.

Local Open Scope ring_scope.

Reserved Notation "x +i* y"
  (at level 40, left associativity, format "x  +i*  y").
Reserved Notation "x -i* y"
  (at level 40, left associativity, format "x  -i*  y").
Reserved Notation "R [i]"
  (at level 2, left associativity, format "R [i]").

Local Notation sgr := Num.sg.
Local Notation sqrtr := Num.sqrt.

CoInductive complex (R : Type) : Type := Complex { Re : R; Im : R }.

Delimit Scope complex_scope with C.
Local Open Scope complex_scope.

Definition real_complex_def (F : ringType) (phF : phant F) (x : F) :=
  Complex x 0.
Notation real_complex F := (@real_complex_def _ (Phant F)).
Notation "x %:C" := (real_complex _ x)
  (at level 2, left associativity, format "x %:C")  : complex_scope.
Notation "x +i* y" := (Complex x y) : complex_scope.
Notation "x -i* y" := (Complex x (- y)) : complex_scope.
Notation "x *i " := (Complex 0 x) (at level 8, format "x *i") : complex_scope.
Notation "''i'" := (Complex 0 1) : complex_scope.
Notation "R [i]" := (complex R)
  (at level 2, left associativity, format "R [i]").

(* Module ComplexInternal. *)
Module ComplexEqChoice.
Section ComplexEqChoice.

Variable R : Type.

Definition sqR_of_complex (x : R[i]) := let: a +i* b := x in [::a;  b].
Definition complex_of_sqR (x : seq R) :=
  if x is [:: a; b] then Some (a +i* b) else None.

Lemma complex_of_sqRK : pcancel sqR_of_complex complex_of_sqR.
Proof. by case. Qed.

End ComplexEqChoice.
End ComplexEqChoice.

Definition complex_eqMixin (R : eqType) :=
  PcanEqMixin (@ComplexEqChoice.complex_of_sqRK R).
Definition complex_choiceMixin  (R : choiceType) :=
  PcanChoiceMixin (@ComplexEqChoice.complex_of_sqRK R).
Definition complex_countMixin  (R : countType) :=
  PcanCountMixin (@ComplexEqChoice.complex_of_sqRK R).

Canonical complex_eqType (R : eqType) :=
  EqType R[i] (complex_eqMixin R).
Canonical complex_choiceType (R : choiceType) :=
  ChoiceType R[i] (complex_choiceMixin R).
Canonical complex_countType (R : countType) :=
  CountType R[i] (complex_countMixin R).

Lemma eq_complex : forall (R : eqType) (x y : complex R),
  (x == y) = (Re x == Re y) && (Im x == Im y).
Proof.
move=> R [a b] [c d] /=.
apply/eqP/andP; first by move=> [-> ->]; split.
by case; move/eqP->; move/eqP->.
Qed.

Lemma complexr0 : forall (R : ringType) (x : R), x +i* 0 = x%:C. Proof. by []. Qed.

Module ComplexField.
Section ComplexField.

Variable R : rcfType.
Local Notation C := R[i].
Local Notation C0 := ((0 : R)%:C).
Local Notation C1 := ((1 : R)%:C).

Definition addc (x y : R[i]) := let: a +i* b := x in let: c +i* d := y in
  (a + c) +i* (b + d).
Definition oppc (x : R[i]) := let: a +i* b := x in (- a) +i* (- b).

Program Definition complex_zmodMixin := @ZmodMixin _ C0 oppc addc _ _ _ _.
Next Obligation. by move=> [a b] [c d] [e f] /=; rewrite !addrA. Qed.
Next Obligation. by move=> [a b] [c d] /=; congr (_ +i* _); rewrite addrC. Qed.
Next Obligation. by move=> [a b] /=; rewrite !add0r. Qed.
Next Obligation. by move=> [a b] /=; rewrite !addNr. Qed.
Canonical complex_zmodType := ZmodType R[i] complex_zmodMixin.

Definition scalec (a : R) (x : R[i]) :=
  let: b +i* c := x in (a * b) +i* (a * c).

Program Definition complex_lmodMixin := @LmodMixin _ _ scalec _ _ _ _.
Next Obligation. by move=> a b [c d] /=; rewrite !mulrA. Qed.
Next Obligation. by move=> [a b] /=; rewrite !mul1r. Qed.
Next Obligation. by move=> a [b c] [d e] /=; rewrite !mulrDr. Qed.
Next Obligation. by move=> [a b] c d /=; rewrite !mulrDl. Qed.
Canonical complex_lmodType := LmodType R R[i] complex_lmodMixin.

Definition mulc (x y : R[i]) := let: a +i* b := x in let: c +i* d := y in
  ((a * c) - (b * d)) +i* ((a * d) + (b * c)).

Lemma mulcC : commutative mulc.
Proof.
move=> [a b] [c d] /=.
by rewrite [c * b + _]addrC ![_ * c]mulrC ![_ * d]mulrC.
Qed.

Lemma mulcA : associative mulc.
Proof.
move=> [a b] [c d] [e f] /=.
rewrite !mulrDr !mulrDl !mulrN !mulNr !mulrA !opprD -!addrA.
by congr ((_ + _) +i* (_ + _)); rewrite !addrA addrAC;
  congr (_ + _); rewrite addrC.
Qed.

Definition invc (x : R[i]) := let: a +i* b := x in let n2 := (a ^+ 2 + b ^+ 2) in
  (a / n2) -i* (b / n2).

Lemma mul1c : left_id C1 mulc.
Proof. by move=> [a b] /=; rewrite !mul1r !mul0r subr0 addr0. Qed.

Lemma mulc_addl : left_distributive mulc addc.
Proof.
move=> [a b] [c d] [e f] /=; rewrite !mulrDl !opprD -!addrA.
by congr ((_ + _) +i* (_ + _)); rewrite addrCA.
Qed.

Lemma nonzero1c : C1 != C0. Proof. by rewrite eq_complex /= oner_eq0. Qed.

Definition complex_comRingMixin :=
  ComRingMixin mulcA mulcC mul1c mulc_addl nonzero1c.
Canonical complex_ringType :=RingType R[i] complex_comRingMixin.
Canonical complex_comRingType := ComRingType R[i] mulcC.

Lemma mulVc : forall x, x != C0 -> mulc (invc x) x = C1.
Proof.
move=> [a b]; rewrite eq_complex => /= hab; rewrite !mulNr opprK.
rewrite ![_ / _ * _]mulrAC [b * a]mulrC subrr complexr0 -mulrDl mulfV //.
by rewrite paddr_eq0 -!expr2 ?expf_eq0 ?sqr_ge0.
Qed.

Lemma invc0 : invc C0 = C0. Proof. by rewrite /= !mul0r oppr0. Qed.

Definition complex_fieldUnitMixin := FieldUnitMixin mulVc invc0.
Canonical complex_unitRingType := UnitRingType C complex_fieldUnitMixin.
Canonical complex_comUnitRingType := Eval hnf in [comUnitRingType of R[i]].

Lemma field_axiom : GRing.Field.mixin_of complex_unitRingType.
Proof. by []. Qed.

Definition ComplexFieldIdomainMixin := (FieldIdomainMixin field_axiom).
Canonical complex_idomainType := IdomainType R[i] (FieldIdomainMixin field_axiom).
Canonical complex_fieldType := FieldType R[i] field_axiom.

Ltac simpc := do ?
  [ rewrite -[(_ +i* _) - (_ +i* _)]/(_ +i* _)
  | rewrite -[(_ +i* _) + (_ +i* _)]/(_ +i* _)
  | rewrite -[(_ +i* _) * (_ +i* _)]/(_ +i* _)].

Lemma real_complex_is_rmorphism : rmorphism (real_complex R).
Proof.
split; [|split=> //] => a b /=; simpc; first by rewrite subrr.
by rewrite !mulr0 !mul0r addr0 subr0.
Qed.

Canonical real_complex_rmorphism :=
  RMorphism real_complex_is_rmorphism.
Canonical real_complex_additive :=
  Additive real_complex_is_rmorphism.

Lemma Re_is_scalar : scalar (@Re R).
Proof. by move=> a [b c] [d e]. Qed.

Canonical Re_additive := Additive Re_is_scalar.
Canonical Re_linear := Linear Re_is_scalar.

Lemma Im_is_scalar : scalar (@Im R).
Proof. by move=> a [b c] [d e]. Qed.

Canonical Im_additive := Additive Im_is_scalar.
Canonical Im_linear := Linear Im_is_scalar.

Definition lec (x y : R[i]) :=
  let: a +i* b := x in let: c +i* d := y in
    (d == b) && (a <= c).

Definition ltc (x y : R[i]) :=
  let: a +i* b := x in let: c +i* d := y in
    (d == b) && (a < c).

Definition normc (x : R[i]) : R :=
  let: a +i* b := x in sqrtr (a ^+ 2 + b ^+ 2).

Notation normC x := (normc x)%:C.

Lemma ltc0_add : forall x y, ltc 0 x -> ltc 0 y -> ltc 0 (x + y).
Proof.
move=> [a b] [c d] /= /andP [/eqP-> ha] /andP [/eqP-> hc].
by rewrite addr0 eqxx addr_gt0.
Qed.

Lemma eq0_normc x : normc x = 0 -> x = 0.
Proof.
case: x => a b /= /eqP; rewrite sqrtr_eq0 ler_eqVlt => /orP [|]; last first.
  by rewrite ltrNge addr_ge0 ?sqr_ge0.
by rewrite paddr_eq0 ?sqr_ge0 ?expf_eq0 //= => /andP[/eqP -> /eqP ->].
Qed.

Lemma eq0_normC x : normC x = 0 -> x = 0. Proof. by case=> /eq0_normc. Qed.

Lemma ge0_lec_total x y : lec 0 x -> lec 0 y -> lec x y || lec y x.
Proof.
move: x y => [a b] [c d] /= /andP[/eqP -> a_ge0] /andP[/eqP -> c_ge0].
by rewrite eqxx ler_total.
Qed.

Lemma normcM x y : normc (x * y) = normc x * normc y.
Proof.
move: x y => [a b] [c d] /=; rewrite -sqrtrM ?addr_ge0 ?sqr_ge0 //.
rewrite sqrrB sqrrD mulrDl !mulrDr -!exprMn.
rewrite mulrAC [b * d]mulrC !mulrA.
suff -> : forall (u v w z t : R), (u - v + w) + (z + v + t) = u + w + (z + t).
  by rewrite addrAC !addrA.
by move=> u v w z t; rewrite [_ - _ + _]addrAC [z + v]addrC !addrA addrNK.
Qed.

Lemma normCM x y : normC (x * y) = normC x * normC y.
Proof. by rewrite -rmorphM normcM. Qed.

Lemma subc_ge0 x y : lec 0 (y - x) = lec x y.
Proof. by move: x y => [a b] [c d] /=; simpc; rewrite subr_ge0 subr_eq0. Qed.

Lemma lec_def x y : lec x y = (normC (y - x) == y - x).
Proof.
rewrite -subc_ge0; move: (_ - _) => [a b]; rewrite eq_complex /= eq_sym.
have [<- /=|_] := altP eqP; last by rewrite andbF.
by rewrite [0 ^+ _]mul0r addr0 andbT sqrtr_sqr ger0_def.
Qed.

Lemma ltc_def x y : ltc x y = (y != x) && lec x y.
Proof.
move: x y => [a b] [c d] /=; simpc; rewrite eq_complex /=.
by have [] := altP eqP; rewrite ?(andbF, andbT) //= ltr_def.
Qed.

Lemma lec_normD x y : lec (normC (x + y)) (normC x + normC y).
Proof.
move: x y => [a b] [c d] /=; simpc; rewrite addr0 eqxx /=.
rewrite -(@ler_pexpn2r _ 2) -?topredE /= ?(ler_paddr, sqrtr_ge0) //.
rewrite [X in _ <= X] sqrrD ?sqr_sqrtr;
   do ?by rewrite ?(ler_paddr, sqrtr_ge0, sqr_ge0, mulr_ge0) //.
rewrite -addrA addrCA (monoRL (addrNK _) (ler_add2r _)) !sqrrD.
set u := _ *+ 2; set v := _ *+ 2.
rewrite [a ^+ _ + _ + _]addrAC [b ^+ _ + _ + _]addrAC -addrA.
rewrite [u + _] addrC [X in _ - X]addrAC [b ^+ _ + _]addrC.
rewrite [u]lock [v]lock !addrA; set x := (a ^+ 2 + _ + _ + _).
rewrite -addrA addrC addKr -!lock addrC.
have [huv|] := ger0P (u + v); last first.
  by move=> /ltrW /ler_trans -> //; rewrite pmulrn_lge0 // mulr_ge0 ?sqrtr_ge0.
rewrite -(@ler_pexpn2r _ 2) -?topredE //=; last first.
  by rewrite ?(pmulrn_lge0, mulr_ge0, sqrtr_ge0) //.
rewrite -mulr_natl !exprMn !sqr_sqrtr ?(ler_paddr, sqr_ge0) //.
rewrite -mulrnDl -mulr_natl !exprMn ler_pmul2l ?exprn_gt0 ?ltr0n //.
rewrite sqrrD mulrDl !mulrDr -!exprMn addrAC -!addrA ler_add2l !addrA.
rewrite [_ + (b * d) ^+ 2]addrC -addrA ler_add2l.
have: 0 <= (a * d - b * c) ^+ 2 by rewrite sqr_ge0.
by rewrite sqrrB addrAC subr_ge0 [_ * c]mulrC mulrACA [d * _]mulrC.
Qed.

Definition complex_numMixin := NumMixin lec_normD ltc0_add eq0_normC
     ge0_lec_total normCM lec_def ltc_def.
Canonical complex_numDomainType := NumDomainType R[i] complex_numMixin.
Canonical complex_numFieldType := [numFieldType of complex R].

End ComplexField.
End ComplexField.

Canonical ComplexField.complex_zmodType.
Canonical ComplexField.complex_lmodType.
Canonical ComplexField.complex_ringType.
Canonical ComplexField.complex_comRingType.
Canonical ComplexField.complex_unitRingType.
Canonical ComplexField.complex_comUnitRingType.
Canonical ComplexField.complex_idomainType.
Canonical ComplexField.complex_fieldType.
Canonical ComplexField.complex_numDomainType.
Canonical ComplexField.complex_numFieldType.
Canonical ComplexField.real_complex_rmorphism.
Canonical ComplexField.real_complex_additive.
Canonical ComplexField.Re_additive.
Canonical ComplexField.Im_additive.

Definition conjc {R : ringType} (x : R[i]) := let: a +i* b := x in a -i* b.
Notation "x ^*" := (conjc x) (at level 2, format "x ^*") : complex_scope.
Local Open Scope complex_scope.
Delimit Scope complex_scope with C.

Ltac simpc := do ?
  [ rewrite -[- (_ +i* _)%C]/(_ +i* _)%C
  | rewrite -[(_ +i* _)%C - (_ +i* _)%C]/(_ +i* _)%C
  | rewrite -[(_ +i* _)%C + (_ +i* _)%C]/(_ +i* _)%C
  | rewrite -[(_ +i* _)%C * (_ +i* _)%C]/(_ +i* _)%C
  | rewrite -[(_ +i* _)%C ^*]/(_ +i* _)%C
  | rewrite -[_ *: (_ +i* _)%C]/(_ +i* _)%C
  | rewrite -[(_ +i* _)%C <= (_ +i* _)%C]/((_ == _) && (_ <= _))
  | rewrite -[(_ +i* _)%C < (_ +i* _)%C]/((_ == _) && (_ < _))
  | rewrite -[`|(_ +i* _)%C|]/(sqrtr (_ + _))%:C%C
  | rewrite (mulrNN, mulrN, mulNr, opprB, opprD, mulr0, mul0r,
    subr0, sub0r, addr0, add0r, mulr1, mul1r, subrr, opprK, oppr0,
    eqxx) ].

Section ComplexTheory.

Variable R : rcfType.

Lemma ReiNIm : forall x : R[i], Re (x * 'i%C) = - Im x.
Proof. by case=> a b; simpc. Qed.

Lemma ImiRe : forall x : R[i], Im (x * 'i%C) = Re x.
Proof. by case=> a b; simpc. Qed.

Lemma complexE x : x = (Re x)%:C + 'i%C * (Im x)%:C :> R[i].
Proof. by case: x => *; simpc. Qed.

Lemma real_complexE x : x%:C = x +i* 0 :> R[i]. Proof. done. Qed.

Lemma sqr_i : 'i%C ^+ 2 = -1 :> R[i].
Proof. by rewrite exprS; simpc; rewrite -real_complexE rmorphN. Qed.

Lemma complexI : injective (real_complex R). Proof. by move=> x y []. Qed.

Lemma ler0c (x : R) : (0 <= x%:C) = (0 <= x). Proof. by simpc. Qed.

Lemma lecE : forall x y : R[i], (x <= y) = (Im y == Im x) && (Re x <= Re y).
Proof. by move=> [a b] [c d]. Qed.

Lemma ltcE : forall x y : R[i], (x < y) = (Im y == Im x) && (Re x < Re y).
Proof. by move=> [a b] [c d]. Qed.

Lemma lecR : forall x y : R, (x%:C <= y%:C) = (x <= y).
Proof. by move=> x y; simpc. Qed.

Lemma ltcR : forall x y : R, (x%:C < y%:C) = (x < y).
Proof. by move=> x y; simpc. Qed.

Lemma conjc_is_rmorphism : rmorphism (@conjc R).
Proof.
split=> [[a b] [c d]|] /=; first by simpc; rewrite [d - _]addrC.
by split=> [[a b] [c d]|] /=; simpc.
Qed.

Lemma conjc_is_scalable : scalable (@conjc R).
Proof. by move=> a [b c]; simpc. Qed.

Canonical conjc_rmorphism := RMorphism conjc_is_rmorphism.
Canonical conjc_additive := Additive conjc_is_rmorphism.
Canonical conjc_linear := AddLinear conjc_is_scalable.

Lemma conjcK : involutive (@conjc R).
Proof. by move=> [a b] /=; rewrite opprK. Qed.

Lemma mulcJ_ge0 (x : R[i]) : 0 <= x * x^*%C.
Proof.
by move: x=> [a b]; simpc; rewrite mulrC addNr eqxx addr_ge0 ?sqr_ge0.
Qed.

Lemma conjc_real (x : R) : x%:C^* = x%:C.
Proof. by rewrite /= oppr0. Qed.

Lemma ReJ_add (x : R[i]) : (Re x)%:C =  (x + x^*%C) / 2%:R.
Proof.
case: x => a b; simpc; rewrite [0 ^+ 2]mul0r addr0 /=.
rewrite -!mulr2n -mulr_natr -mulrA [_ * (_ / _)]mulrA.
by rewrite divff ?mulr1 // -natrM pnatr_eq0.
Qed.

Lemma ImJ_sub (x : R[i]) : (Im x)%:C =  (x^*%C - x) / 2%:R * 'i%C.
Proof.
case: x => a b; simpc; rewrite [0 ^+ 2]mul0r addr0 /=.
rewrite -!mulr2n -mulr_natr -mulrA [_ * (_ / _)]mulrA.
by rewrite divff ?mulr1 ?opprK // -natrM pnatr_eq0.
Qed.

Lemma ger0_Im (x : R[i]) : 0 <= x -> Im x = 0.
Proof. by move: x=> [a b] /=; simpc => /andP [/eqP]. Qed.

(* Todo : extend theory of : *)
(*   - signed exponents *)

Lemma conj_ge0 : forall x : R[i], (0 <= x ^*) = (0 <= x).
Proof. by move=> [a b] /=; simpc; rewrite oppr_eq0. Qed.

Lemma conjc_nat : forall n, (n%:R : R[i])^* = n%:R.
Proof. exact: rmorph_nat. Qed.

Lemma conjc0 : (0 : R[i]) ^* = 0.
Proof. exact: (conjc_nat 0). Qed.

Lemma conjc1 : (1 : R[i]) ^* = 1.
Proof. exact: (conjc_nat 1). Qed.

Lemma conjc_eq0 : forall x : R[i], (x ^* == 0) = (x == 0).
Proof. by move=> [a b]; rewrite !eq_complex /= eqr_oppLR oppr0. Qed.

Lemma conjc_inv: forall x : R[i], (x^-1)^* = (x^*%C )^-1.
Proof. exact: fmorphV. Qed.

Lemma complex_root_conj (p : {poly R[i]}) (x : R[i]) :
  root (map_poly conjc p) x = root p x^*.
Proof. by rewrite /root -{1}[x]conjcK horner_map /= conjc_eq0. Qed.

Lemma complex_algebraic_trans (T : comRingType) (toR : {rmorphism T -> R}) :
  integralRange toR -> integralRange (real_complex R \o toR).
Proof.
set f := _ \o _ => R_integral [a b].
have integral_real x : integralOver f (x%:C) by apply: integral_rmorph.
rewrite [_ +i* _]complexE.
apply: integral_add => //; apply: integral_mul => //=.
exists ('X^2 + 1).
  by rewrite monicE lead_coefDl ?size_polyXn ?size_poly1 ?lead_coefXn.
by rewrite rmorphD rmorph1 /= ?map_polyXn rootE !hornerE -expr2 sqr_i addNr.
Qed.

Lemma normc_def (z : R[i]) : `|z| = (sqrtr ((Re z)^+2 + (Im z)^+2))%:C.
Proof. by case: z. Qed.

Lemma add_Re2_Im2 (z : R[i]) : ((Re z)^+2 + (Im z)^+2)%:C = `|z|^+2.
Proof. by rewrite normc_def -rmorphX sqr_sqrtr ?addr_ge0 ?sqr_ge0. Qed.

Lemma addcJ (z : R[i]) : z + z^*%C = 2%:R * (Re z)%:C.
Proof. by rewrite ReJ_add mulrC mulfVK ?pnatr_eq0. Qed.

Lemma subcJ (z : R[i]) : z - z^*%C = 2%:R * (Im z)%:C * 'i%C.
Proof.
rewrite ImJ_sub mulrCA mulrA mulfVK ?pnatr_eq0 //.
by rewrite -mulrA ['i%C * _]sqr_i mulrN1 opprB.
Qed.

Lemma complex_real (a b : R) : a +i* b \is Num.real = (b == 0).
Proof.
rewrite realE; simpc; rewrite [0 == _]eq_sym.
by have [] := ltrgtP 0 a; rewrite ?(andbF, andbT, orbF, orbb).
Qed.

Lemma complex_realP (x : R[i]) : reflect (exists y, x = y%:C) (x \is Num.real).
Proof.
case: x=> [a b] /=; rewrite complex_real.
by apply: (iffP eqP) => [->|[c []//]]; exists a.
Qed.

Lemma RRe_real (x : R[i]) : x \is Num.real -> (Re x)%:C = x.
Proof. by move=> /complex_realP [y ->]. Qed.

Lemma RIm_real (x : R[i]) : x \is Num.real -> (Im x)%:C = 0.
Proof. by move=> /complex_realP [y ->]. Qed.

End ComplexTheory.

(* Section RcfDef. *)

(* Variable R : realFieldType. *)
(* Notation C := (complex R). *)

(* Definition rcf_odd := forall (p : {poly R}), *)
(*   ~~odd (size p) -> {x | p.[x] = 0}. *)
(* Definition rcf_square := forall x : R, *)
(*   {y | (0 <= y) && if 0 <= x then (y ^ 2 == x) else y == 0}. *)

(* Lemma rcf_odd_sqr_from_ivt : rcf_axiom R -> rcf_odd * rcf_square. *)
(* Proof. *)
(* move=> ivt. *)
(* split. *)
(*   move=> p sp. *)
(*   move: (ivt p). *)
(*   admit. *)
(* move=> x. *)
(* case: (boolP (0 <= x)) (@ivt ('X^2 - x%:P) 0 (1 + x))=> px; last first. *)
(*   by move=> _; exists 0; rewrite lerr eqxx. *)
(* case. *)
(* * by rewrite ler_paddr ?ler01. *)
(* * rewrite !horner_lin oppr_le0 px /=. *)
(*   rewrite subr_ge0 (@ler_trans _ (1 + x)) //. *)
(*     by rewrite ler_paddl ?ler01 ?lerr. *)
(*   by rewrite ler_pemulr // addrC -subr_ge0 ?addrK // subr0 ler_paddl ?ler01. *)
(* * move=> y hy; rewrite /root !horner_lin; move/eqP. *)
(*   move/(canRL (@addrNK _ _)); rewrite add0r=> <-. *)
(* by exists y; case/andP: hy=> -> _; rewrite eqxx. *)
(* Qed. *)

(* Lemma ivt_from_closed : GRing.ClosedField.axiom [ringType of C] -> rcf_axiom R. *)
(* Proof. *)
(* rewrite /GRing.ClosedField.axiom /= => hclosed. *)
(* move=> p a b hab. *)
(* Admitted. *)

(* Lemma closed_form_rcf_odd_sqr : rcf_odd -> rcf_square *)
(*   -> GRing.ClosedField.axiom [ringType of C]. *)
(* Proof. *)
(* Admitted. *)

(* Lemma closed_form_ivt : rcf_axiom R -> GRing.ClosedField.axiom [ringType of C]. *)
(* Proof. *)
(* move/rcf_odd_sqr_from_ivt; case. *)
(* exact: closed_form_rcf_odd_sqr. *)
(* Qed. *)

(* End RcfDef. *)

Section ComplexClosed.

Variable R : rcfType.

Definition sqrtc (x : R[i]) : R[i] :=
  let: a +i* b := x in
  let sgr1 b := if b == 0 then 1 else sgr b in
  let r := sqrtr (a^+2 + b^+2) in
  (sqrtr ((r + a)/2%:R)) +i* (sgr1 b * sqrtr ((r - a)/2%:R)).

Lemma sqr_sqrtc : forall x, (sqrtc x) ^+ 2 = x.
Proof.
have sqr: forall x : R, x ^+ 2 = x * x.
  by move=> x; rewrite exprS expr1.
case=> a b; rewrite exprS expr1; simpc.
have F0: 2%:R != 0 :> R by rewrite pnatr_eq0.
have F1: 0 <= 2%:R^-1 :> R by rewrite invr_ge0 ler0n.
have F2: `|a| <= sqrtr (a^+2 + b^+2).
  rewrite -sqrtr_sqr ler_wsqrtr //.
  by rewrite addrC -subr_ge0 addrK exprn_even_ge0.
have F3: 0 <= (sqrtr (a ^+ 2 + b ^+ 2) - a) / 2%:R.
  rewrite mulr_ge0 // subr_ge0 (ler_trans _ F2) //.
  by rewrite -(maxrN a) ler_maxr lerr.
have F4: 0 <= (sqrtr (a ^+ 2 + b ^+ 2) + a) / 2%:R.
  rewrite mulr_ge0 // -{2}[a]opprK subr_ge0 (ler_trans _ F2) //.
  by rewrite -(maxrN a) ler_maxr lerr orbT.
congr (_ +i* _);  set u := if _ then _ else _.
  rewrite mulrCA !mulrA.
  have->: (u * u) = 1.
    rewrite /u; case: (altP (_ =P _)); rewrite ?mul1r //.
    by rewrite -expr2 sqr_sg => ->.
  rewrite mul1r -!sqr !sqr_sqrtr //.
  rewrite [_+a]addrC -mulrBl opprD addrA addrK.
  by rewrite opprK -mulr2n -mulr_natl [_*a]mulrC mulfK.
rewrite mulrCA -mulrA -mulrDr [sqrtr _ * _]mulrC.
rewrite -mulr2n -sqrtrM // mulrAC !mulrA ?[_ * (_ - _)]mulrC -subr_sqr.
rewrite sqr_sqrtr; last first.
  by rewrite ler_paddr // exprn_even_ge0.
rewrite [_^+2 + _]addrC addrK -mulrA -expr2 sqrtrM ?exprn_even_ge0 //.
rewrite !sqrtr_sqr -mulr_natr.
rewrite [`|_^-1|]ger0_norm // -mulrA [_ * _%:R]mulrC divff //.
rewrite mulr1 /u; case: (_ =P _)=>[->|].
  by rewrite  normr0 mulr0.
by rewrite mulr_sg_norm.
Qed.

Lemma sqrtc_sqrtr :
  forall (x : R[i]), 0 <= x -> sqrtc x = (sqrtr (Re x))%:C.
Proof.
move=> [a b] /andP [/eqP->] /= a_ge0.
rewrite eqxx mul1r [0 ^+ _]exprS mul0r addr0 sqrtr_sqr.
rewrite ger0_norm // subrr mul0r sqrtr0 -mulr2n.
by rewrite -[_*+2]mulr_natr mulfK // pnatr_eq0.
Qed.

Lemma sqrtc0 : sqrtc 0 = 0.
Proof. by rewrite sqrtc_sqrtr ?lerr // sqrtr0. Qed.

Lemma sqrtc1 : sqrtc 1 = 1.
Proof. by rewrite sqrtc_sqrtr ?ler01 // sqrtr1. Qed.

Lemma sqrtN1 : sqrtc (-1) = 'i.
Proof.
rewrite /sqrtc /= oppr0 eqxx [0^+_]exprS mulr0 addr0.
rewrite exprS expr1 mulN1r opprK sqrtr1 subrr mul0r sqrtr0.
by rewrite mul1r -mulr2n divff ?sqrtr1 // pnatr_eq0.
Qed.

Lemma sqrtc_ge0 (x : R[i]) : (0 <= sqrtc x) = (0 <= x).
Proof.
apply/idP/idP=> [psx|px]; last first.
  by rewrite sqrtc_sqrtr // lecR sqrtr_ge0.
by rewrite -[x]sqr_sqrtc exprS expr1 mulr_ge0.
Qed.

Lemma sqrtc_eq0 (x : R[i]) : (sqrtc x == 0) = (x == 0).
Proof.
apply/eqP/eqP=> [eqs|->]; last by rewrite sqrtc0.
by rewrite -[x]sqr_sqrtc eqs exprS mul0r.
Qed.

Lemma normcE x : `|x| = sqrtc (x * x^*%C).
Proof.
case: x=> a b; simpc; rewrite [b * a]mulrC addNr sqrtc_sqrtr //.
by simpc; rewrite /= addr_ge0 ?sqr_ge0.
Qed.

Lemma sqr_normc (x : R[i]) : (`|x| ^+ 2) = x * x^*%C.
Proof. by rewrite normcE sqr_sqrtc. Qed.

Lemma normc_ge_Re (x : R[i]) : `|Re x|%:C <= `|x|.
Proof.
by case: x => a b; simpc; rewrite -sqrtr_sqr ler_wsqrtr // ler_addl sqr_ge0.
Qed.

Lemma normcJ (x : R[i]) :  `|x^*%C| = `|x|.
Proof. by case: x => a b; simpc; rewrite /= sqrrN. Qed.

Lemma invc_norm (x : R[i]) : x^-1 = `|x|^-2 * x^*%C.
Proof.
case: (altP (x =P 0)) => [->|dx]; first by rewrite rmorph0 mulr0 invr0.
apply: (mulIf dx); rewrite mulrC divff // -mulrA [_^*%C * _]mulrC -(sqr_normc x).
by rewrite mulVf // expf_neq0 ?normr_eq0.
Qed.

Lemma canonical_form (a b c : R[i]) :
  a != 0 ->
  let d := b ^+ 2 - 4%:R * a * c in
  let r1 := (- b - sqrtc d) / 2%:R / a in
  let r2 := (- b + sqrtc d) / 2%:R / a in
  a *: 'X^2 + b *: 'X + c%:P = a *: (('X - r1%:P) * ('X - r2%:P)).
Proof.
move=> a_neq0 d r1 r2.
rewrite !(mulrDr, mulrDl, mulNr, mulrN, opprK, scalerDr).
rewrite [_ * _%:P]mulrC !mul_polyC !scalerN !scalerA -!addrA; congr (_ + _).
rewrite addrA; congr (_ + _).
  rewrite -opprD -scalerDl -scaleNr; congr(_ *: _).
  rewrite ![a * _]mulrC !divfK // !mulrDl addrACA !mulNr addNr addr0.
  by rewrite -opprD opprK -mulrDr -mulr2n -mulr_natl divff ?mulr1 ?pnatr_eq0.
symmetry; rewrite -!alg_polyC scalerA; congr (_%:A).
rewrite [a * _]mulrC divfK // /r2 mulrA mulrACA -invfM -natrM -subr_sqr.
rewrite sqr_sqrtc sqrrN /d opprB addrC addrNK -2!mulrA.
by rewrite mulrACA -natf_div // mul1r mulrAC divff ?mul1r.
Qed.

Lemma monic_canonical_form (b c : R[i]) :
  let d := b ^+ 2 - 4%:R * c in
  let r1 := (- b - sqrtc d) / 2%:R in
  let r2 := (- b + sqrtc d) / 2%:R in
  'X^2 + b *: 'X + c%:P = (('X - r1%:P) * ('X - r2%:P)).
Proof.
by rewrite /= -['X^2]scale1r canonical_form ?oner_eq0 // scale1r mulr1 !divr1.
Qed.

Section extramx.
(* missing lemmas from matrix.v or mxalgebra.v *)

Lemma mul_mx_rowfree_eq0 (K : fieldType) (m n p: nat)
                         (W : 'M[K]_(m,n)) (V : 'M[K]_(n,p)) :
  row_free V -> (W *m V == 0) = (W == 0).
Proof. by move=> free; rewrite -!mxrank_eq0 mxrankMfree ?mxrank_eq0. Qed.

Lemma sub_sums_genmxP (F : fieldType) (I : finType) (P : pred I) (m n : nat)
 (A : 'M[F]_(m, n)) (B_ : I -> 'M_(m, n)) :
reflect (exists u_ : I -> 'M_m, A = \sum_(i | P i) u_ i *m B_ i)
  (A <= \sum_(i | P i) <<B_ i>>)%MS.
Proof.
apply: (iffP idP); last first.
  by move=> [u_ ->]; rewrite summx_sub_sums // => i _; rewrite genmxE submxMl.
move=> /sub_sumsmxP [u_ hA].
have Hu i : exists v, u_ i *m  <<B_ i>>%MS = v *m B_ i.
  by apply/submxP; rewrite (submx_trans (submxMl _ _)) ?genmxE.
exists (fun i => projT1 (sig_eqW (Hu i))); rewrite hA.
by apply: eq_bigr => i /= P_i; case: sig_eqW.
Qed.

Lemma mulmxP (K : fieldType) (m n : nat) (A B : 'M[K]_(m, n)) :
  reflect (forall u : 'rV__, u *m A = u *m B) (A == B).
Proof.
apply: (iffP eqP) => [-> //|eqAB].
apply: (@row_full_inj _ _ _ _ 1%:M); first by rewrite row_full_unit unitmx1.
by apply/row_matrixP => i; rewrite !row_mul eqAB.
Qed.

Section Skew.

Variable (K : numFieldType).

Implicit Types (phK : phant K) (n : nat).

Definition skew_vec n i j : 'rV[K]_(n * n) :=
   (mxvec ((delta_mx i j)) - (mxvec (delta_mx j i))).

Definition skew_def phK n : 'M[K]_(n * n) :=
  (\sum_(i | ((i.2 : 'I__) < (i.1 : 'I__))%N) <<skew_vec i.1 i.2>>)%MS.

Variable (n : nat).
Local Notation skew := (@skew_def (Phant K) n).

Lemma skew_direct_sum : mxdirect skew.
Proof.
apply/mxdirect_sumsE => /=; split => [i _|]; first exact: mxdirect_trivial.
apply/mxdirect_sumsP => [] [i j] /= lt_ij; apply/eqP; rewrite -submx0.
apply/rV_subP => v; rewrite sub_capmx => /andP []; rewrite !genmxE.
move=> /submxP [w ->] /sub_sums_genmxP [/= u_].
move/matrixP => /(_ 0 (mxvec_index i j)); rewrite !mxE /= big_ord1.
rewrite /skew_vec /= !mxvec_delta !mxE !eqxx /=.
have /(_ _ _ (_, _) (_, _)) /= eq_mviE :=
  inj_eq (bij_inj (onT_bij (curry_mxvec_bij _ _))).
rewrite eq_mviE xpair_eqE -!val_eqE /= eq_sym andbb.
rewrite ltn_eqF // subr0 mulr1 summxE big1.
  rewrite [w as X in X *m _]mx11_scalar => ->.
  by rewrite mul_scalar_mx scale0r submx0.
move=> [i' j'] /= /andP[lt_j'i'].
rewrite xpair_eqE /= => neq'_ij.
rewrite /= !mxvec_delta !mxE big_ord1 !mxE !eqxx !eq_mviE.
rewrite !xpair_eqE /= [_ == i']eq_sym [_ == j']eq_sym (negPf neq'_ij) /=.
set z := (_ && _); suff /negPf -> : ~~ z by rewrite subrr mulr0.
by apply: contraL lt_j'i' => /andP [/eqP <- /eqP <-]; rewrite ltnNge ltnW.
Qed.
Hint Resolve skew_direct_sum.

Lemma rank_skew : \rank skew = (n * n.-1)./2.
Proof.
rewrite /skew (mxdirectP _) //= -bin2 -triangular_sum big_mkord.
rewrite (eq_bigr (fun _ => 1%N)); last first.
  move=> [i j] /= lt_ij; rewrite genmxE.
  apply/eqP; rewrite eqn_leq rank_leq_row /= lt0n mxrank_eq0.
  rewrite /skew_vec /= !mxvec_delta /= subr_eq0.
  set j1 := mxvec_index _ _.
  apply/negP => /eqP /matrixP /(_ 0 j1) /=; rewrite !mxE eqxx /=.
  have /(_ _ _ (_, _) (_, _)) -> :=
    inj_eq (bij_inj (onT_bij (curry_mxvec_bij _ _))).
  rewrite xpair_eqE -!val_eqE /= eq_sym andbb ltn_eqF //.
  by move/eqP; rewrite oner_eq0.
transitivity (\sum_(i < n) (\sum_(j < n | j < i) 1))%N.
  by rewrite pair_big_dep.
apply: eq_bigr => [] [[|i] Hi] _ /=; first by rewrite big1.
rewrite (eq_bigl _ _ (fun _ => ltnS _ _)).
have [n_eq0|n_gt0] := posnP n; first by move: Hi (Hi); rewrite {1}n_eq0.
rewrite -[n]prednK // big_ord_narrow_leq /=.
  by rewrite -ltnS prednK // (leq_trans _ Hi).
by rewrite sum_nat_const card_ord muln1.
Qed.

Lemma skewP (M : 'rV_(n * n)) :
  reflect ((vec_mx M)^T = - vec_mx M) (M <= skew)%MS.
Proof.
apply: (iffP idP).
  move/sub_sumsmxP => [v ->]; rewrite !linear_sum /=.
  apply: eq_bigr => [] [i j] /= lt_ij; rewrite !mulmx_sum_row !linear_sum /=.
  apply: eq_bigr => k _; rewrite !linearZ /=; congr (_ *: _) => {v}.
  set r := << _ >>%MS; move: (row _ _) (row_sub k r) => v.
  move: @r; rewrite /= genmxE => /sub_rVP [a ->]; rewrite !linearZ /=.
  by rewrite /skew_vec !linearB /= !mxvecK !scalerN opprK addrC !trmx_delta.
move=> skewM; pose M' := vec_mx M.
pose xM i j := (M' i j - M' j i) *: skew_vec i j.
suff -> : M = 2%:R^-1 *:
   (\sum_(i | true && ((i.2 : 'I__) < (i.1 : 'I__))%N) xM i.1 i.2).
  rewrite scalemx_sub // summx_sub_sums // => [] [i j] /= lt_ij.
  by rewrite scalemx_sub // genmxE.
rewrite /xM /= /skew_vec (eq_bigr _ (fun _ _ => scalerBr _ _ _)).
rewrite big_split /= sumrN !(eq_bigr _ (fun _ _ => scalerBl _ _ _)).
rewrite !big_split /= !sumrN opprD ?opprK addrACA [- _ + _]addrC.
rewrite -!sumrN -2!big_split /=.
rewrite /xM /= /skew_vec -!(eq_bigr _ (fun _ _ => scalerBr _ _ _)).
apply: (can_inj vec_mxK); rewrite !(linearZ, linearB, linearD, linear_sum) /=.
have -> /= : vec_mx M = 2%:R^-1 *: (M' - M'^T).
  by rewrite skewM opprK -mulr2n -scaler_nat scalerA mulVf ?pnatr_eq0 ?scale1r.
rewrite {1 2}[M']matrix_sum_delta; congr (_ *: _).
rewrite pair_big /= !linear_sum /= -big_split /=.
rewrite (bigID (fun ij => (ij.2 : 'I__) < (ij.1 : 'I__))%N) /=; congr (_ + _).
  apply: eq_bigr => [] [i j] /= lt_ij.
  by rewrite !linearZ linearB /= ?mxvecK trmx_delta scalerN scalerBr.
rewrite (bigID (fun ij => (ij.1 : 'I__) == (ij.2 : 'I__))%N) /=.
rewrite big1 ?add0r; last first.
  by move=> [i j] /= /andP[_ /eqP ->]; rewrite linearZ /= trmx_delta subrr.
rewrite (@reindex_inj _ _ _ _ (fun ij => (ij.2, ij.1))) /=; last first.
  by move=> [? ?] [? ?] [] -> ->.
apply: eq_big => [] [i j] /=; first by rewrite -leqNgt ltn_neqAle andbC.
by rewrite !linearZ linearB /= ?mxvecK trmx_delta scalerN scalerBr.
Qed.

End Skew.

Notation skew K n := (@skew_def _ (Phant K) n).

Section Companion.

Variable (K : fieldType).

Lemma companion_subproof (p : {poly K}) :
  {M : 'M[K]_((size p).-1)| p \is monic -> char_poly M = p}.
Proof.
have simp := (castmxE, mxE, castmx_id, cast_ord_id).
case Hsp: (size p) => [|sp] /=.
  move/eqP: Hsp; rewrite size_poly_eq0 => /eqP ->.
  by exists 0; rewrite qualifE lead_coef0 eq_sym oner_eq0.
case: sp => [|sp] in Hsp *.
  move: Hsp => /eqP/size_poly1P/sig2_eqW [c c_neq0 ->].
  by exists ((-c)%:M); rewrite monicE lead_coefC => /eqP ->; apply: det_mx00.
have addn1n n : (n + 1 = 1 + n)%N by rewrite addn1.
exists (castmx (erefl _, addn1n _)
       (block_mx (\row_(i < sp) - p`_(sp - i)) (-p`_0)%:M
                 1%:M                        0)).
elim/poly_ind: p sp Hsp (addn1n _) => [|p c IHp] sp; first by rewrite size_poly0.
rewrite size_MXaddC.
have [->|p_neq0] //= := altP eqP; first by rewrite size_poly0; case: ifP.
move=> [Hsp] eq_cast.
rewrite monicE lead_coefDl ?size_polyC ?size_mul ?polyX_eq0 //; last first.
  by rewrite size_polyX addn2 Hsp ltnS (leq_trans (leq_b1 _)).
rewrite lead_coefMX -monicE => p_monic.
rewrite -/_`_0 coefD coefMX coefC eqxx add0r.
case: sp => [|sp] in Hsp p_neq0 p_monic eq_cast *.
  move: Hsp p_monic => /eqP/size_poly1P [l l_neq0 ->].
  rewrite monicE lead_coefC => /eqP ->; rewrite mul1r.
  rewrite /char_poly /char_poly_mx thinmx0 flatmx0 castmx_id.
  set b := (block_mx _ _ _ _); rewrite [map_mx _ b]map_block_mx => {b}.
  rewrite !map_mx0 map_scalar_mx (@opp_block_mx _ 1 0 0 1) !oppr0.
  set b := block_mx _ _ _ _; rewrite (_ : b = c%:P%:M); last first.
    apply/matrixP => i j; rewrite !mxE; case: splitP => k /= Hk; last first.
      by move: (ltn_ord i); rewrite Hk.
    rewrite !ord1 !mxE; case: splitP => {k Hk} k /= Hk; first by move: (ltn_ord k).
    by rewrite ord1 !mxE mulr1n rmorphN opprK.
  by rewrite -rmorphD det_scalar.
rewrite /char_poly /char_poly_mx (expand_det_col _ ord_max).
rewrite big_ord_recr /= big_ord_recl //= big1 ?simp; last first.
  move=> i _; rewrite !simp.
  case: splitP => k /=; first by rewrite /bump leq0n ord1.
  rewrite /bump leq0n => [] [Hik]; rewrite !simp.
  case: splitP => l /=; first by move/eqP; rewrite gtn_eqF.
  rewrite !ord1 addn0 => _ {l}; rewrite !simp -!val_eqE /=.
  by rewrite /bump leq0n ltn_eqF ?ltnS ?add1n // mulr0n subrr mul0r.
case: splitP => i //=; rewrite !ord1 !simp => _ {i}.
case: splitP => i //=; first by move/eqP; rewrite gtn_eqF.
rewrite ord1 !simp => {i}.
case: splitP => i //=; rewrite ?ord1 ?simp // => /esym [eq_i_sp] _.
case: splitP => j //=; first by move/eqP; rewrite gtn_eqF.
rewrite ord1 !simp => {j} _.
rewrite eqxx mulr0n ?mulr1n rmorphN ?opprK !add0r !addr0 subr0 /=.
rewrite -[c%:P in X in _ = X]mulr1 addrC mulrC.
rewrite /cofactor -signr_odd addnn odd_double expr0 mul1r /=.
rewrite !linearB /= -!map_col' -!map_row'.
congr (_ * 'X + c%:P * _).
  have coefE := (coefD, coefMX, coefC, eqxx, add0r, addr0).
  rewrite -[X in _ = X](IHp sp Hsp _ p_monic) /char_poly /char_poly_mx.
   congr (\det (_ - _)).
    apply/matrixP => k l; rewrite !simp -val_eqE /=;
    by rewrite /bump ![(sp < _)%N]ltnNge ?leq_ord.
  apply/matrixP => k l; rewrite !simp.
  case: splitP => k' /=; rewrite ?ord1 /bump ltnNge leq_ord add0n.
    case: splitP => [k'' /= |k'' -> //]; rewrite ord1 !simp => k_eq0 _.
    case: splitP => l' /=; rewrite ?ord1 /bump ltnNge leq_ord add0n !simp;
      last by move/eqP; rewrite ?addn0 ltn_eqF.
    move<-; case: splitP => l'' /=; rewrite ?ord1 ?addn0 !simp.
      by move<-; rewrite subSn ?leq_ord ?coefE.
    move->; rewrite eqxx mulr1n ?coefE subSn ?subrr //=.
    by rewrite !rmorphN ?subnn addr0.
  case: splitP => k'' /=; rewrite ?ord1 => -> // []; rewrite !simp.
  case: splitP => l' /=; rewrite /bump ltnNge leq_ord add0n !simp -?val_eqE /=;
    last by rewrite ord1 addn0 => /eqP; rewrite ltn_eqF.
  by case: splitP => l'' /= -> <- <-; rewrite !simp // ?ord1 ?addn0 ?ltn_eqF.
move=> {IHp Hsp p_neq0 p_monic}; rewrite add0n; set s := _ ^+ _;
apply: (@mulfI _ s); first by rewrite signr_eq0.
rewrite mulrA -expr2 sqrr_sign mulr1 mul1r /s.
pose fix D n : 'M[{poly K}]_n.+1 :=
     if n is n'.+1  then block_mx (-1 :'M_1)   ('X *: pid_mx 1)
                                  0            (D n')           else -1.
pose D' n : 'M[{poly K}]_n.+1 := \matrix_(i, j) ('X *+ (i.+1 == j) - (i == j)%:R).
set M := (_ - _); have -> : M = D' sp.
  apply/matrixP => k l; rewrite !simp.
  case: splitP => k' /=; rewrite ?ord1 !simp // /bump leq0n add1n; case.
  case: splitP => l' /=; rewrite /bump ltnNge leq_ord add0n; last first.
    by move/eqP; rewrite ord1 addn0 ltn_eqF.
  rewrite !simp -!val_eqE /= /bump leq0n ltnNge leq_ord [(true + _)%N]add1n ?add0n.
  by move=> -> ->; rewrite polyC_muln.
have -> n : D' n = D n.
  clear -simp; elim: n => [|n IHn] //=; apply/matrixP => i j; rewrite !simp.
    by rewrite !ord1 /= ?mulr0n sub0r.
  case: splitP => i' /=; rewrite -!val_eqE /= ?ord1 !simp => -> /=.
    case: splitP => j' /=; rewrite ?ord1 !simp => -> /=; first by rewrite sub0r.
    by rewrite eqSS andbT subr0 mulr_natr.
  by case: splitP => j' /=; rewrite ?ord1 -?IHn ?simp => -> //=; rewrite subr0.
elim: sp {eq_cast i M eq_i_sp s} => [|n IHn].
  by rewrite /= (_ : -1 = (-1)%:M) ?det_scalar // rmorphN.
rewrite /= (@det_ublock _ 1 n.+1) IHn.
by rewrite (_ : -1 = (-1)%:M) ?det_scalar // rmorphN.
Qed.

Definition companion (p : {poly K}) : 'M[K]_((size p).-1) :=
  projT1 (companion_subproof p).

Lemma companionK (p : {poly K}) : p \is monic -> char_poly (companion p) = p.
Proof. exact: projT2 (companion_subproof _). Qed.

End Companion.

Section Restriction.

Variable K : fieldType.
Variable m : nat.
Variables (V : 'M[K]_m).

Implicit Types f : 'M[K]_m.

Definition restrict f : 'M_(\rank V) := row_base V *m f *m (pinvmx (row_base V)).

Lemma stable_row_base f :
  (row_base V *m f <= row_base V)%MS = (V *m f <= V)%MS.
Proof.
rewrite eq_row_base.
by apply/idP/idP=> /(submx_trans _) ->; rewrite ?submxMr ?eq_row_base.
Qed.

Lemma eigenspace_restrict f : (V *m f <= V)%MS ->
  forall n a (W : 'M_(n, \rank V)),
  (W <= eigenspace (restrict f) a)%MS =
  (W *m row_base V <= eigenspace f a)%MS.
Proof.
move=> f_stabV n a W; apply/eigenspaceP/eigenspaceP; rewrite scalemxAl.
  by move<-; rewrite -mulmxA -[X in _ = X]mulmxA mulmxKpV ?stable_row_base.
move/(congr1 (mulmx^~ (pinvmx (row_base V)))).
rewrite -2!mulmxA [_ *m (f *m _)]mulmxA => ->.
by apply: (row_free_inj (row_base_free V)); rewrite mulmxKpV ?submxMl.
Qed.

Lemma eigenvalue_restrict  f : (V *m f <= V)%MS ->
  {subset eigenvalue (restrict f) <= eigenvalue f}.
Proof.
move=> f_stabV a /eigenvalueP [x /eigenspaceP]; rewrite eigenspace_restrict //.
move=> /eigenspaceP Hf x_neq0; apply/eigenvalueP.
by exists (x *m row_base V); rewrite ?mul_mx_rowfree_eq0 ?row_base_free.
Qed.

Lemma restrictM : {in [pred f | (V *m f <= V)%MS] &,
                      {morph restrict : f g / f *m g}}.
Proof.
move=> f g; rewrite !inE => Vf Vg /=.
by rewrite /restrict 2!mulmxA mulmxA mulmxKpV ?stable_row_base.
Qed.

End Restriction.

End extramx.
Notation skew K n := (@skew_def _ (Phant K) n).

Section Paper_HarmDerksen.

(* Following    http://www.math.lsa.umich.edu/~hderksen/preprints/linalg.pdf *)
(* quite literally except for Lemma5 where we don't use  hermitian matrices. *)
(* Instead we encode the morphism by hand in 'M[R]_(n * n), which turns  out *)
(* to  be very clumsy for  formalizing commutation and the end  of Lemma  4. *)
(* Moreover, the Qed takes time, so it would be far much better to formalize *)
(* Herm C n and use it instead !                                             *)

Implicit Types (K : fieldType).

Definition CommonEigenVec_def K (phK : phant K) (d r : nat) :=
  forall (m : nat) (V : 'M[K]_m), ~~ (d %| \rank V) ->
  forall (sf :  seq 'M_m), size sf = r ->
  {in sf, forall f, (V *m f <= V)%MS} ->
  {in sf &, forall f g, f *m g = g *m f} ->
  exists2 v : 'rV_m, (v != 0) & forall f, f \in sf ->
  exists a, (v <= eigenspace f a)%MS.
Notation CommonEigenVec K d r := (@CommonEigenVec_def _ (Phant K) d r).

Definition Eigen1Vec_def K (phK : phant K) (d : nat) :=
  forall (m : nat) (V : 'M[K]_m), ~~ (d %| \rank V) ->
  forall (f : 'M_m), (V *m f <= V)%MS -> exists a, eigenvalue f a.
Notation Eigen1Vec K d := (@Eigen1Vec_def _ (Phant K) d).

Lemma Eigen1VecP (K : fieldType) (d : nat) :
  CommonEigenVec K d 1%N <-> Eigen1Vec K d.
Proof.
split=> [Hd m V HV f|Hd m V HV [] // f [] // _ /(_ _ (mem_head _ _))] f_stabV.
  have [] := Hd _ _ HV [::f] (erefl _).
  + by move=> ?; rewrite in_cons orbF => /eqP ->.
  + by move=> ? ?; rewrite /= !in_cons !orbF => /eqP -> /eqP ->.
  move=> v v_neq0 /(_ f (mem_head _ _)) [a /eigenspaceP].
  by exists a; apply/eigenvalueP; exists v.
have [a /eigenvalueP [v /eigenspaceP v_eigen v_neq0]] := Hd _ _ HV _ f_stabV.
by exists v => // ?; rewrite in_cons orbF => /eqP ->; exists a.
Qed.

Lemma Lemma3 K d : Eigen1Vec K d -> forall r, CommonEigenVec K d r.+1.
Proof.
move=> E1V_K_d; elim => [|r IHr m V]; first exact/Eigen1VecP.
move: (\rank V) {-2}V (leqnn (\rank V)) => n {V}.
elim: n m => [|n IHn] m V.
  by rewrite leqn0 => /eqP ->; rewrite dvdn0.
move=> le_rV_Sn HrV [] // f sf /= [] ssf f_sf_stabV f_sf_comm.
have [->|f_neq0] := altP (f =P 0).
  have [||v v_neq0 Hsf] := (IHr _ _ HrV _ ssf).
  + by move=> g f_sf /=; rewrite f_sf_stabV // in_cons f_sf orbT.
  + move=> g h g_sf h_sf /=.
    by apply: f_sf_comm; rewrite !in_cons ?g_sf ?h_sf ?orbT.
  exists v => // g; rewrite in_cons => /orP [/eqP->|]; last exact: Hsf.
  by exists 0; apply/eigenspaceP; rewrite mulmx0 scale0r.
have f_stabV : (V *m f <= V)%MS by rewrite f_sf_stabV ?mem_head.
have sf_stabV : {in sf, forall f, (V *m f <= V)%MS}.
  by move=> g g_sf /=; rewrite f_sf_stabV // in_cons g_sf orbT.
pose f' := restrict V f; pose sf' := map (restrict V) sf.
have [||a a_eigen_f'] := E1V_K_d _ 1%:M _ f'; do ?by rewrite ?mxrank1 ?submx1.
pose W := (eigenspace f' a)%MS; pose Z := (f' - a%:M).
have rWZ : (\rank W + \rank Z)%N = \rank V.
  by rewrite (mxrank_ker (f' - a%:M)) subnK // rank_leq_row.
have f'_stabW : (W *m f' <= W)%MS.
  by rewrite (eigenspaceP (submx_refl _)) scalemx_sub.
have f'_stabZ : (Z *m f' <= Z)%MS.
  rewrite (submx_trans _ (submxMl f' _)) //.
  by rewrite mulmxDl mulmxDr mulmxN mulNmx scalar_mxC.
have sf'_comm : {in [::f' & sf'] &, forall f g, f *m g = g *m f}.
  move=> g' h' /=; rewrite -!map_cons.
  move=> /mapP [g g_s_sf -> {g'}] /mapP [h h_s_sf -> {h'}].
  by rewrite -!restrictM ?inE /= ?f_sf_stabV // f_sf_comm.
have sf'_stabW : {in sf', forall f, (W *m f <= W)%MS}.
  move=> g g_sf /=; apply/eigenspaceP.
  rewrite -mulmxA -[g *m _]sf'_comm ?(mem_head, in_cons, g_sf, orbT) //.
  by rewrite mulmxA scalemxAl (eigenspaceP (submx_refl _)).
have sf'_stabZ : {in sf', forall f, (Z *m f <= Z)%MS}.
  move=> g g_sf /=.
  rewrite mulmxBl sf'_comm ?(mem_head, in_cons, g_sf, orbT) //.
  by rewrite -scalar_mxC -mulmxBr submxMl.
have [eqWV|neqWV] := altP (@eqmxP _ _ _ _ W 1%:M).
  have [] // := IHr _ W _ sf'; do ?by rewrite ?eqWV ?mxrank1 ?size_map.
    move=> g h g_sf' h_sf'; apply: sf'_comm;
    by rewrite in_cons (g_sf', h_sf') orbT.
  move=> v v_neq0 Hv; exists (v *m row_base V).
    by rewrite mul_mx_rowfree_eq0 ?row_base_free.
  move=> g; rewrite in_cons => /orP [/eqP ->|g_sf]; last first.
    have [|b] := Hv (restrict V g); first by rewrite map_f.
    by rewrite eigenspace_restrict // ?sf_stabV //; exists b.
  by exists a; rewrite -eigenspace_restrict // eqWV submx1.
have lt_WV : (\rank W < \rank V)%N.
  rewrite -[X in (_ < X)%N](@mxrank1 K) rank_ltmx //.
  by rewrite ltmxEneq neqWV // submx1.
have ltZV : (\rank Z < \rank V)%N.
  rewrite -[X in (_ < X)%N]rWZ -subn_gt0 addnK lt0n mxrank_eq0 -lt0mx.
  move: a_eigen_f' => /eigenvalueP [v /eigenspaceP] sub_vW v_neq0.
  by rewrite (ltmx_sub_trans _ sub_vW) // lt0mx.
have [] // := IHn _ (if d %| \rank Z then W else Z) _ _ [:: f' & sf'].
+ by rewrite -ltnS (@leq_trans (\rank V)) //; case: ifP.
+ by apply: contra HrV; case: ifP => [*|-> //]; rewrite -rWZ dvdn_add.
+ by rewrite /= size_map ssf.
+ move=> g; rewrite in_cons => /= /orP [/eqP -> {g}|g_sf']; case: ifP => _ //;
  by rewrite (sf'_stabW, sf'_stabZ).
move=> v v_neq0 Hv; exists (v *m row_base V).
  by rewrite mul_mx_rowfree_eq0 ?row_base_free.
move=> g Hg; have [|b] := Hv (restrict V g); first by rewrite -map_cons map_f.
rewrite eigenspace_restrict //; first by exists b.
by move: Hg; rewrite in_cons => /orP [/eqP -> //|/sf_stabV].
Qed.

Lemma Lemma4 r : CommonEigenVec R 2 r.+1.
Proof.
apply: Lemma3=> m V hV f f_stabV.
have [|a] := @odd_poly_root _ (char_poly (restrict V f)).
  by rewrite size_char_poly /= -dvdn2.
rewrite -eigenvalue_root_char => /eigenvalueP [v] /eigenspaceP v_eigen v_neq0.
exists a; apply/eigenvalueP; exists (v *m row_base V).
  by apply/eigenspaceP; rewrite -eigenspace_restrict.
by rewrite mul_mx_rowfree_eq0 ?row_base_free.
Qed.

Notation toC := (real_complex R).
Notation MtoC := (map_mx toC).

Lemma Lemma5 : Eigen1Vec R[i] 2.
Proof.
move=> m V HrV f f_stabV.
suff: exists a, eigenvalue (restrict V f) a.
  by move=> [a /eigenvalue_restrict Hf]; exists a; apply: Hf.
move: (\rank V) (restrict V f) => {f f_stabV V m} n f in HrV *.
pose u := map_mx (@Re R) f; pose v := map_mx (@Im R) f.
have fE : f = MtoC u + 'i%C *: MtoC v.
  rewrite /u /v [f]lock; apply/matrixP => i j; rewrite !mxE /=.
  by case: (locked f i j) => a b; simpc.
move: u v => u v in fE *.
pose L1fun : 'M[R]_n -> _ :=
  2%:R^-1 \*: (mulmxr u       \+ (mulmxr v \o trmx)
           \+ ((mulmx (u^T)) \- (mulmx (v^T) \o trmx))).
pose L1 := lin_mx [linear of L1fun].
pose L2fun : 'M[R]_n -> _ :=
  2%:R^-1 \*: (((@GRing.opp _) \o (mulmxr u \o trmx) \+ mulmxr v)
           \+ ((mulmx (u^T) \o trmx)               \+ (mulmx (v^T)))).
pose L2 := lin_mx [linear of L2fun].
have [] := @Lemma4 _ _ 1%:M _ [::L1; L2] (erefl _).
+ by move: HrV; rewrite mxrank1 !dvdn2 ?negbK odd_mul andbb.
+ by move=> ? _ /=; rewrite submx1.
+ suff {f fE}: L1 *m L2 = L2 *m L1.
    move: L1 L2 => L1 L2 commL1L2 La Lb.
    rewrite !{1}in_cons !{1}in_nil !{1}orbF.
    by move=> /orP [] /eqP -> /orP [] /eqP -> //; symmetry.
  apply/eqP/mulmxP => x; rewrite [X in X = _]mulmxA [X in _ = X]mulmxA.
  rewrite 4!mul_rV_lin !mxvecK /= /L1fun /L2fun /=; congr (mxvec (_ *: _)).
  move=> {L1 L2 L1fun L2fun}.
  case: n {x} (vec_mx x) => [//|n] x in HrV u v *.
  do ?[rewrite -(scalemxAl, scalemxAr, scalerN, scalerDr)
      |rewrite (mulmxN, mulNmx, trmxK, trmx_mul)
      |rewrite  ?[(_ *: _)^T]linearZ ?[(_ + _)^T]linearD ?[(- _)^T]linearN /=].
  congr (_ *: _).
  rewrite !(mulmxDr, mulmxDl, mulNmx, mulmxN, mulmxA, opprD, opprK).
  do ![move: (_ *m _ *m _)] => t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 t11 t12.
  rewrite [X in X + _ + _]addrC [X in X + _ = _]addrACA.
  rewrite [X in _ = (_ + _ + X) + _]addrC [X in _ = X + _]addrACA.
  rewrite [X in _ + (_ + _ + X)]addrC [X in _ + X = _]addrACA.
  rewrite [X in _ = _ + (X + _)]addrC [X in _ = _ + X]addrACA.
  rewrite [X in X = _]addrACA [X in _ = X]addrACA; congr (_ + _).
  by rewrite addrC [X in X + _ = _]addrACA [X in _ + X = _]addrACA.
move=> g g_neq0 Hg; have [] := (Hg L1, Hg L2).
rewrite !(mem_head, in_cons, orbT) => [].
move=> [//|a /eigenspaceP g_eigenL1] [//|b /eigenspaceP g_eigenL2].
rewrite !mul_rV_lin /= /L1fun /L2fun /= in g_eigenL1 g_eigenL2.
do [move=> /(congr1 vec_mx); rewrite mxvecK linearZ /=] in g_eigenL1.
do [move=> /(congr1 vec_mx); rewrite mxvecK linearZ /=] in g_eigenL2.
move=> {L1 L2 L1fun L2fun Hg HrV}.
set vg := vec_mx g in g_eigenL1 g_eigenL2.
exists (a +i* b); apply/eigenvalueP.
pose w := (MtoC vg - 'i%C *: MtoC vg^T).
exists (nz_row w); last first.
  rewrite nz_row_eq0 subr_eq0; apply: contraNneq g_neq0 => Hvg.
  rewrite -vec_mx_eq0; apply/eqP/matrixP => i j; rewrite !mxE /=.
  move: Hvg => /matrixP /(_ i j); rewrite !mxE /=; case.
  by rewrite !(mul0r, mulr0, add0r, mul1r, oppr0) => ->.
apply/eigenspaceP.
case: n f => [|n] f in u v g g_neq0 vg w fE g_eigenL1 g_eigenL2 *.
  by rewrite thinmx0 eqxx in g_neq0.
rewrite (submx_trans (nz_row_sub _)) //; apply/eigenspaceP.
rewrite fE [a +i* b]complexE /=.
rewrite !(mulmxDr, mulmxBl, =^~scalemxAr, =^~scalemxAl) -!map_mxM.
rewrite !(scalerDl, scalerDr, scalerN, =^~scalemxAr, =^~scalemxAl).
rewrite !scalerA /= mulrAC ['i%C * _]sqr_i ?mulN1r scaleN1r scaleNr !opprK.
rewrite [_ * 'i%C]mulrC -!scalerA -!map_mxZ /=.
do 2!rewrite [X in (_ - _) + X]addrC [_ - 'i%C *: _ + _]addrACA.
rewrite ![- _ + _]addrC -!scalerBr -!(rmorphB, rmorphD) /=.
congr (_ + 'i%C *: _); congr map_mx; rewrite -[_ *: _^T]linearZ /=;
rewrite -g_eigenL1 -g_eigenL2 linearZ -(scalerDr, scalerBr);
do ?rewrite ?trmxK ?trmx_mul ?[(_ + _)^T]linearD ?[(- _)^T]linearN /=;
rewrite -[in X in _ *: (_ + X)]addrC 1?opprD 1?opprB ?mulmxN ?mulNmx;
rewrite [X in _ *: X]addrACA.
  rewrite -mulr2n [X in _ *: (_ + X)]addrACA subrr addNr !addr0.
  by rewrite -scaler_nat scalerA mulVf ?pnatr_eq0 // scale1r.
rewrite subrr addr0 addrA addrAC -addrA -mulr2n addrC.
by rewrite -scaler_nat scalerA mulVf ?pnatr_eq0 // scale1r.
Qed.

Lemma Lemma6 k r : CommonEigenVec R[i] (2^k.+1) r.+1.
Proof.
elim: k {-2}k (leqnn k) r => [|k IHk] l.
  by rewrite leqn0 => /eqP ->; apply: Lemma3; apply: Lemma5.
rewrite leq_eqVlt ltnS => /orP [/eqP ->|/IHk //] r {l}.
apply: Lemma3 => m V Hn f f_stabV {r}.
have [dvd2n|Ndvd2n] := boolP (2 %| \rank V); last first.
  exact: @Lemma5 _ _ Ndvd2n _ f_stabV.
suff: exists a, eigenvalue (restrict V f) a.
  by move=> [a /eigenvalue_restrict Hf]; exists a; apply: Hf.
case: (\rank V) (restrict V f) => {f f_stabV V m} [|n] f in Hn dvd2n *.
  by rewrite dvdn0 in Hn.
pose L1 := lin_mx [linear of mulmxr f \+ (mulmx f^T)].
pose L2 := lin_mx [linear of mulmxr f \o mulmx f^T].
have [] /= := IHk _ (leqnn _) _  _ (skew R[i] n.+1) _ [::L1; L2] (erefl _).
+ rewrite rank_skew; apply: contra Hn.
  rewrite -(@dvdn_pmul2r 2) //= -expnSr muln2 -[_.*2]add0n.
  have n_odd : odd n by rewrite dvdn2 /= ?negbK in dvd2n *.
  have {2}<- : odd (n.+1 * n) = 0%N :> nat by rewrite odd_mul /= andNb.
  by rewrite odd_double_half Gauss_dvdl // coprime_pexpl // coprime2n.
+ move=> L; rewrite 2!in_cons in_nil orbF => /orP [] /eqP ->;
  apply/rV_subP => v /submxP [s -> {v}]; rewrite mulmxA; apply/skewP;
  set u := _ *m skew _ _;
  do [have /skewP : (u <= skew R[i] n.+1)%MS by rewrite submxMl];
  rewrite mul_rV_lin /= !mxvecK => skew_u.
    by rewrite opprD linearD /= !trmx_mul skew_u mulmxN mulNmx addrC trmxK.
  by rewrite !trmx_mul trmxK skew_u mulNmx mulmxN mulmxA.
+ suff commL1L2: L1 *m L2 = L2 *m L1.
    move=> La Lb; rewrite !in_cons !in_nil !orbF.
    by move=> /orP [] /eqP -> /orP [] /eqP -> //; symmetry.
  apply/eqP/mulmxP => u; rewrite !mulmxA !mul_rV_lin ?mxvecK /=.
  by rewrite !(mulmxDr, mulmxDl, mulmxA).
move=> v v_neq0 HL1L2; have [] := (HL1L2 L1, HL1L2 L2).
rewrite !(mem_head, in_cons) orbT => [] [] // a vL1 [] // b vL2 {HL1L2}.
move/eigenspaceP in vL1; move/eigenspaceP in vL2.
move: vL2 => /(congr1 vec_mx); rewrite linearZ mul_rV_lin /= mxvecK.
move: vL1 => /(congr1 vec_mx); rewrite linearZ mul_rV_lin /= mxvecK.
move=> /(canRL (addKr _)) ->; rewrite mulmxDl mulNmx => Hv.
pose p := 'X^2 + (- a) *: 'X + b%:P.
have : vec_mx v *m (horner_mx f p) = 0.
  rewrite !(rmorphN, rmorphB, rmorphD, rmorphM) /= linearZ /=.
  rewrite horner_mx_X horner_mx_C !mulmxDr mul_mx_scalar -Hv.
  rewrite addrAC addrA mulmxA addrN add0r.
  by rewrite -scalemxAl -scalemxAr scaleNr addrN.
rewrite [p]monic_canonical_form; move: (_ / 2%:R) (_ / 2%:R).
move=> r2 r1 {Hv p a b L1 L2 Hn}.
rewrite rmorphM !rmorphB /= horner_mx_X !horner_mx_C mulmxA => Hv.
have: exists2 w : 'M_n.+1, w != 0 & exists a, (w <= eigenspace f a)%MS.
  move: Hv; set w := vec_mx _ *m _.
  have [w_eq0 _|w_neq0 r2_eigen] := altP (w =P 0).
    exists (vec_mx v); rewrite ?vec_mx_eq0 //; exists r1.
    apply/eigenspaceP/eqP.
    by rewrite -mul_mx_scalar -subr_eq0 -mulmxBr -/w w_eq0.
  exists w => //; exists r2; apply/eigenspaceP/eqP.
  by rewrite -mul_mx_scalar -subr_eq0 -mulmxBr r2_eigen.
move=> [w w_neq0 [a /(submx_trans (nz_row_sub _)) /eigenspaceP Hw]].
by exists a; apply/eigenvalueP; exists (nz_row w); rewrite ?nz_row_eq0.
Qed.

(* We enunciate a corollary of Theorem 7 *)
Corollary Theorem7' (m : nat) (f : 'M[R[i]]_m) : (0 < m)%N -> exists a, eigenvalue f a.
Proof.
case: m f => // m f _; have /Eigen1VecP := @Lemma6 m 0.
move=> /(_ m.+1 1 _ f) []; last by move=> a; exists a.
+ by rewrite mxrank1 (contra (dvdn_leq _)) // -ltnNge ltn_expl.
+ by rewrite submx1.
Qed.

Lemma complex_acf_axiom : GRing.ClosedField.axiom [ringType of R[i]].
Proof.
move=> n c n_gt0; pose p := 'X^n - \poly_(i < n) c i.
suff [x rpx] : exists x, root p x.
  exists x; move: rpx; rewrite /root /p hornerD hornerN hornerXn subr_eq0.
  by move=> /eqP ->; rewrite horner_poly.
have p_monic : p \is monic.
  rewrite qualifE lead_coefDl ?lead_coefXn //.
  by rewrite size_opp size_polyXn ltnS size_poly.
have sp_gt1 : (size p > 1)%N.
  by rewrite size_addl size_polyXn // size_opp ltnS size_poly.
case: n n_gt0 p => //= n _ p in p_monic sp_gt1 *.
have [] := Theorem7' (companion p); first by rewrite -(subnK sp_gt1) addn2.
by move=> x; rewrite eigenvalue_root_char companionK //; exists x.
Qed.

End Paper_HarmDerksen.

End ComplexClosed.

Definition complex_decFieldMixin (R : rcfType) :=
  closed_fields_QEMixin (@complex_acf_axiom R).
Canonical complex_decField (R : rcfType) :=
  DecFieldType R[i] (complex_decFieldMixin R).
Canonical complex_closedField (R : rcfType) :=
  ClosedFieldType R[i] (@complex_acf_axiom R).

Definition complex_numClosedFieldMixin (R : rcfType):=
  ImaginaryMixin (sqr_i R) (fun x=> esym (sqr_normc x)).

Canonical complex_numClosedFieldType (R : rcfType) :=
  NumClosedFieldType R[i] (complex_numClosedFieldMixin R).

Module ComplexNumArchi.
Section ComplexNumArchi.

Variable R : realClosedArchiFieldType.

Local Notation QtoC := (ratr : rat -> R[i]).
Local Notation QtoCm := [rmorphism of QtoC].
Local Notation pQtoC := (map_poly QtoC).
Local Notation ZtoQ := (intr : int -> rat).
Local Notation ZtoC := (intr : int -> R[i]).
Local Notation Creal := (Num.real : qualifier 0 R[i]).

Lemma complex_archimedean : Num.archimedean_axiom (ComplexField.complex_numDomainType R).
Proof.
move => z.
have R_archi : Num.archimedean_axiom R; first by case:R => ? [].
have normc_norm : (ComplexField.normc z)%:C = `| z |; first by [].
have natR_natmul (p : nat) : p%:R = (1%:R *+ p : R[i]).
  by rewrite /GRing.natmul iteropS /=.
have natC (p : nat) : (p%:R +i* 0 : R[i]) = p%:R.
  by rewrite [X in _ = X]natR_natmul -raddfMn /=.
have natcR (p : nat) : p%:R = (p%:R : R)%:C.
  by rewrite -natC real_complexE.
move: (R_archi (ComplexField.normc z)) => [n n_lt_R].
exists n; rewrite -normc_norm natcR ltcR.
by apply: (ler_lt_trans (ler_norm _) n_lt_R).
Qed.

End ComplexNumArchi.
End ComplexNumArchi.

Canonical complex_numArchiDomain (R : realClosedArchiFieldType) :=
  NumArchiDomainType R[i] (@ComplexNumArchi.complex_archimedean R).
Canonical complex_numArchiField (R : realClosedArchiFieldType) :=
  [numArchiFieldType of R[i]].
Canonical complex_numArchiClosedField (R : realClosedArchiFieldType) :=
  [numArchiClosedFieldType of R[i]].

(* End ComplexInternal. *)

(* Canonical ComplexInternal.complex_eqType. *)
(* Canonical ComplexInternal.complex_choiceType. *)
(* Canonical ComplexInternal.complex_countType. *)
(* Canonical ComplexInternal.complex_ZmodType. *)
(* Canonical ComplexInternal.complex_Ring. *)
(* Canonical ComplexInternal.complex_comRing. *)
(* Canonical ComplexInternal.complex_unitRing. *)
(* Canonical ComplexInternal.complex_comUnitRing. *)
(* Canonical ComplexInternal.complex_iDomain. *)
(* Canonical ComplexInternal.complex_fieldType. *)
(* Canonical ComplexInternal.ComplexField.real_complex_rmorphism. *)
(* Canonical ComplexInternal.ComplexField.real_complex_additive. *)
(* Canonical ComplexInternal.ComplexField.Re_additive. *)
(* Canonical ComplexInternal.ComplexField.Im_additive. *)
(* Canonical ComplexInternal.complex_numDomainType. *)
(* Canonical ComplexInternal.complex_numFieldType. *)
(* Canonical ComplexInternal.conjc_rmorphism. *)
(* Canonical ComplexInternal.conjc_additive. *)
(* Canonical ComplexInternal.complex_decField. *)
(* Canonical ComplexInternal.complex_closedField. *)
(* Canonical ComplexInternal.complex_numClosedFieldType. *)

(* Definition complex_algebraic_trans := ComplexInternal.complex_algebraic_trans. *)

Section ComplexClosedTheory.

Variable R : rcfType.

Lemma complexiE : 'i%C = 'i%R :> R[i].
Proof. by []. Qed.

Lemma complexRe (x : R[i]) : (Re x)%:C = 'Re x.
Proof.
rewrite {1}[x]Crect raddfD /= mulrC ReiNIm rmorphB /=.
by rewrite ?RRe_real ?RIm_real ?Creal_Im ?Creal_Re // subr0.
Qed.

Lemma complexIm (x : R[i]) : (Im x)%:C = 'Im x.
Proof.
rewrite {1}[x]Crect raddfD /= mulrC ImiRe rmorphD /=.
by rewrite ?RRe_real ?RIm_real ?Creal_Im ?Creal_Re // add0r.
Qed.

End ComplexClosedTheory.

Definition complexalg := realalg[i].

Canonical complexalg_eqType := [eqType of complexalg].
Canonical complexalg_choiceType := [choiceType of complexalg].
Canonical complexalg_countype := [choiceType of complexalg].
Canonical complexalg_zmodType := [zmodType of complexalg].
Canonical complexalg_ringType := [ringType of complexalg].
Canonical complexalg_comRingType := [comRingType of complexalg].
Canonical complexalg_unitRingType := [unitRingType of complexalg].
Canonical complexalg_comUnitRingType := [comUnitRingType of complexalg].
Canonical complexalg_idomainType := [idomainType of complexalg].
Canonical complexalg_fieldType := [fieldType of complexalg].
Canonical complexalg_decDieldType := [decFieldType of complexalg].
Canonical complexalg_closedFieldType := [closedFieldType of complexalg].
Canonical complexalg_numDomainType := [numDomainType of complexalg].
Canonical complexalg_numFieldType := [numFieldType of complexalg].
Canonical complexalg_numClosedFieldType := [numClosedFieldType of complexalg].
Canonical complexalg_numArchiDomainType := [numArchiDomainType of complexalg].
Canonical complexalg_numArchiFieldType := [numArchiFieldType of complexalg].
Canonical complexalg_numArchiClosedFieldType := [numArchiClosedFieldType of complexalg].

Lemma complexalg_algebraic : integralRange (@ratr [unitRingType of complexalg]).
Proof.
move=> x; suff [p p_monic] : integralOver (real_complex _ \o realalg_of _) x.
  by rewrite (eq_map_poly (fmorph_eq_rat _)); exists p.
by apply: complex_algebraic_trans; apply: realalg_algebraic.
Qed.


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

Require Import List Arith Lia Wellfounded.

Require Import bt env fun_defs.

Set Implicit Arguments.

Local Notation "e ⇢ x" := (@get_env _ _ e x).
Local Notation "e ⦃  x ⇠ v ⦄" := (@set_env _ _ Var_eq_dec e x v).

Section arith.

  Variables (u x y z : Var) (Hxy : x <> y) (Hxz : x <> z) (Hyz : y <> z) (Hux : u <> x).

  Variable (p_add p_mul p_fact p_size
            p_leb
            : Fun).

  Definition fe_add :=
    MATCH £u WITH
         ø   ⇒ ø
      OR x#z ⇒
      MATCH £x WITH
           ø   ⇒ £z
        OR x#y ⇒ ø#CALL p_add ON (£y#£z).

  Definition fe_mul :=
    MATCH £u WITH
         ø   ⇒ ø
      OR x#z ⇒
      MATCH £x WITH
           ø   ⇒ ø
        OR x#y ⇒ CALL p_add ON (£z#CALL p_mul ON (£y#£z)).

  Definition fe_fact :=
    MATCH £u WITH
         ø   ⇒ ø#ø
      OR x#x ⇒ CALL p_mul ON (£u#CALL p_fact ON £x).

  Definition fe_leb :=
    MATCH £u WITH
         ø   ⇒ ø
      OR u#x ⇒
      MATCH £u WITH
           ø   ⇒ ø#ø
        OR u#u ⇒
        MATCH £x WITH
           ø   ⇒ ø
        OR x#x ⇒ CALL p_leb ON (£u#£x).

  Definition fe_size :=
    MATCH £u WITH
         ø   ⇒ ø#ø
      OR x#y ⇒ ø#CALL p_add ON (CALL p_size ON £x#CALL p_size ON £y).

  Variable (param : Fun -> Var)
           (body : Fun -> fun_expr)

           (Hparam_add : param p_add = u)
           (Hparam_mul : param p_mul = u)
           (Hparam_fact : param p_fact = u)
           (Hparam_leb : param p_leb = u)
           (Hparam_size : param p_size = u)

           (Hbody_add : body p_add = fe_add)
           (Hbody_mul : body p_mul = fe_mul)
           (Hbody_fact : body p_fact = fe_fact)
           (Hbody_leb : body p_leb = fe_leb)
           (Hbody_size : body p_size = fe_size).

  Notation "f // s ~~> v" := (fun_sem param body f s v).

  Fact fe_add_spec f e a b : f // e ~~> ⟨a,b⟩ -> CALL p_add ON f // e ~~> bt_add a b.
  Proof.
    revert f e; induction a as [ | a1 IH1 a2 IH2 ]; intros f e H3; simpl;
      constructor 7 with (1 := H3); rewrite Hbody_add, Hparam_add; unfold fe_add.
    + constructor 5 with ω b.
      1: apply fs_var; rew env.
      constructor 4; apply fs_var; rew env.
    + constructor 5 with ⟨a1,a2⟩ b.
      1: apply fs_var; rew env.
      constructor 5 with a1 a2.
      1: apply fs_var; rew env.
      constructor 3.
      1: constructor 2.
      apply IH2.
      constructor 3; apply fs_var; rew env.
  Qed.

  Fact fe_mul_spec f e a b : f // e ~~> ⟨a,b⟩ -> CALL p_mul ON f // e ~~> bt_mul a b.
  Proof.
    revert f e; induction a as [ | a1 IH1 a2 IH2 ]; intros f e H3; simpl;
      constructor 7 with (1 := H3); rewrite Hbody_mul, Hparam_mul; unfold fe_mul.
    + constructor 5 with ω b.
      1: apply fs_var; rew env.
      constructor 4.
      * apply fs_var; rew env.
      * constructor 2.
    + constructor 5 with ⟨a1,a2⟩ b.
      1: apply fs_var; rew env.
      constructor 5 with a1 a2.
      1: apply fs_var; rew env.
      apply fe_add_spec.
      constructor 3.
      1: apply fs_var; rew env.
      apply IH2.
      constructor 3; apply fs_var; rew env.
  Qed.

  Fact fe_fact_spec f e a : f // e ~~> a -> CALL p_fact ON f // e ~~> bt_fact a.
  Proof.
    revert f e; induction a as [ | v _ a IHa ]; intros f e H;
      constructor 7 with (1 := H); rewrite Hbody_fact, Hparam_fact; unfold fe_fact.
    + constructor 4.
      1: apply fs_var; rew env.
      constructor 3; constructor 2.
    + constructor 5 with v a.
      1: apply fs_var; rew env.
      apply fe_mul_spec; fold bt_fact.
      constructor 3.
      * apply fs_var; rew env.
      * apply IHa, fs_var; rew env.
  Qed.

  Fact fe_leb_spec f e a b : f // e ~~> ⟨a,b⟩ -> CALL p_leb ON f // e ~~> bt_nat_le a b.
  Proof.
    revert f e b; induction a as [ | p _ a IHa ]; intros f e b H;
      constructor 7 with (1 := H); rewrite Hbody_leb, Hparam_leb; unfold fe_leb.
    + constructor 5 with ω b.
      1: apply fs_var; rew env.
      constructor 4.
      1: apply fs_var; rew env.
      constructor 3; constructor 2.
    + constructor 5 with ⟨p,a⟩ b.
      1: apply fs_var; rew env.
      constructor 5 with p a.
      1: apply fs_var; rew env.
      destruct b as [ | q b ].
      * constructor 4.
        1: apply fs_var; rew env.
        constructor 2.
      * constructor 5 with q b.
        1: apply fs_var; rew env.
        apply IHa.
        constructor 3; apply fs_var; rew env.
  Qed.

  Fact fe_size_spec f e t : f // e ~~> t -> CALL p_size ON f // e ~~> bt_size t.
  Proof.
    revert f e; induction t as [ | a IHa b IHb ]; intros f e H; simpl;
      constructor 7 with (1 := H); rewrite Hbody_size, Hparam_size; unfold fe_size.
    + constructor 4.
      1: apply fs_var; rew env.
      constructor 3; constructor 2.
    + constructor 5 with a b.
      1: apply fs_var; rew env.
      constructor 3.
      1: constructor 2.
      apply fe_add_spec.
      constructor 3.
      * apply IHa, fs_var; rew env.
      * apply IHb, fs_var; rew env.
  Qed.

End arith.

Local Notation "f // e ~~> v [ p , b ]" := (fun_sem p b f e v) (at level 70, format "f  //  e  ~~>  v  [ p , b ]", no associativity).

Check fe_add_spec.
Check fe_mul_spec.
Check fe_size_spec.