(* --------------------------------------------------------------------
 * (c) Copyright 2014--2015 INRIA.
 *
 * You may distribute this file under the terms of the CeCILL-B license
 * -------------------------------------------------------------------- *)

Require Import Reals Rtrigo1.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype seq choice.
From mathcomp Require Import fintype algC ssrint ssrnum complex ssralg finfun.
From mathcomp Require Import ssrnat div intdiv mxpoly rat bigop polydiv.
From mathcomp Require Import fieldext poly finset separable polyorder.
From structs Require Import Rstruct.

Import GRing.Theory Num.Def Num.Theory ArchimedeanTheory.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Open Scope ring_scope.

(* Definition des complexes sur les réels de Coq *)

Definition complexR := R[i].

Canonical complexR_eqType := [eqType of complexR].
Canonical complexR_choiceType := [choiceType of complexR].
Canonical complexR_countype := [choiceType of complexR].
Canonical complexR_zmodType := [zmodType of complexR].
Canonical complexR_lmodType := Eval hnf in [lmodType R of complexR].
Canonical complexR_ringType := [ringType of complexR].
Canonical complexR_comRingType := [comRingType of complexR].
Canonical complexR_lalgType := Eval hnf in [lalgType R of complexR].
Canonical complexR_algType := Eval hnf in [algType R of complexR].
Canonical complexR_unitRingType := [unitRingType of complexR].
Canonical complexR_comUnitRingType := [comUnitRingType of complexR].
Canonical complexR_unitAlgType := Eval hnf in [unitAlgType R of complexR].
Canonical complexR_idomainType := [idomainType of complexR].
Canonical complexR_fieldType := [fieldType of complexR].
Canonical complexR_decDieldType := [decFieldType of complexR].
Canonical complexR_closedFieldType := [closedFieldType of complexR].
Canonical complexR_numDomainType := [numDomainType of complexR].
Canonical complexR_numFieldType := [numFieldType of complexR].
Canonical complexR_numClosedFieldType := [numClosedFieldType of complexR].
Canonical complexR_numArchiDomainType := [numArchiDomainType of complexR].
Canonical complexR_numArchiFieldType := [numArchiFieldType of complexR].
Canonical complexR_numArchiClosedFieldType := [numArchiClosedFieldType of complexR].

(*
Canonical complexR_eqType := complex_eqType R_eqType.
(*[eqType of complexR].*)
Canonical complexR_choiceType := complex_choiceType R_choiceType.
(*[choiceType of complexR].*)
Canonical complexR_zmodType := ComplexField.complex_zmodType R_rcfType.
(*[zmodType of complexR].*)
Canonical complexR_lmodType := ComplexField.complex_lmodType R_rcfType.
(*Eval hnf in [lmodType _ of complexR].*)
Canonical complexR_ringType := ComplexField.complex_ringType R_rcfType.
(*[ringType of complexR].*)
Canonical complexR_comRingType := ComplexField.complex_comRingType R_rcfType.
(*[comRingType of complexR].*)
Canonical complexR_lalgType := ComplexField.complex_lalgType R_rcfType.
Canonical complexR_algType := ComplexField.complex_algType R_rcfType.
Canonical complexR_unitRingType := ComplexField.complex_unitRingType R_rcfType.
(*[unitRingType of complexR].*)
Canonical complexR_comUnitRingType := ComplexField.complex_comUnitRingType R_rcfType.
(*[comUnitRingType of complexR].*)
Canonical complexR_unitAlgType := ComplexField.complex_unitAlgType R_rcfType.
Canonical complexR_idomainType := ComplexField.complex_idomainType R_rcfType.
(*[idomainType of complexR].*)
Canonical complexR_fieldType := ComplexField.complex_fieldType R_rcfType.
(*[fieldType of complexR].*)
Canonical complexR_decFieldType := complex_decField R_rcfType.
(*[decFieldType of complexR].*)
Canonical complexR_closedFieldType := complex_closedField R_rcfType.
(*[closedFieldType of complexR].*)
Canonical complexR_numDomainType := ComplexField.complex_numDomainType R_rcfType.
(*[numDomainType of complexR].*)
Canonical complexR_numFieldType := ComplexField.complex_numFieldType R_rcfType.
(*[numFieldType of complexR].*)
Canonical complexR_numClosedFieldType :=
  complex_numClosedFieldType R_realClosedArchiFieldType.
(*[numClosedFieldType of complexR].*)
Canonical complexR_numArchiDomainType :=
  complex_numArchiDomain R_realClosedArchiFieldType.
(*[numArchiDomainType of complexR].*)
Canonical complexR_numArchiFieldType :=
  ComplexField.complex_numDomainType R_realClosedArchiFieldType.
(*[numArchiFieldType of complexR].*)
Canonical complexR_numArchiClosedFieldType :=
  ComplexField.complex_numDomainType R_realClosedArchiFieldType.
(*[numArchiClosedFieldType of complexR].*)
*)

(* Récupération des notations *)

Notation Creal := (@Num.Def.Rreal complexR_numDomainType).
Notation Cint := (@Cint complexR_numArchiDomainType).
Notation Cnat := (@Cnat complexR_numArchiDomainType).

(* Injections *)

Notation QtoC := (ratr : rat -> complexR).
Notation ZtoQ := (intr : int -> rat).

Notation ZtoC := (intr : int -> complexR).

Definition ZtoCE :=
  let CnF := complexR_numFieldType in
  let ZtoCm := intmul1_rmorphism CnF in
  ((rmorph0 ZtoCm, rmorph1 ZtoCm, rmorphMn ZtoCm, rmorphN ZtoCm, rmorphD ZtoCm),
   (rmorphM ZtoCm, rmorphX ZtoCm),
   (rmorphMz ZtoCm, @intr_norm CnF, @intr_sg CnF, @intr_eq0 CnF),
   =^~ (@ler_int CnF, @ltr_int CnF, (inj_eq (@intr_inj CnF)))).

(* retour à R depuis les complexes *)
Notation Re_R := (@complex.Re R_rcfType).
Notation Im_R := (@complex.Im R_rcfType).
Notation norm_R := ComplexField.normc.

Canonical Re_R_additive := [additive of Re_R].
Canonical Re_R_linear := [linear of Re_R].
Canonical Im_R_additive := [additive of Im_R].
Canonical Im_R_linear := [linear of Im_R].

Notation RtoC := (real_complex R : R -> complexR).

Ltac RtoC_simpl :=
  rewrite -?complexRe -?complexIm -?[`| _ |]/(((norm_R _)%:C)%C) -?[((_)%:C)%C]/(RtoC _) /=.

Lemma RtoC_inj : injective RtoC.
Proof. by move => x y /eqP; rewrite /RtoC eq_complex /= eq_refl andbT => /eqP. Qed.

Lemma RtoC_norm x : RtoC `|x| = `|RtoC x|.
Proof.
rewrite normc_def; RtoC_simpl; apply/eqP; rewrite (inj_eq RtoC_inj); apply/eqP.
by rewrite expr0n /= addr0 sqrtr_sqr.
Qed.

Lemma ler_RtoC x y : (RtoC x <= RtoC y) = (x <= y).
Proof. by rewrite -lecR; RtoC_simpl. Qed.

Lemma ltr_RtoC x y : (RtoC x < RtoC y) = (x < y).
Proof. by rewrite -ltcR; RtoC_simpl. Qed.

Definition RtoCE :=
  let CnF := R_rcfType in
  let RtoCm := ComplexField.real_complex_rmorphism CnF in
  ((rmorph0 RtoCm, rmorph1 RtoCm, rmorphMn RtoCm, rmorphN RtoCm, rmorphD RtoCm),
   (rmorphM RtoCm, rmorphX RtoCm),
   (rmorphMz RtoCm, RtoC_norm),
   =^~ (ler_RtoC, ltr_RtoC, (inj_eq RtoC_inj))).

(* tactiques *)
Definition C_simpl :=
  (addr0, add0r, subr0, mulr0, mul0r, mulr1, mul1r, mulr0n, mulrS, expr0, exprS).

(* complex exponential *)

Definition Cexp (z : complexR) : complexR :=
  RtoC (exp(Re_R z)) * (RtoC (cos (Im_R z)) + 'i * RtoC (sin (Im_R z))).

Lemma Cexp_exp x :
  x \in Creal -> Cexp(x) = RtoC (exp(Re_R x)).
Proof.
move=> /Creal_ImP; RtoC_simpl; rewrite /Cexp => /eqP.
rewrite /eqP fmorph_eq0 => /eqP ->; rewrite sin_0 cos_0 /=.
by rewrite !RtoCE !C_simpl.
Qed.

Lemma Cexp0 :
  Cexp(0) = 1.
Proof. by rewrite /Cexp /= sin_0 cos_0 !RtoCE !C_simpl expR0. Qed.

Lemma CexpRD x y :
  Cexp(x) * Cexp(y) = Cexp(GRing.add x y).
Proof.
rewrite /Cexp mulrA [X in X *_ = _]mulrC mulrA -rmorphM /= expRD addrC -mulrA.
rewrite -raddfD /= mulC_rect -!rmorphM -rmorphD -rmorphB /= -cos_add.
by rewrite [X in RtoC( X + _)]mulrC -sin_add -!raddfD [y + x]addrC /=.
Qed.

Lemma Cexp_morph : {morph Cexp : x y / x + y >-> x * y}.
Proof. by move=> x y; rewrite CexpRD. Qed.

Lemma CexpRX x :
  forall n : nat,
    Cexp(x) ^+ n = Cexp(x *+ n).
Proof.
elim => [|n Ihn]; rewrite !C_simpl; first by rewrite Cexp0.
by rewrite Ihn Cexp_morph.
Qed.

Lemma CscaleE (x : R) (y : complexR) :
  x *: y = RtoC x * y.
Proof. by case: y => [yr yi]; rewrite /GRing.scale /= /RtoC; simpc. Qed.

Module ComplexTotalOrder.

Section OrderDef.

Implicit Types x y : complexR.

(* def of total order *)
Definition letc x y :=
    ('Re x < 'Re y) || (('Re x == 'Re y) && ('Im x <= 'Im y)).

Definition lttc x y :=
    (letc x y) && (x != y).

Lemma letcc : reflexive letc.
Proof. by move=> x; rewrite /letc eq_refl lerr andbT orbT. Qed.
Hint Resolve letcc.

Lemma letc_trans : transitive letc.
Proof.
move=> x y z; rewrite /letc => /orP[Ryx | /andP[/eqP <- Iyx]].
  move=> /orP[Rxz | /andP[/eqP <- _]].
  + by apply/orP; left; apply: (ltr_trans Ryx Rxz).
  + by rewrite Ryx.
move=> /orP[Ryz | /andP[/eqP <- Ixz]].
+ by rewrite Ryz.
+ by rewrite eq_refl (ler_trans Iyx Ixz) andbT orbT.
Qed.

Lemma letc_asym : antisymmetric letc.
Proof.
move=> x y /andP[]; rewrite /letc => /orP[Rxy | /andP[/eqP Rxy Ixy /=]].
  move=> /orP[ | /andP[]].
  + by rewrite ltr_gtF.
  + by rewrite (gtr_eqF Rxy).
move=> /orP[ | /andP[/eqP Ryx Iyx]].
+ by rewrite Rxy ltrr.
+ apply/eqP; rewrite eq_C -Ryx eq_refl andTb.
  by apply/eqP; apply: ler_asym; rewrite Ixy Iyx.
Qed.

Lemma lttc_neqAle x y :
  (lttc x y) = (x != y) && (letc x y).
Proof. by rewrite /lttc andbC. Qed.

Lemma letc_eqVlt x y :
  (letc x y) = (x == y) || (lttc x y).
Proof.
rewrite lttc_neqAle.
case: (boolP (x == y)) => [/eqP -> | _ //=].
by rewrite orTb letcc.
Qed.

Lemma lttcNge x y : lttc x y = ~~ (letc y x).
Proof.
rewrite lttc_neqAle eq_C /letc !negb_or !negb_and.
rewrite -real_ltrNge -?real_lerNgt ?ler_eqVlt ?Creal_Re ?Creal_Im //.
have [ | | _] := (real_ltrgtP (Creal_Re x) (Creal_Re y)); rewrite //=.
by have [ | | ] := (real_ltrgtP (Creal_Im x) (Creal_Im y)).
Qed.

Lemma letcNgt x y : letc x y = ~~ (lttc y x).
Proof. by rewrite lttcNge negbK. Qed.

Lemma lttcc x : lttc x x = false.
Proof. by rewrite /lttc eq_refl /= andbF. Qed.

Lemma lttc_trans : transitive lttc.
Proof.
move=> y x z; rewrite /lttc_neqAle => /andP [le_xy _].
rewrite !lttcNge => /negP le_zy; apply/negP => le_zx.
by apply: le_zy; apply: (letc_trans le_zx le_xy).
Qed.

Lemma neq_lttc (x y : R[i]) :
  (x != y) = (lttc x y) || (lttc y x).
Proof.
rewrite !lttcNge -negb_and; congr (~~ _).
apply/idP/idP => [/eqP -> | H_anti].
  by rewrite andbb.
by rewrite eq_sym; apply/eqP; apply: letc_asym.
Qed.

Lemma eqc_letc x y : (x == y) = (letc x y && letc y x).
Proof. by apply/eqP/idP=> [->|/letc_asym]; rewrite ?letcc. Qed.

Lemma letc_total : total letc.
Proof. by move=> x y; rewrite letc_eqVlt lttcNge -orbA orNb orbT. Qed.

Lemma lttc_le_trans y x z : lttc x y -> letc y z -> lttc x z.
Proof.
move=> lt_xy; rewrite letc_eqVlt => /orP [/eqP <- // | ].
by apply: lttc_trans.
Qed.

Lemma letc_lt_trans y x z : letc x y -> lttc y z -> lttc x z.
Proof. by rewrite letc_eqVlt => /orP [/eqP <- // | ]; apply: lttc_trans. Qed.

Lemma lttc_eqF x y : lttc x y -> (x == y) = false.
Proof. by rewrite /lttc => /andP[ _ ] /negbTE. Qed.

(* Monotony of addition *)
Lemma letc_add2l x : {mono +%R x : y z / letc y z}.
Proof.
move=> y z; rewrite /letc !raddfD /= ltr_add2l ler_add2l.
by rewrite -subr_eq0 opprD addrAC addNKr addrC subr_eq0.
Qed.

Lemma letc_add2r x : {mono +%R^~ x : y z / letc y z}.
Proof. by move=> y z /=; rewrite ![_ + x]addrC letc_add2l. Qed.

Lemma mono_inj f : {mono f : x y / letc x y} -> injective f.
Proof. by move=> mf x y /eqP; rewrite eqc_letc !mf -eqc_letc=> /eqP. Qed.

Lemma letcW_mono f : {mono f : x y / letc x y} -> {mono f : x y / lttc x y}.
Proof. by move=> mf x y; rewrite !lttc_neqAle mf (inj_eq (mono_inj mf)). Qed.

Lemma letcW_mono_Cto (R' : eqType) (f : complexR -> R') (g : rel R') :
  injective f ->
  {mono f : x y / letc x y >-> g x y} ->
  {mono f : x y / lttc x y >-> (x != y) && g x y}.
Proof. by move=> inj_f mf x y /=; rewrite lttc_neqAle mf (inj_eq inj_f). Qed.

Lemma lttc_add2r z x y : lttc (x + z) (y + z) = lttc x y.
Proof. by rewrite (letcW_mono (letc_add2r _)). Qed.

Lemma lttc_add2l z x y : lttc (z + x) (z + y) = lttc x y.
Proof. by rewrite (letcW_mono (letc_add2l _)). Qed.

Lemma letc_add x y z t : letc x y -> letc z t -> letc (x + z) (y + t).
Proof.
by move=> lxy lzt; rewrite (@letc_trans (y + z)) ?letc_add2l ?letc_add2r.
Qed.

Lemma lttc_add x y z t : lttc x y -> lttc z t -> lttc (x + z) (y + t).
Proof.
by move=> lxy lzt; rewrite (@lttc_trans (y + z)) ?lttc_add2l ?lttc_add2r.
Qed.

Lemma letc_sum (I : Type) (r : seq I) (P : pred I) (F G : I -> complexR) :
  (forall i : I, P i -> letc (F i) (G i)) ->
  letc (\sum_(i <- r | P i) F i) (\sum_(i <- r | P i) G i).
Proof. by exact: (big_ind2 _ (letcc _) letc_add). Qed.

(* changer l'énoncé pour la size *)
Lemma lttc_sum (I : Type) (r : seq I) (F G : I -> complexR) :
  (0 < size r)%N -> (forall i : I, lttc (F i) (G i)) ->
  lttc (\sum_(i <- r) F i) (\sum_(i <- r) G i).
Proof.
case: r => [// | x r _ Hi]; rewrite big_cons big_cons.
apply: (@lttc_le_trans (G x + \sum_(j <- r) F j)); first by rewrite lttc_add2r.
by rewrite letc_add2l; apply: letc_sum => i _; rewrite letc_eqVlt Hi orbT.
Qed.

(* letc_iff *)
Definition letcif (x y : complexR) (C : bool) : Prop :=
    ((letc x y) * ((x == y) = C))%type.

Definition letc_of_leif x y C (le_xy : letcif x y C) := le_xy.1 : letc x y.
Coercion letc_of_leif : letcif >-> is_true.

Lemma letcifP x y C : reflect (letcif x y C) (if C then x == y else lttc x y).
Proof.
rewrite /letcif letc_eqVlt; apply: (iffP idP)=> [|[]].
  by case: C => [/eqP->|lxy]; rewrite ?eqxx // lxy lttc_eqF.
by move=> /orP[/eqP->|lxy] <-; rewrite ?eqxx // lttc_eqF.
Qed.

Lemma letcif_refl x C : reflect (letcif x x C) C.
Proof. by apply: (iffP idP) => [-> | <-] //; split; rewrite ?eqxx. Qed.

Lemma letcif_trans x1 x2 x3 C12 C23 :
  letcif x1 x2 C12 -> letcif x2 x3 C23 -> letcif x1 x3 (C12 && C23).
Proof.
move=> ltx12 ltx23; apply/letcifP; rewrite -ltx12.
case eqx12: (x1 == x2).
  by rewrite (eqP eqx12) lttc_neqAle !ltx23 andbT; case C23.
by rewrite (@lttc_le_trans x2) ?ltx23 // lttc_neqAle eqx12 ltx12.
Qed.

Lemma letcif_le x y : letc x y -> letcif x y (letc y x).
Proof. by move=> lexy; split=> //; rewrite eqc_letc lexy. Qed.

Lemma letcif_eq x y : letc x y -> letcif x y (x == y).
Proof. by []. Qed.

Lemma getc_letcif x y C : letcif x y C -> letc y x = C.
Proof. by case=> le_xy; rewrite eqc_letc le_xy. Qed.

Lemma lttc_letcif x y C : letcif x y C -> (lttc x y) = ~~ C.
Proof. by move=> le_xy; rewrite lttc_neqAle !le_xy andbT. Qed.

Lemma mono_letcif (f : complexR -> complexR) C :
    {mono f : x y / letc x y} ->
  forall x y, (letcif (f x) (f y) C) = (letcif x y C).
Proof. by move=> mf x y; rewrite /letcif mf (inj_eq (mono_inj _)). Qed.

Lemma letcif_add x1 y1 C1 x2 y2 C2 :
    letcif x1 y1 C1 -> letcif x2 y2 C2 ->
  letcif (x1 + x2) (y1 + y2) (C1 && C2).
Proof.
rewrite -(mono_letcif _ (letc_add2r x2)) -(mono_letcif C2 (letc_add2l y1)).
exact: letcif_trans.
Qed.

Lemma letcif_sum (I : finType) (P C : pred I) (E1 E2 : I -> complexR) :
    (forall i, P i -> letcif (E1 i) (E2 i) (C i)) ->
  letcif (\sum_(i | P i) E1 i) (\sum_(i | P i) E2 i) [forall (i | P i), C i].
Proof.
move=> leE12; rewrite -big_andE.
elim/big_rec3: _ => [|i Ci m2 m1 /leE12]; first by rewrite /letcif letcc eqxx.
exact: letcif_add.
Qed.

(* max *)
Definition maxc x y := if (letc x y) then y else x.

Lemma maxcA : associative maxc.
Proof.
move=> a b c; rewrite /maxc.
case: (boolP (letc b c)) => [Hbc | /negbTE Hbc].
  case: (boolP (letc a b)) => [Hab | //].
  by rewrite Hbc (letc_trans Hab Hbc).
case: (boolP (letc a b)) => [Hab | ]; first by rewrite Hbc.
rewrite -lttcNge => Hab; apply/eqP; rewrite eq_sym; apply/eqP.
apply: ifF; apply/negbTE; rewrite -lttcNge.
by apply: (lttc_trans _ Hab); rewrite lttcNge Hbc.
Qed.

Lemma maxc_addl : left_distributive +%R maxc.
Proof. by move=> x y z; rewrite /maxc /= letc_add2r; case: ifP => _. Qed.

Lemma maxc_addr : right_distributive +%R maxc.
Proof. by move=> x y z; rewrite ![x + _]addrC maxc_addl. Qed.

Lemma maxcc x : maxc x x = x.
Proof. by rewrite /maxc letcc. Qed.

Lemma maxcC : commutative maxc.
Proof.
move=> x y; rewrite /maxc; case: (boolP (letc x y)).
  rewrite letc_eqVlt => /orP [/eqP -> | ]; first by rewrite letcc.
  by rewrite lttcNge => /negbTE ->.
by rewrite -lttcNge lttc_neqAle => /andP[_ ->].
Qed.

Lemma maxcl x y : letc x (maxc x y).
Proof. by rewrite /maxc; case: (boolP (letc x y)). Qed.

Lemma maxcr x y : letc y (maxc x y).
Proof. by rewrite maxcC maxcl. Qed.

(* bigop pour le max pour des listes non vides ? *)
Definition bigmaxc x0 lc :=
  foldr maxc (head x0 lc) (behead lc).

Lemma bigmaxc_nil x0 : bigmaxc x0 [::] = x0.
Proof. by rewrite /bigmaxc. Qed.

Lemma bigmaxc_un x0 x :
  bigmaxc x0 [:: x] = x.
Proof. by rewrite /bigmaxc. Qed.

Lemma bigmaxc_cons x0 x y lc :
  bigmaxc x0 (x :: y :: lc) = maxc x (bigmaxc x0 (y :: lc)).
Proof.
rewrite /bigmaxc /=; elim: lc => [/= | a lc /=].
  by rewrite maxcC.
set b := foldr _ _ _; set c := foldr _ _ _ => H.
by rewrite [maxc a b]maxcC maxcA H -maxcA (maxcC c a).
Qed.

Lemma bigmaxc_letc x0 lc i :
  (i < size lc)%N -> letc (nth x0 lc i) (bigmaxc x0 lc).
Proof.
case: lc i => [i | x lc]; first by rewrite nth_nil bigmaxc_nil letcc.
elim: lc x => [x i /= | x lc /= ihlc y i i_size].
  by rewrite ltnS leqn0 => /eqP ->; rewrite nth0 bigmaxc_un /=.
rewrite bigmaxc_cons /=; case: i i_size => [_ /= | i]; first by rewrite maxcl.
rewrite ltnS /=; move/(ihlc x); move/(letc_trans)=> H; apply: H.
by rewrite maxcr.
Qed.

(* Compatibilité avec l'addition *)
Lemma bigmaxc_addr x0 lc x :
  bigmaxc (x0 + x) (map (fun y => y + x) lc) = (bigmaxc x0 lc) + x.
Proof.
case: lc => [/= | y lc]; first by rewrite bigmaxc_nil.
elim: lc y => [y | y lc ihlc z]; first by rewrite /= !bigmaxc_un.
by rewrite map_cons !bigmaxc_cons ihlc maxc_addl.
Qed.

Lemma bigmaxc_index x0 lc :
  (0 < size lc)%N -> (index (bigmaxc x0 lc) lc < size lc)%N.
Proof.
case: lc => [//= | x l _].
elim: l x => [x | x lc]; first by rewrite bigmaxc_un /= eq_refl.
move/(_ x); set z := bigmaxc _ _ => /= ihl y; rewrite bigmaxc_cons /maxc -/z.
case: (letc y z); last by rewrite eq_refl.
by case: (y == z); rewrite //.
Qed.

Lemma bigmaxc_mem x0 lc :
  (0 < size lc)%N -> bigmaxc x0 lc \in lc.
Proof. by move/(bigmaxc_index x0); rewrite index_mem. Qed.

Lemma bigmaxc_leqP x0 lc x :
  (0 < size lc)%N ->
  reflect (forall i, (i < size lc)%N -> letc (nth x0 lc i) x) (letc (bigmaxc x0 lc) x).
Proof.
move=> lc_size; apply: (iffP idP) => [le_x i i_size | H].
  by apply: (letc_trans _ le_x); apply: bigmaxc_letc.
by move/(nthP x0): (bigmaxc_mem x0 lc_size) => [i i_size <-]; apply: H.
Qed.

Lemma bigmaxcP x0 lc x :
  (x \in lc /\ forall i, (i < size lc) %N -> letc (nth x0 lc i) x) -> (bigmaxc x0 lc = x).
Proof.
move=> [] /(nthP x0) [] j j_size j_nth x_letc; apply: letc_asym; apply/andP; split.
  by apply/bigmaxc_leqP => //; apply: (leq_trans _ j_size).
by rewrite -j_nth (bigmaxc_letc _ j_size).
Qed.

(* surement à supprimer à la fin
Lemma bigmaxc_lttc x0 lc :
  uniq lc -> forall i, (i < size lc)%N -> (i != index (bigmaxc x0 lc) lc)
    -> lttc (nth x0 lc i) (bigmaxc x0 lc).
Proof.
move=> lc_uniq Hi size_i /negP neq_i.
rewrite lttc_neqAle (bigmaxc_letc _ size_i) andbT.
apply/negP => /eqP H; apply: neq_i; rewrite -H eq_sym; apply/eqP.
by apply: index_uniq.
Qed. *)

Lemma bigmaxc_letcif x0 lc :
  uniq lc -> forall i, (i < size lc)%N ->
     letcif (nth x0 lc i) (bigmaxc x0 lc) (i == index (bigmaxc x0 lc) lc).
Proof.
move=> lc_uniq i i_size; rewrite /letcif (bigmaxc_letc _ i_size).
rewrite -(nth_uniq x0 i_size (bigmaxc_index _ (leq_trans _ i_size)) lc_uniq) //.
rewrite nth_index //.
by apply: bigmaxc_mem; apply: (leq_trans _ i_size).
Qed.

(* bigop pour le max pour des listes non vides ? *)
Definition bmaxf n (f : {ffun 'I_n.+1 -> complexR}) :=
  bigmaxc (f ord0) (codom f).

Lemma bmaxf_letc n (f : {ffun 'I_n.+1 -> complexR}) i :
  letc (f i) (bmaxf f).
Proof.
move: (@bigmaxc_letc (f ord0) (codom f) (nat_of_ord i)).
rewrite /bmaxf size_codom card_ord => H; move: (ltn_ord i); move/H.
suff -> : nth (f ord0) (codom f) i = f i; first by [].
by rewrite /codom (nth_map ord0) ?size_enum_ord // nth_ord_enum.
Qed.

Lemma bmaxf_index n (f : {ffun 'I_n.+1 -> complexR}) :
  (index (bmaxf f) (codom f) < n.+1)%N.
Proof.
rewrite /bmaxf.
have {6}-> : n.+1 = size (codom f) by rewrite size_codom card_ord.
by apply: bigmaxc_index; rewrite size_codom card_ord.
Qed.

Definition index_bmaxf n f := Ordinal (@bmaxf_index n f).

Lemma ordnat i n (ord_i : (i < n)%N) :
  i = nat_of_ord (Ordinal ord_i).
Proof. by []. Qed.

Lemma eq_index_bmaxf n (f : {ffun 'I_n.+1 -> complexR}) :
  f (index_bmaxf f) = bmaxf f.
Proof.
move: (bmaxf_index f).
rewrite -{3}[n.+1]card_ord -(size_codom f) index_mem.
move/(nth_index (f ord0)) => <-; rewrite (nth_map ord0).
  by rewrite (ordnat (bmaxf_index _)) /index_bmaxf nth_ord_enum.
by rewrite size_enum_ord; apply: bmaxf_index.
Qed.

Lemma bmaxf_letcif n (f : {ffun 'I_n.+1 -> complexR}) :
  injective f -> forall i,
     letcif (f i) (bmaxf f) (i == index_bmaxf f).
Proof.
by move=> inj_f i; rewrite /letcif bmaxf_letc -(inj_eq inj_f) eq_index_bmaxf.
Qed.

(*
Lemma bmaxf_lttc n (f : {ffun 'I_n.+1 -> complexR}) :
  injective f -> forall i, lttc (f i) (bmaxf f) = (index_bmaxf f != i).
Proof.
move=> inj_f i; rewrite /lttc bmaxf_letc andTb eq_sym.
apply/idP/idP => /negP Hneg; apply/negP => /eqP Heq; apply: Hneg; apply/eqP.
  by rewrite -eq_index_bmaxf Heq.
by apply: inj_f; rewrite eq_index_bmaxf.
Qed.
*)

(*
(* Compatibilité avec l'addition *)
Lemma bigmaxc_addr x0 lc x :
  bigmaxc (x0 + x) (map (fun y => y + x) lc) = (bigmaxc x0 lc) + x.
Proof.
case: lc => [/= | y lc]; first by rewrite bigmaxc_nil.
elim: lc y => [y | y lc ihlc z]; first by rewrite /= !bigmaxc_un.
by rewrite map_cons !bigmaxc_cons ihlc maxc_addl.
Qed.

Lemma bigmaxc_index x0 lc :
  (0 < size lc)%N -> (index (bigmaxc x0 lc) lc < size lc)%N.
Proof.
case: lc => [//= | x l _].
elim: l x => [x | x lc]; first by rewrite bigmaxc_un /= eq_refl.
move/(_ x); set z := bigmaxc _ _ => /= ihl y; rewrite bigmaxc_cons /maxc -/z.
case: (letc y z); last by rewrite eq_refl.
by case: (y == z); rewrite //.
Qed.

Lemma bigmaxc_mem x0 lc :
  (0 < size lc)%N -> bigmaxc x0 lc \in lc.
Proof. by move/(bigmaxc_index x0); rewrite index_mem. Qed.

Lemma bigmaxc_leqP x0 lc x :
  (0 < size lc)%N ->
  reflect (forall i, (i < size lc)%N -> letc (nth x0 lc i) x) (letc (bigmaxc x0 lc) x).
Proof.
move=> lc_size; apply: (iffP idP) => [le_x i i_size | H].
  by apply: (letc_trans _ le_x); apply: bigmaxc_letc.
by move/(nthP x0): (bigmaxc_mem x0 lc_size) => [i i_size <-]; apply: H.
Qed.

Lemma bigmaxcP x0 lc x :
  (x \in lc /\ forall i, (i < size lc) %N -> letc (nth x0 lc i) x) -> (bigmaxc x0 lc = x).
Proof.
move=> [] /(nthP x0) [] j j_size j_nth x_letc; apply: letc_asym; apply/andP; split.
  by apply/bigmaxc_leqP => //; apply: (leq_trans _ j_size).
by rewrite -j_nth (bigmaxc_letc _ j_size).
Qed.

Lemma bigmaxc_lttc x0 lc :
  uniq lc -> forall i, (i < size lc)%N -> (i != index (bigmaxc x0 lc) lc)
    -> lttc (nth x0 lc i) (bigmaxc x0 lc).
Proof.
move=> lc_uniq Hi size_i /negP neq_i.
rewrite lttc_neqAle (bigmaxc_letc _ size_i) andbT.
apply/negP => /eqP H; apply: neq_i; rewrite -H eq_sym; apply/eqP.
by apply: index_uniq.
Qed.*)

(* compatibilité opération produit monome : voir formule exacte *)
(* bigmax lttc ? surement mieux *)

End OrderDef.

End ComplexTotalOrder.

Section MinPoly.

Local Notation "x 'is_algebraic'" := (algebraicOver QtoC x)
  (at level 55).
 (*
Lemma poly_caract_root (F E : fieldType) (f : {rmorphism F -> E}) x :
    algebraicOver f x -> x != 0 ->
    {p : {poly F} | [&& p \is monic, root (map_poly f p) x & p`_0 != 0]}.
Proof.
move=> /integral_algebraic /sig2W[p pmonic proot] xneq0.
wlog p_0: p proot pmonic / p`_0 != 0=> [hwlog|]; last by exists p; apply/and3P.
have pneq0 : p != 0 by rewrite monic_neq0.
About multiplicity_XsubC.
have [n ] := multiplicity_XsubC p 0
/implyP /(_ pneq0) rootqN0 p_eq]] := multiplicity_XsubC p 0.
move: pneq0 proot pmonic.
rewrite p_eq rmorphM rootM rmorphX rmorphB rmorph0 /= map_polyX => pn0 pr pm.
have qmonic : q \is monic by move: pm; rewrite monicMr ?monic_exp ?monicXsubC.
have qn : q`_0 != 0 by rewrite -horner_coef0.
have qr : root (map_poly f q) x.
  move: pr; case: {p_eq pn0 pm} n => [|n] .
    by rewrite expr0 rootC oner_eq0 orbF.
  by rewrite rmorph0 root_exp_XsubC (negPf xneq0) orbF.
exact: (hwlog q).
Qed.*)

Lemma separable_polyZ (R : idomainType) (p : {poly R}) (a : R) :
    a != 0 -> separable_poly (a *: p) = separable_poly p.
Proof.
by move=> an0; rewrite /separable_poly derivZ coprimep_scalel ?coprimep_scaler.
Qed.

Definition psep (R : idomainType) (p : {poly R}) :=
  let p_ := gcdp p (deriv p) in
    (lead_coef p_) *: (p %/ p_).

Lemma psep_separable (R : idomainType) (p : {poly R}) :
  p != 0 -> separable_poly (psep p).
Proof.
move=> p_neq0; rewrite /psep separable_polyZ ?make_separable //.
by rewrite lead_coef_eq0 gcdp_eq0 negb_and p_neq0.
Qed.

Lemma psep_neq0 (R : idomainType) (p : {poly R}) :
  p != 0 -> psep p != 0.
Proof.
move=> p_neq0; pose p_ := gcdp p (deriv p).
have lc_neq0 : lead_coef p_ != 0.
  by rewrite lead_coef_eq0 gcdp_eq0 negb_and p_neq0.
by rewrite /psep scale_poly_eq0 negb_or lc_neq0 andTb dvdp_div_eq0 ?dvdp_gcdl.
Qed.

(*
Lemma psep_monic (R : fieldType) (p : {poly R}) :
  p \is monic -> psep p \is monic.
Proof.
move=> monic_p; pose p_ := gcdp p (deriv p).
have lc_neq0 : lead_coef p_ != 0.
  by rewrite lead_coef_eq0 gcdp_eq0 negb_and monic_neq0.
have p_monic : (lead_coef p_)^-1 *: p_ \is monic.
  by apply/monicP; rewrite lead_coefZ mulrC mulfV.
rewrite -(monicMr _ p_monic) /psep -/p_ -scalerCA scalerA mulrC mulfV //.
by rewrite scale1r divpK // /p_ dvdp_gcdl.
Qed.*)

Lemma psep_root (F E : numFieldType) (f : {rmorphism F -> E}) (p : {poly F}) (x : E) :
  p != 0 -> root (map_poly f p) x -> root (map_poly f (psep p)) x.
Proof.
move=> p_neq0 root_p; pose p_ := gcdp p (deriv p).
have lc_neq0 : lead_coef p_ != 0.
  by rewrite lead_coef_eq0 gcdp_eq0 negb_and p_neq0.
rewrite map_polyZ /=; apply/rootP/eqP.
rewrite hornerZ mulf_eq0; apply/orP; right; apply/eqP/rootP.
move: (divpK (dvdp_gcdl p (deriv p))); rewrite -/p_ => eq_p.
rewrite -mu_gt0; last first.
  rewrite map_poly_eq0; apply/negP => /eqP H; rewrite H mul0r in eq_p.
  by rewrite -eq_p eq_refl in p_neq0.
have fp_neq0 : (map_poly f (p %/ p_)) * (map_poly f p_) != 0.
  by rewrite -rmorphM eq_p map_poly_eq0.
rewrite -(ltn_add2r (\mu_x (map_poly f p_))) add0n -mu_mul //.
rewrite -rmorphM /= divpK ?dvdp_gcdl //.
rewrite (mu_deriv_root _ root_p) ?map_poly_eq0 // addn1 ltnS /p_ /=.
rewrite gcdp_map deriv_map /=.
have H := (divpK (dvdp_gcdr (map_poly f p) (map_poly f p^`()))).
rewrite -{2}H mu_mul ?leq_addl // H -size_poly_eq0 -deriv_map size_deriv.
rewrite -lt0n -ltnS prednK; last by rewrite lt0n size_poly_eq0 map_poly_eq0.
by apply: (root_size_gt1 _ root_p); rewrite map_poly_eq0.
Qed.

Section MinPoly_byalgC.

Lemma poly_caract_byalgC x : x is_algebraic ->
  {p | [/\ (p \is monic), separable_poly p, irreducible_poly p &
    forall q, root (map_poly QtoC q) x = (p %| q)]}.
Proof.
move=> /integral_algebraic /sig2W[p pmonic proot].
move H : (size p) => n.
case: n H.
  by move/eqP; move/monic_neq0: pmonic; rewrite -size_poly_eq0 => /negbTE ->.
case => [size_p | n eq_n].
  move/(root_size_gt1 _): proot; rewrite map_poly_eq0 => H.
  by move/monic_neq0: pmonic; move/H; rewrite size_map_poly size_p.
elim: n {-2}n (leqnn n) p pmonic proot eq_n => [n /= |].
  rewrite leqn0 => /eqP -> p pmonic proot_x size_p.
  exists p; split => // [||q].
  + move/eqP: (size_deriv p); rewrite size_p /= => /size_poly1P[a a_neq0 eq_p'].
    by rewrite /separable_poly eq_p' -alg_polyC coprimep_scaler ?coprimep1.
  + rewrite /irreducible_poly size_p.
    split => // q size_q div_q; rewrite -dvdp_size_eqp // eqn_leq.
    apply/andP; split; first by apply/dvdp_leq; first apply/monic_neq0.
    rewrite size_p ltn_neqAle eq_sym size_q /= lt0n size_poly_eq0.
    by apply/(dvdpN0 div_q (monic_neq0 pmonic)).
  + move: proot_x; rewrite !root_factor_theorem => /dvdp_size_eqp.
    rewrite size_XsubC size_map_poly size_p eq_refl => /esym H.
    rewrite -(dvdp_map (ratr_rmorphism complexR_numFieldType)) /=.
    by apply/eqp_dvdl.
move=> n ihn np lenp p pmonic proot_x size_p.
have [s_root eq_s] := (closed_field_poly_normal
                                    (map_poly (ratr_rmorphism algCnumField) p)).
pose xC := nth 0 s_root 0.
have proot_xC : root (map_poly ratr p) xC.
  apply/rootP/eqP; rewrite eq_s hornerZ mulf_eq0 lead_coef_eq0 map_poly_eq0.
  rewrite (negbTE (monic_neq0 _)) //= horner_prod prodf_seq_eq0.
  apply/hasP; exists xC; last by rewrite andTb hornerXsubC subrr.
  rewrite /xC mem_nth //.
  have -> : size s_root = (size p).-1.
    rewrite -(size_map_poly (ratr_rmorphism algCnumField)) /= eq_s size_scale.
      by rewrite size_prod_XsubC.
    by rewrite lead_coef_eq0 map_poly_eq0 monic_neq0 ?pmonic.
  by rewrite size_p /=.
have isQ := algebraics_fundamentals.rat_algebraic_decidable
                                 Algebraics.Implementation.algebraic.
have [q [qmonic root_qxC irr_q]] :=
     algebraics_fundamentals.minPoly_decidable_closure isQ
                                    (Algebraics.Implementation.algebraic xC).
have size_q : (1 < size q)%N.
  rewrite -(size_map_poly (ratr_rmorphism algCnumField)).
  by rewrite (@root_size_gt1 _ xC) ?map_poly_eq0 ?monic_neq0.
case: (boolP (root (map_poly ratr q) x)) => [qroot_x | q_notroot].
  exists q; do? split => //.
    suff -> : q = psep q by rewrite psep_separable ?monic_neq0.
    move/(irredp_XsubCP irr_q): (dvdp_gcdl q q^`()) => [].
      rewrite /psep; move/eqp_eq; rewrite lead_coef1 scale1r => ->.
      set z := lead_coef (gcdp _ _); rewrite alg_polyC lead_coefC -mul_polyC.
      rewrite divpKC //; apply/modp_eq0P; rewrite modpC // /z lead_coef_eq0.
      rewrite gcdp_eq0 negb_and -size_poly_eq0 -lt0n.
      by apply/orP; left; rewrite (ltn_trans _ size_q).
    move/eqp_size/esym/eq_leq; have := (@leq_gcdpr _ q q^`()) .
    rewrite -size_poly_eq0 size_deriv -lt0n -(ltn_add2r 1) ?addn1 prednK //.
      move/(_ size_q) => legcdp_1 le_q_gcdp.
      move: (leq_trans le_q_gcdp legcdp_1).
      by rewrite -ltnS prednK ?ltnn // (ltn_trans _ size_q).
    by rewrite (ltn_trans _ size_q).
  move=> q0; apply/idP/idP=> [q0root_x | /dvdpP[r ->]]; last first.
    by rewrite rmorphM rootM qroot_x orbT.
  suffices /eqp_dvdl <-: gcdp q q0 %= q by apply: dvdp_gcdr.
  rewrite irr_q ?dvdp_gcdl ?gtn_eqF // -(size_map_poly (ratr_rmorphism complexR_numFieldType)).
  rewrite gcdp_map /= (@root_size_gt1 _ x) ?root_gcd ?q0root_x ?qroot_x //.
  by rewrite gcdp_eq0 negb_and map_poly_eq0 monic_neq0.
have: (q %| p).
  suffices /eqp_dvdl <-: gcdp q p %= q by apply: dvdp_gcdr.
  rewrite irr_q ?dvdp_gcdl ?gtn_eqF //.
  rewrite -(size_map_poly (ratr_rmorphism algCnumField)) gcdp_map /=.
  rewrite (@root_size_gt1 _ xC) ?root_gcd ?px0 //.
    by rewrite gcdp_eq0 negb_and map_poly_eq0 monic_neq0.
  by rewrite proot_xC root_qxC.
rewrite dvdp_eq; set r := _ %/ _ => /eqP eq_p.
have rmonic : r \is monic.
  by move/(monicMr r): qmonic; rewrite -eq_p pmonic.
have root_r : root (map_poly ratr r) x.
  by move: proot_x; rewrite eq_p rmorphM /= rootM (negbTE q_notroot) orbF.
have size_r : (1 < size r)%N.
  rewrite -(size_map_poly (ratr_rmorphism complexR_numFieldType)).
  by rewrite (@root_size_gt1 _ x) ?map_poly_eq0 ?monic_neq0.
have Hsize : ((size r).-2 <= n)%N.
  rewrite -(leq_add2r 1) !addn1.
  apply: (leq_trans _ lenp); rewrite -(leq_add2r 2) !addn2.
  rewrite -size_p prednK ?prednK //; first last.
  + by rewrite -(ltn_add2r 1) ?addn1 prednK // (ltn_trans _ size_r).
  + by rewrite (ltn_trans _ size_r).
  + rewrite eq_p size_monicM ?monic_neq0 //.
    rewrite -subn1 -addnBA ?subn1 ?(ltn_trans _ size_q) //.
    rewrite -[X in (X < _)%N]addn0 ltn_add2l.
    by rewrite -(ltn_add2r 1) ?addn1 prednK // (ltn_trans _ size_q).
apply: (ihn (size r).-2 Hsize r rmonic root_r).
rewrite prednK ?prednK //.
  by rewrite (ltn_trans _ size_r).
by rewrite -(ltn_add2r 1) ?addn1 prednK // (ltn_trans _ size_r).
Qed.

End MinPoly_byalgC.

(*
Lemma psep_coef0 (R : fieldType) (p : {poly R}) :
  p`_0 != 0 -> (psep p)`_0 != 0.
Proof.
move=> p0.
rewrite coefZ mulf_eq0 negb_or; apply/andP; split.
  rewrite lead_coef_eq0 gcdp_eq0 negb_and; apply/orP; left.
  by apply/negP => /eqP p_eq0; rewrite p_eq0 coef0 eq_refl in p0.
apply/negP => /eqP eqr; move/negP : p0; apply.
rewrite -(divpK (dvdp_gcdl p (deriv p))) coefM big1 // => i _.
have -> : nat_of_ord i = 0%N by apply/eqP; rewrite -leqn0 -ltnS.
by rewrite eqr mul0r.
Qed.
*)
(*
Lemma poly_sep (F E : numFieldType) (f : {rmorphism F -> E})
  (n : nat) (P : {ffun 'I_n -> {poly F}}) (x : {ffun 'I_n -> E}) :
  (forall i, root (map_poly f (P i)) (x i)) ->
  (forall i, P i \is monic) -> exists p : {poly F},
  [&& p \is monic, [forall i, root (map_poly f p) (x i)] & separable_poly p].
Proof.
move=> root_p monic_p.
pose r := \prod_(i < n) P i.
have r_neq0 : r != 0 by apply/prodf_neq0 => i _; rewrite monic_neq0.
have monic_r : r \is monic by apply: monic_prod.
have root_r i : root (map_poly f r) (x i).
  apply/rootPt; rewrite rmorph_prod horner_prod; apply/prodf_eq0.
  by exists i; rewrite //= (rootP (root_p i)).
pose p_ := gcdp r (deriv r); pose lc_ := (lead_coef p_).
have lc_neq0 : lc_ != 0.
  by rewrite /lc_ lead_coef_eq0 gcdp_eq0 negb_and r_neq0.
have lc_p_monic : lc_^-1 *: p_ \is monic.
  by apply/monicP; rewrite lead_coefZ mulrC mulfV.
exists (lc_ *: (r %/ p_)); apply/and3P; split.
+ rewrite -(monicMr _ lc_p_monic) -scalerCA scalerA mulrC mulfV //.
  by rewrite scale1r divpK // /p_ dvdp_gcdl.
+ apply/forallP => i; rewrite map_polyZ; apply/rootP/eqP.
  rewrite hornerZ mulf_eq0; apply/orP; right; apply/eqP/rootP.
  move: (divpK (dvdp_gcdl r (deriv r))); rewrite -/p_ => eq_p.
  rewrite -mu_gt0; last first.
    rewrite map_poly_eq0; apply/negP => /eqP H; rewrite H mul0r in eq_p.
    by rewrite -eq_p eq_refl in r_neq0.
  have rp_neq0 : (map_poly f (r %/ p_)) * (map_poly f p_) != 0.
    by rewrite -rmorphM eq_p map_poly_eq0.
  rewrite -(ltn_add2r (\mu_(x i) (map_poly f p_))) add0n -mu_mul //.
  rewrite -rmorphM /= divpK ?dvdp_gcdl //.
  rewrite (mu_deriv_root _ (root_r i)) ?map_poly_eq0 // addn1 ltnS /p_ /=.
  rewrite gcdp_map deriv_map /=.
  have H := (divpK (dvdp_gcdr (map_poly f r) (map_poly f r^`()))).
  rewrite -{2}H mu_mul ?leq_addl // H -size_poly_eq0 -deriv_map size_deriv.
  rewrite -lt0n -ltnS prednK; last by rewrite lt0n size_poly_eq0 map_poly_eq0.
  by apply: (root_size_gt1 _ (root_r i)); rewrite map_poly_eq0.
+ by rewrite separable_polyZ ?make_separable.
Qed.
*)

Lemma ratr_eq0 (x : rat) : ((QtoC x) == (0: complexR)) = (x == 0).
Proof.
by rewrite -numq_eq0 mulf_eq0 invr_eq0 !intr_eq0 (negbTE (denq_neq0 x)) orbF.
Qed.

Lemma polyZ_algebraic (x : complexR) (p : {poly int}) :
  p != 0 -> root (map_poly ZtoC p) x -> x is_algebraic.
Proof.
move=> p_neq0 rootpx; rewrite /algebraicOver.
exists (map_poly intr p).
  by rewrite map_poly_eq0_id0 // intr_eq0 lead_coef_eq0.
have ZtoQtoC : QtoC \o intr =1 ZtoC by move=> y /=; rewrite ratr_int.
by rewrite -map_poly_comp (eq_map_poly ZtoQtoC).
Qed.

Lemma poly_algebraic (x : complexR) (p : {poly complexR}) :
  p != 0 -> root p x -> p \is a polyOver Cint -> x is_algebraic.
Proof.
move=> p_neq0 rootpx /floorCpP[q eq_p_q]; rewrite /algebraicOver.
have ZtoQtoC : QtoC \o intr =1 ZtoC by move=> y /=; rewrite ratr_int.
exists (map_poly intr q).
  move: p_neq0; rewrite eq_p_q -(eq_map_poly ZtoQtoC) map_poly_comp.
  by rewrite map_poly_eq0.
by rewrite -map_poly_comp (eq_map_poly ZtoQtoC) -eq_p_q.
Qed.

Lemma poly_caract_int (x : complexR) : x is_algebraic ->
    {p : {poly int} | [/\ (zcontents p = 1),
      irreducible_poly p, separable_poly (map_poly ZtoC p)
      & forall q : {poly int}, root (map_poly ZtoC q) x = (p %| q)]}.
Proof.
move=> algebraic_x.
have [r [mon_r sep_r [irr_r div_r] root_r]] := (poly_caract_byalgC algebraic_x).
have [q [a a_neq0 r_eq]] := (rat_poly_scale r).
have q_neq0 : q != 0.
  apply/negP => /eqP q_eq0; move: r_eq; rewrite q_eq0 map_poly0 scaler0.
  by apply/eqP/monic_neq0.
have eq_qz : map_poly ZtoQ (zprimitive q) = ((zcontents q)%:~R^-1 * a%:~R) *: r.
  rewrite r_eq -scalerA [X in _ *: X]scalerA mulfV ?intr_eq0 ?a_neq0 // scale1r.
  rewrite [X in _ *: _ _ X]zpolyEprim map_polyZ scalerA mulrC mulfV ?scale1r //.
  by rewrite intr_eq0 zcontents_eq0 q_neq0.
have ZtoQtoC : QtoC \o intr =1 ZtoC by move=> y /=; rewrite ratr_int.
exists (zprimitive q); split.
+ by rewrite zcontents_primitive q_neq0.
+ split.
    rewrite -size_rat_int_poly eq_qz size_scale //.
    by rewrite mulf_neq0 ?invr_neq0 ?intr_eq0 ?zcontents_eq0.
  move=> p; rewrite -size_rat_int_poly.
  move=> size_p; rewrite -dvdp_rat_int eq_qz dvdp_scaler; last first.
    by rewrite mulf_neq0 ?invr_neq0 ?intr_eq0 ?zcontents_eq0.
  move/(div_r _ size_p)/eqpP => [[b1 b2]] /= /andP[b1_n0 b2_n0] eq_b.
  rewrite -dvdp_size_eqp.
    rewrite size_zprimitive -size_rat_int_poly -(size_scale _ b1_n0) eq_b.
    rewrite (size_scale _ b2_n0) r_eq size_scale ?invr_eq0 ?intr_eq0 //.
    by rewrite size_rat_int_poly.
  rewrite -dvdp_rat_int eq_qz; apply/dvdpP.
  set u := (_ * _).
  exists (u * b2^-1 * b1)%:P.
  rewrite mul_polyC -[in RHS]scalerA -[in RHS]scalerA eq_b.
  by congr (u *: _); rewrite scalerA mulrC mulfV ?scale1r.
+ rewrite -(eq_map_poly ZtoQtoC) map_poly_comp eq_qz /= map_polyZ /=.
  rewrite separable_polyZ ?separable_map //.
  by rewrite ratr_eq0 mulf_neq0 ?invr_eq0 ?intr_eq0 ?zcontents_eq0.
+ move=> p; rewrite -(eq_map_poly ZtoQtoC) map_poly_comp root_r r_eq.
  rewrite dvdp_scalel ?invr_eq0 ?intr_eq0 //.
  by rewrite dvdp_rat_int [q in LHS]zpolyEprim dvdp_scalel ?zcontents_eq0.
Qed.

(*
Lemma poly_caract_int (x : complexR) : x is_algebraic -> x != 0 ->
    exists p : {poly int}, [&& (p != 0), root (map_poly ZtoC p) x,
    (p`_0 != 0), (0 < lead_coef p) & separable_poly (map_poly ZtoC p)].
Proof.
move => algebraic_x xn0.
have [r /andP[monr /andP[rootr r0_neq0]]] := (poly_caract_root algebraic_x xn0).
have monp := (psep_monic monr).
have rootp := (psep_root (monic_neq0 monr) rootr).
have p0_neq0 := (psep_coef0 r0_neq0).
have sepp := (psep_separable (monic_neq0 monr)).
have : {q : {poly int} & {a : int_ZmodType | (0 < a)
     & psep r = a%:~R^-1 *: map_poly (intr : int -> rat) q}}.
  have [p_ [a /negbTE a_neq0 eq_p_p_]] := rat_poly_scale (psep r).
  have [a_gt0 | a_le0 | /eqP] := (ltrgt0P a); last by rewrite a_neq0.
    by exists p_; exists a.
  exists (- p_); exists (- a); rewrite ?oppr_gt0 //.
  by rewrite !rmorphN invrN /= scaleNr scalerN opprK.
move=> [p_ [a a_gt0 eq_p_p_]].
have a_neq0 : ratr a%:~R != 0 :> complexR.
  by rewrite ratr_int intr_eq0 lt0r_neq0.
have p_0_neq0 : p_`_0 != 0.
  apply/negP => /eqP p_eq0; move/negP: p0_neq0; apply.
  by rewrite eq_p_p_ coefZ coef_map p_eq0 mulr0.
have p__neq0 : p_ != 0.
  by apply/negP => /eqP p__eq0; move/negP: p_0_neq0; rewrite p__eq0 coef0.
have eq_p__p : (map_poly intr p_) = a%:~R *: (psep r).
  by rewrite eq_p_p_ scalerA mulfV ?scale1r // intr_eq0; apply: lt0r_neq0.
have lc_p_gt0 : (0 < (lead_coef p_)).
  have H : (lead_coef p_)%:~R = a%:~R * lead_coef (psep r).
    rewrite eq_p_p_ lead_coefZ lead_coef_map_eq ?intr_eq0 ?lead_coef_eq0 //.
    by rewrite mulrA mulfV ?mul1r // intr_eq0; apply: (lt0r_neq0 a_gt0).
  by rewrite -(ltr0z rat_numDomainType) H (monicP monp) mulr1 ltr0z.
have ZtoQtoC : QtoC \o intr =1 ZtoC by move=> y /=; rewrite ratr_int.
have root_map_p : root (map_poly intr p_) x.
  by rewrite -(eq_map_poly ZtoQtoC) map_poly_comp eq_p__p map_polyZ /= rootZ.
exists p_; apply/and5P; split; rewrite //.
rewrite -(eq_map_poly ZtoQtoC) map_poly_comp eq_p__p map_polyZ /=.
by rewrite (separable_polyZ _ a_neq0) separable_map.
Qed.*)
(*
Lemma polyMinZ_subproof (x : complexR) : x is_algebraic -> x != 0 ->
    {p : {poly int} | [&& (p != 0), root (map_poly ZtoC p) x,
    (p`_0 != 0), (0 < lead_coef p) & separable_poly (map_poly ZtoC p)]}.
Proof.
move => x_alg x_neq0.
have [p /and5P] := (sigW (poly_caract_int x_alg x_neq0)).
move => [p_neq0 rootp p0_neq0 lc_gt0 p_sep].
exists p; apply/and5P; split; rewrite ?p_sep ?andbT //.
Qed.

Definition polyMinZ (x : complexR) (H : x is_algebraic) :=
  match Sumbool.sumbool_of_bool(x != 0) with
  |right _ => 'X
  |left toto => sval(polyMinZ_subproof H toto)
  end.
*)

Definition polyMinZ (x : complexR) (H : x is_algebraic) :=
  sval (poly_caract_int H).

Definition polyMin (x : complexR) (H : x is_algebraic) :=
  map_poly ZtoC (polyMinZ H).

(*
+ by rewrite map_poly_eq0_id0 ?intr_eq0 ?(lt0r_neq0 lc_gt0).
+ by apply/polyOverP => i; rewrite coef_map /= Cint_int.
+ by rewrite coef_map intr_eq0.
by rewrite lead_coef_map_eq ?intr_eq0 ?ltr0z ?lt0r_neq0.
Qed.
*)

Lemma polyMinZ_zcontents (x : complexR) (H : x is_algebraic) :
    zcontents (polyMinZ H) = 1.
Proof. by move: (svalP (poly_caract_int H)) => [->]. Qed.

Lemma polyMinZ_neq0 (x : complexR) (H : x is_algebraic) : (polyMinZ H) != 0.
Proof. by rewrite -zcontents_eq0 polyMinZ_zcontents. Qed.

Lemma polyMin_neq0 (x : complexR) (H : x is_algebraic) : (polyMin H) != 0.
Proof.
by rewrite map_poly_eq0_id0 ?intr_eq0 ?lead_coef_eq0 polyMinZ_neq0.
Qed.

Lemma polyMinZ_irr (x : complexR) (H : x is_algebraic) :
  irreducible_poly (polyMinZ H).
Proof. by move: (svalP (poly_caract_int H)) => []. Qed.

Lemma polyMinZ_root (x : complexR) (H : x is_algebraic) :
  root (map_poly ZtoC (polyMinZ H)) x.
Proof.
move: (svalP (poly_caract_int H)) => [_ _ _ ->].
by rewrite dvdpp.
Qed.

Lemma polyMin_root (x : complexR) (H : x is_algebraic) :
  root (polyMin H) x.
Proof. by rewrite polyMinZ_root. Qed.

Lemma polyMinZ_dvdp (x : complexR) (H : x is_algebraic) (q : {poly int}) :
    root (map_poly ZtoC q) x = ((polyMinZ H) %| q).
Proof. by move: (svalP (poly_caract_int H)) => []. Qed.

Lemma polyMin_dvdp (x : complexR) (H : x is_algebraic) (q : {poly complexR}):
  q \is a polyOver Cint -> root q x = ((polyMin H) %| q).
Proof.
move/floorCpP => [r ->]; rewrite polyMinZ_dvdp -dvdp_rat_int /polyMin.
rewrite -(dvdp_map (ratr_rmorphism complexR_numFieldType)) -!map_poly_comp /=.
by congr ( _ %| _); apply: eq_map_poly => y /=; rewrite ratr_int.
Qed.

Lemma polyMinZ_lcoef_gt0 (x : complexR) (H : x is_algebraic) :
  0 < lead_coef (polyMinZ H).
Proof.
rewrite -sgz_gt0 -sgz_contents.
move: (svalP (poly_caract_int H)) => [-> _ _ _].
by rewrite sgz1.
Qed.

Lemma polyMin_lcoef_gt0 (x : complexR) (H : x is_algebraic) :
  0 < lead_coef (polyMin H).
Proof.
by rewrite lead_coef_map_eq ?intr_eq0 ?ltr0z ?lt0r_neq0 // polyMinZ_lcoef_gt0.
Qed.

Lemma polyMinZ_separable (x : complexR) (H : x is_algebraic) :
  separable_poly (map_poly ZtoC (polyMinZ H)).
Proof. by move: (svalP (poly_caract_int H)) => []. Qed.

Lemma polyMin_separable (x : complexR) (H : x is_algebraic) :
  separable_poly (polyMin H).
Proof. by rewrite polyMinZ_separable. Qed.

Lemma polyMin_over (x : complexR) (H : x is_algebraic) :
  polyMin H \is a polyOver Cint.
Proof.
by rewrite /polyMin; apply/polyOverP => i; rewrite coef_map Cint_int.
Qed.

(*
Lemma polyMinZ_coef0_neq0 (x : complexR) (H : x is_algebraic) :
  ((polyMinZ H)`_0 == 0) = (x == 0).
Proof.
rewrite /polyMinZ.
case : ((Sumbool.sumbool_of_bool (x != 0))) => [a | /eqP ->]; last first.
  by rewrite coefX eq_refl.
move: (svalP (polyMinZ_subproof H a)) => /and5P[_ _ /negbTE -> _ _].
by apply: esym; apply/negP /negP.
Qed.

Lemma polyMin_coef0_neq0 (x : complexR) (H : x is_algebraic) :
  ((polyMin H)`_0 == 0) = (x == 0).
Proof.
by rewrite coef_map intr_eq0 polyMinZ_coef0_neq0.
Qed.
*)

(*
Print coprimep.
Pdiv.CommonIdomain.eqp_dvdl:
  forall (R : idomainType) (d2 d1 p : {poly R}), d1 %= d2 -> (d1 %| p) = (d2 %| p)

dvdp_rat_int: forall p q : {poly int_Ring}, (map_poly ZtoQ p %| map_poly ZtoQ q) = (p %| q)
Search _ gcdp.
Search _ size 1%N.
mul_polyC: forall (R : ringType) (a : R) (p : {poly R}), a%:P * p = a *: p
size1_polyC: forall (R : ringType) (p : {poly R}), (size p <= 1)%N -> p = (p`_0)%:P
dvdp_gcd_idr: forall (R : idomainType) (m n : {poly R}), n %| m -> gcdp m n %= n
leq_gcdpr: forall (R : idomainType) (p q : {poly R}), q != 0 -> (size (gcdp p q) <= size q)%N
separable_root:
  forall (R : idomainType) (p : {poly R}) (x : R),
  separable_poly (p * ('X - x%:P)) = separable_poly p && ~~ root p x

irredp_XsubC: forall (R : idomainType) (x : R), irreducible_poly ('X - x%:P)
poly2_root: forall (F : fieldType) (p : {poly F}), size p = 2 -> {r : F | root p r}

About poly_caract_int.

About algebraic0.
About sigW.
Check (sigW (poly_caract_int (algebraic0 (ratr_rmorphism complexR_numFieldType)))).
*)

Lemma polyMinseq (n : nat) (f : {ffun 'I_n -> complexR}) :
  (forall i : 'I_n, f i is_algebraic) ->
  {p : {poly complexR} | [&& [forall i, root p (f i)],
  separable_poly p, p != 0, p \is a polyOver Cint & (0 < lead_coef p)]}.
Proof.
move=> f_alg; pose p i := polyMinZ (f_alg i); pose Pp := \prod_(i < n) p i.
have Pp_neq0 : Pp != 0 by apply/prodf_neq0 => i _; rewrite /p polyMinZ_neq0.
pose P := psep (map_poly ZtoQ Pp).
have ZtoQtoC : QtoC \o intr =1 ZtoC by move=> y /=; rewrite ratr_int.
have rootP i : root (map_poly QtoC P) (f i).
  apply: psep_root; rewrite ?map_poly_eq0_id0 ?intr_eq0 ?lead_coef_eq0 //.
  rewrite -map_poly_comp (eq_map_poly ZtoQtoC) rmorph_prod /=.
  apply/rootPt; rewrite horner_prod; apply/prodf_eq0; exists i => //.
  by apply/rootPt /polyMinZ_root.
have Psep : separable_poly (map_poly QtoC P).
  rewrite separable_map psep_separable ?map_poly_eq0_id0 //.
  by rewrite intr_eq0 lead_coef_eq0.
have P_neq0 : P != 0.
  by rewrite psep_neq0 // map_poly_eq0_id0 ?intr_eq0 ?lead_coef_eq0.
have : {q : {poly int} & {a : int_ZmodType | (0 < lead_coef q)
       & P = a%:~R^-1 *: map_poly ZtoQ q}}.
  have [p_ [a /negbTE a_neq0 eq_p_p_]] := rat_poly_scale P.
  have lc_p_ : lead_coef p_ != 0.
    rewrite lead_coef_eq0; apply/negP => /eqP p__eq0.
    rewrite p__eq0 map_poly0 scaler0 in eq_p_p_.
    by rewrite eq_p_p_ eq_refl in P_neq0.
  exists ((sgr (lead_coef p_)) *: p_); exists ((sgr (lead_coef p_)) * a).
    by rewrite lead_coefZ -normrEsg normr_gt0.
  rewrite eq_p_p_ map_polyZ rmorphM invfM /=; set x := (sgr _)%:~R.
  by rewrite scalerA mulrC mulrA mulfV ?mul1r ?intr_eq0 ?sgr_eq0.
move=> [p_ [a a_gt0 eq_P_p_]].
have a_neq0 : QtoC a%:~R != 0.
  rewrite ratr_eq0; apply/negP => /eqP a_eq0.
  by rewrite a_eq0 invr0 scale0r in eq_P_p_; rewrite eq_P_p_ eq_refl in P_neq0.
have eq_p__P : map_poly ZtoC p_ = map_poly QtoC (a%:~R *: P).
  rewrite eq_P_p_ scalerA mulfV -?ratr_eq0 // scale1r -map_poly_comp.
  by apply: eq_map_poly.
exists ((ratr a%:~R) *: (map_poly QtoC P)); apply/and5P; split.
+ by apply/forallP => i; rewrite rootZ.
+ by rewrite separable_polyZ.
+ by rewrite scale_poly_eq0 negb_or a_neq0 andTb map_poly_eq0.
+ rewrite -map_polyZ -eq_p__P;
  by apply/polyOverP => i; rewrite coef_map Cint_int.
+ rewrite -map_polyZ -eq_p__P lead_coef_map_eq ?ltr0z //.
  rewrite intr_eq0 lead_coef_eq0; apply/negP => /eqP eq_p_.
by rewrite eq_p_ map_poly0 scaler0 in eq_P_p_; rewrite eq_P_p_ eq_refl in P_neq0.
Qed.

(*
Lemma polyMin_subproof (x : complexR) : x is_algebraic -> x != 0 ->
    {p : {poly int} | [&& (p != 0), root (map_poly ZtoC p) x,
    (p`_0 != 0), (0 < lead_coef p) & separable_poly (map_poly ZtoC p)]}.
Proof.
move => x_alg x_neq0.
have [p /and5P] := (sigW (poly_caract_int x_alg x_neq0)).
move => [p_neq0 rootp p0_neq0 lc_gt0 p_sep].
by exists p; rewrite p_neq0 rootp p0_neq0 lc_gt0 p_sep.
Qed.

Definition polyMin (x : complexR) (H : x is_algebraic) :=
  match Sumbool.sumbool_of_bool(x != 0) with
  |right _ => 'X
  |left toto => sval(polyMin_subproof H toto)
  end.

Lemma polyMin_neq0 (x : complexR) (H : x is_algebraic) : (polyMin H) != 0.
Proof.
rewrite /polyMin.
case : ((Sumbool.sumbool_of_bool (x != 0))) => [a | _]; last first.
  by rewrite polyX_eq0.
by move: (svalP (polyMin_subproof H a)) => /and5P[].
Qed.

Lemma polyMin_root (x : complexR) (H : x is_algebraic) :
  root (map_poly ZtoC (polyMin H)) x.
Proof.
rewrite /polyMin.
case : ((Sumbool.sumbool_of_bool (x != 0))) => [a | /eqP ->]; last first.
  by rewrite map_polyX rootX.
by move: (svalP (polyMin_subproof H a)) => /and5P[].
Qed.

Lemma polyMin_lcoef_gt0 (x : complexR) (H : x is_algebraic) :
  0 < lead_coef (polyMin H).
Proof.
rewrite /polyMin.
case : ((Sumbool.sumbool_of_bool (x != 0))) => [a | _]; last first.
  by rewrite lead_coefX.
by move: (svalP (polyMin_subproof H a)) => /and5P[].
Qed.

Lemma polyMin_coef0_neq0 (x : complexR) (H : x is_algebraic) :
  ((polyMin H)`_0 == 0) = (x == 0).
Proof.
rewrite /polyMin.
case : ((Sumbool.sumbool_of_bool (x != 0))) => [a | /eqP ->]; last first.
  by rewrite coefX eq_refl.
move: (svalP (polyMin_subproof H a)) => /and5P[_ _ /negbTE -> _ _].
by apply/eqP; rewrite eq_sym; apply/eqP/negbTE; rewrite a.
Qed.

Lemma polyMin_separable (x : complexR) (H : x is_algebraic) :
  separable_poly (map_poly ZtoC (polyMin H)).
Proof.
rewrite /polyMin.
case : ((Sumbool.sumbool_of_bool (x != 0))) => [a | _]; last first.
  by rewrite /separable_poly deriv_map derivX rmorph1 coprimep1.
by move: (svalP (polyMin_subproof H a)) => /and5P[].
Qed.

*)

End MinPoly.

(* Inutile ici ?
Lemma Euler :
  1 + Cexp (PI%:C * 'i) = 0.
Proof.
rewrite /Cexp ImiRe ReiNIm -complexr0 /= cos_PI sin_PI !complexr0.
rewrite oppr0 exp_0 mul1r; apply/eqP.
by rewrite eq_complex /= addr0 addrN eq_refl.
Qed. *)

(* Utile ?
Lemma ReM (x : complexR) y :
  Re_R (x * (RtoC y)) = (Re_R x) * y.
Proof. by rewrite real_complexE; case: x => r i /=; rewrite !C_simpl. Qed.

Lemma ImM (x : complexR) y :
  Im (x * y%:C) = (Im x) * y.
Proof.
rewrite real_complexE; case: x => r i.
by rewrite mulcalc /= mulr0 add0r.
Qed.

Lemma ReX (y : R) n :
  Re (y%:C ^+ n) = y ^+ n.
Proof.
elim: n => [| n Ihn].
  by rewrite !expr0 /=.
by rewrite !exprS mulrC ReM Ihn mulrC.
Qed.

Lemma ImX (y : R) n :
  Im (y%:C ^+ n) = 0.
Proof.
elim: n => [| n Ihn].
  by rewrite !expr0 /=.
by rewrite !exprS mulrC ImM Ihn mul0r.
Qed. *)


(*
  Author(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) TU Dortmund University, Dortmund, Germany
*)

(*
  Reduction(s):
    Halting of Minsky machines with two counters (MM2_HALTING) to
    Halting of Minsky machines with two counters starting from (0, 0) (MM2_ZERO_HALTING)
*)

Require Import List PeanoNat Lia Relations.Relation_Operators Relations.Operators_Properties.

Require Import Undecidability.MinskyMachines.MM2.
Require Import Undecidability.MinskyMachines.Util.MM2_facts.

Require Undecidability.Shared.deterministic_simulation.
Module sim := deterministic_simulation.

Require Import ssreflect ssrbool ssrfun.

Set Default Goal Selector "!".

Module Argument.
Section MM2_MM2.
  Variables (M : list mm2_instr) (a0 b0 : nat).

  Local Notation mm2_state := (nat*(nat*nat))%type.
  Local Notation mm2_reaches x y := (clos_refl_trans mm2_state (mm2_step M) x y).

  Definition shift_instr (mm2i : mm2_instr) : mm2_instr :=
    match mm2i with
    | mm2_dec_a q => mm2_dec_a (if q is 0 then 0 else q+a0+b0)
    | mm2_dec_b q => mm2_dec_b (if q is 0 then 0 else q+a0+b0)
    | _ => mm2i
    end.

  Definition shift_state (x : mm2_state) : mm2_state :=
    match x with
    | (p, (a, b)) => ((if p is 0 then 0 else p+a0+b0), (a, b))
    end.

  Definition M' := repeat mm2_inc_a a0 ++ repeat mm2_inc_b b0 ++ map shift_instr M.

  Local Notation mm2'_reaches x y := (clos_refl_trans mm2_state (mm2_step M') x y).

  Lemma length_M' : length M' = a0+b0+length M.
  Proof.
    by rewrite /M' !app_length !repeat_length map_length Nat.add_assoc.
  Qed.

  Lemma init_a0 n : n <= a0 -> mm2'_reaches (1, (0, 0)) (1+n, (n, 0)).
  Proof.
    elim: n. { move=> _. by apply: rt_refl. }
    move=> n IH ?. apply: rt_trans; [|apply: rt_step].
    - apply: IH. lia.
    - exists mm2_inc_a. split; [|constructor].
      rewrite /M'. apply /nth_error_Some_mm2_instr_at_iff.
      rewrite nth_error_app1. { by rewrite repeat_length. }
      by apply: nth_error_repeat.
  Qed.

  Lemma init_b0 n : n <= b0 -> mm2'_reaches (1+a0, (a0, 0)) (1+a0+n, (a0, n)).
  Proof.
    elim: n. { move=> _. rewrite Nat.add_0_r. by apply: rt_refl. }
    move=> n IH ?. apply: rt_trans; [|apply: rt_step].
    - apply: IH. lia.
    - exists mm2_inc_b. have ->: 1 + a0 + S n = S (1 + a0 + n) by lia.
      split; [|constructor].
      rewrite /M' /=. apply /nth_error_Some_mm2_instr_at_iff.
      rewrite nth_error_app2 repeat_length. { lia. }
      rewrite nth_error_app1. { rewrite repeat_length. lia. }
      apply: nth_error_repeat. lia.
  Qed.

  Lemma init_a0b0 : mm2'_reaches (1, (0, 0)) (1+a0+b0, (a0, b0)).
  Proof.
    by apply: rt_trans; [apply: (init_a0 a0)|apply: (init_b0 b0)].
  Qed.

  Lemma instr_at' mm2i p : mm2_instr_at mm2i p M -> mm2_instr_at (shift_instr mm2i) (p+a0+b0) M'.
  Proof.
    move=> /[dup] /mm2_instr_at_pos -> /nth_error_Some_mm2_instr_at_iff Hp /=.
    apply /nth_error_Some_mm2_instr_at_iff.
    rewrite /M'.
    rewrite nth_error_app2 repeat_length. { lia. }
    rewrite nth_error_app2 repeat_length. { lia. }
    have -> : Nat.pred p + a0 + b0 - a0 - b0 = Nat.pred p by lia.
    by rewrite nth_error_map Hp.
  Qed.

  Lemma mm2_step_sim x y :
    mm2_step M x y ->
    mm2_step M' (shift_state x) (shift_state y).
  Proof.
    move=> > [] instr [Hinstr Hxy].
    case: Hxy Hinstr.
    all: move=> > /= /[dup] /mm2_instr_at_pos -> /instr_at' H'instr;
      (eexists; by split; [eassumption|constructor]).
  Qed.

  Definition sync x x' := shift_state x = x'.

  Lemma mm2_step_sim' x y x' :
    mm2_step M x y -> sync x x' -> exists y', clos_trans _ (mm2_step M') x' y' /\ sync y y'.
  Proof.
    move=> /mm2_step_sim Hxy. rewrite /sync => <-.
    exists (shift_state y). by split; [apply: t_step|].
  Qed.

  Lemma mm2_stuck_sim' x x' :
    sim.stuck (mm2_step M) x -> sync x x' -> sim.terminates (mm2_step M') x'.
  Proof.
    rewrite /sync => /mm2_stop_index_iff Hx <-. exists (shift_state x).
    split; [apply: rt_refl|].
    apply /mm2_stop_index_iff.
    rewrite length_M'.
    move: x Hx => [[|p] [a b]] /=; lia.
  Qed.

  Lemma transport : MM2_HALTING (M, a0, b0) -> MM2_ZERO_HALTING M'.
  Proof.
    have Hsim := sim.terminates_transport mm2_step_sim' mm2_stuck_sim'.
    move=> /Hsim => /(_ _ erefl) [y [Hxy Hy]].
    exists y. split; [|done].
    by apply: rt_trans; [apply: init_a0b0|apply: Hxy].
  Qed.

  Lemma reflection : MM2_ZERO_HALTING M' -> MM2_HALTING (M, a0, b0).
  Proof.
    move=> [y'] [Hxy' Hy']. have Hinit := init_a0b0.
    have Hx'y' : mm2'_reaches (shift_state (1, (a0, b0))) y'.
    { have [z [/mm2_steps_stop_refl Hyz Hinitz]] := mm2_steps_confluent Hxy' Hinit.
      by rewrite -(Hyz Hy'). }
    have Hsim := sim.terminates_reflection (@mm2_step_det M') mm2_step_sim' (mm2_exists_step_dec M).
    apply: (Hsim _ _ erefl).
    by exists y'.
  Qed.

End MM2_MM2.
End Argument.

Require Import Undecidability.Synthetic.Definitions.

(* halting of Minsky machines with two counters
   many-one reduces to
   halting of Minsky machines with two counters starting from (0, 0) *)
Theorem reduction : MM2_HALTING ⪯ MM2_ZERO_HALTING.
Proof.
  exists (fun '(P, a0, b0) => Argument.M' P a0 b0).
  intros [[P a0] b0]. constructor.
  - apply Argument.transport.
  - apply Argument.reflection.
Qed.


Require Import Coq.ZArith.BinInt.
Require Import riscv.Encode.
Require Import riscv.util.ZBitOps.
Require Import riscv.util.prove_Zeq_bitwise.

Lemma invert_encode_S: forall {opcode rs1 rs2 funct3 simm12},
  verify_S opcode rs1 rs2 funct3 simm12 ->
  forall inst,
  encode_S opcode rs1 rs2 funct3 simm12 = inst ->
  opcode = bitSlice inst 0 7 /\
  funct3 = bitSlice inst 12 15 /\
  rs1 = bitSlice inst 15 20 /\
  rs2 = bitSlice inst 20 25 /\
  simm12 = signExtend 12 (Z.shiftl (bitSlice inst 25 32) 5 <|> bitSlice inst 7 12).
Proof. intros. unfold encode_S, verify_S in *. prove_Zeq_bitwise. Qed.


From QuickChick Require Import QuickChick.
Import QcDefaultNotation. Open Scope qc_scope.
Import GenLow GenHigh.
Set Warnings "-extraction-opaque-accessed,-extraction".

Require Import List ZArith.
Import ListNotations.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import seq ssreflect ssrbool ssrnat eqtype.

(* end hide *)

(** ** Introduction *)

(** It is not uncommon during a verification effort to spend many
    hours attempting to prove a slightly false theorem, only to result
    in frustration when the mistake is realized and one needs to start
    over. Other theorem provers have testing tools to quickly raise
    one's confidence before embarking on the body of the proof;
    Isabelle has its own QuickCheck clone, as well as Nitpick,
    Sledgehammer and a variety of other tools; ACL2 has gone a step
    further using random testing to facilitate its
    automation. QuickChick is meant to fill this void for Coq.

    Consider the following short function [remove] that takes a
    natural number [x] and a list of nats [l] and proceeds to remove
    [x] from the list. While one might be tempted to pose the question
    "Is there a bug in this definition?", such a question has little
    meaning without an explicit specification. Here, [removeP]
    requires that after removing [x] from [l], the resulting list does
    not contain any occurences of [x]. *)

Fixpoint remove (x : nat) (l : list nat) : list nat :=
  match l with
    | []   => []
    | h::t => if beq_nat h x then t else h :: remove x t
  end.

Check remove.

Definition removeP (x : nat) (l : list nat) :=
  (~~ (existsb (fun y => beq_nat y x) (remove x l))).

(** For this simple example, it is not hard to "spot" the bug by
    inspection. We will use QuickChick to find out what is wrong.

    QuickChick provides a toplevel command [QuickChick] that receives
    as input an executable property and attempts to falsify it. *)

Print removeP.
QuickChick removeP.

(** Internally, the code is extracted to OCaml, compiled and ran to
obtain the output:
<<
    0

    [ 0, 0 ]

    Failed! After 17 tests and 12 shrinks
>>
    The output signifies that if we use an input where [x] is [0] and
    [l] is the two element list containing two zeros, then our
    property fails. Indeed, we can now identify that the [then] branch
    of [remove] fails to make a recursive call, which means that only
    one occurence of each element will be deleted. The last line of
    the output states that it took 17 tests to identify some fault
    inducing input and 12 shrinks to reduce it to a minimal
    counterexample.

    Before we begin to explain exactly how QuickChick magically comes
    up with this result, it is important to point out the first (and
    arguably most important) limitation of this tool: it requires an
    *executable* specification. QuickChick needs to be able to "run" a
    property and decide whether it is true or not; a definition like
    [remove_spec] can't be QuickChecked! *)

Definition remove_spec :=
  forall x l, ~ In x (remove x l).

(** QuickChick requires either a functional spec (like [removeP]) or a
    decidability procedure for an inductive spec. *)

(** ** Property Based Random Testing Ingredients

    There are four basic ingredients in property based random testing:

    - An executable property, as discussed above
    - A printer, to report counterexamples found
    - A generator, to produce random inputs
    - A shrinker, to reduce counterexamples.

    We will now review the latter three in order. *)

(** *** Printing

    For printing, QuickChick uses a [Show] typeclass, like Haskell. *)

Print Show.
(**  ==> Record Show (A : Type) : Type
            := Build_Show { show : A -> String.string }   *)

(** The [Show] typeclass contains a single function [show] from some
    type [A] to Coq's [string]. QuickChick provides default instances
    for [string]s (the identity function), [nat], [bool], [Z],
    etc. (via extraction to appropriate OCaml functions for
    efficiency), as well as some common compound datatypes: lists,
    pairs and options.

    Writing your own show instance is easy! Let's define a simple
    [Color] datatype. *)

Inductive Color := Red | Green | Blue | Yellow.

(** After ensuring we have opened the [string] scope, we can declare
    an instance of [Show Color] by encoding [show] as a simple pattern
    matching on colors. *)

Require Import String. Open Scope string.
Instance show_color : Show Color :=
  {| show c :=
       match c with
         | Red    => "Red"
         | Green  => "Green"
         | Blue   => "Blue"
         | Yellow => "Yellow"
       end
  |}.

Eval compute in (show Green).
(** ==> "Green" : string *)

(** While writing show instances is relatively straightforward, it can
    get tedious.  The QuickChick provides a lot of automation, which
    will be discussed at the end of this Tutorial. *)

(** *** Generators *)

(** **** The [G] Monad *)

(** The heart of property based random testing is the random
    generation of inputs.  In QuickChick, a generator for elements of
    some type [A] is a monadic object with type [G A]. The monad [G]
    serves as an abstraction over random seed plumbing. Consider
    writing a program that given a random seed generates many
    integers: one needs to use the given seed to produce an integer
    while at the same time obtain a new, altered seed to use for
    future draws. This [State]-monad like behavior is hidden behind
    [G].

    Standard monadic functions have the [Gen] suffix. *)

Check bindGen.
(** ==> bindGen : G ?A -> (?A -> G ?B) -> G ?B *)

Check returnGen.
(** ==> returnGen : ?A -> G ?A *)

(** For those familiar with Haskell's monadic interface, QuickChick
    also provides variants of [liftM] (as [liftGen]) with arities 1 to
    5, [sequence] (as [sequenceGen]) and [foldM] (as [foldGen]). *)

(** **** Primitive generators *)

(** Primitive generators for booleans, natural numbers and integers
    are provided via extraction to OCaml. They can be accessed via the
    [choose] combinator.
 *)

Check choose.
(** ==> choose : Z * Z -> G Z *)

(** While here [choose] is monomorphised to [Z], it actually takes an
    interval of any type [A] that satisfies a [ChoosableFromInterval]
    typeclass (with default standard numeric instances) and produces
    an object of type [A] within that interval.

    We can see that in action using [Sample]. This is another toplevel
    command by QuickChick that runs a generator a number of times and
    prints whatever was generated in the form of a list. *)

Sample (choose(0, 10)).
(** ==> [ 1, 2, 1, 9, 8, 1, 3, 6, 2, 1, 8, 0, 1, 1, 3, 5, 4, 10, 4, 6 ] *)

(** **** Lists *)

(** Due to being the most commonly used compound datatype, lists have
    special combinators in Haskell's QuickCheck. The same is true in
    QuickChick; there are two combinators, [listOf] and [vectorOf]. *)

Check listOf.
(** ==> listOf : G ?A -> G (list ?A) *)

(** [listOf] takes as input a generator for elements of type [A] and returns a
    generator for lists of the same type. *)

Sample (listOf (choose (0,4))).
(** ==> [ [ 0, 3, 2, 0 ],
         [ 1, 3, 4, 1, 0, 3, 0, 2, 2, 3, 2, 2, 2, 0, 4, 2, 3, 0, 1 ],
         [ 3, 4, 3, 1, 2, 4, 4, 1, 0, 3, 4, 3, 2, 2, 4, 4, 1 ],
         [ 0 ],
         [ 4, 2, 3 ],
         [ 3, 3, 4, 0, 1, 4, 3, 2, 4, 1 ],
         [ 0, 4 ],
         [  ],
         [ 1, 0, 1, 3, 1 ],
         [ 0, 0 ],
         [ 1, 4 ],
         [ 4, 3, 2, 0, 2, 2, 4, 0 ],
         [ 1, 1, 0, 0, 1, 4 ],
         [ 2, 0, 2, 1, 3, 3 ],
         [ 4, 3, 3, 0, 1 ],
         [ 3, 3, 3 ],
         [ 3, 2, 4 ],
         [ 1, 2 ],
         [  ],
         [  ]
       ]
*)

(** The second combinator, [vectorOf], receives an additional numeric
    argument [n], the length of the list to be generated. *)

Check vectorOf.
(** ==> vectorOf : nat -> G ?A -> G (list ?A) *)

(** This raises a question: how does [listOf] decide how big of a list
    to generate? The answer is hidden inside the [G] monad.

    In addition to handling random seed plumbing, the [G] monad also
    provides a [Reader]-like environment with size information: a
    natural number [n] that nominally serves as the upper bound on the
    depth of the generated objects.  QuickChick progressively tries
    larger and larger values for [n], in order to explore larger and
    deeper part of the search space. Note that each generator can
    choose to interpret this input size however it wants and there is
    no guarantee that all generators comply to this standard - it is
    more of a "good practice" when writing one to respect this
    bound. *)

(** **** Custom Datatypes *)

(** Naturally, a lot of the time one needs to write generators involving
    user-defined datatypes. Let's revisit our color datatype; to generate a
    color, we only need to pick one of its four constructors, [Red], [Green],
    [Blue] and [Yellow]. This is done using [elements]. *)

Check elements.
(** ==> elements : ?A -> list ?A -> G ?A *)

(** This is the first place where the totality checker of Coq raises a
    design question. While Haskell's QuickCheck can simply fail
    raising an [error] whenever the input list is empty, Coq does not
    allow that behavior. Instead of increasing the burden to the user
    by requiring a proof that the list is not empty or by making the
    return type an option, QuickChick requires an additional element
    of type [A] as input to serve as a "default" object.  If the list
    is not empty, [elements] returns a generator that picks an element
    of that list; otherwise the generator always returns the default
    object.

    Moreover, QuickChick provides convenient notation to hide this
    default if it is apparent from the structure. *)

(*
Notation            Scope
" 'elems' [ x ] " := elements x (cons x nil)
                      : qc_scope
                      (default interpretation)
" 'elems' [ x ; y ] " := elements x (cons x (cons y nil))
                      : qc_scope
                      (default interpretation)
" 'elems' [ x ; y ; .. ; z ] " := elements x
                                    (cons x (cons y .. (cons z nil) ..))
                      : qc_scope
                      (default interpretation)
" 'elems' ( x ;; l ) " := elements x (cons x l)
                      : qc_scope
                      (default interpretation)
*)

(** Armed with [elems], we can write the following simple [Color]
    generator. *)

Definition genColor : G Color :=
  elems [ Red ; Green ; Blue ; Yellow ].

Sample genColor.
(** ==> [ Blue, Red, Yellow, Red, Blue, Yellow, Yellow, Blue, Green, Red, Green,
         Blue, Blue, Red, Yellow, Blue, Red, Blue, Blue, Red ] *)

(** For more complicated ADTs, QuickChick provides more
    combinators. We will showcase them using everyone's favorite
    datatype: Trees!

    Our trees are standard binary trees; either [Leaf]s or [Node]s
    containing some payload of type [A] and two subtrees. *)

Inductive Tree A :=
| Leaf : Tree A
| Node : A -> Tree A -> Tree A -> Tree A.

Arguments Leaf {A}.
Arguments Node {A} _ _ _.

(** Before getting to generators for trees, we give a simple [Show]
    instance.  The rather inconvenient need for a local [let fix]
    declaration stems from the fact that Coq's typeclasses (unlike
    Haskell's) are not automatically recursive. *)

Instance showTree {A} `{_ : Show A} : Show (Tree A) :=
  {| show :=
       let fix aux t :=
         match t with
           | Leaf => "Leaf"
           | Node x l r => "Node (" ++ show x ++ ") (" ++ aux l ++ ") (" ++ aux r ++ ")"
         end
       in aux
  |}.

(** The first combinator that actually combines different generators
    is [oneof]. *)

Check oneof.
(** ==> oneof : G ?A -> list (G ?A) -> G ?A *)

(** [oneof] takes a default generator and a list of generators, and
    picks one of the generators from the list uniformly at random, as
    long as the list is not empty.  Just like before, QuickChick
    introduces the notation [oneOf] to hide this default element.

    At this point, Coq's termination checker saves us from shooting
    ourselves in the foot. The "obvious" first generator that one
    might write is the following [genTree]: either generate a [Leaf]
    or a [Node] whose subtrees are generated recursively and whose
    payload is produced by a generator for elements of type [A].*)

(*
Fixpoint genTree {A} (g : G A) : G (Tree A) :=
  oneOf [ returnGen Leaf ;
          liftGen3 Node  g (genTree g) (genTree g) ].*)

(** Of course, this fixpoint will not pass Coq's termination
    check. Attempting to justify this fixpoint to oneself, one might
    say that at some point the random generation will pick a [Leaf] so
    it will eventually terminate. Sadly, in this case the expected
    size of the generated Tree is infinite...

    The solution is the standard "fuel" solution Coq users are so
    familiar with: we add an additional natural number [sz] as a
    parameter; when that parameter is [O] we only generate
    non-recursive branches, while we decrease this size in each
    recursive call. Thus, [sz] serves as a bound on the depth of the
    tree.

 *)

Fixpoint genTreeSized {A} (sz : nat) (g : G A) : G (Tree A) :=
  match sz with
    | O => returnGen Leaf
    | S sz' => oneOf [ returnGen Leaf ;
                       liftGen3  Node g (genTreeSized sz' g) (genTreeSized sz' g)
                     ]
  end.

Sample (genTreeSized 3 (choose(0,3))).
(** ==> [ Leaf,
         Leaf,
         Node (3) (Node (0) (Leaf) (Leaf)) (Node (2) (Leaf) (Node (3) (Leaf) (Leaf))),
         Leaf,
         Leaf,
         Leaf,
         Node (1) (Leaf) (Node (1) (Leaf) (Node (0) (Leaf) (Leaf))),
         Leaf,
         Node (3) (Leaf) (Leaf),
         Node (1) (Leaf) (Leaf),
         Leaf,
         Leaf,
         Node (0) (Leaf) (Node (0) (Leaf) (Node (2) (Leaf) (Leaf))),
         Node (0) (Node (2) (Node (3) (Leaf) (Leaf)) (Leaf)) (Leaf),
         Node (0) (Leaf) (Leaf),
         Leaf,
         Leaf,
         Leaf,
         Leaf,
         Leaf ]
*)

(** While this generator succesfully generated trees, just by
    observing [Sample] above there is a problem: [genTreeSized]
    produces way too many [Leaf]s! That is to be expected, 50% of the
    time we generate a [Leaf]. The solution is to skew the
    distribution towards [Node]s, using the most expressive QuickChick
    combinator, [frequency] and its associated default-lifting
    notation [freq].
 *)
Check frequency.
(** ==> frequency : G ?A -> seq (nat * G ?A) -> G ?A *)

(** [freq] takes a list of generators, each one tagged with a natural
    number that serves as the weight of that generator. In the
    following example, a [Leaf] will be generated 1 / (sz + 1) of the
    time, while a [Node] the remaining sz / (sz + 1) of the time.*)

Fixpoint genTreeSized' {A} (sz : nat) (g : G A) : G (Tree A) :=
  match sz with
    | O => returnGen Leaf
    | S sz' => freq [ (1,  returnGen Leaf) ;
                      (sz, liftGen3  Node g (genTreeSized' sz' g) (genTreeSized' sz' g))
                    ]
  end.

Sample (genTreeSized' 3 (choose(0,3))).
(** ==> [ Node (3) (Node (1) (Node (3) (Leaf) (Leaf)) (Leaf)) (Node (0) (Leaf) (Node (3) (Leaf) (Leaf))),
         Leaf,
         Node (2) (Node (1) (Leaf) (Leaf)) (Leaf),
         Node (0) (Leaf) (Node (0) (Node (2) (Leaf) (Leaf)) (Node (0) (Leaf) (Leaf))),
         Node (1) (Node (2) (Leaf) (Node (0) (Leaf) (Leaf))) (Leaf),
         Node (0) (Node (0) (Leaf) (Node (3) (Leaf) (Leaf))) (Node (2) (Leaf) (Leaf)),
         Node (1) (Node (3) (Node (2) (Leaf) (Leaf)) (Node (3) (Leaf) (Leaf))) (Node (1) (Leaf) (Node (2) (Leaf) (Leaf))),
         Node (0) (Node (0) (Node (0) (Leaf) (Leaf)) (Node (1) (Leaf) (Leaf))) (Node (2) (Node (3) (Leaf) (Leaf)) (Node (0) (Leaf) (Leaf))),
         Node (2) (Node (2) (Leaf) (Leaf)) (Node (1) (Node (2) (Leaf) (Leaf)) (Node (2) (Leaf) (Leaf))),
         Node (2) (Node (3) (Node (2) (Leaf) (Leaf)) (Leaf)) (Node (0) (Node (2) (Leaf) (Leaf)) (Leaf)),
         Leaf,
         Node (2) (Node (3) (Node (3) (Leaf) (Leaf)) (Leaf)) (Leaf),
         Leaf,
         Node (1) (Leaf) (Leaf),
         Leaf,
         Node (1) (Node (2) (Leaf) (Node (3) (Leaf) (Leaf))) (Node (0) (Leaf) (Node (1) (Leaf) (Leaf))),
         Leaf,
         Node (3) (Node (0) (Node (0) (Leaf) (Leaf)) (Leaf)) (Node (0) (Leaf) (Node (2) (Leaf) (Leaf))),
         Node (2) (Node (2) (Node (0) (Leaf) (Leaf)) (Leaf)) (Node (1) (Leaf) (Node (2) (Leaf) (Leaf))),
         Leaf ]
 *)

(** To showcase this generator, we will use the notion of mirroring a
    tree: swapping its left and right subtrees recursively. *)

Fixpoint mirror {A : Type} (t : Tree A) : Tree A :=
  match t with
    | Leaf => Leaf
    | Node x l r => Node x (mirror r) (mirror l)
  end.

(** We also need a simple structural equality on trees *)
Fixpoint eq_tree (t1 t2 : Tree nat) : bool :=
  match t1, t2 with
    | Leaf, Leaf => true
    | Node x1 l1 r1, Node x2 l2 r2 =>
      beq_nat x1 x2 && eq_tree l1 l2 && eq_tree r1 r2
    | _, _ => false
  end.

(** One expects that [mirror] should be unipotent; mirroring a tree
    twice yields the original tree.  *)

Definition mirrorP (t : Tree nat) := eq_tree (mirror (mirror t)) t.

(** To test this assumption, we can use the [forAll] property
    combinator that receives a generator [g] for elements of type [A]
    and an executable property with argument [A] and tests the
    property on random inputs of [g]. *)

QuickChick (forAll (genTreeSized' 5 (choose (0,5))) mirrorP).

(** QuickChick quickly responds that this property passed 10000 tests,
    so we gain some confidence in its truth. But what would happend if
    we had the *wrong* property? *)

Definition faultyMirrorP (t : Tree nat) := eq_tree (mirror t) t.

Check forAll.

QuickChick (forAll (genTreeSized' 5 (choose (0,5))) faultyMirrorP).
(** ==> Node (3) (Node (0) (Leaf) (Node (0) (Node (1) (Leaf) (Leaf)) (Leaf)))
(Node (5) (Node (0) (Node (1) (Leaf) (Node (4) (Leaf) (Leaf))) (Node (4) (Leaf)
(Node (0) (Leaf) (Leaf)))) (Node (5) (Node (4) (Node (0) (Leaf) (Leaf)) (Leaf))
(Node (3) (Leaf) (Leaf))))

*** Failed! After 1 tests and 0 shrinks
*)

(** The bug is found immediately and reported. However, is this counterexample
    really helpful? What is the important part of it? The reported bug is too
    big and noisy to identify the root cause of the problem. That is where
    shrinking comes in. *)

(** **** Shrinking *)

(** Shrinking, also known as delta debugging, is a greedy process by
    which we can find a smaller counterexample given a relatively
    large one. Given a shrinking function [s] of type [A -> list A]
    and a counterexample [x] of type [A] that is known to falsify some
    property [p], QuickChick (lazily) tries [p] on all members of [s
    x] until it finds another counterexample; then it repeats this
    process.

    This greedy algorithm can only work if all elements of [s x] are
    strictly "smaller" that [x] for all [x]. Most of the time, a
    shrinking function for some type only returns elements that are
    "one step" smaller. For example, consider the default shrinking
    function for lists provided by QuickChick. *)

Print shrinkList.
(** ==> shrinkList =
     fix shrinkList (A : Type) (shr : A -> seq A) (l : seq A) {struct l} :
       seq (seq A) :=
       match l with
       | [::] => [::]
       | x :: xs =>
           ((xs :: List.map (fun xs' : seq A => x :: xs') (shrinkList A shr xs))%SEQ ++
            List.map (fun x' : A => (x' :: xs)%SEQ) (shr x))%list
       end
          : forall A : Type, (A -> seq A) -> seq A -> seq (seq A)
*)

(** An empty list can not be shrunk - there is no smaller list.  A
    cons cell can be shrunk in three ways: by returning the tail of
    the list, by shrinking the tail of the list and consing the head,
    or by shrinking the head and consing its tail. By induction, this
    process can generate all smaller lists.

    Writing a shrinking instance for trees is equally straightforward:
    we don't shrink [Leaf]s while for [Node]s we can return the left
    or right subtrees, shrink the payload or one of the subtrees.*)

Open Scope list.
Fixpoint shrinkTree {A} (s : A -> list A) (t : Tree A) : seq (Tree A) :=
  match t with
    | Leaf => []
    | Node x l r => [l] ++ [r] ++
                    map (fun x' => Node x' l r) (s x) ++
                    map (fun l' => Node x l' r) (shrinkTree s l) ++
                    map (fun r' => Node x l r') (shrinkTree s r)
  end.

(** Armed with [shrinkTree], we use the [forAllShrink] property
    combinator that takes an additional argument, a shrinker *)

QuickChick (forAllShrink (genTreeSized' 5 (choose (0,5))) (shrinkTree shrink) faultyMirrorP).

(** ==> Node (0) (Leaf) (Node (0) (Leaf) (Leaf))

*** Failed! After 1 tests and 8 shrinks *)

(** We now got a much simpler counterexample (in fact, this is one of
    the two minimal ones) and can tell that the real problem occurs
    when the subtrees of a [Node] are different. *)

(** **** Putting it all Together *)

(** QuickChick, just like QuickCheck, provides an [Arbitrary]
    typeclass parameterized over some type [A] with two objects:
    [arbitrary] and [shrink].

    The [arbitrary] object is a generator for elements of type [A]. If
    we were to encode an [Arbitrary] instance for trees we would like
    to use [genTreeSized']; however that generator takes an additional
    size argument.  The [G] monad will provide that argument through
    the combinator [sized].*)

Check sized.
(** ==> sized : (nat -> G ?A) -> G ?A *)

(** [sized] receives a function that given a number produces a
    generator, just like [genTreeSized'], and returns a generator that
    uses the size information inside the [G] monad.

    The [shrink] function is simply a shrinker like [shrinkTree]. *)

Instance genTree {A} `{Gen A} : GenSized (Tree A) :=
  {| arbitrarySized n := genTreeSized n arbitrary |}.

Instance shrTree {A} `{Shrink A} : Shrink (Tree A) :=
  {| shrink x := shrinkTree shrink x |}.

(** With this [Arbitrary] instance we can once again use the toplevel
    [QuickChick] command with just the property.  *)

QuickChick faultyMirrorP.

(** [QuickChick] internally calls the function [quickCheck] with type
    [forall prop. Checkable prop => prop -> Result]. But what _is_
    [Checkable]? It is easy to see how a boolean is [Checkable]; we
    can always tell if it is true or not and then return a [Result],
    [Success]/[Failure] as appropriate.

    To see how executable properties are [Checkable], consider a
    single argument function [p : A -> Bool] that returns a
    boolean. If we know that [A] has [Show] and [Arbitrary] instances,
    we can just call [forAllShrink] with [arbitrary] and
    [shrink]. Going a step further, the result type doesn't really
    need to be [Bool], it can be a [Checkable]! Thus, we can provide a
    [Checkable] instance for arbitrary functions.*)

Print testFun.

(** **** Collecting Statistics *)

(** Earlier in this tutorial we claimed that [genTreeSized] produced
    "too many" [Leaf]s. But how can we justify that? Just looking at
    the result of [Sample] gives us an idea that something is going
    wrong but just observing a handful of samples cannot realistically
    provide statistical guarantees. That is where [collect], another
    property combinator, comes in. In Haskell notation, [collect]
    would have the type [collect : Show A, Checkable prop => A -> prop
    -> prop]; it takes some value of type [A] that can be shown and a
    property, and returns the property itself. Whenever the resulting
    property is exercised, the [A] object is captured and statistics
    are collected.

    For example, consider a [size] function on [Tree]s.
 *)

Fixpoint size {A} (t : Tree A) : nat :=
  match t with
    | Leaf => O
    | Node _ l r => 1 + size l + size r
  end.

(** If we were to write a dummy property to check our generators and
    measure the size of generated trees, we could use [treeProp]
    below. *)

Definition treeProp (g : nat -> G nat -> G (Tree nat)) n :=
  forAll (g n (choose (0,n))) (fun t =>
  collect (size t) true).

QuickChick (treeProp genTreeSized  5).

(** ==>
4947 : 0
1258 : 1
673 : 2
464 : 6
427 : 5
393 : 3
361 : 7
302 : 4
296 : 8
220 : 9
181 : 10
127 : 11
104 : 12
83 : 13
64 : 14
32 : 15
25 : 16
16 : 17
13 : 18
6 : 19
5 : 20
2 : 21
1 : 23
+++ OK, passed 10000 tests

We see that 62.5% of the tests are either [Leaf]s or empty [Nodes], while too
few tests have larger sizes. Compare that with [genTreeSized'] below.  *)

QuickChick (treeProp genTreeSized' 5).
(** ==>
1624 : 0
571 : 10
564 : 12
562 : 11
559 : 9
545 : 8
539 : 14
534 : 13
487 : 7
487 : 15
437 : 16
413 : 6
390 : 17
337 : 5
334 : 1
332 : 18
286 : 19
185 : 4
179 : 20
179 : 2
138 : 21
132 : 3
87 : 22
62 : 23
19 : 24
10 : 25
6 : 26
2 : 27
+++ OK, passed 10000 tests

A lot fewer terms have small sizes, allowing us to explore larger terms*)

(** ** Avoiding Work  :) *)

(** While a lot of time putting a bit of time and effort in a
    generator and a shrinker, the examples shown here are fairly
    straightforward. After writing a couple of [Show] and [Arbitrary]
    instances, it can get tedious and boring. That is precisely why
    [QuickChick] provides some automation in deriving such instances
    for _plain_ datatypes automatically. *)

Derive Arbitrary for Tree.
(* GenSizedTree is defined *)
(* ShrinkTree is defined *)
Print GenSizedTree.
Print ShrinkTree.

Derive Show for Tree.
(* ShowTree is defined *)
Print ShowTree.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                                                                          *)
(*       Ordered sets                                                       *)
(*                                                                          *)
(*                                                                          *)
(****************************************************************************)
(*                                  Order.v                                 *)
(****************************************************************************)

Section VR.

Variable V : Set.          (* The Universe of discourse *)
Variable R : V -> V -> Prop.   (* Given with order relation R *)
Variable V_eq : V -> V -> Prop. (* and equality V_eq *)

Definition reflexivity := forall x : V, R x x.
Definition anti_symetry := forall x y : V, R x y -> R y x -> V_eq x y.
Definition transitivity := forall x y z : V, R x y -> R y z -> R x z.

Definition order := reflexivity /\ anti_symetry /\ transitivity.

Definition totality := forall x y : V, R x y \/ R y x.
Definition total_order := order /\ totality.

End VR.


Require Import Reals.
Require Import Lra.
Require Import Ensembles.
Require Import Ranalysis1.
Local Open Scope R_scope.

Definition x_squared (x : R) := x * x.

Definition closed_unit_interval := fun x => 0 <= x <= 1.
Definition open_unit_interval := fun x => 0 < x < 1.

Definition Open_Interval (a : R) (b : R) := fun x => a < x < b.

Record Interval : Type := mkinterval {a :> R; b :> R; H : a < b}.
Lemma zero_lt_one : 0 < 1. Proof. lra. Qed.
Definition zero_to_one := mkinterval 0 1 zero_lt_one.

Lemma xsquared_derivable : derivable x_squared.
Proof.
  unfold derivable, derivable_pt, derivable_pt_abs, derivable_pt_lim, x_squared.
  intros x.
  Admitted.

Definition derive_threex := derive x_squared xsquared_derivable.

Lemma conjugate_trick (a b : R) : a * a - b * b = (a - b) * (a + b).
Proof.
  lra.
Qed.

Lemma zero_numerator_equals_zero :
  forall (x y : R), x / y = 0 -> x = 0.
Proof.
  intros x y H.
  Admitted.

Theorem xsquared_continuous : continuity x_squared.
Proof.
  unfold continuity, continuity_pt, continue_in, no_cond, limit1_in, limit_in, dist, x_squared.
  simpl.
  unfold D_x.
  intros c eps H.
  exists (Rmin 1 (Rabs (eps / (2 * c + 1)))).
  split.
  - compute; destruct Rcase_abs as [| G1]; destruct Rle_dec as [| G2]; try lra.
    unfold not in G2.
    destruct G1; try lra.
    apply zero_numerator_equals_zero in H0.
    lra.
  - intros x G.
    destruct G as [G1 G2]; destruct G1 as [_ G].
    unfold R_dist, Rabs in *.
    destruct Rcase_abs as [| F] in G2;
      destruct Rcase_abs as [| E];
      destruct Rcase_abs as [| E'];
      compute in G2; destruct Rle_dec in G2;
        field_simplify; try lra.
Admitted.

Definition three_x (x : R) := 3 * x.

Theorem threex_continuous : continuity three_x.
Proof.
  unfold continuity, three_x.
  unfold continuity_pt, continue_in, limit1_in, limit_in, dist, D_x; simpl.
  intros x eps H.
  exists (eps/3).
  split; try lra.
  intros x0 G.
  unfold no_cond, R_dist in G.
  destruct G as [[_ G1] G2].
  unfold R_dist, Rabs.
  unfold Rabs in G2; destruct Rcase_abs in G2; destruct Rcase_abs; try lra.
Qed.

Lemma threex_derivable : derivable three_x.
Proof.
  unfold derivable, derivable_pt, derivable_pt_abs, derivable_pt_lim, three_x.
  intros x.
  simpl.
  Admitted.

Check derive.

Lemma threex_has_mean_value_property_on_0_1 :
  exists (c : R),
    0 < c < 1 /\ derive three_x threex_derivable c = (three_x 1 - three_x 0) / (1 - 0).
Proof.
  exists (1/2). (*any c in (0,1) will do.*)
  split; try lra.
  unfold derive, derive_pt, three_x.
  destruct threex_derivable as [c  G].
  unfold derivable_pt_abs, derivable_pt_lim in G.
  simpl.
  specialize (G 1).
  destruct G as [delt G]; try lra.
  unfold three_x in G.
  unfold Rabs in G.
  specialize (G 1).
  destruct Rcase_abs in G; try lra.
  assert (H : 1 <> 0). lra.
  specialize (G H).
  destruct Rcase_abs in G; try lra.
  destruct delt as [delt delt_pos].

Lemma xsquared_has_mean_value_property_on_minus1_1 :
    exists (c : R),
      (-1) < c < 1 ->
      derive x_squared xsquared_derivable c = (x_squared 1 - x_squared (-1)) / (1 - (-1)).
Proof.
  exists 0.
  intros H.
  unfold x_squared in *.
  unfold derive, derive_pt.
  rewrite conjugate_trick; field_simplify.
  destruct xsquared_derivable as [x G].
  unfold derivable_pt_abs, derivable_pt_lim in G.
  simpl.
  Admitted.

Theorem mean_value_theorem {a b : R}
        (f : R -> R) (H : derivable f) (A : Open_Interval a b) :
  exists (c : R), A c -> derive f H c = (f b - f a) / (b - a).


Require Export GeoCoq.Elements.OriginalProofs.lemma_NCdistinct.
Require Export GeoCoq.Elements.OriginalProofs.proposition_31short.
Require Export GeoCoq.Elements.OriginalProofs.lemma_collinearparallel.
Require Export GeoCoq.Elements.OriginalProofs.proposition_29.

Section Euclid.

Context `{Ax:euclidean_euclidean}.

Lemma proposition_32 :
   forall A B C D,
   Triangle A B C -> BetS B C D ->
   SumA C A B A B C A C D.
Proof.
intros.
assert (nCol A B C) by (conclude_def Triangle ).
assert (neq B A) by (forward_using lemma_NCdistinct).
assert (neq A B) by (conclude lemma_inequalitysymmetric).
let Tf:=fresh in
assert (Tf:exists F, (BetS B A F /\ Cong A F B A)) by (conclude lemma_extension);destruct Tf as [F];spliter.
assert (Col B A F) by (conclude_def Col ).
assert (Col A B F) by (forward_using lemma_collinearorder).
assert (eq B B) by (conclude cn_equalityreflexive).
assert (Col A B B) by (conclude_def Col ).
assert (neq B F) by (forward_using lemma_betweennotequal).
assert (neq F B) by (conclude lemma_inequalitysymmetric).
assert (nCol F B C) by (conclude lemma_NChelper).
assert (BetS F A B) by (conclude axiom_betweennesssymmetry).
rename_H H;let Tf:=fresh in
assert (Tf:exists E H S, (BetS E C H /\ CongA E C A C A B /\ Par E H F B /\ BetS E S B /\ BetS C S A)) by (conclude proposition_31short);destruct Tf as [E[H[S]]];spliter.
assert (neq B C) by (forward_using lemma_betweennotequal).
assert (neq C B) by (conclude lemma_inequalitysymmetric).
let Tf:=fresh in
assert (Tf:exists G, (BetS C B G /\ Cong B G C B)) by (conclude lemma_extension);destruct Tf as [G];spliter.
assert (neq C A) by (forward_using lemma_NCdistinct).
let Tf:=fresh in
assert (Tf:exists J, (BetS C A J /\ Cong A J C A)) by (conclude lemma_extension);destruct Tf as [J];spliter.
assert (neq A C) by (conclude lemma_inequalitysymmetric).
let Tf:=fresh in
assert (Tf:exists K, (BetS A C K /\ Cong C K A C)) by (conclude lemma_extension);destruct Tf as [K];spliter.
let Tf:=fresh in
assert (Tf:exists M, (BetS A B M /\ Cong B M A B)) by (conclude lemma_extension);destruct Tf as [M];spliter.
assert (Col F B A) by (forward_using lemma_collinearorder).
assert (Par E H A B) by (conclude lemma_collinearparallel).
assert (BetS K C A) by (conclude axiom_betweennesssymmetry).
assert (Col C S A) by (conclude_def Col ).
assert (Col C A S) by (forward_using lemma_collinearorder).
assert (nCol A C B) by (forward_using lemma_NCorder).
assert (Col A C S) by (forward_using lemma_collinearorder).
assert (neq C S) by (forward_using lemma_betweennotequal).
assert (neq S C) by (conclude lemma_inequalitysymmetric).
assert (eq C C) by (conclude cn_equalityreflexive).
assert (Col A C C) by (conclude_def Col ).
assert (nCol S C B) by (conclude lemma_NChelper).
assert (nCol B S C) by (forward_using lemma_NCorder).
assert (Col E S B) by (conclude_def Col ).
assert (Col B S E) by (forward_using lemma_collinearorder).
assert (eq B B) by (conclude cn_equalityreflexive).
assert (Col B S B) by (conclude_def Col ).
assert (BetS B S E) by (conclude axiom_betweennesssymmetry).
assert (neq B E) by (forward_using lemma_betweennotequal).
assert (nCol B E C) by (conclude lemma_NChelper).
assert (Col B E S) by (forward_using lemma_collinearorder).
assert (eq E E) by (conclude cn_equalityreflexive).
assert (Col B E E) by (conclude_def Col ).
assert (neq S E) by (forward_using lemma_betweennotequal).
assert (nCol S E C) by (conclude lemma_NChelper).
assert (nCol S C E) by (forward_using lemma_NCorder).
assert (Col S C C) by (conclude_def Col ).
assert (Col C S A) by (conclude_def Col ).
assert (Col S C A) by (forward_using lemma_collinearorder).
assert (neq C A) by (forward_using lemma_betweennotequal).
assert (nCol C A E) by (conclude lemma_NChelper).
assert (Col A B M) by (conclude_def Col ).
assert (Col B A M) by (forward_using lemma_collinearorder).
assert (Par E H B A) by (forward_using lemma_parallelflip).
assert (neq A M) by (forward_using lemma_betweennotequal).
assert (neq M A) by (conclude lemma_inequalitysymmetric).
assert (Par E H M A) by (conclude lemma_collinearparallel).
assert (BetS H C E) by (conclude axiom_betweennesssymmetry).
assert (BetS M B A) by (conclude axiom_betweennesssymmetry).
assert (BetS F A B) by (conclude axiom_betweennesssymmetry).
assert (BetS D C B) by (conclude axiom_betweennesssymmetry).
assert (nCol B C A) by (forward_using lemma_NCorder).
assert (nCol A C B) by (forward_using lemma_NCorder).
assert (eq A A) by (conclude cn_equalityreflexive).
assert (neq B E) by (forward_using lemma_betweennotequal).
assert (BetS E C H) by (conclude axiom_betweennesssymmetry).
assert (BetS A S C) by (conclude axiom_betweennesssymmetry).
assert (nCol C E A) by (forward_using lemma_NCorder).
assert (Col C E H) by (conclude_def Col ).
assert (Col C E E) by (conclude_def Col ).
assert (neq E H) by (forward_using lemma_betweennotequal).
assert (neq H E) by (conclude lemma_inequalitysymmetric).
assert (nCol H E A) by (conclude lemma_NChelper).
assert (nCol E H A) by (forward_using lemma_NCorder).
let Tf:=fresh in
assert (Tf:exists Q, (BetS A Q H /\ BetS E S Q)) by (conclude postulate_Pasch_outer);destruct Tf as [Q];spliter.
assert (Col E S Q) by (conclude_def Col ).
assert (Col S E B) by (forward_using lemma_collinearorder).
assert (Col S E Q) by (forward_using lemma_collinearorder).
assert (Col E B Q) by (conclude lemma_collinear4).
assert (Col B E Q) by (forward_using lemma_collinearorder).
assert (neq H E) by (forward_using lemma_betweennotequal).
assert (neq C E) by (forward_using lemma_betweennotequal).
let Tf:=fresh in
assert (Tf:exists L, (BetS H E L /\ Cong E L C E)) by (conclude lemma_extension);destruct Tf as [L];spliter.
assert (BetS L E H) by (conclude axiom_betweennesssymmetry).
assert (Col L E H) by (conclude_def Col ).
assert (neq L H) by (forward_using lemma_betweennotequal).
assert (neq E H) by (forward_using lemma_betweennotequal).
assert (Col A B M) by (conclude_def Col ).
assert (neq A M) by (forward_using lemma_betweennotequal).
assert (neq A B) by (forward_using lemma_betweennotequal).
assert (~ Meet A M L H).
 {
 intro.
 let Tf:=fresh in
 assert (Tf:exists c, (neq A M /\ neq L H /\ Col A M c /\ Col L H c)) by (conclude_def Meet );destruct Tf as [c];spliter.
 assert (Col H E L) by (conclude_def Col ).
 assert (Col L H E) by (forward_using lemma_collinearorder).
 assert (neq H L) by (forward_using lemma_betweennotequal).
 assert (neq L H) by (conclude lemma_inequalitysymmetric).
 assert (Col H c E) by (conclude lemma_collinear4).
 assert (Col E H c) by (forward_using lemma_collinearorder).
 assert (Col A B M) by (conclude_def Col ).
 assert (Col M A B) by (forward_using lemma_collinearorder).
 assert (Col M A c) by (forward_using lemma_collinearorder).
 assert (neq A M) by (forward_using lemma_betweennotequal).
 assert (neq M A) by (conclude lemma_inequalitysymmetric).
 assert (Col A B c) by (conclude lemma_collinear4).
 assert (Col B A F) by (conclude_def Col ).
 assert (Col A B F) by (forward_using lemma_collinearorder).
 assert (Col B c F) by (conclude lemma_collinear4).
 assert (Col F B c) by (forward_using lemma_collinearorder).
 assert (Meet E H F B) by (conclude_def Meet ).
 assert (~ Meet E H F B) by (conclude_def Par ).
 contradict.
 }
assert (BetS B Q E) by (conclude lemma_collinearbetween).
assert (nCol A H E) by (forward_using lemma_NCorder).
assert (Col A Q H) by (conclude_def Col ).
assert (Col A H Q) by (forward_using lemma_collinearorder).
assert (eq H H) by (conclude cn_equalityreflexive).
assert (Col A H H) by (conclude_def Col ).
assert (neq Q H) by (forward_using lemma_betweennotequal).
assert (nCol Q H E) by (conclude lemma_NChelper).
assert (nCol Q E H) by (forward_using lemma_NCorder).
assert (eq E E) by (conclude cn_equalityreflexive).
assert (Col Q E E) by (conclude_def Col ).
assert (Col Q E B) by (forward_using lemma_collinearorder).
assert (nCol B E H) by (conclude lemma_NChelper).
let Tf:=fresh in
assert (Tf:exists T, (BetS B T C /\ BetS H T Q)) by (conclude postulate_Pasch_inner);destruct Tf as [T];spliter.
assert (BetS Q T H) by (conclude axiom_betweennesssymmetry).
assert (BetS A T H) by (conclude lemma_3_5b).
assert (Col B T C) by (conclude_def Col ).
assert (Col C B T) by (forward_using lemma_collinearorder).
assert (nCol C B A) by (forward_using lemma_NCorder).
assert (TS A C B H) by (conclude_def TS ).
assert (TS H C B A) by (conclude lemma_oppositesidesymmetric).
assert (Par H E M A) by (forward_using lemma_parallelflip).
assert (CongA A C E B A C) by (conclude lemma_equalanglesflip).
assert ((CongA H C B C B A /\ CongA D C E C B A /\ RT E C B C B A)) by (conclude proposition_29).
assert (CongA C B A A B C) by (conclude lemma_ABCequalsCBA).
assert (CongA D C E A B C) by (conclude lemma_equalanglestransitive).
assert (BetS T C D) by (conclude lemma_3_6a).
assert (neq T D) by (forward_using lemma_betweennotequal).
assert (nCol B C A) by (forward_using lemma_NCorder).
assert (Col B C T) by (forward_using lemma_collinearorder).
assert (Col B C D) by (conclude_def Col ).
assert (nCol T D A) by (conclude lemma_NChelper).
assert (nCol A T D) by (forward_using lemma_NCorder).
assert (Col A T A) by (conclude_def Col ).
assert (Col A T H) by (conclude_def Col ).
assert (neq A H) by (forward_using lemma_betweennotequal).
assert (nCol A H D) by (conclude lemma_NChelper).
assert (nCol H A D) by (forward_using lemma_NCorder).
assert (BetS H T A) by (conclude axiom_betweennesssymmetry).
assert (BetS D C T) by (conclude axiom_betweennesssymmetry).
let Tf:=fresh in
assert (Tf:exists R, (BetS D R A /\ BetS H C R)) by (conclude postulate_Pasch_outer);destruct Tf as [R];spliter.
assert (Out C E R) by (conclude_def Out ).
assert (Out C A A) by (conclude lemma_ray4).
assert (neq C D) by (forward_using lemma_betweennotequal).
assert (eq D D) by (conclude cn_equalityreflexive).
assert (BetS A R D) by (conclude axiom_betweennesssymmetry).
assert (CongA B A C A C E) by (conclude lemma_equalanglessymmetric).
assert (CongA B A C A C R) by (conclude lemma_equalangleshelper).
assert (nCol C A B) by (forward_using lemma_NCorder).
assert (CongA C A B B A C) by (conclude lemma_ABCequalsCBA).
assert (CongA C A B A C R) by (conclude lemma_equalanglestransitive).
assert (Out C D D) by (conclude lemma_ray4).
assert (CongA A B C D C E) by (conclude lemma_equalanglessymmetric).
assert (CongA A B C D C R) by (conclude lemma_equalangleshelper).
assert (nCol A D H) by (forward_using lemma_NCorder).
assert (Col D R A) by (conclude_def Col ).
assert (Col A D R) by (forward_using lemma_collinearorder).
assert (eq D D) by (conclude cn_equalityreflexive).
assert (Col A D D) by (conclude_def Col ).
assert (neq D R) by (forward_using lemma_betweennotequal).
assert (neq R D) by (conclude lemma_inequalitysymmetric).
assert (nCol R D H) by (conclude lemma_NChelper).
assert (nCol R H D) by (forward_using lemma_NCorder).
assert (Col H C R) by (conclude_def Col ).
assert (Col R H C) by (forward_using lemma_collinearorder).
assert (eq R R) by (conclude cn_equalityreflexive).
assert (Col R H R) by (conclude_def Col ).
assert (neq C R) by (forward_using lemma_betweennotequal).
assert (neq R C) by (conclude lemma_inequalitysymmetric).
assert (nCol R C D) by (conclude lemma_NChelper).
assert (nCol D C R) by (forward_using lemma_NCorder).
assert (CongA D C R R C D) by (conclude lemma_ABCequalsCBA).
assert (CongA A B C R C D) by (conclude lemma_equalanglestransitive).
assert (SumA C A B A B C A C D) by (conclude_def SumA ).
close.
Qed.

End Euclid.