(* (c) Copyright 2006-2016 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 order ssralg ssrint div ssrnum rat poly closed_field.
From mathcomp
Require Import polyrcf matrix mxalgebra tuple mxpoly zmodp binomial realalg.
From mathcomp Require Import mxpoly.

(**********************************************************************)
(*   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 Order.TTheory 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.

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

Declare Scope complex_scope.
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 (R : ringType) (x : R) : x +i* 0 = x%:C. Proof. by []. Qed.

Module ComplexField.
Section ComplexField_ringType.

Variable R : ringType.
Local Notation C := R[i].
Local Notation C0 := ((0 : 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.

End ComplexField_ringType.

Section ComplexField_comRingType.
Variable R : comRingType.
Local Notation C := R[i].

Definition mulc (x y : C) := 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.

End ComplexField_comRingType.

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

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 R).
Proof. by move=> [a b] /=; rewrite !mul1r !mul0r subr0 addr0. Qed.

Lemma mulc_addl : left_distributive (@mulc R) (@addc R).
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 R) (@mulcC R) mul1c mulc_addl nonzero1c.
Canonical complex_ringType := RingType R[i] complex_comRingMixin.
Canonical complex_comRingType := ComRingType R[i] (@mulcC R).

End ComplexField_fieldType.

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

Section ComplexField_realFieldType.

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

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.

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.

End ComplexField_realFieldType.

Module Normc.
Section Normc.
Variable R : rcfType.
Implicit Types x : R[i].

(*  TODO: when Pythagorean Fields are added, weaken to Pythagorean Field *)
Definition normc x :=
  let: a +i* b := x in sqrtr (a ^+ 2 + b ^+ 2).

Lemma normc0 : normc 0%C = 0 :> R.
Proof. by rewrite /normc /= expr0n/= addr0 sqrtr0. Qed.

Lemma normc1 : normc 1%C = 1 :> R.
Proof. by rewrite /normc /= expr0n/= expr1n addr0 sqrtr1. Qed.

Lemma eq0_normc x : normc x = 0 -> x = 0.
Proof.
case: x => a b /= /eqP; rewrite sqrtr_eq0 le_eqVlt => /orP[|]; last first.
  by rewrite ltNge addr_ge0 ?sqr_ge0.
by rewrite paddr_eq0 ?sqr_ge0 ?expf_eq0 //= => /andP[/eqP -> /eqP ->].
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 normcV x : normc x^-1 = (normc x)^-1.
Proof.
have [->|x0] := eqVneq x 0; first by rewrite ?(invr0,normc0).
have nx0 : normc x != 0 by apply: contra x0 => /eqP/eq0_normc ->.
by apply: (mulfI nx0); rewrite -normcM !divrr ?unitfE// normc1.
Qed.

End Normc.
End Normc.

Section ComplexField.
Variable R : rcfType.
Implicit Types x y : R[i].

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

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 :=
  let: a +i* b := x in let: c +i* d := y in
    (d == b) && (a <= c).

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

Lemma ltc0_add x y : ltc 0 x -> ltc 0 y -> ltc 0 (x + y).
Proof.
move: x y => [a b] [c d] /= /andP [/eqP-> ha] /andP [/eqP-> hc].
by rewrite addr0 eqxx addr_gt0.
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 le_total.
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 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) //= lt_def.
Qed.

Import Normc.

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

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

Lemma normCM x y : normC (x * y) = normC x * normC y.
Proof. by rewrite -rmorphM normcM. 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 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=> /ltW /le_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_porderType := POrderType ring_display R[i] complex_numMixin.
Canonical complex_numDomainType := NumDomainType R[i] complex_numMixin.
Canonical complex_numFieldType := [numFieldType of R[i]].
Canonical complex_normedZmodType :=
  NormedZmodType R[i] R[i] complex_numMixin.

End ComplexField.
End ComplexField.

Canonical ComplexField.complex_zmodType.
(* we do not export the canonical structure of lmodType on purpose *)
(* i.e. no: Canonical ComplexField.complex_lmodType.               *)
(* indeed, this would prevent C fril having a normed module over C *)
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_porderType.
Canonical ComplexField.complex_normedZmodType.
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.
Implicit Types (k : R) (x y z : R[i]).

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

Lemma ImiRe : forall x, 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.

Local Lemma real_complexE_deprecated k : k%:C = k +i* 0 :> R[i]. Proof. done. Qed.
#[deprecated(since="1.1.3", note="Use complexr0 instead.")]
Notation real_complexE := real_complexE_deprecated.

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

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

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

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

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

Lemma lecR : forall k k', (k%:C <= k'%:C) = (k <= k').
Proof. by move=> k k'; simpc. Qed.

Lemma ltcR : forall k k', (k%:C < k'%:C) = (k < k').
Proof. by move=> k k'; 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.

Canonical conjc_rmorphism := RMorphism conjc_is_rmorphism.
Canonical conjc_additive := Additive conjc_is_rmorphism.

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, (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, (x ^* == 0) = (x == 0).
Proof. by move=> [a b]; rewrite !eq_complex /= eqr_oppLR oppr0. Qed.

Lemma conjc_inv: forall x, (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 k : integralOver f (k%: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.
(* FIXME: remove the -?expr2 when requiring MC >= 1.16.0 *)
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 : reflect (exists k, x = k%: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 : x \is Num.real -> (Re x)%:C = x.
Proof. by move=> /complex_realP [y ->]. Qed.

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

End ComplexTheory.

Definition Rcomplex := complex.
Canonical Rcomplex_eqType (R : eqType) := [eqType of Rcomplex R].
Canonical Rcomplex_countType (R : countType) := [countType of Rcomplex R].
Canonical Rcomplex_choiceType (R : choiceType) := [choiceType of Rcomplex R].
Canonical Rcomplex_zmodType (R : rcfType) := [zmodType of Rcomplex R].
Canonical Rcomplex_ringType (R : rcfType) := [ringType of Rcomplex R].
Canonical Rcomplex_comRingType (R : rcfType) := [comRingType of Rcomplex R].
Canonical Rcomplex_unitRingType (R : rcfType) := [unitRingType of Rcomplex R].
Canonical Rcomplex_comUnitRingType (R : rcfType) := [comUnitRingType of Rcomplex R].
Canonical Rcomplex_idomainType (R : rcfType) := [idomainType of Rcomplex R].
Canonical Rcomplex_fieldType (R : rcfType) := [fieldType of Rcomplex R].
Canonical Rcomplex_lmodType (R : rcfType) :=
  LmodType R (Rcomplex R) (ComplexField.complex_lmodMixin R).

Module RComplexLMod.
Section RComplexLMod.
Variable R : rcfType.
Implicit Types (k : R) (x y z : Rcomplex R).
Canonical ComplexField.complex_lmodType.

Lemma conjc_is_scalable : scalable (conjc : Rcomplex R -> Rcomplex R).
Proof. by move=> a [b c]; simpc. Qed.
Canonical conjc_linear := AddLinear conjc_is_scalable.

End RComplexLMod.
End RComplexLMod.
Canonical RComplexLMod.conjc_linear.

(* 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 (le_trans _ F2) //.
  by rewrite -(maxrN a) le_maxr lexx.
have F4: 0 <= (sqrtr (a ^+ 2 + b ^+ 2) + a) / 2%:R.
  rewrite mulr_ge0 // -{2}[a]opprK subr_ge0 (le_trans _ F2) //.
  by rewrite -(maxrN a) le_maxr lexx 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 ?lexx // 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 : core.

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 Restriction.

Variable K : fieldType.
Variable m : nat.
Variable (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 oddM 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 oddM /= 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' (companionmx p); first by rewrite -(subnK sp_gt1) addn2.
by move=> x; rewrite eigenvalue_root_char companionmxK //; exists x.
Qed.

Definition complex_decFieldMixin := closed_field_QEMixin complex_acf_axiom.
Canonical complex_decField := DecFieldType R[i] complex_decFieldMixin.
Canonical complex_closedField := ClosedFieldType R[i] complex_acf_axiom.

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

Canonical complex_numClosedFieldType :=
  NumClosedFieldType R[i] complex_numClosedFieldMixin.

End Paper_HarmDerksen.

End ComplexClosed.

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_porderType := [porderType of complexalg].
Canonical complexalg_numDomainType := [numDomainType of complexalg].
Canonical complexalg_normedZmodType :=
  [normedZmodType complexalg of complexalg].
Canonical complexalg_numFieldType := [numFieldType of complexalg].
Canonical complexalg_numClosedFieldType := [numClosedFieldType 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.


From Hammer Require Import Tactics Reflect Hints.
From Hammer Require Import Hammer.

From mathcomp Require Import ssreflect ssrfun zmodp ssrbool ssrnat ssralg seq fintype finalg tuple eqtype.

From Coq Require Import FunctionalExtensionality.
From Coq Require Import Relation_Definitions RelationClasses.

Require Import CoqArith.Utils.

Require Import Program.

Section Sigma_1_1_Internal.

Inductive PolyTerm : Type :=
| PolyVar : nat -> PolyTerm
| PolyFun : forall (i a : nat), (|[a]| -> PolyTerm) -> PolyTerm
| PolyMinusOne : PolyTerm
| PolyPlusOne : PolyTerm
| PolyZero : PolyTerm
| PolyPlus : PolyTerm -> PolyTerm -> PolyTerm
| PolyTimes : PolyTerm -> PolyTerm -> PolyTerm
| PolyInd : PolyTerm -> PolyTerm -> PolyTerm.

Inductive ZerothOrderFormula : Type :=
| ZONot : ZerothOrderFormula -> ZerothOrderFormula
| ZOAnd : ZerothOrderFormula -> ZerothOrderFormula -> ZerothOrderFormula
| ZOOr : ZerothOrderFormula -> ZerothOrderFormula -> ZerothOrderFormula
| ZOImp : ZerothOrderFormula -> ZerothOrderFormula -> ZerothOrderFormula
| ZOEq : PolyTerm -> PolyTerm -> ZerothOrderFormula.

Inductive QuantifiedFormula : Type :=
| ZO : ZerothOrderFormula
    -> QuantifiedFormula
| QExists : forall (bs : seq (PolyTerm))
                   (y : PolyTerm),
            QuantifiedFormula
         -> QuantifiedFormula
| QForall : PolyTerm
         -> QuantifiedFormula
         -> QuantifiedFormula.

End Sigma_1_1_Internal.

Section Sigma_1_1_Denotation.

Variable (FSize : nat).

Record Sigma11Model : Type :=
  mkSigma11Model {
      V_F : nat -> 'F_FSize;
      F_S : nat -> { a & (|[a]| -> 'F_FSize) -> option 'F_FSize };
  }.

Definition indFun {p} (x y : 'F_p) : 'F_p := if (x < y) then 1%R else 0%R.

Theorem FinFieEq {p} {a b : 'F_p} (e : a == b = true) : a = b.
Proof.
  destruct a, b.
  apply EEConvert in e; simpl in e.
  destruct e.
  by replace i with i0;[|apply eq_irrelevance].
Qed.

Program Fixpoint Poly_Denote (M : Sigma11Model)
  (r : PolyTerm) : option ('F_FSize) :=
  match r with
  | PolyVar m => Some (V_F M m)
  | PolyFun i a t =>
    (if a == projT1 (F_S M i) as b return ((a == projT1 (F_S M i)) = b -> option ('F_FSize))
     then fun _ => (
          let ds := option_fun (fun x => Poly_Denote M (t x)) in
          obind (fun t : |[a]| -> 'F_FSize => projT2 (F_S M i) t) ds)
      else fun _ => None) (erefl _)
  | PolyMinusOne => Some (-1)%R
  | PolyPlusOne => Some 1%R
  | PolyZero => Some 0%R
  | PolyPlus r1 r2 =>
    let d1 := Poly_Denote M r1 in
    let d2 := Poly_Denote M r2 in
    obind (fun r1 => obind (fun r2 => Some (r1 + r2)%R) d2) d1
  | PolyTimes r1 r2 =>
    let d1 := Poly_Denote M r1 in
    let d2 := Poly_Denote M r2 in
    obind (fun r1 => obind (fun r2 => Some (r1 * r2)%R) d2) d1
  | PolyInd r1 r2 =>
    let r1 := Poly_Denote M r1 in
    let r2 := Poly_Denote M r2 in
    obind (fun r1 => obind (fun r2 => Some (indFun r1 r2)) r2) r1
  end.
Next Obligation. apply EEConvert in e; qauto. Qed.

Fixpoint ZerothOrder_Denote (M : Sigma11Model)
  (f : ZerothOrderFormula) : option bool :=
  match f with
  | ZONot f =>
    let d := ZerothOrder_Denote M f in
    obind (fun d => Some (~~ d)) d
  | ZOAnd f1 f2 =>
    let d1 := ZerothOrder_Denote M f1 in
    let d2 := ZerothOrder_Denote M f2 in
    obind (fun r1 => obind (fun r2 => Some (r1 && r2)) d2) d1
  | ZOOr f1 f2 =>
    let d1 := ZerothOrder_Denote M f1 in
    let d2 := ZerothOrder_Denote M f2 in
    obind (fun r1 => obind (fun r2 => Some (r1 || r2)) d2) d1
  | ZOImp f1 f2 =>
    let d1 := ZerothOrder_Denote M f1 in
    let d2 := ZerothOrder_Denote M f2 in
    obind (fun r1 => obind (fun r2 => Some (r1 ==> r2)) d2) d1
  | ZOEq r1 r2 =>
    let d1 := Poly_Denote M r1 in
    let d2 := Poly_Denote M r2 in
    obind (fun r1 => obind (fun r2 => Some (r1 == r2)) d2) d1
  end.

Definition AddModelV (M : Sigma11Model) (r : 'F_FSize) : Sigma11Model :=
  {| V_F := ExtendAt0 r (V_F M); F_S := F_S M |}.

Definition AddModelF  (M : Sigma11Model) (f : { newA & (|[newA]| -> 'F_FSize) -> option ('F_FSize)})  :
  Sigma11Model := {| V_F := V_F M; F_S := ExtendAt0 f (F_S M) |}.

Program Fixpoint FunBounds
  (M : Sigma11Model) {a}
  (ins : |[a]| -> 'F_FSize) (out : 'F_FSize)
  (insB : |[a]| -> PolyTerm) (outB : PolyTerm) : bool :=
  match a with
  | 0 =>
    match Poly_Denote M outB with
    | None => false
    | Some oB => out < oB
    end
  | n.+1 =>
    match Poly_Denote M (insB 0) with
    | None => false
    | Some iB => (ins 0 < iB) && @FunBounds (AddModelV M (ins 0)) n (fun x => ins (x.+1)) out (fun x => insB (x.+1)) outB
    end
  end.

Definition Fun_Bound_Check
  (M : Sigma11Model)
  {n : nat}
  (bs : |[n]| -> PolyTerm)
  (y : PolyTerm)
  (f : (|[n]| -> 'F_FSize) -> option ('F_FSize)) : Prop :=
forall (ins : |[n]| -> 'F_FSize) (out : 'F_FSize),
  f ins == Some out ->
  FunBounds M ins out bs y == true.

Fixpoint QuantifiedFormula_Denote (M : Sigma11Model) (f : QuantifiedFormula) : Prop :=
  match f with
  | ZO z => ZerothOrder_Denote M z == Some true
  | QExists bs y f =>
    exists (F : (|[length bs]| -> 'F_FSize) -> option ('F_FSize)),
    Fun_Bound_Check M (lnth bs) y F /\ QuantifiedFormula_Denote (AddModelF M (existT _ (length bs) F)) f
  | QForall b f =>
    match Poly_Denote M b with
    | None => False
    | Some p' => forall (r : 'F_FSize), r < p' -> QuantifiedFormula_Denote (AddModelV M r) f
    end
  end.

End Sigma_1_1_Denotation.


Require Import FP.Structures.Injection.
Require Import FP.Data.Function.

Import FunctionNotation.

Class MReader (R:Type) (m:Type->Type) : Type :=
  { ask : m R
  ; local : forall {A}, (R -> R) -> m A -> m A
  }.

Section DerivingMReader.
  Variable (n:Type -> Type).
  Context {m} {HFB_:HasFunctorBijection m n} {R} {MReader_:MReader R n}.

  Definition DerivingMReader_ask : m R := ffrom ask.
  Definition DerivingMReader_local {A} (f:R -> R) : m A -> m A :=
    ffrom '.' local f '.' fto.
  Definition DerivingMReader : MReader R m :=
    {| ask := DerivingMReader_ask
     ; local := @DerivingMReader_local
    |}.
End DerivingMReader.


From iris Require Export  algebra.auth algebra.numbers.
From iris Require Import  base_logic.lib.own proofmode.proofmode.

Notation "'●nat' n" := (auth_auth (A:=natUR) (DfracOwn 1%Qp) n%nat) (at level 20).
Notation "'◯nat' n" := (auth_frag (A:=natUR) n%nat) (at level 20).

Section Auth_nat.
  Context `{inG Σ (authR natUR)}.

  Lemma auth_nat_alloc (n : nat) :
    ⊢ |==> ∃ γ, own γ (●nat n) ∗ own γ (◯nat n).
  Proof.
    iMod (own_alloc (●nat n ⋅ ◯nat n)) as (γ) "[? ?]".
    - by apply auth_both_valid_2.
    - by auto with iFrame.
  Qed.

  Lemma own_auth_nat_le (γ : gname) (m n : nat) :
    own γ (●nat m) -∗
    own γ (◯nat n) -∗
    ⌜(n ≤ m)%nat⌝.
  Proof.
    iIntros "H● H◯".
    by iDestruct (own_valid_2 with "H● H◯")
      as % [?%nat_le_sum _] % auth_both_valid.
  Qed.

  Lemma own_auth_nat_weaken (γ : gname) (n₁ n₂ : nat) :
    (n₂ ≤ n₁)%nat →
    own γ (◯nat n₁) -∗
    own γ (◯nat n₂).
  Proof.
    iIntros (I) "H".
    rewrite (_ : n₁ = (n₁ - n₂) + n₂)%nat ; last lia.
    iDestruct "H" as "[_$]".
  Qed.

  Lemma own_auth_nat_zero (γ : gname) :
    ⊢ |==> own γ (◯nat 0).
  Proof.
    apply own_unit.
  Qed.

  Lemma auth_nat_update_incr (γ : gname) (m k : nat) :
    own γ (●nat m) -∗
    |==> own γ (●nat (m + k)) ∗ own γ (◯nat k).
  Proof.
    iIntros "H●".
    rewrite -own_op. iApply (own_update with "H●").
    apply auth_update_alloc, nat_local_update. rewrite right_id. lia.
  Qed.

  Lemma auth_nat_update_decr (γ : gname) (m n k : nat) :
    (k ≤ n)%nat →
    own γ (●nat m) -∗
    own γ (◯nat n) -∗
    |==> own γ (●nat (m - k)) ∗ own γ (◯nat (n - k)).
  Proof.
    iIntros (I) "H● H◯".
    iDestruct (own_auth_nat_le with "H● H◯") as %J.
    rewrite -own_op. iApply (own_update_2 with "H● H◯").
    apply auth_update, nat_local_update. lia.
  Qed.
End Auth_nat.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU Lesser General Public License for more details.                *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(** * Ordered lists and their properties

- Key definitions: [ordered]
- Initial author: Laurent.Thery@inria.fr (2003)

*)

From Coq Require Import Sorting.Permutation.
From Huffman Require Export AuxLib.

Set Default Proof Using "Type".

Section ordered.
Variable A : Type.
Variable order : A -> A -> Prop.
Hypothesis order_trans : forall a b c : A, order a b -> order b c -> order a c.

(** Ordered list with respect to an order *)
Inductive ordered : list A -> Prop :=
  | ordered_nil : ordered []
  | ordered_one : forall a : A, ordered (a :: [])
  | ordered_cons :
      forall (a b : A) (l : list A),
      order a b -> ordered (b :: l) -> ordered (a :: b :: l).
#[local] Hint Constructors ordered : core.

(** Inversion theorem *)
Theorem ordered_inv_order :
 forall (a b : A) (l : list A), ordered (a :: b :: l) -> order a b.
Proof.
intros a b l H; inversion H; auto.
Qed.

(** Inversion theorem *)
Theorem ordered_inv :
 forall (a : A) (l : list A), ordered (a :: l) -> ordered l.
Proof.
intros a l H; inversion H; auto.
Qed.

(** The second element of a list can be skipped *)
Theorem ordered_skip :
 forall (a b : A) (l : list A), ordered (a :: b :: l) -> ordered (a :: l).
Proof using order_trans.
intros a b l; case l; clear l; auto.
intros c l H; apply ordered_cons.
apply order_trans with (b := b); auto.
apply ordered_inv_order with (1 := H).
apply ordered_inv_order with (1 := ordered_inv _ _ H).
apply ordered_inv with (1 := ordered_inv _ _ H).
Qed.

(** All the element of the list are smaller than the first one *)
Theorem ordered_trans :
 forall (a b : A) (l : list A), ordered (a :: l) -> In b l -> order a b.
Proof using order_trans.
intros a b l; generalize a b; elim l; clear l a b.
intros a b H H2; inversion H2.
simpl in |- *; intros c l H a b H0 [H1| H1].
rewrite <- H1; apply ordered_inv_order with (1 := H0).
apply order_trans with (b := c); auto.
apply ordered_inv_order with (1 := H0).
apply H; auto.
apply ordered_inv with (1 := H0).
Qed.

(**
  In an ordered list split in two, elements of the first part
  are always smaller than the ones of the second part
*)
Theorem ordered_trans_app :
 forall (a b : A) (l1 l2 : list A),
 ordered (l1 ++ l2) -> In a l1 -> In b l2 -> order a b.
Proof using order_trans.
intros a b l1 l2; generalize a b; elim l1; simpl in |- *; clear l1 a b.
intros a b H H1; case H1.
intros c l H a b H0 [H1| H1] H2.
rewrite <- H1; apply ordered_trans with (1 := H0); auto with datatypes.
apply H; auto.
apply ordered_inv with (1 := H0); auto.
Qed.

(** If the order is antisymmetric, there is only one ordered list *)
Theorem ordered_perm_antisym_eq :
 (forall a b : A, order a b -> order b a -> a = b) ->
 forall l1 l2 : list A,
 Permutation l1 l2 -> ordered l1 -> ordered l2 -> l1 = l2.
Proof using order_trans.
intros antisym l1; elim l1; clear l1; simpl in |- *; auto.
intros l2 H1 H2 H3; apply sym_equal; apply Permutation_nil; auto.
intros a l1 Rec l2; case l2; simpl in |- *.
intros H; absurd (length (a :: l1) = length (A:=A) []).
simpl in |- *; red in |- *; intros; discriminate.
apply Permutation_length; auto.
intros a0 l H H0 H1.
cut (a = a0).
intros H3; apply f_equal2 with (f := cons (A:=A)); auto.
apply Rec; auto.
apply Permutation_cons_inv with (a := a); auto.
pattern a at 2 in |- *; rewrite H3; auto.
apply ordered_inv with (1 := H0); auto.
apply ordered_inv with (1 := H1); auto.
generalize (Permutation_in a H); simpl in |- *;
 (intros H2; case H2; auto; clear H2; intros H2).
generalize (Permutation_in a0 (Permutation_sym H)); simpl in |- *;
 (intros H3; case H3; auto; clear H3; intros H3).
apply antisym.
apply ordered_trans with (1 := H0); auto.
apply ordered_trans with (1 := H1); auto.
Qed.

End ordered.

#[export] Hint Constructors ordered : core.

Arguments ordered [A].

(** Ordered list are preserved by maps *)
Theorem ordered_map_inv :
 forall (A B : Type) (order : A -> A -> Prop) (g : B -> A) (l : list B),
 ordered (fun x y => order (g x) (g y)) l -> ordered order (map g l).
Proof.
intros A B order g l; elim l; simpl in |- *; auto.
intros a1 l1; case l1; simpl in |- *; auto.
intros b l0 H H0; inversion H0; auto.
Qed.


(***********************************************************************

Copyright (c) 2014 Jonathan Leivent

Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation files (the
"Software"), to deal in the Software without restriction, including
without limitation the rights to use, copy, modify, merge, publish,
distribute, sublicense, and/or sell copies of the Software, and to
permit persons to whom the Software is furnished to do so, subject to
the following conditions:

The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

***********************************************************************)

(***********************************************************************

"Fully" Verified, "Fully" Erased, Red/Black Trees

See README.md for details.

***********************************************************************)

Require Import common.
Typeclasses eauto := 8.

Context {A : Set}.
Context {ordA : Ordered A}.

Notation EL := (## (list A)).

Inductive color : Set :=
| Red : color
| Black : color.

Notation EC := (## color).

(***********************************************************************
OKNode captures allowed relationships between the color of the current
node, its height (all heights are "black" heights - only black nodes
are counted), and the colors and height of its left and right
subtrees.
***********************************************************************)
Inductive OKNode
: forall (c : color)(height : EN)(leftColor :  EC)(rightColor : EC)(childHeight : EN), Prop :=
| OKRed{h}         : OKNode Red       h #Black #Black h
| OKBlack{h cl cr} : OKNode Black (ES h)  cl     cr   h.

Hint Constructors OKNode.

(*Lemmas and hints to enable automatic inversion of OKNodes,
  even in non-Prop contexts.*)
Lemma OKNode1{ho hi cl cr}(ok : OKNode Red ho cl cr hi) : ho=hi/\cl=#Black/\cr=#Black.
Proof. xinv ok. Qed.

Hint Extern 1 =>
match goal with H:OKNode Red _ _ _ _ |- _ => apply OKNode1 in H; simplify_hyps end.

Lemma OKNode2{ho hi cl cr}(ok : OKNode Black ho cl cr hi) : ho=ES hi.
Proof. xinv ok. Qed.

Hint Extern 1 =>
match goal with H:OKNode Black _ _ _ _ |- _ => apply OKNode2 in H; simplify_hyps end.

Lemma OKNode3{ho hi co cr}(ok : OKNode co ho #Red cr hi) : co=Black/\ho=ES hi.
Proof. xinv ok. Qed.

Hint Extern 1 =>
match goal with H:OKNode _ _ #Red _ _ |- _ => apply OKNode3 in H; simplify_hyps end.

Lemma OKNode4{ho hi co cl}(ok : OKNode co ho cl #Red hi) : co=Black/\ho=ES hi.
Proof. xinv ok. Qed.

Hint Extern 1 =>
match goal with H:OKNode _ _ _ #Red _ |- _ => apply OKNode4 in H; simplify_hyps end.

(***********************************************************************
The Red/Black Tree itself, with erasable indices
***********************************************************************)
Inductive rbtree : forall (color : EC)(height : EN)(contents : EL), Set :=
| Leaf : rbtree #Black #0 []
| Node{ho cl cr hi fl fr}
      (co : color)(tl : rbtree cl hi fl)(d : A)(tr : rbtree cr hi fr)
      {ok : OKNode co ho cl cr hi} (*colors and heights correspond properly*)
      {s : Esorted (fl++^d++fr)} (*contents are properly sorted*)
  : rbtree #co ho (fl++^d++fr).

Hint Constructors rbtree.

(************************************************************************)

(*some prettifying tactic notation*)

Tactic Notation
  "Recurse" hyp(t) "=" "Node" ident(co) ident(tl) ident(d) ident(tr) "[" ident(xl) "|" ident(xr) "]"
  := induction t as [ |? ? ? ? ? ? co tl xl d tr xr]; [zauto| ].

Tactic Notation "Compare" hyp(x) hyp(y) := case (compare_spec x y); intros; subst.

Ltac Call x := let Q := fresh in assert (Q:=x); xinv Q.

(************************************************************************)

Section Find.

  Inductive findResult(x : A) : forall (contents : EL), Set :=
  | Found{fl fr} : findResult x (fl++^x++fr)
  | NotFound{f}{ni : ENotIn x f} : findResult x f.

  Hint Constructors findResult.

  Definition find(x : A){c h f}(t : rbtree c h f) : findResult x f.
  Proof.
    Recurse t = Node c tl d tr [GoLeft|GoRight].
    Compare x d.
    - (*x=d*) eauto.
    - (*x<d*) xinv GoLeft. all:zauto.
    - (*x>d*) xinv GoRight. all:zauto.
  Defined.

End Find.

(************************************************************************)

Definition Cof{c h f}(t : rbtree c h f) : {c' : color | c=#c'}.
Proof. destruct t. all:eexists. all:reflexivity. Defined.

Ltac csplit t := case (Cof t); intros [|] ->.

(************************************************************************)

(*Only Esorted and lt props are needed when solving Esorted props - so
convert all rbtree hyps into Esorted hyps prior to solving Esorted
(sorted, when unerased) props. *)

Definition Sof{c h f}(t : rbtree c h f) : Esorted f.
Proof. destruct t. all:unerase. all:eauto. Defined.

Ltac SofAll :=
  repeat match goal with
             H : rbtree _ _ _ |- _ => apply Sof in H
         end.

Ltac solve_esorted := SofAll; unerase; solve_sorted.

Hint Extern 20 (Esorted _) => solve_esorted.

(************************************************************************)

Definition midRedCombine{h cl cr fl fm fr}
           (tl : rbtree cl h fl)(x:A)(tm : rbtree #Red h fm)(y:A)(tr : rbtree cr h fr)
           {s : Esorted (fl++^x++fm++^y++fr)}
: rbtree #Red (ES h) (fl++^x++fm++^y++fr).
Proof.
  xinv tm. intros. zauto.
Defined.

Hint Extern 40 (rbtree _ _ (_++_++_++_++_)) => eapply midRedCombine.

Definition red2black{h f}(t : rbtree #Red h f) : rbtree #Black (ES h) f.
Proof.
  xinv t. intros. eauto.
Defined.

Hint Extern 10 (rbtree ?C _ ?F) =>
  unify C #Black; match goal with T : rbtree #Red _ F |- _ => apply (red2black T) end.

(***********************************************************************
iChanged captures allowed relationships between the colors and heights
of the input and output nodes of insert.  It is a set, but with erased
indices, and so is available to the runtime as an enumeration type,
which reduces the need for insert to inspect nodes to determine
whether rebalancing is necessary.
***********************************************************************)
Inductive iChanged
: forall                   (inC : EC)(inH : EN)(outC : EC)(outH : EN), Set :=
| iSameIndx{c h} : iChanged c         h         c              h
| iReddened{h}   : iChanged #Black    h         #Red           h
| iBlackInc{h}   : iChanged #Red      h         #Black     (ES h).

Hint Constructors iChanged.

Hint Extern 100 (OKNode _ _ _ _ _) =>
match goal with H : (OKNode _ _ _ _ _) |- _ =>  xinv H end.

Section insert_rebalancing.

  Inductive iOut(ci : EC)(hi : EN)(f : EL) : Set :=
  | iout{co ho}(i : iChanged ci hi co ho)(to : rbtree co ho f) : iOut ci hi f.

  Hint Constructors iOut.

  Definition rebalRight{h fl fr cr}
             (tl : rbtree #Black (ES h) fl)(d : A)(tr : rbtree cr h fr)
             {s : Esorted (fl++^d++fr)}
  : iOut #Black (ES h) (fl++^d++fr).
  Proof.
    xinv tl. intros tl0 tr0 ok0 s0.
    csplit tr0.
    - zauto.
    - csplit tl0. all:zauto.
  Defined.

  Definition rebalLeft{h fl fr cl}
             (tl : rbtree cl h fl)(d : A)(tr : rbtree #Black (ES h) fr)
             {s : Esorted (fl++^d++fr)}
  : iOut #Black (ES h) (fl++^d++fr).
  Proof.
    xinv tr. intros tl0 tr0 ok0 s0.
    csplit tl0.
    - zauto.
    - csplit tr0. all:zauto.
  Defined.

End insert_rebalancing.

Section insertion.

  Hint Resolve rebalRight rebalLeft.

  Definition color2change(c : color){h}
  : iChanged #c h #Black (match c with Red => ES h | Black => h end).
  Proof.
    destruct c; eauto.
  Defined.

  Hint Extern 5 (iChanged _ _ _ _) => eapply color2change.

  Inductive insertResult(x : A)
  : forall (inC : EC)(inH : EN)(contents : EL), Set :=
  | FoundByInsert{c h fl fr} : insertResult x c h (fl++^x++fr)
  | Inserted{ci hi co ho fl fr}
          (i : iChanged ci hi co ho)(to : rbtree co ho (fl++^x++fr))
    : insertResult x ci hi (fl++fr).

  Hint Constructors insertResult.

  Definition iout2ins{ci hi fl x fr}(i : iOut ci hi (fl++^x++fr))
  : insertResult x ci hi (fl++fr).
  Proof.
    destruct i. eauto.
  Defined.

  Hint Resolve iout2ins.

  Hint Extern 1 (insertResult _ #Black #0 []) => rewrite <- Eapp_nil_l; eapply Inserted.

  Definition insert(x : A){c h f}(t : rbtree c h f) : insertResult x c h f.
  Proof.
    Recurse t = Node c tl d tr [GoLeft|GoRight].
    Compare x d.
    - (*x=d*) eauto.
    - (*x<d*) xinv GoLeft.
      + zauto.
      + intros i t'. xinv i. all:zauto.
    - (*x>d*) xinv GoRight.
      + zauto.
      + intros i t'. xinv i. all:zauto.
  Defined.

End insertion.

(***********************************************************************
dChanged captures allowed relationships between the colors and heights
of the input and output nodes of delete and delmin.  It is a set, like
iChanged, and reduces the need for delmin and delete to inspect nodes
to determine if rebalancing is necessary.
***********************************************************************)
Inductive dChanged
: forall (inC : EC)(inH : EN)(outC : EC)(outH : EN), Set :=
| stillFits{ci co h} : ci=co \/ ci=#Red \/ co=#Black -> dChanged ci h co h
| rebalance{h}       : dChanged #Black (ES h) #Black h.

Inductive delout (*intermediate result for delmin and delete*)
: forall (inC : EC)(inH : EN)(contents : EL), Set :=
| Delout {co ho f ci hi}
       (dc : dChanged ci hi co ho)(t : rbtree co ho f) : delout ci hi f.

Hint Constructors delout.

Section delete_rebalancing.

  Hint Constructors dChanged.

  Definition dRotateLeft{h fl fr}
             (tl : rbtree #Black h fl)(d : A)(tr : rbtree #Red (ES h) fr)
             {s : Esorted (fl++^d++fr)}
  : rbtree #Black (ES (ES h)) (fl++^d++fr).
  Proof.
    xinv tr. intros tl0 tr0 ok0 s0.
    xinv tl0.
    - eauto.
    - intros tl1 tr1 ok1 s1.
      csplit tl1.
      + zauto.
      + (*zauto alone used to work here, but no longer*)
        rewrite ?Eapp_assoc.
        rewrite group3Eapp.
        zauto.
  Defined.

  Hint Resolve dRotateLeft.

  Definition dRotateRight{h fl fr}
             (tl : rbtree #Red (ES h) fl)(d : A)(tr : rbtree #Black h fr)
             {s : Esorted (fl++^d++fr)}
  : rbtree #Black (ES (ES h)) (fl++^d++fr).
  Proof.
    xinv tl. intros tl0 tr0 ok0 s0.
    xinv tr0.
    - eauto.
    - intros tl1 tr1 ok1 s1.
      csplit tr1. all:zauto.
  Defined.

  Hint Resolve dRotateRight.

  Definition color2dchange(c : color){ho hi}{ok : OKNode c ho # Black # Black hi}
  : dChanged #c ho #Black hi.
  Proof.
    destruct c. all:eauto.
  Defined.

  Hint Resolve color2dchange.

  Definition colorAs(c : color){h f ho}(ok : OKNode c ho # Black # Black h)(t : rbtree # Red h f)
  : rbtree # c ho f.
  Proof.
    destruct c. all:eauto.
  Defined.

  Hint Extern 100 (rbtree _ _ ?F) =>
  match goal with C : color, O : OKNode _ _ #Black #Black _ |- _ => eapply (colorAs C O) end.

  Definition CofOK{h1 c1 h2 c2 c}(ok : OKNode c h1 c1 h2 c2) := c.
  Ltac csplitOK ok := let c := eval compute in (CofOK ok) in destruct c.

  Definition dRebalRight{h fl fr cl co ho}
             (tl : rbtree cl (ES h) fl)(d:A)(tr : rbtree # Black h fr)
             (ok : OKNode co ho cl # Black (ES h)){s : Esorted (fl ++ ^ d ++ fr)}
  : delout # co ho (fl ++ ^ d ++ fr).
  Proof.
    xinv tl. intros tl0 tr0 ok0 s0.
    csplitOK ok0.
    - zauto.
    - csplit tr0. all:zauto.
  Defined.

  Definition dRebalLeft{h fl fr cr co ho}
             (tl : rbtree # Black h fl)(d:A)(tr : rbtree cr (ES h) fr)
             (ok : OKNode co ho # Black cr (ES h)){s : Esorted (fl ++ ^ d ++ fr)}
  : delout # co ho (fl ++ ^ d ++ fr).
  Proof.
    xinv tr. intros tl0 tr0 ok0 s0.
    csplitOK ok0.
    - zauto.
    - csplit tl0. all:zauto.
  Defined.

  Hint Resolve dRebalRight dRebalLeft.

  Definition dFitLeft{fl cr hi fr co ho cl}
             (dr : delout cl hi fl)(d : A)(tr : rbtree cr hi fr)
             (ok : OKNode co ho cl cr hi){s : Esorted (fl ++ ^ d ++ fr)}
  : delout # co ho (fl ++ ^ d ++ fr).
  Proof.
    xinv dr. intros dc t'. xinv dc. all:zauto.
  Defined.

  Definition dFitRight{cl hi fl fr co ho cr}
             (tl : rbtree cl hi fl)(d : A)(dr : delout cr hi fr)
             (ok : OKNode co ho cl cr hi){s : Esorted (fl ++ ^ d ++ fr)}
  : delout # co ho (fl ++ ^ d ++ fr).
  Proof.
    xinv dr. intros dc t'. xinv dc. all:zauto.
  Defined.

  Definition colorFit{ci hi f co ho}(t : rbtree ci hi f)(ok : OKNode co ho # Black ci hi)
  : delout # co ho f.
  Proof.
    csplit t. all:eauto.
  Defined.

End delete_rebalancing.

Section deletion.

  Hint Resolve colorFit dFitLeft dFitRight.

  Inductive delminResult
  : forall (inC : EC)(inH : EN)(contents : EL), Set :=
  | NoMin : delminResult #Black #0 []
  | MinDeleted{ci hi f}
              (m : A)(dr : delout ci hi f) : delminResult ci hi (^m++f).

  Hint Constructors delminResult.

  Definition delmin{c h f}(t : rbtree c h f) : delminResult c h f.
  Proof.
    Recurse t = Node c tl d tr [GoLeft|GoRight].
    xinv GoLeft. all:zauto.
  Defined.

  Inductive deleteResult(x : A)(ci : EC)(hi : EN)
  : forall (contents : EL), Set :=
  | DelNotFound{f}{ni : ENotIn x f} : deleteResult x ci hi f
  | Deleted{fl fr}
           (r : delout ci hi (fl++fr)) : deleteResult x ci hi (fl++^x++fr).

  Hint Constructors deleteResult.

  Definition delete(x : A){c h f}(t : rbtree c h f) : deleteResult x c h f.
  Proof.
    Recurse t = Node c tl d tr [GoLeft|GoRight].
    Compare x d.
    - (*x=d*) Call (delmin tr). all:eauto.
    - (*x<d*) xinv GoLeft. all:zauto.
    - (*x>d*) xinv GoRight. all:zauto.
  Defined.

End deletion.

(*The fully erased generated code:*)
Extraction Language Ocaml.
Set Printing Width 132.
Extract Inductive delout => "( * )" [ "(,)" ].
Extract Inductive iOut => "( * )" [ "(,)" ].
Extraction Inline iout2ins.
Extraction "redblack.ml" insert find delmin delete.


(* * Constructor and Deconstructor Machines for Lists *)

From Undecidability.TM Require Import ProgrammingTools.

Local Arguments plus : simpl never. Local Arguments mult : simpl never.

Set Default Proof Using "Type".

Lemma tl_length (X : Type) (xs : list X) :
  length (tl xs) = pred (length xs).
Proof. destruct xs; cbn; auto. Qed.

Section CaseList.

  (* ** Deconstructor *)

  Variable X : Type.
  Variable (sigX : finType).
  Hypothesis (cX : codable sigX X).

  Set Default Proof Using "Type".

  Definition stop (s: (sigList sigX)^+) :=
    match s with
    | inr (sigList_cons) => true
    | inr (sigList_nil) => true
    | inl _ => true
    | _ => false
    end.

  Definition Skip_cons : pTM (sigList sigX)^+ unit 1 :=
    Move Rmove;;
    MoveToSymbol stop id.

  Definition M1 : pTM (sigList sigX)^+ unit 2 :=
    LiftTapes Skip_cons [|Fin0|];;
    LiftTapes (Write (inl STOP)) [|Fin1|];;
    MovePar Lmove Lmove;;
    CopySymbols_L stop;;
    LiftTapes (Write (inl START)) [|Fin1|].

  Definition CaseList : pTM (sigList sigX)^+ bool 2 :=
    LiftTapes (Move Rmove) [|Fin0|];;
    Switch (LiftTapes (ReadChar) [|Fin0|])
          (fun s => match s with
                 | Some (inr sigList_nil) => (* nil *)
                   Return (LiftTapes (Move Lmove) [|Fin0|]) false
                 | Some (inr sigList_cons) => (* cons *)
                   M1;;
                   LiftTapes Skip_cons [|Fin0|];;
                   Return (LiftTapes (Move Lmove;; Write (inl START)) [|Fin0|]) true
                 | _ => Return Nop default (* invalid input *)
                 end).

  (* *** Corectness *)

  Definition Skip_cons_Rel : pRel (sigList sigX)^+ unit 1 :=
    Mk_R_p (
        ignoreParam (
            fun tin tout =>
              forall ls rs (x : X) (l : list X),
                tin = midtape (inl START :: ls) (inr sigList_cons)
                              (map inr (Encode_map _ _ x) ++ map inr (Encode_map _ _ l) ++ inl STOP :: rs) ->
                match l with
                | nil =>
                  tout = midtape (rev (map inr (Encode_map _ _ x)) ++ inr sigList_cons :: inl START :: ls)
                                 (inr sigList_nil) (inl STOP :: rs)
                | x'::l' =>
                  tout = midtape (rev (map inr (Encode_map _ _ x)) ++ inr sigList_cons :: inl START :: ls)
                                 (inr sigList_cons) (map inr (Encode_map _ _ x') ++ map inr (Encode_map _ _ l') ++ inl STOP :: rs)
                end)).

  Lemma stop_lemma x :
    forall s : (sigList sigX)^+, s el map inr (map sigList_X (encode x)) -> stop s = false.
  Proof.
    rewrite List.map_map. intros ? (?&<-&?) % in_map_iff. cbn. reflexivity.
  Qed.

  Lemma Skip_cons_Realise : Skip_cons ⊨ Skip_cons_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold Skip_cons. TM_Correct. }
    {
      intros tin ((), tout) H. intros ls rs x l HTin. TMSimp. clear_trivial_eqs.
      destruct l as [ | x' l']; cbn.
      - rewrite MoveToSymbol_correct_moveright; cbn; auto.
        + now rewrite map_id.
        + apply stop_lemma.
      - rewrite MoveToSymbol_correct_moveright; cbn; auto.
        + now rewrite map_map, map_id, map_app, <- app_assoc, !map_map.
        + apply stop_lemma.
    }
  Qed.

  Definition M1_Rel : pRel (sigList sigX)^+ unit 2 :=
    ignoreParam (
        fun tin tout =>
          forall ls rs (x : X) (l : list X) (s1 : nat),
            tin[@Fin0] = midtape (inl START :: ls) (inr sigList_cons)
                                 (map inr (Encode_map _ _ x) ++ map inr (Encode_map _ _ l) ++ inl STOP :: rs) ->
            isVoid_size tin[@Fin1] s1 ->
            tout[@Fin0] = tin[@Fin0] /\
            tout[@Fin1] ≃(; s1 - (S (size x))) x).

  Lemma M1_Realise : M1 ⊨ M1_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold M1. TM_Correct. eapply Skip_cons_Realise. }
    {
      intros tin ((), tout) H. intros ls rs x l s HTin0 HRight. TMSimp; clear_trivial_eqs.
      rename H4 into HCopy.
      destruct HRight as (r1&r2&HRight&Hs). TMSimp.

      specialize H with (1 := eq_refl).
      destruct l as [ | x' l']; TMSimp.
      - rewrite CopySymbols_L_correct_moveleft in HCopy; cbn; auto.
        2: setoid_rewrite <- in_rev; apply stop_lemma.
        inv HCopy. TMSimp.
        cbn. rewrite !rev_involutive. repeat econstructor. cbn. f_equal. simpl_tape. reflexivity.
        + simpl_list. rewrite skipn_length. simpl_tape. unfold size. rewrite tl_length. lia.
      - rewrite CopySymbols_L_correct_moveleft in HCopy; cbn; auto.
        2: setoid_rewrite <- in_rev; apply stop_lemma.
        inv HCopy. TMSimp.
        cbn. rewrite !rev_involutive. repeat econstructor.
        + f_equal. cbn. rewrite !map_map, map_app, <- app_assoc, map_map. reflexivity.
        + cbn. f_equal. simpl_tape. reflexivity.
        + simpl_list. rewrite skipn_length. simpl_tape. unfold size. rewrite tl_length. lia.
    }
  Qed.

  Definition CaseList_size0 {sigX X : Type} {cX : codable sigX X} (x : X) (s0 : nat) := S (s0 + size x).
  Definition CaseList_size1 {sigX X : Type} {cX : codable sigX X} (x : X) (s1 : nat) := s1 - (S (size x)).

  Definition CaseList_Rel : pRel (sigList sigX)^+ bool 2 :=
    fun tin '(yout, tout) =>
      forall (l : list X) (s0 s1 : nat),
        tin[@Fin0] ≃(;s0) l ->
        isVoid_size tin[@Fin1] s1 ->
        match yout, l with
        | false, nil =>
          tout[@Fin0] ≃(;s0) @nil X /\
          isVoid_size tout[@Fin1] s1
        | true, x :: l' =>
          tout[@Fin0] ≃(; CaseList_size0 x s0) l' /\
          tout[@Fin1] ≃(; CaseList_size1 x s1) x
        | _, _ => False
        end.

  Lemma CaseList_Realise : CaseList ⊨ CaseList_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold CaseList. TM_Correct. eapply M1_Realise. eapply Skip_cons_Realise. }
    {
      intros tin (yout, tout) H. intros l s0 s1 HEncL HRight.
      unfold CaseList_size0, CaseList_size1 in *.
      destruct HEncL as (ls&HEncL&Hs0). pose proof HRight as (ls'&rs'&HRight'&Hs1). TMSimp; clear_trivial_eqs.
      destruct l as [ | x l'] in *; cbn in *; TMSimp; clear_trivial_eqs.
      { (* nil *)
        split; auto.
        - repeat econstructor; cbn; simpl_tape. auto.
      }
      { (* cons *)
        rewrite !map_map, map_app, <- app_assoc in *.
        setoid_rewrite map_map in H. setoid_rewrite map_map in H0.
        specialize H with (1 := eq_refl) (2 := HRight).
        TMSimp. specialize H0 with (1 := eq_refl).
        destruct l' as [ | x' l'']; TMSimp.
        - repeat split; auto. hnf. eexists. split. simpl_tape. f_equal.
          + rewrite tl_length. simpl_list. cbn. unfold size. lia.
        - repeat split; auto. hnf. eexists. simpl_tape. rewrite List.map_map. cbn. simpl_list. split.
          + f_equal. f_equal. now rewrite !map_map.
          + rewrite tl_length. simpl_list. cbn. unfold size. lia.
      }
    }
  Qed.

  (* *** Termination *)

  Lemma Skip_cons_Terminates :
    projT1 (Skip_cons) ↓
           (fun tin k =>
              exists ls rs (x : X) (l : list X),
                tin[@Fin0] = midtape (inl START :: ls) (inr sigList_cons)
                                     (map inr (Encode_map _ _ x) ++ map inr (Encode_map _ _ l) ++ inl STOP :: rs) /\
                 6 + 4 *size x <= k).
  Proof.
    eapply TerminatesIn_monotone.
    { unfold Skip_cons. TM_Correct. }
    {
      intros tin k (ls&rs&x&l&HTin&Hk). TMSimp.
      exists 1, (4 + 4 *size x). repeat split. 1-2: lia.
      intros tmid () H. TMSimp.
      destruct l as [ | x' l]; cbn.
      - rewrite MoveToSymbol_steps_moveright; cbn; auto. now rewrite !map_length.
      - rewrite MoveToSymbol_steps_moveright; cbn; auto. now rewrite !map_length.
    }
  Qed.

  Lemma M1_Terminates :
    projT1 M1 ↓
           (fun tin k =>
              exists ls rs (x : X) (l : list X),
                tin[@Fin0] = midtape (inl START :: ls) (inr sigList_cons)
                                     (map inr (Encode_map _ _ x) ++ map inr (Encode_map _ _ l) ++ inl STOP :: rs) /\
                 23 + 12 *size x <= k).
  Proof.
    eapply TerminatesIn_monotone.
    { unfold M1. TM_Correct. eapply Skip_cons_Realise. eapply Skip_cons_Terminates. }
    {
      intros tin k (ls&rs&x&l&HTin&Hk). TMSimp.
      exists (6 + 4 *size x), (16 + 8 *size x). repeat split; try lia. eauto 6.
      intros tmid_ (). intros (H&HInj); TMSimp. specialize H with (1 := eq_refl).
      destruct l as [ | x' l']; TMSimp. (* Both cases are identical *)
      1-2: exists 1, (14 + 8 *size x); repeat split; try lia.
      - intros tmid2 (). intros (_&HInj2); TMSimp.
        exists 3, (10 + 8 *size x). repeat split; try lia.
        intros tmid3 (). intros (H3&H3'); TMSimp.
        exists (8+8*size cX x), 1. repeat split; cbn; try lia.
        + rewrite CopySymbols_L_steps_moveleft; auto.
          now rewrite rev_length, !map_length.
      - intros tmid2 (). intros (_&HInj2); TMSimp.
        exists 3, (10 + 8 *size x). repeat split; try lia.
        intros tmid3 (). intros (H3&H3'); TMSimp.
        exists (8+8*size cX x), 1. repeat split; cbn; try lia.
        + rewrite CopySymbols_L_steps_moveleft; auto.
          now rewrite rev_length, !map_length.
    }
  Qed.

  Definition CaseList_steps_cons {sigX X : Type} {cX : codable sigX X} (x : X) := 42 + 16 *size x.

  Definition CaseList_steps_nil := 5.

  Definition CaseList_steps {sigX X : Type} {cX : codable sigX X} (l:list X) :=
    match l with
    | nil => CaseList_steps_nil
    | x::l' => CaseList_steps_cons x
    end.

  Lemma CaseList_Terminates :
    projT1 CaseList ↓
           (fun tin k =>
              exists l : list X,
                tin[@Fin0] ≃ l /\
                isVoid tin[@Fin1] /\
                CaseList_steps l <= k).
  Proof.
    unfold CaseList_steps, CaseList_steps_cons, CaseList_steps_nil. eapply TerminatesIn_monotone.
    { unfold CaseList. TM_Correct.
      - eapply M1_Realise.
      - eapply M1_Terminates.
      - eapply Skip_cons_Realise.
      - eapply Skip_cons_Terminates.
    }
    {
      cbn. intros tin k (l&HEncL&HRight&Hk).
      destruct HEncL as (ls&HEncL); TMSimp.
      destruct l as [ | x l']; cbn.
      {
        exists 1, 3. repeat split; try lia.
        intros tmid (). intros (H1&HInj1); TMSimp.
        exists 1, 1. repeat split; try lia.
        intros tmid2 ymid2 ((H2&H2')&HInj2). apply Vector.cons_inj in H2' as (H2'&_). TMSimp.
        lia.
      }
      {
        exists 1, (40 + 16 *size x). repeat split; try lia.
        intros tmid (). intros (H1&HInj1); TMSimp.
        exists 1, (38 + 16 *size x). repeat split; try lia.
        intros tmid2 ymid2 ((H2&H2')&HInj2). apply Vector.cons_inj in H2' as (H2'&_). TMSimp.
        exists (23 + 12 *size x), (14 + 4 *size x). repeat split; try lia.
        { TMSimp_goal. rewrite !map_map, List.map_app, <- app_assoc, !map_map. do 4 eexists; eauto. split.
          - f_equal. now rewrite !map_map.
          - lia.
        }
        intros tmid3 () H3'.
        rewrite !map_map, map_app, <- app_assoc in H3'.
        setoid_rewrite map_map in H3'.
        specialize H3' with (1 := eq_refl) (2 := isVoid_isVoid_size HRight). TMSimp.
        exists (6 + 4 *size x), 3. repeat split; try lia.
        { do 4 eexists; repeat split; eauto. now rewrite !map_map. }
        intros tmid4 () (H4&HInj4); TMSimp.
        setoid_rewrite map_map in H4.
        specialize H4 with (1 := eq_refl).
        destruct l' as [ | x' l'']; TMSimp. (* both cases are equal *)
        - exists 1, 1. repeat split; try lia.
        - exists 1, 1. repeat split; try lia.
      }
    }
  Qed.

  (* ** [IsNil] *)

  Definition IsNil : pTM (sigList sigX)^+ bool 1 :=
    Move Rmove;;
    Switch ReadChar
    (fun s =>
       match s with
       | Some (inr sigList_nil) =>
         Return (Move Lmove) true
       | _ => Return (Move Lmove) false
       end).

  Definition IsNil_Rel : pRel (sigList sigX)^+ bool 1 :=
    Mk_R_p (
        fun tin '(yout, tout) =>
          forall (xs : list X) (s : nat),
            tin ≃(;s) xs ->
            match yout, xs with
            | true, nil => tout ≃(;s) xs
            | false, _ :: _ => tout ≃(;s) xs
            | _, _ => False
            end).

  Definition IsNil_steps := 5.

  Lemma IsNil_Sem : IsNil ⊨c(IsNil_steps) IsNil_Rel.
  Proof.
    unfold IsNil_steps. eapply RealiseIn_monotone.
    { unfold IsNil. TM_Correct. }
    { Unshelve. 4-11: reflexivity. lia. }
    {
      intros tin (yout, tout) H. cbn. intros xs s HEncXs.
      destruct HEncXs as (ls & HEncXs & Hs). TMSimp.
      destruct xs as [ | x xs' ]; TMSimp.
      - now repeat econstructor.
      - now repeat econstructor.
    }
  Qed.

  (* ** Constructors *)

  (* *** [nil] *)

  Definition Constr_nil : pTM (sigList sigX)^+ unit 1 := WriteValue (@nil X).

  Goal Constr_nil = WriteMove (inl STOP) Lmove;; WriteMove (inr sigList_nil) Lmove;; Write (inl START).
  Proof. reflexivity. Qed.

  Definition Constr_nil_Rel : pRel (sigList sigX)^+ unit 1 :=
    Mk_R_p (ignoreParam (fun tin tout => forall (s : nat), isVoid_size tin s -> tout ≃(; pred s) @nil X)).

  Definition Constr_nil_steps := 5.

  Lemma Constr_nil_Sem : Constr_nil ⊨c(Constr_nil_steps) Constr_nil_Rel.
  Proof.
    unfold Constr_nil_steps. eapply RealiseIn_monotone.
    { unfold Constr_nil. TM_Correct. }
    { reflexivity. }
    { intros tin ((), tout) H. cbn in *. intros s HRight.
      specialize H with (1 := HRight). contains_ext. unfold WriteValue_size. lia. }
  Qed.

  (* *** [cons] *)

  Definition Constr_cons : pTM (sigList sigX)^+ unit 2 :=
    LiftTapes (MoveRight _;; Move Lmove) [|Fin1|];;
    LiftTapes (CopySymbols_L stop) [|Fin1;Fin0|];;
    LiftTapes (WriteMove (inr sigList_cons) Lmove;; Write (inl START)) [|Fin0|].

  Definition Constr_cons_size {sigX X : Type} {cX : codable sigX X} (y : X) (s0 : nat) := s0 - size y - 1.

  Definition Constr_cons_Rel : pRel (sigList sigX)^+ unit 2 :=
    ignoreParam (
        fun tin tout =>
          forall (l:list X) (y:X) (s0 s1 : nat),
            tin[@Fin0] ≃(;s0) l ->
            tin[@Fin1] ≃(;s1) y ->
            tout[@Fin0] ≃(;Constr_cons_size y s0) y :: l /\
            tout[@Fin1] ≃(;s1) y
      ).

  Lemma Constr_cons_Realise : Constr_cons ⊨ Constr_cons_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold Constr_cons. TM_Correct. apply MoveRight_Realise with (X := X). }
    {
      intros tin ((), tout) H. intros l y s0 s HEncL HEncY.
      unfold Constr_cons_size in *.
      TMSimp; clear_trivial_eqs.
      modpon H. destruct H as (ls&H). TMSimp.
      destruct HEncL as (ls2&HEncL&Hs). TMSimp.
      rewrite CopySymbols_L_correct_moveleft in H0; swap 1 2; auto.
      { intros ? (?&<-& (?&<-&?) % in_rev % in_map_iff) % in_map_iff. cbn. reflexivity. }
      inv H0. TMSimp.
      repeat econstructor.
      - cbn. f_equal. simpl_tape. rewrite !map_rev, rev_involutive. f_equal.
        now rewrite !List.map_map, map_app, <- app_assoc, List.map_map.
      - simpl_tape. rewrite tl_length. simpl_list. rewrite skipn_length. unfold size. lia.
      - f_equal. now rewrite !map_rev, rev_involutive.
      - auto.
    }
  Qed.

  Definition Constr_cons_steps {sigX X : Type} {cX : codable sigX X} (x : X) := 23 + 12 * size x.

  Lemma Constr_cons_Terminates :
    projT1 Constr_cons ↓
           (fun tin k =>
              exists (l: list X) (y: X),
                tin[@Fin0] ≃ l /\
                tin[@Fin1] ≃ y /\
                Constr_cons_steps y <= k).
  Proof.
    unfold Constr_cons_steps. eapply TerminatesIn_monotone.
    { unfold Constr_cons. TM_Correct.
      - apply MoveRight_Realise with (X := X).
      - apply MoveRight_Realise with (X := X).
      - apply MoveRight_Terminates with (X := X).
    }
    {
      intros tin k (l&y&HEncL&HEncY&Hk). cbn.
      exists (10 + 4 * size y), (12 + 8 * size y). repeat split; try lia.
      - cbn. exists (8 + 4 * size y), 1. repeat split; try lia.
        + eexists. split. eauto. reflexivity.
      - intros tmid () (H&HInj). TMSimp.
        modpon H. destruct H as (ls&HEncY'). TMSimp.
        exists (8 + 8 * size y), 3. repeat split; try lia.
        + erewrite CopySymbols_L_steps_moveleft; eauto. now rewrite map_length, rev_length, map_length.
        + intros tmid2 (). intros (H2&HInj2). TMSimp.
          exists 1, 1. repeat split; try lia.
    }
  Qed.

End CaseList.

Arguments CaseList    : simpl never.
Arguments IsNil       : simpl never.
Arguments Constr_nil _ {_ _}: simpl never.
Arguments Constr_cons : simpl never.

Arguments CaseList_size0      {sigX X cX} : simpl never.
Arguments CaseList_size1      {sigX X cX} : simpl never.
Arguments Constr_cons_size    {sigX X cX} : simpl never.

Arguments CaseList_steps_cons {sigX X cX} : simpl never.
Arguments CaseList_steps      {sigX X cX} : simpl never.
Arguments Constr_cons_steps   {sigX X cX} : simpl never.
Arguments CaseList_steps_nil              : simpl never.

(*
(* ** Compatibility of running time functions with encoding mapping *)

Section Steps_comp.
  Variable (sig tau: finType) (X:Type) (cX: codable sig X).
  Variable (I : Retract sig tau).

  Lemma CaseList_steps_cons_comp x :
    CaseList_steps_cons (Encode_map cX I) x = CaseList_steps_cons cX x.
  Proof. unfold CaseList_steps_cons. now rewrite Encode_map_hasSize. Qed.

  Lemma CaseList_steps_comp l :
    CaseList_steps (Encode_map cX I) l = CaseList_steps cX l.
  Proof. unfold CaseList_steps. destruct l; auto. apply CaseList_steps_cons_comp. Qed.

  Lemma CaseList_size0_comp x s0 :
    CaseList_size0 (Encode_map cX I) x s0 = CaseList_size0 cX x s0.
  Proof. unfold CaseList_size0. now rewrite Encode_map_hasSize. Qed.

  Lemma CaseList_size1_comp x s1 :
    CaseList_size1 (Encode_map cX I) x s1 = CaseList_size1 cX x s1.
  Proof. unfold CaseList_size1. now rewrite Encode_map_hasSize. Qed.

  Lemma Constr_cons_steps_comp l :
    Constr_cons_steps (Encode_map cX I) l = Constr_cons_steps cX l.
  Proof. unfold Constr_cons_steps. now rewrite Encode_map_hasSize. Qed.

End Steps_comp.
*)

(* ** Tactic Support *)

Ltac smpl_TM_CaseList :=
  once lazymatch goal with
  | [ |- CaseList _ ⊨ _ ] => apply CaseList_Realise
  | [ |- projT1 (CaseList _) ↓ _ ] => apply CaseList_Terminates

  | [ |- IsNil _ ⊨ _ ] => eapply RealiseIn_Realise; apply IsNil_Sem
  | [ |- IsNil _ ⊨c(_) _ ] => apply IsNil_Sem
  | [ |- projT1 (IsNil _ ) ↓ _ ] => eapply RealiseIn_TerminatesIn; apply IsNil_Sem

  | [ |- Constr_nil _ ⊨ _ ] => eapply RealiseIn_Realise; apply Constr_nil_Sem
  | [ |- Constr_nil _ ⊨c(_) _ ] => apply Constr_nil_Sem
  | [ |- projT1 (Constr_nil _) ↓ _ ] => eapply RealiseIn_TerminatesIn; apply Constr_nil_Sem

  | [ |- Constr_cons _ ⊨ _ ] => apply Constr_cons_Realise
  | [ |- projT1 (Constr_cons _) ↓ _ ] => apply Constr_cons_Terminates
  end.

Smpl Add smpl_TM_CaseList : TM_Correct.

From Undecidability.TM.Hoare Require Import HoareLogic HoareRegister HoareTactics.

Section CaseList.

  Variable (X : Type) (sigX : finType) (codX : codable sigX X).

  Definition Constr_cons_sizefun (x : X) : Vector.t (nat->nat) 2 :=
    [|Constr_cons_size x; id|].

  Lemma Constr_cons_SpecT_size (x : X) (xs : list X) (ss : Vector.t nat 2) :
    TripleT
      (≃≃(([], withSpace  [|Contains _ xs; Contains _ x |] ss))) (Constr_cons_steps x) (Constr_cons sigX)
      (fun _ => ≃≃(([], withSpace  [|Contains _ (x::xs); Contains _ x|] (appSize (Constr_cons_sizefun x) ss)))).
  Proof. unfold withSpace.
    eapply Realise_TripleT.
    - apply Constr_cons_Realise.
    - apply Constr_cons_Terminates.
    - intros tin [] tout H HEnc. cbn in *.
      specialize (HEnc Fin0) as HEnc0; specialize (HEnc Fin1) as HEnc1; simpl_vector in *; cbn in *.
      modpon H. tspec_solve.
    - intros tin k HEnc Hk. cbn.
      specialize (HEnc Fin0) as HEnc0; specialize (HEnc Fin1) as HEnc1; simpl_vector in *; cbn in *.
      eauto.
  Qed.

  Lemma Constr_nil_SpecT_size (ss : Vector.t nat 1) :
    TripleT
      (≃≃(([], withSpace  [|Void |] ss))) Constr_nil_steps (Constr_nil X)
      (fun _ => ≃≃(([], withSpace  [|Contains _ (@nil X) |] (appSize [|pred|] ss)))).
  Proof. unfold withSpace.
    eapply RealiseIn_TripleT.
    - apply Constr_nil_Sem.
    - intros tin [] tout H HEnc. cbn in *.
      specialize (HEnc Fin0). simpl_vector in *; cbn in *. modpon H. tspec_solve.
  Qed.

  Definition CaseList_size (xs : list X) : Vector.t (nat->nat) 2 :=
    match xs with
    | nil => [|id;id|]
    | x :: xs => [|CaseList_size0 x; CaseList_size1 x|]
    end.

  Lemma CaseList_SpecT_size (xs : list X) (ss : Vector.t nat 2) :
    TripleT
      (≃≃(([], withSpace  [|Contains _ xs; Void |] ss))) (CaseList_steps xs) (CaseList sigX)
      (fun yout => ≃≃([yout = match xs with [] => false | _ => true end],withSpace
                         (match xs with
                          |   x::xs' => [|Contains _ xs'; Contains _ x|]
                          |    nil => [|Contains _ xs; Void|]
                          end)
                         (appSize (CaseList_size xs) ss))).
  Proof. unfold withSpace.
    eapply Realise_TripleT.
    - apply CaseList_Realise.
    - apply CaseList_Terminates.
    - intros tin yout tout H HEnc. cbn in *.
      specialize (HEnc Fin0) as HEnc0; specialize (HEnc Fin1) as HEnc1; simpl_vector in *; cbn in *.
      modpon H. destruct yout, xs; cbn in *; eauto.
      + destruct H as (H1&H2). tspec_solve. easy.
      + destruct H as (H1&H2). tspec_solve. easy.
    - intros tin k HEnc Hk. cbn.
      specialize (HEnc Fin0) as HEnc0; specialize (HEnc Fin1) as HEnc1; simpl_vector in *; cbn in *.
      eauto.
  Qed.

End CaseList.

Ltac hstep_List :=
  match goal with
  | [ |- TripleT ?P ?k (Constr_cons _) ?Q ] => eapply Constr_cons_SpecT_size
  | [ |- TripleT ?P ?k (Constr_nil  _) ?Q ] => eapply Constr_nil_SpecT_size
  | [ |- TripleT ?P ?k (CaseList    _) ?Q ] => eapply CaseList_SpecT_size
  end.

Smpl Add hstep_List : hstep_Spec.