(** This file is part of CoqEAL, the Coq Effective Algebra Library.
(c) Copyright INRIA and University of Gothenburg, see LICENSE *)
(* Formalization of the Sasaki-Murao algorithm *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq path ssralg.
From mathcomp Require Import fintype perm choice matrix bigop zmodp poly polydiv mxpoly.

From CoqEAL Require Import minor hrel param refinements seqmx.

Import GRing.Theory Pdiv.Ring Pdiv.CommonRing Pdiv.RingMonic.
Import Refinements.Op.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Local Open Scope ring_scope.

Section generic_bareiss.

Variable R : Type.

Local Open Scope hetero_computable_scope.
Local Open Scope computable_scope.

Variable polyR : Type.
Variable mxR : nat -> nat -> Type.
Variable mxpolyR : nat -> nat -> Type.

Context `{zero_of R, one_of polyR}.
Context `{forall m n, opp_of (mxR m n)}.
Context `{ursubmx : ursubmx_of mxpolyR}.
Context `{dlsubmx : dlsubmx_of mxpolyR}.
Context `{drsubmx : drsubmx_of mxpolyR}.
Context `{!hmul_of mxpolyR}.
Context `{forall m n, sub_of (mxpolyR m n)}.
Context `{forall m n, scale_of polyR (mxpolyR m n)}.
Context `{map_mx : forall m n, map_mx_of polyR polyR (mxpolyR m n) (mxpolyR m n)}.
Context `{top_left : forall m, top_left_of (mxpolyR (1 + m) (1 + m)) polyR}.
Context `{divp : div_of polyR}.
Variable char_poly_mx : forall n, mxR n n -> mxpolyR n n.
Variable head : polyR -> R.

Fixpoint bareiss_rec m (a : polyR) : mxpolyR (1 + m) (1 + m) -> polyR :=
  match m with
    | S p => fun M =>
      let d   := top_left M in
      let l   := ursubmx M in
      let c   := dlsubmx M in
      let N   := drsubmx M in
      let M'  := (d *: N - c *m l)%HC in
      let M'' := map_mx (fun x => x %/ a) M' in
        bareiss_rec d M''
    | _ => fun M => top_left M
  end.

Definition bareiss n (M : mxpolyR (1 + n) (1 + n)) := bareiss_rec 1 M.

Definition bareiss_char_poly n (M : mxR (1 + n) (1 + n)) :=
  bareiss (char_poly_mx M).

(* The actual determinant function based on Bareiss *)
Definition bdet n (M : mxR (1 + n) (1 + n)) := head (bareiss_char_poly (- M)%C).

End generic_bareiss.

Parametricity bareiss_rec.
Parametricity bareiss.
Parametricity bareiss_char_poly.
Parametricity bdet.

(* First some general lemmas *)
Section prelude.

Variable R : comRingType.

Lemma key_lemma m d l (c : 'cV[R]_m) M :
  d ^+ m * \det (block_mx d%:M l c M) = d * \det (d *: M - c *m l).
Proof.
rewrite -[d ^+ m]mul1r -det_scalar -(det1 _ 1) -(det_ublock _ 0) -det_mulmx.
rewrite mulmx_block ?(mul0mx,addr0,add0r,mul1mx,mul_scalar_mx) -2![LHS]mul1r.
rewrite -{1}(@det1 _ 1) -{2}(@det1 _ m) mulrA -(@det_lblock _ _ _ _ (- c)).
rewrite -det_mulmx mulmx_block ?(mul1mx,mul0mx,addr0) addrC mul_mx_scalar.
by rewrite scalerN subrr det_ublock det_scalar1 addrC mulNmx.
Qed.

(* The key lemma of our proof: after simplification, all the k-minors *)
(* (involving 1st line/column) can be divided by (M 0 0)^k *)
Lemma key_lemma_sub m n k (M : 'M[R]_(1 + m,1 + n))
  (f : 'I_k -> 'I_m) (g : 'I_k -> 'I_n) :
  M 0 0 * (minor f g (M 0 0 *: drsubmx M - dlsubmx M *m ursubmx M)) =
  M 0 0 ^+ k * (minor (lift_pred f) (lift_pred g) M).
Proof.
rewrite /minor -{7}[M]submxK submatrix_add submatrix_scale submatrix_opp.
have -> : ulsubmx M = (M 0 0)%:M by apply/rowP=> i; rewrite ord1 !mxE !lshift0.
by rewrite submatrix_lift_block key_lemma submatrix_mul.
Qed.

(* Why is this not in the libraries? *)
Lemma monic_lreg (p : {poly R}) : p \is monic -> GRing.lreg p.
Proof. by rewrite monicE=> /eqP h; apply/lreg_lead; rewrite h; apply/lreg1. Qed.

End prelude.

Section bareiss_correctness.

Variable R : comRingType.

Instance : zero_of R := 0.
Instance : one_of {poly R} := 1.
Instance : forall m n, opp_of 'M[R]_(m, n) := fun m n M => - M.
Instance ursubmx : ursubmx_of (matrix {poly R}) := @matrix.ursubmx {poly R}.
Instance dlsubmx : dlsubmx_of (matrix {poly R}) := @matrix.dlsubmx {poly R}.
Instance drsubmx : drsubmx_of (matrix {poly R}) := @matrix.drsubmx {poly R}.
Instance : hmul_of (matrix {poly R}) := @mulmx [ringType of {poly R}].
Instance : forall m n, sub_of (matrix {poly R} m n) :=
  fun m n (M N : 'M[{poly R}]_(m,n)) => M - N.
Instance : forall m n, scale_of {poly R} (matrix {poly R} m n) :=
  @scalemx [ringType of {poly R}].
Instance map_mx : forall m n, map_mx_of {poly R} {poly R} (matrix {poly R} m n)
  (matrix {poly R} m n) :=
  fun m n f => @matrix.map_mx {poly R} {poly R} f m n.
Instance top_left : forall m, top_left_of 'M[{poly R}]_(1 + m,1 + m) {poly R} :=
  fun m M => M ord0 ord0.
Instance : div_of {poly R} := @rdivp R.
Definition head : {poly R} -> R := fun p => p`_0.

(* Lemma bareiss_invariants : forall m a (M : 'M[{poly R}]_(1 + m)), *)
(*   a \is monic -> *)
(*  (forall p (h h' : p < 1 + m), pminor h h' M \is monic) -> *)
(*  (forall k (f g : 'I_k.+1 -> 'I_m.+1), rdvdp (a ^+ k) (minor f g M)) -> *)
(*   let d   := M 0 0     in let l   := ursubmx M in *)
(*   let c   := dlsubmx M in let N   := drsubmx M in *)
(*   let M'  := d *: N - c *m l in let M'' := map_mx (fun x => rdivp x a) M' in *)
(*   [/\ M 0 0 \is monic, *)
(*       M' = a *: M'', (* This is not really an invariant *) *)
(*       forall p (h h' : p < m), pminor h h' M'' \is monic & *)
(*       forall k (f g : 'I_k.+1 -> 'I_m), rdvdp (d ^+ k) (minor f g M'') ]. *)
(* Proof. *)
(* move=> m a M am hpm hdvd /=. *)
(* set d := M 0 0; set M' := _ - _; set M'' := map_mx _ _; simpl in M'. *)
(* have hM' : M' = a *: M''. *)
(*   pose f := fun m (i : 'I_m) (x : 'I_2) => if x == 0 then 0 else (lift 0 i). *)
(*   apply/matrixP => i j. *)
(*   rewrite !mxE big_ord1 !rshift1 [a * _]mulrC rdivpK ?(eqP am,expr1n,mulr1) //. *)
(*   move: (hdvd 1%nat (f _ i) (f _ j)). *)
(*   by rewrite !minor2 /f /= expr1 !mxE !lshift0 !rshift1. *)
(* have d_monic : d \is monic. *)
(*   have -> // : d = pminor (ltn0Sn m) (ltn0Sn m) M. *)
(*   have h : widen_ord (ltn0Sn m) =1 (fun _ => 0) *)
(*     by move=> x; apply/ord_inj; rewrite [x]ord1. *)
(*   by rewrite /pminor (minor_eq h h) minor1. *)
(* split=> // [p h h'|k f g]. *)
(*   rewrite -(@monicMl _ (a ^+ p.+1)) ?monic_exp // -detZ -submatrix_scale -hM'. *)
(*   rewrite -(monicMl _ d_monic) key_lemma_sub monicMr ?monic_exp //. *)
(*   by rewrite (minor_eq (lift_pred_widen_ord h) (lift_pred_widen_ord h')) hpm. *)
(* case/rdvdpP: (hdvd _ (lift_pred f) (lift_pred g)); rewrite ?monic_exp // => x hx. *)
(* apply/rdvdpP; rewrite ?monic_exp //; exists x. *)
(* apply/(@lregX _ _ k.+1 (monic_lreg am))/(monic_lreg d_monic). *)
(* rewrite -detZ -submatrix_scale -hM' key_lemma_sub mulrA [x * _]mulrC mulrACA. *)
(* by rewrite -exprS [_ * x]mulrC -hx. *)
(* Qed. *)

(* Lemma bareiss_recE2 : forall m a (M : 'M[{poly R}]_(1 + m)), *)
(*   a \is monic -> *)
(*  (forall p (h h' : p < 1 + m), pminor h h' M \is monic) -> *)
(*  (forall k (f g : 'I_k.+1 -> 'I_m.+1), rdvdp (a ^+ k) (minor f g M)) -> *)
(*   a ^+ m * (bareiss_rec a M) = \det M. *)
(* Proof. *)
(* elim=> [a M _ _ _|m ih a M am hpm hdvd] /=. *)
(*   by rewrite expr0 mul1r {2}[M]mx11_scalar det_scalar1. *)
(* case: (bareiss_invariants am hpm hdvd). *)
(* set d := M 0 0; set M' := _ - _; set M'' := map_mx _ _; simpl in M'. *)
(* move=> d_monic hM' h1 h2. *)
(* rewrite -[M]submxK; apply/(@lregX _ d m.+1 (monic_lreg d_monic)). *)
(* have -> : ulsubmx M = d%:M by apply/rowP=> i; rewrite !mxE ord1 lshift0. *)
(* rewrite key_lemma -/M' hM' detZ mulrCA [_ * (a ^+ _ * _)]mulrCA !exprS -!mulrA. *)
(* by rewrite ih. *)
(* Qed. *)

Lemma bareiss_recE : forall m a (M : 'M[{poly R}]_(1 + m)),
  a \is monic ->
 (forall p (h h' : p < 1 + m), pminor h h' M \is monic) ->
 (forall k (f g : 'I_k.+1 -> 'I_m.+1), rdvdp (a ^+ k) (minor f g M)) ->
  a ^+ m * (bareiss_rec a M) = \det M.
Proof.
elim=> [a M _ _ _|m ih a M am hpm hdvd] /=.
  by rewrite expr0 mul1r {2}[M]mx11_scalar det_scalar1.
have ak_monic k : a ^+ k \is monic by apply/monic_exp.
simpC; rewrite /map_mx /drsubmx /dlsubmx /ursubmx /top_left.
set d := M 0 0; set M' := (_ - _); set M'' := matrix.map_mx _ _; simpl in M'.
have d_monic : d \is monic.
  have -> // : d = pminor (ltn0Sn _) (ltn0Sn _) M.
  have h : widen_ord (ltn0Sn m.+1) =1 (fun _ => 0)
    by move=> x; apply/ord_inj; rewrite [x]ord1.
  by rewrite /pminor (minor_eq h h) minor1.
have dk_monic : forall k, d ^+ k \is monic by move=> k; apply/monic_exp.
have hM' : M' = a *: M''.
  pose f := fun m (i : 'I_m) (x : 'I_2) => if x == 0 then 0 else (lift 0 i).
  apply/matrixP => i j.
  rewrite !mxE big_ord1 !rshift1 [a * _]mulrC rdivpK ?(eqP am,expr1n,mulr1) //.
  move: (hdvd 1%nat (f _ i) (f _ j)).
  by rewrite !minor2 /f /= expr1 !mxE !lshift0 !rshift1.
rewrite -[M]submxK; apply/(@lregX _ d m.+1 (monic_lreg d_monic)).
have -> : matrix.ulsubmx M = d%:M by apply/rowP=> i; rewrite !mxE ord1 lshift0.
rewrite key_lemma -/M' hM' detZ mulrCA [_ * (a ^+ _ * _)]mulrCA !exprS -!mulrA.
rewrite ih // => [p h h'|k f g].
  rewrite -(@monicMl _ (a ^+ p.+1)) // -detZ -submatrix_scale -hM'.
  rewrite -(monicMl _ d_monic) key_lemma_sub monicMr //.
  by rewrite (minor_eq (lift_pred_widen_ord h) (lift_pred_widen_ord h')) hpm.
case/rdvdpP: (hdvd _ (lift_pred f) (lift_pred g)) => // x hx.
apply/rdvdpP => //; exists x.
apply/(@lregX _ _ k.+1 (monic_lreg am))/(monic_lreg d_monic).
rewrite -detZ -submatrix_scale -hM' key_lemma_sub mulrA [x * _]mulrC mulrACA.
by rewrite -exprS [_ * x]mulrC -hx.
Qed.

Lemma bareissE n (M : 'M[{poly R}]_(1 + n))
  (H : forall p (h h' : p < 1 + n), pminor h h' M \is monic) :
  bareiss M = \det M.
Proof.
rewrite /bareiss -(@bareiss_recE n 1 M) ?monic1 ?expr1n ?mul1r //.
by move=> k f g; rewrite expr1n rdvd1p.
Qed.

Lemma bareiss_char_polyE n (M : 'M[R]_(1 + n)) :
  bareiss_char_poly (@char_poly_mx R) M = char_poly M.
Proof.
rewrite /bareiss_char_poly bareissE // => p h h'.
exact: pminor_char_poly_mx_monic.
Qed.

Lemma bdetE n (M : 'M[R]_(1 + n)) :
  bdet (polyR:= {poly R}) (@char_poly_mx R) head M = \det M.
Proof.
rewrite /bdet /head bareiss_char_polyE char_poly_det.
have -> : (-M)%C = -M by [].
by rewrite -scaleN1r detZ mulrA -expr2 sqrr_sign mul1r.
Qed.

Section bareiss_param.

Local Open Scope rel_scope.

Context (C : Type) (rC : R -> C -> Type).
Context (polyC : Type) (RpolyC : {poly R} -> polyC -> Type).
Context (mxC : nat -> nat -> Type)
        (RmxC : forall m1 m2, nat_R m1 m2 ->
                forall n1 n2, nat_R n1 n2 ->
                'M[R]_(m1, n1) -> mxC m2 n2 -> Type).
Arguments RmxC {_ _} _ {_ _} _ _ _.
(* Cyril: bug *)
(*Arguments RmxC {_ _ _ _ _ _} _ _. *)
Context (mxpolyC : nat -> nat -> Type)
        (RmxpolyC : forall m1 m2, nat_R m1 m2 ->
                    forall n1 n2, nat_R n1 n2 ->
                    'M[{poly R}]_(m1, n1) -> mxpolyC m2 n2 -> Type).
Arguments RmxpolyC {_ _} _ {_ _} _ _ _.
(* Cyril: bug *)
(* Arguments RmxpolyC {_ _ _ _ _ _} _ _. *)
Context `{zero_of C, one_of polyC}.
Context `{forall m n, opp_of (mxC m n)}.
Context `{ursubmxC : ursubmx_of mxpolyC}.
Context `{dlsubmxC : dlsubmx_of mxpolyC}.
Context `{drsubmxC : drsubmx_of mxpolyC}.
Context `{!hmul_of mxpolyC}.
Context `{subC : forall m n, sub_of (mxpolyC m n)}.
Context `{forall m n, scale_of polyC (mxpolyC m n)}.
Context `{map_mxC : forall m n, map_mx_of polyC polyC (mxpolyC m n) (mxpolyC m n)}.
Context `{top_leftC : forall m, top_left_of (mxpolyC (1 + m) (1 + m)) polyC}.
Context `{divpC : div_of polyC}.
Variable char_poly_mxC : forall n, mxC n n -> mxpolyC n n.
Variable headC : polyC -> C.
Context `{!refines rC 0%R 0%C, !refines RpolyC 1%R 1%C}.
Context `{forall m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2),
          refines (RmxC rm rn ==> RmxC rm rn) -%R -%C}.
Context `{forall m11 m12 (rm1 : nat_R m11 m12) m21 m22 (rm2 : nat_R m21 m22)
                 n11 n12 (rn1 : nat_R n11 n12) n21 n22 (rn2 : nat_R n21 n22),
          refines (RmxpolyC (addn_R rm1 rm2) (addn_R rn1 rn2) ==>
                            RmxpolyC rm1 rn2) (@ursubmx m11 m21 n11 n21)
                  (@ursubmxC m12 m22 n12 n22)}.
Context `{forall m11 m12 (rm1 : nat_R m11 m12) m21 m22 (rm2 : nat_R m21 m22)
                 n11 n12 (rn1 : nat_R n11 n12) n21 n22 (rn2 : nat_R n21 n22),
          refines (RmxpolyC (addn_R rm1 rm2) (addn_R rn1 rn2)==>
                            RmxpolyC rm2 rn1) (@dlsubmx m11 m21 n11 n21)
                  (@dlsubmxC m12 m22 n12 n22)}.
Context `{forall m11 m12 (rm1 : nat_R m11 m12) m21 m22 (rm2 : nat_R m21 m22)
                 n11 n12 (rn1 : nat_R n11 n12) n21 n22 (rn2 : nat_R n21 n22),
          refines (RmxpolyC (addn_R rm1 rm2) (addn_R rn1 rn2) ==>
                            RmxpolyC rm2 rn2) (@drsubmx m11 m21 n11 n21)
                  (@drsubmxC m12 m22 n12 n22)}.
Context `{forall m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2)
                 p1 p2 (rp : nat_R p1 p2),
          refines (RmxpolyC rm rn ==> RmxpolyC rn rp ==> RmxpolyC rm rp) mulmx
                  (@hmul_op _ _ _ m2 n2 p2)}.
Context `{forall m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2),
          refines (RmxpolyC rm rn ==> RmxpolyC rm rn ==> RmxpolyC rm rn)
                  (fun M N => M - N) sub_op}.
Context `{forall m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2),
          refines (RpolyC ==> RmxpolyC rm rn ==> RmxpolyC rm rn) *:%R *:%C}.
Context `{forall m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2),
          refines ((RpolyC ==> RpolyC) ==> RmxpolyC rm rn ==> RmxpolyC rm rn)
                  (fun f => @matrix.map_mx _ _ f m1 n1) (@map_mxC m2 n2)}.
Context `{forall m1 m2 (rm : nat_R m1 m2),
          refines (RmxpolyC (nat_R_S_R rm) (nat_R_S_R rm) ==> RpolyC)
                  (@top_left m1) (@top_leftC m2)}.
Context `{!refines (RpolyC ==> RpolyC ==> RpolyC) (@rdivp R) divpC}.
Context `{forall n1 n2 (rn : nat_R n1 n2),
          refines (RmxC rn rn ==> RmxpolyC rn rn) (@char_poly_mx _ n1)
                  (@char_poly_mxC n2)}.
Context `{!refines (RpolyC ==> rC) head headC}.

#[export] Instance RpolyC_bareiss_rec m1 m2 (rm : nat_R m1 m2) :
  refines (RpolyC ==> RmxpolyC (nat_R_S_R rm) (nat_R_S_R rm) ==> RpolyC)
          (bareiss_rec (polyR:={poly R}) (mxpolyR:=matrix {poly R}) (m:=m1))
          (bareiss_rec (polyR:=polyC) (mxpolyR:=mxpolyC) (m:=m2)).
Proof. param bareiss_rec_R. Qed.

#[export] Instance refine_bareiss_rec m :
  refines (RpolyC ==> RmxpolyC (nat_R_S_R (nat_Rxx m)) (nat_R_S_R (nat_Rxx m))
                  ==> RpolyC)
          (bareiss_rec (polyR:={poly R}) (mxpolyR:=matrix {poly R}) (m:=m))
          (bareiss_rec (polyR:=polyC) (mxpolyR:=mxpolyC) (m:=m)).
Proof. exact: RpolyC_bareiss_rec. Qed.

#[export] Instance RpolyC_bareiss n1 n2 (rn : nat_R n1 n2) :
  refines (RmxpolyC (nat_R_S_R rn) (nat_R_S_R rn) ==> RpolyC)
          (bareiss (polyR:={poly R}) (mxpolyR:=matrix {poly R}) (n:=n1))
          (bareiss (polyR:=polyC) (mxpolyR:=mxpolyC) (n:=n2)).
Proof. param bareiss_R. Qed.

#[export] Instance refine_bareiss n :
  refines (RmxpolyC (nat_R_S_R (nat_Rxx n)) (nat_R_S_R (nat_Rxx n)) ==> RpolyC)
          (bareiss (polyR:={poly R}) (mxpolyR:=matrix {poly R}) (n:=n))
          (bareiss (polyR:=polyC) (mxpolyR:=mxpolyC) (n:=n)).
Proof. exact: RpolyC_bareiss. Qed.

#[export] Instance RpolyC_bareiss_char_poly n1 n2 (rn : nat_R n1 n2) :
  refines (RmxC (nat_R_S_R rn) (nat_R_S_R rn) ==> RpolyC)
          (bareiss_char_poly (polyR:={poly R}) (mxR:=matrix R)
                             (mxpolyR:=matrix {poly R}) (@char_poly_mx R)
                             (n:=n1))
          (bareiss_char_poly (polyR:=polyC) (mxR:=mxC) (mxpolyR:=mxpolyC)
                             char_poly_mxC (n:=n2)).
Proof. param bareiss_char_poly_R. Qed.

#[export] Instance refine_bareiss_char_poly n :
  refines (RmxC (nat_R_S_R (nat_Rxx n)) (nat_R_S_R (nat_Rxx n)) ==> RpolyC)
          (bareiss_char_poly (polyR:={poly R}) (mxR:=matrix R)
                             (mxpolyR:=matrix {poly R}) (@char_poly_mx R)
                             (n:=n))
          (bareiss_char_poly (polyR:=polyC) (mxR:=mxC) (mxpolyR:=mxpolyC)
                             char_poly_mxC (n:=n)).
Proof. exact: RpolyC_bareiss_char_poly. Qed.

#[export] Instance RC_bdet n1 n2 (rn : nat_R n1 n2) :
  refines (RmxC (nat_R_S_R rn) (nat_R_S_R rn) ==> rC)
          (bdet (R:=R) (polyR:={poly R}) (mxR:=matrix R)
                (mxpolyR:=matrix {poly R}) (@char_poly_mx R) head
                (n:=n1))
          (bdet (R:=C) (polyR:=polyC) (mxR:=mxC) (mxpolyR:=mxpolyC)
                char_poly_mxC headC (n:=n2)).
Proof. param bdet_R. Qed.

#[export] Instance refine_bdet n :
  refines (RmxC (nat_R_S_R (nat_Rxx n)) (nat_R_S_R (nat_Rxx n)) ==> rC)
          (bdet (R:=R) (polyR:={poly R}) (mxR:=matrix R)
                (mxpolyR:=matrix {poly R}) (@char_poly_mx R) head
                (n:=n))
          (bdet (R:=C) (polyR:=polyC) (mxR:=mxC) (mxpolyR:=mxpolyC)
                char_poly_mxC headC (n:=n)).
Proof. exact: RC_bdet. Qed.

#[export] Instance RC_det_bdet n1 n2 (rn : nat_R n1 n2) :
  refines (RmxC (nat_R_S_R rn) (nat_R_S_R rn) ==> rC) determinant
          (bdet (R:=C) (polyR:=polyC) (mxpolyR:=mxpolyC) char_poly_mxC headC
                (n:=n2)).
Proof.
  rewrite refinesE=> M M' HM.
  rewrite -bdetE.
  exact: refinesP.
Qed.

#[export] Instance refine_det n :
  refines (RmxC (nat_R_S_R (nat_Rxx n)) (nat_R_S_R (nat_Rxx n)) ==> rC)
          determinant (bdet (R:=C) (polyR:=polyC) (mxpolyR:=mxpolyC)
                            char_poly_mxC headC (n:=n)).
Proof. exact: RC_det_bdet. Qed.

End bareiss_param.

(***** WIP below here **********)

End bareiss_correctness.

From mathcomp Require Import ssrint.
From CoqEAL Require Import binnat binint seqpoly poly_div binord trivial_seq.

Section test_bareiss.

Definition M : 'M[int]_(2,2) := \matrix_(i,j < 2) 3%:Z.

Goal \det M == 0.
by coqeal [(\det _)%pattern] vm_compute.
Qed.

Definition detM := [coqeal vm_compute of \det M].

Goal \det (1 : 'M[int]_(3)) = 1.
by coqeal.
Abort.

Definition Madd := \matrix_(i,j < 29) (i + j)%:Z%:P.
Time Definition det_Madd := [coqeal vm_compute of \det Madd].

Definition ctmat1 : 'M[int]__ := \matrix_(i < 3, j < 3)
  (nth [::] [:: [::  1 ; 1 ; 1 ]
              ; [:: -1 ; 1 ; 1 ]
              ; [::  0 ; 0 ; 1 ] ] i)`_j.

Definition det_ctmat1 := [coqeal vm_compute of \det ctmat1].
Definition char_poly_ctmat1 :=
  [coqeal vm_compute of \det _ for char_poly ctmat1].

End test_bareiss.

(* Section poly_op. *)

(* Variable R : comRingType. *)

(* Implicit Types p q : {poly R}. *)

(* Definition prptnl n p := \poly_(j < size p - n) p`_(j + n). *)

(* Lemma prptnl0p p : prptnl 0 p = p. *)
(* Proof. *)
(* rewrite /prptnl subn0 -[RHS]coefK. *)
(* apply/polyP=> i. *)
(* by rewrite !coef_poly addn0. *)
(* Qed. *)

(* Lemma prptnlp0 n : prptnl n 0 = 0. *)
(* Proof. *)
(* rewrite /prptnl size_poly0 sub0n. *)
(* apply/polyP=> i. *)
(* by rewrite coef_poly /= coef0. *)
(* Qed. *)

(* Lemma prptnl_oversize n p : size p <= n -> prptnl n p = 0. *)
(* Proof. *)
(* move=> h; apply/polyP=> i. *)
(* by rewrite coef_poly coef0 ltn_subRL leqNgt ltnS -[size p]addn0 *)
(*            (leq_add h (leq0n _)). *)
(* Qed. *)

(* Lemma prptnl_add n p q : prptnl n (p + q) = prptnl n p + prptnl n q. *)
(* Proof. *)
(* apply/polyP => i; symmetry. *)
(* rewrite /prptnl coefD !coef_poly coefD !ltn_subRL addnC. *)
(* have [H1|H1] := ltnP. *)
(*   have [_|H2] := ltnP; first by rewrite -coefD; have [|/leq_sizeP ->] := ltnP. *)
(*   move/leq_sizeP: (H2) => -> //. *)
(*   by rewrite (size_addl (leq_ltn_trans H2 H1)) H1. *)
(* move/leq_sizeP: (H1) => -> //. *)
(* have [H2|/leq_sizeP -> //] := ltnP; last by rewrite addr0 if_same. *)
(* by rewrite [p + q]addrC (size_addl (leq_ltn_trans H1 H2)) H2. *)
(* Qed. *)

(* Lemma prptnl_opp n p : prptnl n (- p) = - prptnl n p. *)
(* Proof. *)
(* apply/polyP => i. *)
(* rewrite /prptnl coefN !coef_poly coefN size_opp -{2}oppr0. *)
(* by case: ltnP. *)
(* Qed. *)

(* Lemma prptnl_sub n p q : prptnl n (p - q) = prptnl n p - prptnl n q. *)
(* Proof. by rewrite prptnl_add prptnl_opp. Qed. *)

(* Lemma prptnlX n p : prptnl n p = prptnl n.+1 (p * 'X). *)
(* Proof. *)
(* have [/eqP ->|Hpn0] := (boolP (p == 0)); first by rewrite mul0r !prptnlp0. *)
(* apply/polyP => i. *)
(* by rewrite !coef_poly size_mulX ?coefMX // subnS subSKn addnS. *)
(* Qed. *)

(* Lemma prptnlXn n k p : prptnl n p = prptnl (n + k) (p * 'X^k). *)
(* Proof. *)
(* elim: k => [|k ih]; first by rewrite addn0 expr0 mulr1. *)
(* by rewrite addnS exprS mulrCA mulrC -prptnlX. *)
(* Qed. *)

(* Lemma size_prptnl n p : size (prptnl n p) = (size p - n)%N. *)
(* Proof. *)
(* have [/eqP ->|Hpn0] := (boolP (p == 0)); first by rewrite prptnlp0 size_poly0 sub0n. *)
(* have [H|] := (ltnP n (size p)). *)
(*   rewrite size_poly_eq //. *)
(*   suff -> : ((size p - n).-1 + n)%N = (size p).-1 by rewrite lead_coef_eq0. *)
(*   case: (size p) H => // m; rewrite ltnS => H. *)
(*   by rewrite subSKn subnK. *)
(* rewrite /prptnl -subn_eq0 => /eqP ->. *)
(* rewrite -[0%N](@size_poly0 R). *)
(* congr size; congr polyseq. *)
(* apply/polyP => i. *)
(* by rewrite coef_poly size_poly0 coef0. *)
(* Qed. *)

(* Lemma prptnlS n p : prptnl n.+1 p = prptnl 1 (prptnl n p). *)
(* Proof. *)
(* apply/polyP=> i. *)
(* rewrite !coef_poly [(i + 1)%N]addnC -ltn_subRL subnS !subn1 size_prptnl add1n. *)
(* by rewrite addSnnS; case: ltnP. *)
(* Qed. *)

(* Lemma mulXn_prptnl : forall n p q, p * 'X^n = q -> p = prptnl n q. *)
(* Proof. *)
(* elim=> [p q|n ih p q h]; first by rewrite expr0 mulr1 prptnl0p => ->. *)
(* rewrite prptnlS -(ih (p * 'X)); first by rewrite -prptnlX prptnl0p. *)
(* by rewrite -mulrA -exprS. *)
(* Qed. *)

(* (* Key property - maybe it should be expressed with rdivp... *) *)
(* Lemma test n p q r : p * 'X^n = q + r -> size r <= n -> p = prptnl n q. *)
(* Proof. *)
(* move=> h_eq sr. *)
(* by rewrite (mulXn_prptnl h_eq) prptnl_add (prptnl_oversize sr) addr0. *)
(* Qed. *)

(* Lemma prptnlK m n p : prptnl m (prptnl n p) = prptnl (m + n) p. *)
(* Proof. *)
(* apply/polyP => i. *)
(* rewrite !coef_poly {1}addnC -ltn_subRL {1}[(m + n)%N]addnC subnDA size_prptnl. *)
(* by rewrite addnA; case: ltnP. *)
(* Qed. *)

(* Lemma prptnl_mulC n d p : prptnl n (d%:P * p) = d%:P * prptnl n p. *)
(* Proof. *)
(* elim/poly_ind: p n => [n|p c ih [|n]]; first by rewrite mulr0 !prptnlp0 mulr0. *)
(*   by rewrite !prptnl0p. *)
(* rewrite mulrDr !prptnl_add mulrDr mulrA -!prptnlX ih -polyC_mul. *)
(* rewrite ![prptnl n.+1 _%:P]prptnl_oversize ?mulr0 ?addr0 // size_polyC. *)
(*   by case: (c == 0). *)
(* by case: (d * c == 0). *)
(* Qed. *)

(* (* Lemma prptnlC : forall n c, prptnl n c%:P =  *) *)

(* Lemma prptnl_mul n p q : prptnl (size p + n) (p * q) = *)
(*                          prptnl (size p) (p * prptnl n q). *)
(* Proof. *)
(* elim/poly_ind: p q n=> [|p c ih] q n; first by rewrite !mul0r !prptnlp0. *)
(* have [/eqP ->|Hpn0] := (boolP (p == 0)). *)
(*   by rewrite mul0r add0r !prptnl_mulC prptnlK. *)
(* rewrite !mulrDl !prptnl_add size_addl size_mulX //; last first. *)
(*   rewrite size_polyC ltnS. *)
(*   by case: (c == 0) => //=; rewrite lt0n size_eq0 -polyseq0. *)
(* rewrite mulrC mulrA -prptnlX mulrC ih // -mulrA ['X * _]mulrC mulrA. *)
(* by rewrite -prptnlX -prptnl_mulC prptnlK addSn. *)
(* Qed. *)

(* (* Lemma prptnl_monic : forall n p, prptnl n p \is monic = (p \is monic). *) *)
(* (* Proof. *) *)
(* (* move => n. *) *)
(* (* elim/poly_ind. *) *)
(* (*   by rewrite prptnlp0. *) *)
(* (* move=> p c ih. *) *)
(* (* rewrite prptnl_add !monicE. *) *)
(* (* admit. *) *)
(* (* Qed. *) *)

(* Definition pmul (n : nat) p q := prptnl n (p * q). *)

(* Lemma pmulP : forall n p q, pmul n p q = prptnl n (p * q). *)
(* Admitted. *)

(* Fixpoint sasaki_rec m (a : {poly R}) : 'M[{poly R}]_(1 + m) -> {poly R} := *)
(*   match m return 'M[_]_(1 + m) -> {poly R} with *)
(*     | S p => fun (M: 'M[_]_(1 + _)) => *)
(*       let d   := M 0 0 in *)
(*       let l   := ursubmx M in *)
(*       let c   := dlsubmx M in *)
(*       let N   := drsubmx M in *)
(*       let M'  := \matrix_(i,j) (pmul (size a).-2 d (N i j) - *)
(*                                 pmul (size a).-2 (c i 0) (l 0 j)) in *)
(*       let q   := rdivp 'X^(size a).*2.+1 a in *)
(*       let M'' := map_mx (fun x => pmul ((size a).+3 - (size a == 1))%N q x) M' in *)
(*         sasaki_rec d M'' *)
(*     | _ => fun M => M 0 0 *)
(*   end. *)

(* Definition sasaki_char_poly n (M : 'M[R]_(1 + n)) := sasaki_rec 1 (char_poly_mx M). *)

(* (* Lemma size_rdivp : forall p q, p \is monic -> rdvdp p q -> size (rdivp q p) = (size q - (size p).-1)%N. *) *)
(* (* Proof. *) *)
(* (* move=> p q pm hdvd. *) *)

(* (* admit. *) *)
(* (* Qed. *) *)

(* (* Lemma test_size : forall m (a : {poly R}) (M : 'M[{poly R}]_(1 + m)), *) *)
(* (*   a \is monic ->  *) *)
(* (*   M 0 0 \is monic -> *) *)
(* (*   (forall i j, rdvdp (R:=R) a *) *)
(* (*    (M 0 0 * M (lift 0 i) (lift 0 j) - M (lift 0 i) 0 * M 0 (lift 0 j))) -> *) *)
(* (*  (* (forall i, size (M i i) = (size a).+2)%N ->   *) *) *)
(* (*  (* (forall i j, size (M j i * M i j) * (i != j) < size (M i i * M j j)) -> *) *) *)
(* (*  (forall i j, if i == j then size (M i i) = (size a).+2  *) *)
(* (*                         else (M i j == 0) || (size (M i j) == (size a).-1)) -> *) *)
(* (*   forall i j, size (rdivp (M 0 0 * M (lift 0 i) (lift 0 j) -  *) *)
(* (*                            M (lift 0 i) 0 * M 0 (lift 0 j)) a) <= (size a).+2. *) *)
(* (* Proof. *) *)
(* (* move=> m a /= M am m00 hdvd h1 /= i j. *) *)
(* (* rewrite size_rdivp //. *) *)
(* (* rewrite size_addl. *) *)
(* (* case hij: (i == j). *) *)
(* (*   rewrite (eqP hij). *) *)
(* (*   rewrite size_monicM //. *) *)
(* (*   move: (h1 0 0). *) *)
(* (*   rewrite eqxx => -> /=. *) *)
(* (*   move: (h1 (lift 0 j) (lift 0 j)). *) *)
(* (*   rewrite eqxx => ->. *) *)
(* (*   admit. *) *)
(* (* admit. *) *)
(* (* admit. *) *)
(* (* rewrite size_opp. *) *)
(* (* case h000: (M (lift 0 i) (lift 0 j) == 0). *) *)
(* (*   (* by rewrite (eqP h000) mulr0 size_poly0 sub0n. *) *) *)
(* (*   admit. *) *)
(* (* rewrite [size (M 0 0 * _)]size_monicM //. *) *)
(* (* admit. *) *)
(* (* admit. *) *)

(* (* Qed. *) *)

(* (* Lemma sasaki_recE : forall m (a : {poly R}) (M : 'M[{poly R}]_(1 + m)), *) *)
(* (*   a \is monic ->  *) *)
(* (*  (forall (p : nat) (h h' : p < 1 + m), pminor h h' M \is monic) -> *) *)
(* (*  (forall k (f g : 'I_k.+1 -> 'I_m.+1), rdvdp (a ^+ k) (minor f g M)) -> *) *)
(* (*  (forall i, size (M i i) = (size a).+2)%N -> *) *)
(* (*  (forall i j, size (M j i * M i j) * (i != j) < size (M i i * M j j)) -> *) *)
(* (*  (* (forall (f g : 'I_2 -> 'I_m.+1), size (minor f g M) <= (size a).+2) -> *) *) *)
(* (*   sasaki_rec a M = bareiss_rec a M. *) *)
(* (* Proof. *) *)
(* (* elim=> //= m ih a M am hpm hdvdk hsize1 hsize2. *) *)
(* (* case: (bareiss_invariants am hpm hdvdk). *) *)
(* (* set d := M 0 0; set M' := _ - _; set M'' := map_mx _ _; simpl in M' => h1 h2 h3 h4. *) *)
(* (* suff -> : map_mx *) *)
(* (*      [eta pmul ((size a).+3 - (size a == 1)%N) *) *)
(* (*             (rdivp (R:=R) 'X^(size a).*2.+1 a)] *) *)
(* (*      (\matrix_(i, j) (pmul (size a).-2 (M 0 0) ((drsubmx M) i j) - *) *)
(* (*                       pmul (size a).-2 ((dlsubmx M) i 0) ((ursubmx M) 0 j))) = *) *)
(* (*    map_mx ((rdivp (R:=R))^~ a) (M 0 0 *: drsubmx M - dlsubmx M *m ursubmx M). *) *)
(* (*   rewrite ih //. *) *)

(* (* move=> i. *) *)
(* (* rewrite -/M'. *) *)
(* (* rewrite !mxE !big_ord1 !mxE !lshift0 !rshift1 /d size_rdivp //; last first. *) *)
(* (*   pose f := fun (x : 'I_2) => if x == 0 then 0 else (lift 0 i). *) *)
(* (*   have := (@hdvdk _ f f). *) *)
(* (*   by rewrite minor2 /f /= expr1. *) *)
(* (* rewrite (hsize1 0). *) *)
(* (* rewrite size_addl; last first. *) *)
(* (*   rewrite size_opp. *) *)
(* (*   move: (hsize2 0 (lift 0 i)). *) *)
(* (*   by rewrite /= muln1. *) *)
(* (* case H0 : (M (lift 0 i) (lift 0 i) == 0). *) *)
(* (* move: (hsize1 (lift 0 i)). *) *)
(* (* by rewrite (eqP H0) size_poly0. *) *)
(* (* rewrite size_monicM //; last by rewrite H0. *) *)
(* (* rewrite (hsize1 0) (hsize1 (lift 0 i)). *) *)
(* (* simpl. *) *)
(* (* case a0 : (size a == 0)%N. *) *)
(* (*   move: am. *) *)
(* (*   move: a0. *) *)
(* (*   rewrite size_poly_eq0 => /eqP ->. *) *)
(* (*   rewrite monicE. *) *)
(* (*   rewrite lead_coef0. *) *)
(* (*   rewrite eq_sym =>HH. *) *)
(* (*   move: (oner_neq0 R). *) *)
(* (*   by rewrite HH. *) *)
(* (* rewrite -subn1 subnBA; last by rewrite lt0n a0. *) *)
(* (* rewrite addn1 -!addnS. *) *)
(* (* rewrite addnC. *) *)
(* (* rewrite -addnBA. *) *)
(* (* by rewrite subnn addn0. *) *)
(* (* done. *) *)

(* (* admit. *) *)

(* (* apply/matrixP=> i j; rewrite !mxE big_ord1 !pmulP !mxE lshift0 -prptnl_sub !rshift1. *) *)
(* (* have [sa0|an0] := boolP (size a == 0)%N. *) *)
(* (*   rewrite (eqP sa0); move: sa0; rewrite size_poly_eq0 => /eqP -> /=. *) *)
(* (*   by rewrite !rdivp0 mul0r prptnlp0. *) *)
(* (* have a0 : a != 0 by rewrite -size_poly_eq0. *) *)
(* (* set e := M _ _; set N := M _ _; set c := M _ _; set l := M _ _. *) *)

(* (* have hdvd : rdvdp a (d * N - c * l). *) *)
(* (*   move: (hdvdk 1%N) => HHH. *) *)
(* (*   pose f := fun (x : 'I_2) => if x == 0 then 0 else (lift 0 i). *) *)
(* (*   pose g := fun (x : 'I_2) => if x == 0 then 0 else (lift 0 j). *) *)
(* (*   move: (HHH f g). *) *)
(* (*   by rewrite minor2 /f /g /= expr1.  *) *)

(* (* have := (rdivp_eq am ('X^(size a).*2.+1)). *) *)
(* (* set q := rdivp _ _; set r := rmodp _ _; set M''' := rdivp _ _. *) *)
(* (* move=> Hqr. *) *)

(* (* have H1 : M''' * 'X^(size a).*2.+1 = (d * N - c * l) * q + M''' * r. *) *)
(* (*   rewrite Hqr mulrDr. *) *)
(* (*   congr (_ + _). *) *)
(* (*   rewrite mulrC -mulrA mulrC. *) *)
(* (*   congr (_ * _). *) *)
(* (*   rewrite /M' mulrC rdivpK //. *) *)
(* (*   move: am. *) *)
(* (*   by rewrite monicE => /eqP ->; rewrite expr1n mulr1. *) *)

(* (* have := (ltn_rmodpN0 'X^(size a).*2.+1 a0); rewrite -/r => Hr. *) *)

(* (* have q0 : q != 0. *) *)
(* (*   apply/eqP => q0; move: Hqr Hr. *) *)
(* (*   rewrite q0 !mul0r add0r => <-. *) *)
(* (*   by rewrite size_polyXn -addnn -!addnS -{3}[size a]addn0 leq_add2l. *) *)

(* (* have laq0 : lead_coef q * lead_coef a != 0. *) *)
(* (*   have H : GRing.lreg (lead_coef a). *) *)
(* (*     move: am. *) *)
(* (*     rewrite monicE => /eqP ->. *) *)
(* (*     exact: lreg1. *) *)
(* (*   by rewrite mulrC (mulrI_eq0 _ H) lead_coef_eq0. *) *)

(* (* have Hsize : size q = (size a).+3. *) *)
(* (*   have := (size_polyXn R (size a).*2.+1). *) *)
(* (*   rewrite Hqr size_addl size_proper_mul //. *) *)
(* (*     rewrite -addnn -addSn => /eqP. *) *)
(* (*     rewrite -eqSS -!addSn prednK /=. *) *)
(* (*       by rewrite eqn_add2r => /eqP. *) *)
(* (*     by rewrite addn_gt0 !lt0n an0 orbT. *) *)
(* (*   move: q0. *) *)
(* (*   rewrite -size_poly_eq0. *) *)
(* (*   case: (size q) => // n _. *) *)
(* (*   exact: (ltn_addl n Hr). *) *)

(* (* have Hm' : size M''' <= (size a).+2. *) *)
(* (* rewrite /M'''. *) *)
(* (*   (* apply/(leq_trans (leq_rdivp (d * N - c * l) a)). *) *) *)
(* (*   rewrite /e /N /c /l. *) *)
(* (*   rewrite test_size //. *) *)
(* (*   move=> /= x y. *) *)
(* (*   move: (hdvdk 1%N) => HHH. *) *)
(* (*   pose f := fun (apa : 'I_2) => if apa == 0 then 0 else (lift 0 x). *) *)
(* (*   pose g := fun (apa : 'I_2) => if apa == 0 then 0 else (lift 0 y). *) *)
(* (*   move: (HHH f g). *) *)
(* (*   by rewrite minor2 /f /g /= expr1.  *) *)

(* (* have H2 : size (M''' * r) <= (size a).*2.+1. *) *)
(* (*   rewrite (leq_trans (size_mul_leq M''' r)) // -addnn. *) *)
(* (*   have := (leq_add Hm' Hr). *) *)
(* (*   rewrite !addSn addnS ltnS => HH. *) *)
(* (*   have H : (size M''' + size r).-1 <= (size M''' + size r). *) *)
(* (*     by case: (size M''' + size r)%N. *) *)
(* (*   exact: (leq_trans H HH). *) *)

(* (* rewrite (test H1 H2). *) *)
(* (* case sa: (size a == 1)%N. *) *)
(* (*   by rewrite (eqP sa) prptnl0p -addnn mulrC. *) *)
(* (* rewrite subn0 -Hsize -prptnl_mul Hsize mulrC. *) *)
(* (* f_equal. *) *)
(* (* rewrite -addnn !addSn -!addnS prednK. *) *)
(* (*   rewrite prednK //. *) *)
(* (*   by case: (size a) an0. *) *)
(* (* by case: (size a) an0 sa => //= [[]]. *) *)
(* (* Qed.  *) *)

(* (* OLD STUFF BELOW *) *)

(* (* Definition sasaki_char_poly n (M : 'M[R]_(1 + n)) := sasaki_rec 1 (char_poly_mx M). *) *)

(* (* (* Lemma sasakiE : forall m (M : 'M[R]_(1 + m)), sasaki_char_poly M = bareiss_char_poly M. *) *) *)
(* (* (* Proof. *) *) *)
(* (* (* rewrite /sasaki_char_poly /bareiss_char_poly /bareiss. *) *) *)
(* (* (* elim. *) *) *)
(* (* (* move=> M. *) *) *)
(* (* (* simpl. *) *) *)
(* (* (* done. *) *) *)
(* (* (* move=> n ih M. *) *) *)
(* (* (* simpl. *) *) *)
(* (* (* rewrite /bareiss. *) *) *)

(* (* Lemma size_rmodpXn p (p0 : p != 0) : size (rmodp 'X^(size p).*2.+1 p) < (size p). *) *)
(* (* Proof. exact: (ltn_rmodpN0 'X^(size p).*2.+1 p0). Qed. *) *)

(* (* Lemma size_rdivpXn p (pm : p \is monic) : size (rdivp 'X^(size p).*2.+1 p) = (size p).+3. *) *)
(* (* Proof. *) *)
(* (* move: (rdivp_eq pm ('X^(size p).*2.+1)) (ltn_rmodpN0 'X^(size p).*2.+1 (monic_neq0 pm)) *) *)
(* (*       (size_polyXn R (size p).*2.+1). *) *)
(* (* set q := rdivp _ _; set r := rmodp _ _ => -> Hr. *) *)
(* (* rewrite size_addl size_proper_mul //. *) *)
(* (*     rewrite -addnn -addSn => /eqP. *) *)
(* (*     rewrite -eqSS -!addSn prednK /=. *) *)
(* (*       by rewrite eqn_add2r => /eqP. *) *)
(* (*     by rewrite addn_gt0 !lt0n !size_poly_eq0 (monic_neq0 pm) orbT. *) *)
(* (*   admit. *) *)

(* (*   move: (monic_neq0 pm). *) *)
(* (*   rewrite -size_poly_eq0. *) *)
(* (*   case: (size p) => // n _ /=. *) *)
(* (*   rewrite addnS /=. *) *)
(* (*   move: (ltn_addl n Hr). *) *)
(* (*   admit. *) *)
(* (* admit. *) *)
(* (* Qed. *) *)

(* (* Lemma sasaki_recE : forall m (a : {poly R}) (M : 'M[{poly R}]_(1 + m)), *) *)
(* (*   (* (forall (f g : 'I_2 -> 'I_(1 + m)%N), size (minor f g M) <= (size a).+2) -> *) *) *)
(* (*   (* (forall i j, if i == j then size (M i i) == (size a).+1 *) *) *)
(* (*   (*                        else size (M i j) <= size a) -> *) (* THIS DOES NOT WORK!!! *) *) *)
(* (*   a \is monic -> *) *)
(* (*   (forall i, M i i \is monic) -> *) *)
(* (*   (* (forall i j, size (M i i * M j j) == (size a).+2) -> *) *) *)
(* (*   (* (forall i j, size (M 0 i * M j 0) <= size a) -> *) *) *)
(* (*   (* (forall i j, size (M 0 0 * M (lift 0 i) (lift 0 j) - M (lift 0 i) 0 * M 0 (lift 0 j)) <= (size a).+2) -> *) *) *)
(* (*  (* (forall (f g : 'I_2 -> 'I_m.+1), rdvdp a (minor f g M)) -> *) *) *)
(* (*   sasaki_rec a M = bareiss_rec a M. *) *)
(* (* Proof. *) *)
(* (* (* elim=> //= m ih a M hs am hm. *) *) *)
(* (* (* elim=> //= m ih a M am hm hs_diag hs. *) *) *)
(* (* elim=> //= m ih a M am hm. *) *)

(* (* (* have -> : (map_mx *) *) *)
(* (* (*         (fun x : {poly R} => *) *) *)
(* (* (*          if (size a == 1)%N *) *) *)
(* (* (*          then pmul (size a).+2 (rdivp (R:=R) 'X^(size a).*2.+1 a) x *) *) *)
(* (* (*          else pmul (size a).+3 (rdivp (R:=R) 'X^(size a).*2.+1 a) x) *) *) *)
(* (* (*         (\matrix_(i, j) (pmul (size a).-2 (M 0 0) ((drsubmx M) i j) - *) *) *)
(* (* (*                          pmul (size a).-2 ((dlsubmx M) i 0) ((ursubmx M) 0 j)))) = (map_mx ((rdivp (R:=R))^~ a) *) *) *)
(* (* (*         (M 0 0 *: drsubmx M - dlsubmx M *m ursubmx M)); last first. *) *) *)
(* (* (*   admit. *) *) *)

(* (* rewrite ih; last first. *) *)
(* (*   admit. *) *)
(* (*   (* move=> i. *) *) *)
(* (*   (* rewrite !mxE !pmulP -prptnl_sub !lshift0 !rshift1. *) *) *)
(* (*   (* case: ifP => sa1; rewrite prptnl_monic. *) *) *)
(* (*   (* rewrite (eqP sa1) /= prptnl0p. *) *) *)
(* (*   (* admit. *) *) *)
(* (*   (* admit. *) *) *)

(* (* (* simpl. *) *) *)
(* (* (*   move=> i j. *) *) *)
(* (* (*   rewrite !mxE !pmulP -prptnl_sub !lshift0 !rshift1. *) *) *)
(* (* (*   case: ifP => sa1. *) *) *)
(* (* (*   rewrite (eqP sa1) /= !prptnl0p. *) *) *)
(* (* (* Search _ rdivp size. *) *) *)
(* (* (* have -> : lift 0 0 = 1. *) *) *)
(* (* (*   by move=> n; apply/ord_inj. *) *) *)
(* (* (*   admit. *) *) *)
(* (* (*   admit. *) *) *)

(* (* (*   move=> i j. *) *) *)
(* (* (*   rewrite !mxE !pmulP -prptnl_sub !lshift0 !rshift1. *) *) *)
(* (* (*   case: ifP => sa1. *) *) *)
(* (* (*   rewrite (eqP sa1) /= prptnl0p. *) *) *)
(* (* (*   admit. *) *) *)
(* (* (*   admit. *) *) *)

(* (* (*   move=> i. *) *) *)
(* (* (*   rewrite !mxE !pmulP -prptnl_sub !lshift0 !rshift1. *) *) *)
(* (* (*   case: ifP => sa1; rewrite prptnl_monic. *) *) *)
(* (* (*   rewrite (eqP sa1) /= prptnl0p. *) *) *)

(* (* (*     admit. *) *) *)
(* (*   exact: (hm 0). *) *)
(* (* (* move=> f g. *) *) *)
(* (* (* rewrite minor2 !mxE !pmulP -prptnl_sub !lshift0 !rshift1. *) *) *)

(* (* (* case: ifP=> sa. *) *) *)
(* (* (* rewrite (eqP sa) /= !prptnl0p size_addl.  *) *) *)
(* (* (* rewrite size_proper_mul. *) *) *)
(* (* (* rewrite !size_prptnl. *) *) *)
(* (* (* rewrite size_proper_mul. *) *) *)
(* (* (* Search _ size rdivp. *) *) *)

(* (* (* rewrite /minor. *) *) *)
(* (* (* simpl. *) *) *)

(* (* (* move=> i j. *) *) *)
(* (* (* case: ifP=> hij. *) *) *)
(* (* (* rewrite (eqP hij). *) *) *)
(* (* (* rewrite !mxE !pmulP !rshift1 !lshift0 -prptnl_sub. *) *) *)
(* (* (* case: ifP => sa. *) *) *)
(* (* (* set q := rdivp _ _. *) *) *)
(* (* (* set d := M _ _; set N := M _ _; set c := M _ _; set l := M _ _. *) *) *)

(* (* (*   admit. *) *) *)
(* (* (* admit. *) *) *)
(* (* (* admit. *) *) *)

(* (* congr bareiss_rec. *) *)
(* (* apply/matrixP=> i j; rewrite !mxE big_ord1 !pmulP !mxE lshift0 -prptnl_sub !rshift1. *) *)
(* (* have [sa0|an0] := boolP (size a == 0)%N. *) *)
(* (*   rewrite (eqP sa0); move: sa0; rewrite size_poly_eq0 => /eqP -> /=. *) *)
(* (*   by rewrite !rdivp0 mul0r prptnlp0. *) *)
(* (* have a0 : a != 0 by rewrite -size_poly_eq0. *) *)
(* (* set d := M _ _; set N := M _ _; set c := M _ _; set l := M _ _. *) *)

(* (* have hdvd : rdvdp a (d * N - c * l) by admit. *) *)

(* (* have := (rdivp_eq am ('X^(size a).*2.+1)). *) *)
(* (* set q := rdivp _ _; set r := rmodp _ _; set M' := rdivp _ _.  *) *)
(* (* move=> Hqr. *) *)

(* (* have H1 : M' * 'X^(size a).*2.+1 = (d * N - c * l) * q + M' * r. *) *)
(* (*   rewrite Hqr mulrDr. *) *)
(* (*   congr (_ + _). *) *)
(* (*   rewrite mulrC -mulrA mulrC. *) *)
(* (*   congr (_ * _). *) *)
(* (*   rewrite /M' mulrC rdivpK //. *) *)
(* (*   move: am. *) *)
(* (*   by rewrite monicE => /eqP ->; rewrite expr1n mulr1. *) *)

(* (* have := (ltn_rmodpN0 'X^(size a).*2.+1 a0); rewrite -/r => Hr. *) *)

(* (* have q0 : q != 0. *) *)
(* (*   apply/eqP => q0; move: Hqr Hr. *) *)
(* (*   rewrite q0 !mul0r add0r => <-. *) *)
(* (*   by rewrite size_polyXn -addnn -!addnS -{3}[size a]addn0 leq_add2l. *) *)

(* (* have laq0 : lead_coef q * lead_coef a != 0. *) *)
(* (*   have H : GRing.lreg (lead_coef a). *) *)
(* (*     move: am. *) *)
(* (*     rewrite monicE => /eqP ->. *) *)
(* (*     exact: lreg1. *) *)
(* (*   by rewrite mulrC (mulrI_eq0 _ H) lead_coef_eq0. *) *)

(* (* have Hsize : size q = (size a).+3. *) *)
(* (*   have := (size_polyXn R (size a).*2.+1). *) *)
(* (*   rewrite Hqr size_addl size_proper_mul //. *) *)
(* (*     rewrite -addnn -addSn => /eqP. *) *)
(* (*     rewrite -eqSS -!addSn prednK /=. *) *)
(* (*       by rewrite eqn_add2r => /eqP. *) *)
(* (*     by rewrite addn_gt0 !lt0n an0 orbT. *) *)
(* (*   move: q0. *) *)
(* (*   rewrite -size_poly_eq0. *) *)
(* (*   case: (size q) => // n _. *) *)
(* (*   exact: (ltn_addl n Hr). *) *)

(* (* have Hm' : size M' <= (size a).+2. *) *)
(* (*   (* rewrite /M'. *) *) *)
(* (*   (* apply/(leq_trans (leq_rdivp (d * N - c * l) a)). *) *) *)
(* (*   (* rewrite /d /N /c /l. *) *) *)
(* (*   (* rewrite size_addl. *) *) *)
(* (*   (* case hij: (i == j). *) *) *)
(* (*   (*   rewrite (eqP hij). *) *) *)
(* (*   (* rewrite size_proper_mul. *) *) *)
(* (*   (* move: (hs 0 0). *) *) *)
(* (*   (* rewrite eqxx => /eqP ->. *) *) *)
(* (*   (* move: (hs (lift 0 j) (lift 0 j)). *) *) *)
(* (*   (* rewrite eqxx => /eqP ->. *) *) *)
(* (*   (* rewrite addnS /=. *) *) *)
(* (*   (* move: (hs i j). *) *) *)
(* (*   (* done. *) *) *)
(* (*   admit. *) *)
(* (* (* exact: (key_invariant Hs i j). *) *) *)

(* (* have H2 : size (M' * r) <= (size a).*2.+1. *) *)
(* (*   rewrite (leq_trans (size_mul_leq M' r)) // -addnn. *) *)
(* (*   have := (leq_add Hm' Hr). *) *)
(* (*   rewrite !addSn addnS ltnS => HH. *) *)
(* (*   have H : (size M' + size r).-1 <= (size M' + size r). *) *)
(* (*     by case: (size M' + size r)%N. *) *)
(* (*   exact: (leq_trans H HH). *) *)

(* (* rewrite (test H1 H2). *) *)
(* (* case sa: (size a == 1)%N. *) *)
(* (*   by rewrite (eqP sa) prptnl0p -addnn mulrC. *) *)
(* (* rewrite -Hsize -prptnl_mul Hsize mulrC. *) *)
(* (* f_equal. *) *)
(* (* rewrite -addnn !addSn -!addnS prednK. *) *)
(* (*   rewrite prednK //. *) *)
(* (*   by case: (size a) an0. *) *)
(* (* by case: (size a) an0 sa => //= [[]]. *) *)
(* (* Qed.  *) *)

(* End poly_op. *)

(* (* Test computations *) *)

(* (* *)
(*    WARNING never use compute, but vm_compute, *)
(*    otherwise it's painfully slow *)
(* *) *)
(* Require Import ZArith Zinfra. *)
(* Section test. *)

(* Definition excp n (M: Matrix [cringType Z of Z]) := ex_char_poly_mx n M. *)

(* Definition idZ n := @ident _ [cringType Z of Z] n. *)

(* Definition cpmxid2 := (excp 2 (idZ 2)). *)
(* Definition cpid2 := (exBareiss_rec 2 [:: 1%Z] cpmxid2). *)

(* Eval vm_compute in cpid2. *)

(* Definition detid2 := horner_seq cpid2 0%Z. *)

(* Eval vm_compute in detid2. *)

(* Definition M2 := cM 19%Z [:: 3%Z] [:: (-2)%Z] (cM 26%Z [::] [::] (@eM _ _)). *)

(* Definition cpmxM2 := excp 2 M2. *)
(* Definition cpM2 := exBareiss 2 cpmxM2. *)

(* Eval vm_compute in cpM2. *)
(* Eval vm_compute in ex_bdet 2 M2. *)

(* (* Random 3x3 matrix *) *)
(* Definition M3 := *)
(*   cM 10%Z [:: (-42%Z); 13%Z] [:: (-34)%Z; 77%Z] *)
(*      (cM 15%Z [:: 76%Z] [:: 98%Z] *)
(*          (cM 49%Z [::] [::] (@eM _ _))). *)

(* Time Eval vm_compute in ex_bdet 3 M3. *)

(* (* Random 10x10 matrix *) *)
(* Definition M10 := cM (-7)%Z [:: (-12)%Z ; (-15)%Z ; (-1)%Z ; (-8)%Z ; (-8)%Z ; 19%Z ; (-3)%Z ; (-8)%Z ; 20%Z] [:: 5%Z ; (-14)%Z ; (-12)%Z ; 19%Z ; 20%Z ; (-5)%Z ; (-3)%Z ; 8%Z ; 16%Z] (cM 1%Z [:: 16%Z ; (-18)%Z ; 8%Z ; (-13)%Z ; 18%Z ; (-6)%Z ; 10%Z ; 6%Z] [:: 5%Z ; 4%Z ; 0%Z ; 4%Z ; (-18)%Z ; (-19)%Z ; (-2)%Z ; 3%Z] (cM (-8)%Z [:: 1%Z ; (-10)%Z ; 12%Z ; 0%Z ; (-14)%Z ; 18%Z ; (-5)%Z] [:: (-14)%Z ; (-10)%Z ; 15%Z ; 0%Z ; 13%Z ; (-12)%Z ; (-16)%Z] (cM (-13)%Z [:: (-2)%Z ; (-14)%Z ; (-11)%Z ; 15%Z ; (-1)%Z ; 8%Z] [:: 6%Z ; 9%Z ; (-19)%Z ; (-19)%Z ; (-16)%Z ; (-10)%Z] (cM (-12)%Z [:: 1%Z ; (-5)%Z ; 16%Z ; 5%Z ; 6%Z] [:: 16%Z ; (-20)%Z ; 19%Z ; 16%Z ; 5%Z] (cM 2%Z [:: (-10)%Z ; (-3)%Z ; (-17)%Z ; 18%Z] [:: 4%Z ; (-4)%Z ; 20%Z ; (-7)%Z] (cM 4%Z [:: (-8)%Z ; 2%Z ; 9%Z] [:: 17%Z ; 10%Z ; 10%Z] (cM (-15)%Z [:: 16%Z ; 3%Z] [:: 5%Z ; (-1)%Z] (cM 3%Z [:: 4%Z] [:: (-12)%Z] ((@eM _ _)))))))))). *)

(* Time Eval vm_compute in ex_bdet 10 M10. *)

(* (* *)
(* (* Random 20x20 matrix *) *)
(* Definition M20 := cM (-17)%Z [:: 4%Z ; 9%Z ; 4%Z ; (-7)%Z ; (-4)%Z ; 16%Z ; (-13)%Z ; (-6)%Z ; (-4)%Z ; (-9)%Z ; 18%Z ; 7%Z ; 3%Z ; (-14)%Z ; 8%Z ; (-17)%Z ; 17%Z ; (-2)%Z ; 8%Z] [:: 0%Z ; 10%Z ; 17%Z ; (-7)%Z ; 3%Z ; 18%Z ; (-3)%Z ; 6%Z ; 2%Z ; (-7)%Z ; (-3)%Z ; 16%Z ; 7%Z ; (-9)%Z ; 15%Z ; (-17)%Z ; (-9)%Z ; (-18)%Z ; 9%Z] (cM 13%Z [:: (-3)%Z ; 9%Z ; 7%Z ; 4%Z ; 18%Z ; 2%Z ; 7%Z ; 9%Z ; (-10)%Z ; 18%Z ; 4%Z ; 13%Z ; (-16)%Z ; (-5)%Z ; 6%Z ; (-14)%Z ; 3%Z ; 12%Z] [:: 14%Z ; (-15)%Z ; 14%Z ; (-7)%Z ; 11%Z ; 10%Z ; (-10)%Z ; 9%Z ; (-4)%Z ; (-7)%Z ; (-4)%Z ; 7%Z ; (-10)%Z ; 15%Z ; (-4)%Z ; 12%Z ; (-18)%Z ; 4%Z] (cM 16%Z [:: (-5)%Z ; 8%Z ; 4%Z ; 8%Z ; 4%Z ; (-18)%Z ; 10%Z ; 3%Z ; (-12)%Z ; 12%Z ; 8%Z ; 11%Z ; (-12)%Z ; (-1)%Z ; 12%Z ; (-5)%Z ; (-10)%Z] [:: 1%Z ; (-15)%Z ; (-3)%Z ; (-3)%Z ; 6%Z ; (-3)%Z ; 18%Z ; 6%Z ; (-6)%Z ; (-10)%Z ; 15%Z ; 11%Z ; 6%Z ; (-4)%Z ; (-4)%Z ; 9%Z ; (-3)%Z] (cM (-12)%Z [:: 1%Z ; 6%Z ; 7%Z ; 5%Z ; 0%Z ; (-2)%Z ; 2%Z ; 14%Z ; 15%Z ; (-10)%Z ; (-14)%Z ; (-6)%Z ; 3%Z ; 17%Z ; (-11)%Z ; (-8)%Z] [:: (-15)%Z ; (-8)%Z ; 5%Z ; 18%Z ; 15%Z ; (-14)%Z ; 13%Z ; 17%Z ; 12%Z ; 16%Z ; (-18)%Z ; 13%Z ; 14%Z ; 17%Z ; (-8)%Z ; (-9)%Z] (cM (-17)%Z [:: (-12)%Z ; (-14)%Z ; (-7)%Z ; (-1)%Z ; 14%Z ; (-14)%Z ; (-13)%Z ; (-4)%Z ; 18%Z ; 13%Z ; (-9)%Z ; 15%Z ; (-10)%Z ; 18%Z ; 14%Z] [:: 8%Z ; (-14)%Z ; 9%Z ; 16%Z ; (-3)%Z ; (-8)%Z ; 9%Z ; (-9)%Z ; (-13)%Z ; 4%Z ; 15%Z ; 15%Z ; 6%Z ; (-14)%Z ; (-6)%Z] (cM 9%Z [:: 4%Z ; (-6)%Z ; 5%Z ; (-3)%Z ; (-6)%Z ; 18%Z ; 2%Z ; 10%Z ; 9%Z ; 17%Z ; (-12)%Z ; (-9)%Z ; 1%Z ; (-2)%Z] [:: (-10)%Z ; (-2)%Z ; 17%Z ; 14%Z ; 1%Z ; (-16)%Z ; 17%Z ; 18%Z ; (-3)%Z ; 4%Z ; (-14)%Z ; 17%Z ; 10%Z ; 7%Z] (cM 16%Z [:: (-15)%Z ; (-15)%Z ; (-18)%Z ; (-12)%Z ; 15%Z ; 7%Z ; (-11)%Z ; (-7)%Z ; (-8)%Z ; (-3)%Z ; (-17)%Z ; (-17)%Z ; (-12)%Z] [:: (-8)%Z ; 4%Z ; 12%Z ; (-7)%Z ; (-11)%Z ; 13%Z ; (-16)%Z ; 7%Z ; 16%Z ; (-1)%Z ; 16%Z ; 3%Z ; (-9)%Z] (cM (-15)%Z [:: 0%Z ; (-12)%Z ; 0%Z ; 16%Z ; 13%Z ; (-5)%Z ; 4%Z ; 1%Z ; 13%Z ; 11%Z ; 0%Z ; 16%Z] [:: 0%Z ; (-17)%Z ; (-10)%Z ; (-6)%Z ; 7%Z ; (-1)%Z ; 17%Z ; 8%Z ; 8%Z ; (-15)%Z ; (-16)%Z ; (-18)%Z] (cM 5%Z [:: 8%Z ; (-17)%Z ; (-15)%Z ; 0%Z ; 8%Z ; 1%Z ; (-2)%Z ; 14%Z ; 14%Z ; (-1)%Z ; (-7)%Z] [:: 14%Z ; (-11)%Z ; (-4)%Z ; (-18)%Z ; (-10)%Z ; (-11)%Z ; (-10)%Z ; (-6)%Z ; (-14)%Z ; (-13)%Z ; 5%Z] (cM (-7)%Z [:: 1%Z ; (-3)%Z ; (-7)%Z ; (-1)%Z ; 2%Z ; 14%Z ; 13%Z ; 7%Z ; 17%Z ; 7%Z] [:: 0%Z ; 1%Z ; (-7)%Z ; 12%Z ; (-1)%Z ; (-5)%Z ; (-12)%Z ; (-7)%Z ; 8%Z ; (-4)%Z] (cM 15%Z [:: (-18)%Z ; (-17)%Z ; 6%Z ; 1%Z ; (-13)%Z ; (-12)%Z ; 4%Z ; 13%Z ; 11%Z] [:: 12%Z ; 2%Z ; (-7)%Z ; (-18)%Z ; 0%Z ; 13%Z ; (-15)%Z ; (-16)%Z ; (-2)%Z] (cM 5%Z [:: (-9)%Z ; (-11)%Z ; 14%Z ; (-6)%Z ; (-11)%Z ; (-15)%Z ; (-12)%Z ; (-4)%Z] [:: (-12)%Z ; 8%Z ; (-8)%Z ; (-14)%Z ; 9%Z ; 3%Z ; 14%Z ; 3%Z] (cM (-18)%Z [:: 16%Z ; (-1)%Z ; 3%Z ; 11%Z ; 9%Z ; (-9)%Z ; 14%Z] [:: (-2)%Z ; (-7)%Z ; (-1)%Z ; 6%Z ; (-16)%Z ; 1%Z ; 6%Z] (cM 3%Z [:: (-8)%Z ; (-1)%Z ; (-1)%Z ; 15%Z ; 10%Z ; 6%Z] [:: 3%Z ; 7%Z ; 15%Z ; 12%Z ; 8%Z ; 5%Z] (cM (-14)%Z [:: (-2)%Z ; (-5)%Z ; 8%Z ; (-9)%Z ; 10%Z] [:: 12%Z ; 0%Z ; (-3)%Z ; 11%Z ; (-2)%Z] (cM 6%Z [:: (-8)%Z ; (-4)%Z ; (-9)%Z ; (-1)%Z] [:: 2%Z ; 5%Z ; (-8)%Z ; 0%Z] (cM (-14)%Z [:: (-8)%Z ; (-2)%Z ; 16%Z] [:: 11%Z ; 2%Z ; (-2)%Z] (cM 16%Z [:: (-14)%Z ; 9%Z] [:: (-17)%Z ; 8%Z] (cM (-18)%Z [:: (-11)%Z] [:: (-14)%Z] ((@eM _ _)))))))))))))))))))). *)

(* Time Eval vm_compute in ex_bdet 20 M20. *)

(*      = 75728050107481969127694371861%Z *)
(*      : CZmodule.Pack (Phant Z_comRingType) (CRing.class Z_cringType) *)
(*          Z_cringType *)
(* Finished transaction in 63. secs (62.825904u,0.016666s) *)
(* *) *)

(* End test. *)

(* (* Extraction Language Haskell. *) *)
(* (*  Extraction "Bareiss" ex_bdet. *) *)


From Undecidability.FOL.Semantics Require Import Tarski.FullFacts.
From Undecidability.FOL.Semantics Require Export FiniteTarski.Listability.
From Undecidability.FOL.Syntax Require Import Facts.
Require Import Undecidability.Synthetic.DecidabilityFacts.
Require Import Undecidability.Shared.Dec.
Require Import List.

Section DefaultSyntax. (* An alternative development of FSAT in Trakhtenbrot is "Trakhtenbrot Syntax" *)
  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Context {ff : falsity_flag}.

  (* Satisfiability in a finite and decidable model *)

  Definition FSAT (phi : form) :=
    exists D (I : interp D) rho, listable D /\ (forall p, decidable (fun v => i_atom (P:=p) v)) /\ rho ⊨ phi.

  (* Validity in a finite and decidable model *)

  Definition FVAL (phi : form) :=
    forall D (I : interp D) rho, listable D /\ (forall p, decidable (fun v => i_atom (P:=p) v)) -> rho ⊨ phi.

  (* Satisfiability in a discrete, finite, and decidable model *)

  Definition FSATd (phi : form) :=
    exists D (I : interp D) rho, listable D /\ discrete D /\ (forall p, decidable (fun v => i_atom (P:=p) v)) /\ rho ⊨ phi.

  (* Satisfiability in a discrete, finite, and decidable model restricted to closed formulas *)

  Definition cform := { phi | bounded 0 phi }.

  Definition FSATdc (phi : cform) :=
    FSATd (proj1_sig phi).
End DefaultSyntax.

Section decidable.
  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Context {ff : falsity_flag}.

  (* Show satisfaction decidable for fixed model *)
  Lemma general_decider D (I:interp D) (e : env D) f : cListable D -> (forall (ff:falsity_flag) p v ee, dec (ee ⊨ atom p v)) -> dec (e ⊨ f).
  Proof.
  intros Hfin Hdec.
  induction f as [|f p v|f [] l IHl r IHr|f [] v IHv] in e|-*.
  - now right.
  - apply Hdec.
  - cbn. now apply and_dec.
  - cbn. now apply or_dec.
  - cbn. now apply impl_dec.
  - cbn. apply fin_dec. 1:easy. intros k. apply IHv.
  - cbn. apply fin_dec_ex. 1:easy. intros k. apply IHv.
  Qed.
End decidable.


(* Copyright (c) 2014, Robert Dockins *)

Require Import Ascii.
Require Export String.
Open Scope string_scope.

Require Import Setoid.
Require Import NArith.
Require Import Arith.
Require Import Omega.
Require Import List.

Require Import basics.
Require Import categories.
Require Import preord.
Require Import sets.
Require Import finsets.
Require Import esets.

(**  * Atoms for nominal types

     Atoms are concretely represented by ASCII strings.
     Here we provide some operations on atoms, including an
     operation for choosing fresh atoms.
  *)

(**  ASCII characters are ordered by inheriting their numerical order.
  *)
Definition char_ord (x y:ascii) := N.le (N_of_ascii x) (N_of_ascii y).

(**  Strings are ordered lexicographically.
  *)
Fixpoint string_ord (x y:string) :=
  match x, y with
  | "", _ => True
  | String a x', "" => False
  | String a x', String b y' =>
       (a <> b /\ char_ord a b) \/
       (a = b /\ string_ord x' y')
  end.

Obligation Tactic := idtac.

Program Definition string_ord_mixin : Preord.mixin_of string :=
  Preord.Mixin string string_ord _ _.
Next Obligation.
  induction x; simpl; auto.
Qed.
Next Obligation.
  induction x; simpl; auto.
  induction y; simpl; intuition.
  destruct z; auto.
  intuition subst.
  left.
  unfold char_ord in *.
  split; auto.
  intro. subst a.
  apply H.
  rewrite <- (ascii_N_embedding a1).
  rewrite <- (ascii_N_embedding a0).
  f_equal.
  apply N.le_antisymm; auto.
  eapply N.le_trans; eauto.
  auto.
  destruct z. elim H0.
  subst a0.
  intuition subst; auto.
  right; split; eauto.
Qed.

(**  [atom] is the preorder of strings with their
     lexicographic order.  We use these for object-level
     variables.
  *)
Canonical Structure atom : Preord.type :=
  Preord.Pack string string_ord_mixin.

(**   The order on [atom] is decidable.
  *)
Program Definition atom_dec : ord_dec atom := OrdDec _ _.
Next Obligation.
  induction x; simpl; intros.
  left. exact I.
  destruct y.
  right. intro. apply H.
  case_eq (N_of_ascii a ?= N_of_ascii a0)%N.
  intros.
  destruct (IHx y).
  left. red. simpl.
  right. split; auto.
  rewrite <- (ascii_N_embedding a).
  rewrite <- (ascii_N_embedding a0).
  replace (N_of_ascii a) with (N_of_ascii a0); auto.
  symmetry.
  apply N.compare_eq. auto.
  right.
  intro. red in H0. simpl in H0.
  intuition.
  apply H0.
  rewrite <- (ascii_N_embedding a).
  rewrite <- (ascii_N_embedding a0).
  replace (N_of_ascii a) with (N_of_ascii a0); auto.
  symmetry.
  apply N.compare_eq. auto.
  intro.
  left. red; simpl.
  left.
  split. intro.
  subst a0.
  generalize (N.compare_ge_iff (N_of_ascii a) (N_of_ascii a)).
  intros. destruct H0. apply H1. apply N.le_refl. auto.
  red. red. rewrite H. discriminate.
  intro. right. intro.
  red in H0. simpl in H0.
  destruct H0.
  destruct H0. hnf in H1.
  apply H1; auto.
  destruct H0. subst a0.
  generalize (N.compare_le_iff (N_of_ascii a) (N_of_ascii a)).
  rewrite H. intros.
  destruct H0. apply H2; auto.
  apply N.le_refl.
Defined.

(**  [atom] is actually a partial order with respect to [=].
  *)
Lemma atom_strong_eq : forall (x y:atom), x ≈ y -> x = y.
Proof.
  induction x.
  induction y; simpl; intros; auto.
  destruct H. elim H0.
  induction y; simpl; intros; auto.
  destruct H. elim H.
  destruct H.
  destruct H. destruct H0.
  destruct H; destruct H0.
  elim H.
  rewrite <- (ascii_N_embedding a).
  rewrite <- (ascii_N_embedding a0).
  f_equal.
  apply N.le_antisymm; auto.
  destruct H; destruct H0.
  elim H; auto.
  destruct H0.
  destruct H; destruct H0.
  elim H0; auto.
  destruct H; destruct H0.
  subst a0.
  f_equal. apply IHx.
  split; auto.
Qed.

Section unfold.
  Variables X A:Type.
  Variable step : X -> X * A.

  Definition unfold_stream (seed:X) (n:N) : A :=
       N.peano_rect (fun _ => X -> A)
                    (fun x => snd (step x))
                    (fun _ r x => r (fst (step x)))
                    n seed.

  Variable invariant : X -> Prop.
  Variable wf_rel : X -> X -> Prop.
  Variable out_prop : A -> Prop.

  Hypothesis wf : well_founded wf_rel.

  Hypothesis ind_step : forall x,
    invariant x -> let (x',a) := step x in
      (invariant x' /\ wf_rel x' x) \/ out_prop a.

  Lemma unfold_find : forall x,
    invariant x ->
    exists n a, unfold_stream x n = a /\ out_prop a.
  Proof.
    induction x using (well_founded_induction wf); intros.
    generalize (ind_step x H0).
    case_eq (step x); intros x' a ?.
    intros [[??]|?].
    destruct (H x') as [n [a' [??]]]; auto.
    exists (N.succ n). exists a'.
    split; auto.
    unfold unfold_stream; rewrite N.peano_rect_succ.
    rewrite H1. simpl. auto.
    exists N.zero. exists a.
    compute.
    rewrite H1; split; simpl; auto.
  Defined.

End unfold.

(**  When choosing fresh atoms, these are the only characters
     that will be used.
  *)
Definition allowable_chars := "abcdefghijklmnopqrstuvwxyz".

Fixpoint adjoin_char (s:string) (ls:list string) :=
  match s with
  | "" => nil
  | String a s' => map (fun q => String a q) ls ++
                   adjoin_char s' ls
  end.

Fixpoint perms (n:nat) (s:string) : list string :=
  match n with
  | 0 => ""::nil
  | S n' => adjoin_char s (perms n' s)
  end.

Lemma perms_len : forall n s s',
  In s' (perms n s) -> String.length s' = n.
Proof.
  induction n; simpl; intuition subst; auto.
  revert H. generalize s at 1.
  induction s0; simpl; intros. elim H.
  apply in_app_or in H. destruct H.
  generalize (IHn s). revert H.
  generalize (perms n s).
  induction l; simpl; intuition.
  subst s'. simpl. f_equal.
  apply H0; auto.
  apply IHs0; auto.
Qed.

Lemma perms_neq_nil : forall n a s,
  perms n (String a s) = nil -> False.
Proof.
  induction n; simpl; intros.
  discriminate.
  apply (IHn a s).
  destruct (perms n (String a s)); auto.
  simpl in H. discriminate.
Qed.

Definition idents_step (x:nat * list string) :
  (nat * list string * option string) :=
  match x with
  | (n, s::l) => (n, l, Some s)
  | (n, nil)  => (S n, perms (S n) allowable_chars, None)
  end.

(**  The set of all "choosable" atoms.  We enumerate
     this set using an unfold.
  *)
Definition idents_set : eset atom :=
  unfold_stream (nat*list string) (option string) idents_step (0, nil).

(**  The [idents_set] contains at least on string of a given
     (nonzero) length.  This will be used to show that we can
     always choose a fresh atom distinct from any finite set of atoms.
  *)
Section idents_length.
  Variable len:nat.
  Hypothesis len0 : 0 < len.

  Definition idents_inv (x:nat * list string) :=
    fst x < len \/
    (fst x = len /\
      snd x <> nil /\
      forall s, In s (snd x) -> String.length s = len).

  Definition idents_wf (x' x:nat * list string) :=
    (fst x < fst x' <= len) \/
    (fst x = fst x' /\ length (snd x') < length (snd x)).

  Definition idents_out (a:option string) :=
    match a with
    | None => False
    | Some s => String.length s = len
    end.

  Lemma wf_idents_wf : well_founded idents_wf.
  Proof.
    red. intros [x l].
    destruct (le_gt_dec x len) as [H|H].
    set (z := len - x).
    assert (x = len - z).
    subst z.
    omega.
    clearbody z. revert x l H H0.
    induction z using (well_founded_induction lt_wf).
    intro x.
    induction l using
      (well_founded_induction (well_founded_ltof _ (@List.length string))); intros.
    constructor; intros.
    destruct y; simpl in *.
    destruct H3; simpl in *.
    apply H with (len - n); omega.
    destruct H3. subst n.
    apply H0; auto.
    induction l using
      (well_founded_induction (well_founded_ltof _ (@List.length string))); intros.
    constructor; intros.
    destruct H1. simpl in *.
    elimtype False. omega.
    simpl in *. destruct H1.
    destruct y; simpl in *.
    subst n. apply H0.
    auto.
  Defined.

Opaque perms.
  Lemma idents_find_len_aux :
    exists n, exists a,
      idents_set n = a /\ idents_out a.
  Proof.
    apply unfold_find with idents_inv idents_wf.
    apply wf_idents_wf.
    unfold idents_inv. unfold idents_step.
    intros [n l]. simpl.
    intros. destruct H.
    destruct l; simpl.
    left.
    split.
    destruct (eq_nat_dec (S n) len).
    right. split; auto.
    split.
    red. apply perms_neq_nil.
    rewrite e.
    apply perms_len.
    left. omega.
    red. simpl.
    left. omega.
    left. split; auto.
    red. simpl.
    right. split; auto.
    destruct H as [?[??]]. subst n.
    destruct l. elim H0. auto.
    simpl. right.
    apply H1. simpl; auto.
    hnf. simpl.
    auto.
  Defined.

  Lemma idents_find : exists s,
    s ∈ idents_set /\
    String.length s = len.
  Proof.
    destruct idents_find_len_aux as [n [a [??]]].
    hnf in H0. destruct a. 2: elim H0.
    exists c. split; auto.
    exists n. rewrite H. auto.
  Defined.

End idents_length.

Definition max_len
  := fold_right (fun x y => max (String.length x) y) 0.

Lemma max_len_le (xs:finset atom) (x:atom) :
  x ∈ xs ->
  String.length x <= max_len xs.
Proof.
  induction xs; simpl; intros.
  apply nil_elem in H. elim H.
  apply cons_elem in H. destruct H.
  apply atom_strong_eq in H. subst x.
  apply Max.le_max_l.
  apply le_trans with (max_len xs); auto.
  apply Max.le_max_r.
Qed.

Section fresh.
  Variable atoms : finset atom.

  Program Definition fresh_idents :=
    esubset_dec atom (fun x => ~In x atoms) _ idents_set.
  Next Obligation.
    intro.
    destruct (In_dec string_dec x atoms); auto.
  Defined.

  Lemma fresh_idents_inhabited : einhabited fresh_idents.
  Proof.
    apply member_inhabited.
    destruct (idents_find (S (max_len atoms))) as [s [??]].
    red. auto with arith.
    exists s. unfold fresh_idents.
    destruct H as [n ?].
    exists n. simpl.
    unfold esubset_dec.
    destruct (idents_set n).
    2: elim H.
    unfold fresh_idents_obligation_1.
    destruct (in_dec string_dec c atoms).
    assert (String.length s <= max_len atoms).
    apply max_len_le. exists c. split; auto.
    rewrite H0 in H1.
    omega.
    auto.
  Defined.

  Definition fresh_atom := choose atom fresh_idents fresh_idents_inhabited.

  Lemma fresh_atom_is_fresh : fresh_atom ∉ atoms.
  Proof.
    red; intro.
    unfold fresh_atom in H.
    unfold choose in H.
    destruct (find_inhabitant atom fresh_idents fresh_idents_inhabited)
      as [a [b [??]]].
    simpl in *.
    unfold fresh_idents in e.
    unfold esubset_dec in e.
    destruct (idents_set b). 2: discriminate.
    destruct (fresh_idents_obligation_1 c).
    apply n.
    inversion e. subst a.
    destruct H as [q [??]].
    apply atom_strong_eq in H0. subst q. auto.
    discriminate.
  Qed.
End fresh.

Lemma fresh_atom_is_fresh' (l1 l2:finset atom) :
  l1 ⊆ l2 ->
  fresh_atom l2 ∉ l1.
Proof.
  repeat intro.
  apply H in H0.
  apply (fresh_atom_is_fresh l2); auto.
Qed.


From discprob.basic Require Import base order.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.monad Require Import monad monad_par par_quicksort monad_par_hoare.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
From mathcomp Require Import path.
Require Import Coq.omega.Omega Coq.Program.Wf.

Lemma perm_eq_cat {A: eqType} (l1a l1b l2a l2b: seq A) :
  perm_eq l1a l2a →
  perm_eq l1b l2b →
  perm_eq (l1a ++ l1b) (l2a ++ l2b).
Proof.
  move /perm_eqP => Hpa.
  move /perm_eqP => Hpb.
  apply /perm_eqP.
  intros x. rewrite ?count_cat. rewrite (Hpa x) (Hpb x). done.
Qed.

Lemma sorted_cat {A: eqType} (l1 l2: seq A) (R: rel A):
  sorted R l1 → sorted R l2 →
  (∀ n1 n2, n1 \in l1 → n2 \in l2 → R n1 n2) →
  sorted R (l1 ++ l2).
Proof.
  revert l2. induction l1 => //=.
  intros l2 HP Hsorted Hle.
  rewrite cat_path. apply /andP; split; auto.
  induction l2 => //=. apply /andP; split; auto.
  apply Hle.
  - apply mem_last.
  - rewrite in_cons eq_refl //.
Qed.

Lemma quicksort_correct (l: list nat): mspec (qs l) (λ l', (sorted leq l' && perm_eq l l'):Prop).
Proof.
  remember (size l) as k eqn:Heq.
  revert l Heq.
  induction k as [k IH] using (well_founded_induction lt_wf) => l Heq.
  destruct l as [| a l].
  - rewrite //= => b. rewrite mem_seq1. move /eqP => -> //=.
  - destruct l as [| b0 l0].
    { rewrite //= => b. rewrite mem_seq1. move /eqP => -> //=. }
    rewrite qs_unfold.
    remember (b0 :: l0) as l eqn:Hl0. clear l0 Hl0.
    tbind (λ x, sval x \in a :: l).
    { intros (?&?) => //. }
    intros (pv&Hin) _.
    tbind (λ x, lower (sval x) = [ seq n <- (a :: l) | ltn n pv] ∧
                middle (sval x) = [ seq n <- (a :: l) | n == pv] ∧
                upper (sval x) = [ seq n <- (a :: l) | ltn pv n]).
    { remember (a :: l) as l0 eqn:Heql0.
      apply mspec_mret => //=. clear. induction l0 as [|a l]; first by rewrite //=.
      rewrite //=; case (ltngtP a pv) => //= ?;
      destruct (IHl) as (?&?&?); repeat split; auto; f_equal; done.
    }
    remember (a :: l) as l0 eqn:Heql0.
    intros (spl&Hin'). intros (Hl&Hm&Hu). rewrite //= in Hl, Hm, Hu.
    tbind (λ x, (sorted leq (fst x) && perm_eq (lower spl) (fst x)) ∧
                (sorted leq (snd x) && perm_eq (upper spl) (snd x))).
    { rewrite //=.
      eapply (mspec_rpar2 _ _ (λ x, (sorted leq x && perm_eq (lower spl) x))
                              (λ x, (sorted leq x && perm_eq (upper spl) x))).
      - eapply (IH (size (lower spl))); auto.
        rewrite Heq.
        move /andP in Hin'.
        destruct Hin' as (pf1&pf2); move /implyP in pf2.
        rewrite -(perm_eq_size pf1) //= ?size_cat -?plusE //;
          assert (Hlt: (lt O (size (middle spl)))) by
            ( apply /ltP; apply pf2 => //=; destruct p; eauto; subst; rewrite //=).
        rewrite //= in Hlt. omega.
      - eapply (IH (size (upper spl))); auto.
        rewrite Heq.
        move /andP in Hin'.
        destruct Hin' as (pf1&pf2); move /implyP in pf2.
        rewrite -(perm_eq_size pf1) //= ?size_cat -?plusE //;
          assert (Hlt: (lt O (size (middle spl)))) by
            ( apply /ltP; apply pf2 => //=; destruct p; eauto; subst; rewrite //=).
        rewrite //= in Hlt. omega.
    }
    intros (ll&lu) (Hll&Hlu).
    move /andP in Hll. destruct Hll as (Hllsorted&Hllperm).
    move /andP in Hlu. destruct Hlu as (Hlusorted&Hluperm).
    apply mspec_mret => //=. apply /andP; split.
    * apply sorted_cat; [| apply sorted_cat |]; auto.
      ** rewrite Hm. clear. induction l0 => //=.
         case: ifP; auto.
         move /eqP => ->. rewrite //=.
         clear IHl0.
         induction l0 => //=.
         case: ifP; auto. move /eqP => -> //=. rewrite leqnn IHl0 //.
      ** rewrite Hm => a' b'; rewrite mem_filter.
         move /andP => [Heqpv Hin1 Hin2]. move /eqP in Heqpv.
         move: Hin2.
         rewrite -(perm_eq_mem Hluperm) Hu mem_filter.
         move /andP => [Hgtpv ?]. move /ltP in Hgtpv.
         rewrite Heqpv. apply /leP. omega.
      ** intros a' b'. rewrite -(perm_eq_mem Hllperm) Hl mem_filter.
         move /andP => [Hgtpv ?]. move /ltP in Hgtpv.
         rewrite mem_cat. move /orP => [].
         *** rewrite Hm; rewrite mem_filter.
             move /andP => [Heqpv ?]. move /eqP in Heqpv.
             rewrite Heqpv. apply /leP. omega.
         *** rewrite -(perm_eq_mem Hluperm) Hu mem_filter.
             move /andP => [Hltpv ?]. move /ltP in Hltpv.
             apply /leP. omega.
    * move /andP in Hin'. destruct Hin' as (Hperm&_).
      rewrite perm_eq_sym in Hperm.
      rewrite (perm_eq_trans Hperm) //.
      repeat apply perm_eq_cat; auto.
Qed.


Require Import VST.floyd.proofauto.
Require Import VST.progs.sumarray.
#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.
Definition Gprog: funspecs := nil.
Definition Delta1 : tycontext :=
  ltac:(let x := constr:(func_tycontext f_sumarray Vprog Gprog nil)
         in let y := eval hnf in x
         in exact y).

(* This example is from the "EX, Intros, Exists" chapter of the Verifiable C Reference Manual *)
Lemma exercise1:
 let Delta := @abbreviate _ Delta1 in
 forall sh p,
 ENTAIL Delta,
   EX x:Z,
    PROP(0<=x) LOCAL(temp _i (Vint (Int.repr x)))
    SEP (EX y:Z, !!(x<y) && data_at sh tint (Vint (Int.repr y)) p)
|-- EX u: Z,
     PROP(0<u) LOCAL()
     SEP (data_at sh tint (Vint (Int.repr u)) p).
Proof.
intros.
Intros a b.
Exists b.
entailer!.
Qed.

(* These examples of [rep_lia] are from is from the "Integers: nat, Z, int" chapter of the Verifiable C Reference Manual *)
Lemma exercise2:
  forall x,
  Int.min_signed <= x <= Int.max_signed ->
  Int.signed (Int.repr x) = x.
Proof.
intros x H.
(* Notice that the premise H is needed for the next line *)
rewrite Int.signed_repr by rep_lia.
auto.
Qed.

Lemma exercise3:
  forall n, 0 <= n <= Int.max_signed ->
  Int.min_signed <= 0 <= n.
Proof.
intros.
rep_lia.
Qed.

Lemma exercise3b:
  forall al: list Z ,  Zlength al < 50 ->
         0 <= Zlength al < Int.max_signed.
Proof.
intros.
rep_lia.
Qed.

Lemma exercise3c:
  forall i,
         0 <= Int.unsigned (Int.repr i) <= Int.max_unsigned.
Proof.
intros.
rep_lia.
Qed.

(**  How to manage semi-opaque constants, using #[export] Hint Rewrite : rep_lia. *)
(* Suppose you have an uninitialized array of size N: *)

Module Test1.
Definition N : Z := 20.

Lemma exercise4:
 let Delta := @abbreviate _ Delta1 in
 forall sh p,
    data_at sh (tarray tint N) (Vint (Int.repr 1) :: Vint (Int.repr 2) :: repeat Vundef (Z.to_nat (N-2))) p
 |--  !! (0 <= Zlength (repeat Vundef (Z.to_nat (N-2))) < Int.max_signed).
Proof.
intros.
simpl.
(* It's not nice that [simpl] unfolded the list_repeat. *)
entailer!.
repeat rewrite Zlength_cons. rewrite Zlength_nil.
rep_lia.
Abort.

(* To avoid unfolding of the list_repeat, let us make N opaque. *)

Global Opaque N.

(* Unfortunately, that's not good enough:
  Opaque prevents "simpl" and "simple apply" from unfolding N,
  but "reflexivity" and "auto" will still unfold N, causing some
  proofs to blow up. *)
End Test1.

Definition N : Z := proj1_sig (opaque_constant 20).

Lemma exercise4b:
 let Delta := @abbreviate _ Delta1 in
 forall sh p,
    data_at sh (tarray tint N) (Vint (Int.repr 1) :: Vint (Int.repr 2) :: repeat Vundef (Z.to_nat (N-2))) p
 |--  !! (0 <= Zlength (repeat Vundef (Z.to_nat (N-2))) < Int.max_signed).
Proof.
intros.
simpl.
(* That's better; the data_at is more concise.  But now, unfortunately: *)
entailer!.
rewrite Zlength_repeat.
Fail rep_lia.
(* now rep_lia does not know that N=20. *)
Abort.

(* To tell rep_lia that N=20, just add a hint to the rep_lia database: *)

Definition N_eq : N=20 := proj2_sig (opaque_constant _).
#[export] Hint Rewrite N_eq : rep_lia.

Lemma exercise4c:
 let Delta := @abbreviate _ Delta1 in
 forall sh p,
    data_at sh (tarray tint N) (Vint (Int.repr 1) :: Vint (Int.repr 2) :: repeat Vundef (Z.to_nat (N-2))) p
 |--  !! (0 <= Zlength (repeat Vundef (Z.to_nat (N-2))) < Int.max_signed).
Proof.
intros.
simpl.
(* That's still good; the data_at is more concise.  *)
entailer!.
rewrite Zlength_repeat.
rep_lia.
rep_lia.
Qed.

(* Summary: Make opaque constants using opaque_constant,
  but Rewrite rule to the rep_lia database. *)


(**
This file is part of the CoqApprox formalization of rigorous
polynomial approximation in Coq:
http://tamadi.gforge.inria.fr/CoqApprox/

Copyright (C) 2010-2012, ENS de Lyon.
Copyright (C) 2010-2016, Inria.
Copyright (C) 2014-2016, IRIT.

This library is governed by the CeCILL-C license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/or redistribute the library under the terms of the CeCILL-C
license as circulated by CEA, CNRS and Inria at the following URL:
http://www.cecill.info/

As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided
only with a limited warranty and the library's author, the holder of
the economic rights, and the successive licensors have only limited
liability. See the COPYING file for more details.
*)

From Coq Require Import ZArith Reals Psatz.
From mathcomp.ssreflect Require Import ssreflect ssrbool ssrfun eqtype ssrnat bigop.
From Coquelicot Require Import Coquelicot.

Require Import Stdlib.
Require Import MathComp.
Require Import Xreal.
Require Import Interval.
Require Import Taylor.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Local Open Scope nat_scope.

Notation IInan := Interval.Inan (only parsing).

Lemma contains_Xreal (xi : interval) (x : ExtendedR) :
  contains xi x -> contains xi (Xreal (proj_val x)).
Proof. by case: x =>//; case: xi. Qed.

(*******************************************************************************)
(** For convenience, define a predicate [not_empty'] equivalent to [not_empty] *)
(*******************************************************************************)

Definition not_empty' (xi : interval) := exists v : ExtendedR, contains xi v.

Lemma not_emptyE xi : not_empty' xi -> not_empty xi.
Proof.
case: xi =>[|l u] [v Hv]; first by exists R0.
case: v Hv =>[//|r] Hr.
by exists r.
Qed.

Lemma not_empty'E xi : not_empty xi -> not_empty' xi.
Proof.
case=>[r Hr]; by exists (Xreal r).
Qed.

(**************************************************************)
(** Some support results relating inequalities and [contains] *)
(**************************************************************)

Definition intvl a b x := (a <= x <= b)%R.

Lemma intvl_connected a b : connected (intvl a b).
Proof.
move=> x y Hx Hy z Hz; split.
- exact: Rle_trans (proj1 Hx) (proj1 Hz).
- exact: Rle_trans (proj2 Hz) (proj2 Hy).
Qed.

Lemma intvl_l l u x0 :
  intvl l u x0 -> intvl l u l.
Proof. by case=> [H1 H2]; split =>//; apply: Rle_refl || apply: Rle_trans H2. Qed.

Lemma intvl_u l u x0 :
  intvl l u x0 -> intvl l u u.
Proof. by case=> [H1 H2]; split =>//; apply: Rle_refl || apply: Rle_trans H2. Qed.

Lemma intvl_lVu l u x0 x :
  intvl l u x -> intvl l u x0 -> intvl l x0 x \/ intvl x0 u x.
Proof.
move=> [H1 H2] [H3 H4].
have [Hle|Hlt] := Rle_lt_dec x x0.
by left.
by move/Rlt_le in Hlt; right.
Qed.

(********************************************)
(** Some support results about monotonicity *)
(********************************************)

Section PredArg.
Variable P : R -> Prop.

Definition Rincr (f : R -> R) :=
  forall x y : R,
  P x -> P y ->
  (x <= y -> f x <= f y)%R.

Definition Rdecr (f : R -> R) :=
  forall x y : R,
  P x -> P y ->
  (x <= y -> f y <= f x)%R.

Definition Rmonot (f : R -> R) :=
  Rincr f \/ Rdecr f.

Definition Rpos_over (g : R -> R) :=
  forall x : R, (P x -> 0 <= g x)%R.

Definition Rneg_over (g : R -> R) :=
  forall x : R, (P x -> g x <= 0)%R.

Definition Rcst_sign (g : R -> R) :=
  Rpos_over g \/ Rneg_over g.

Definition Rderive_over (f f' : R -> R) :=
  forall x : R, P x -> is_derive f x (f' x).

Lemma Rderive_pos_imp_incr (f f' : R -> R) :
  connected P -> Rderive_over f f' -> Rpos_over f' -> Rincr f.
Proof.
rewrite /Rpos_over /Rincr.
move=> Hco Hder H0 x y Hx Hy Hxy; rewrite //=.
eapply (derivable_pos_imp_increasing f f' P) =>//.
move=> r Hr.
move/(_ _ Hr) in Hder.
move/(_ _ Hr) in H0.
apply: conj H0.
exact/is_derive_Reals.
Qed.

Lemma Rderive_neg_imp_decr (f f' : R -> R) :
  connected P -> Rderive_over f f' -> Rneg_over f' -> Rdecr f.
Proof.
rewrite /Rneg_over /Rdecr.
move=> Hco Hder H0 x y Hx Hy Hxy; rewrite //=.
eapply (derivable_neg_imp_decreasing f f' P) =>//.
move=> r Hr.
move/(_ _ Hr) in Hder.
move/(_ _ Hr) in H0.
apply: conj H0.
exact/is_derive_Reals.
Qed.

Lemma Rderive_cst_sign (f f' : R -> R) :
  connected P -> Rderive_over f f' -> Rcst_sign f' -> Rmonot f.
Proof.
move=> Hco Hder [H|H].
left; exact: Rderive_pos_imp_incr H.
right; exact: Rderive_neg_imp_decr H.
Qed.

End PredArg.

(********************************************************************)
(** Instantiation of [Taylor.Cor_Taylor_Lagrange] for intervals *)
(********************************************************************)

Lemma sum_f_to_big n (f : nat -> R) :
  sum_f_R0 f n = \big[Rplus/0%R]_(0 <= i < n.+1) f i.
Proof.
elim: n =>[|n IHn]; first by rewrite big_nat_recl // big_mkord big_ord0 Rplus_0_r.
by rewrite big_nat_recr //= IHn.
Qed.

Section NDerive.
Variable xf : R -> ExtendedR.
Let f x := proj_val (xf x).
Let Dn := Derive_n f.
Variable dom : R -> Prop.
Hypothesis Hdom : connected dom.
Variable n : nat.
Hypothesis Hdef : forall r, dom r -> xf r <> Xnan.
Hypothesis Hder : forall n r, dom r -> ex_derive_n f n r.

Theorem ITaylor_Lagrange x0 x :
  dom x0 ->
  dom x ->
  exists xi : R,
  dom xi /\
  (f x - \big[Rplus/0%R]_(0 <= i < n.+1)
          (Dn i x0 / INR (fact i) * (x - x0)^i))%R =
  (Dn n.+1 xi / INR (fact n.+1) * (x - x0) ^ n.+1)%R /\
  (x <= xi <= x0 \/ x0 <= xi <= x)%R.
Proof.
move=> Hx0 Hx.
case (Req_dec x0 x)=> [->|Hneq].
  exists x; split =>//=; split; last by auto with real.
  rewrite (Rminus_diag_eq x) // Rmult_0_l Rmult_0_r.
  rewrite big_nat_recl // pow_O big1 /Dn /=; try field.
  by move=> i _; rewrite Rmult_0_l Rmult_0_r.
have Hlim x1 x2 : (x1 < x2)%R -> dom x1 -> dom x2 ->
  forall (k : nat) (r1 : R), (k <= n)%coq_nat ->
  (fun r2 : R => x1 <= r2 <= x2)%R r1 ->
  derivable_pt_lim (Dn k) r1 (Dn (S k) r1).
  move=> Hx12 Hdom1 Hdom2 k y Hk Hy.
  have Hdy: (dom y) by move: Hdom; rewrite /connected; move/(_ x1 x2); apply.
  by apply/is_derive_Reals/Derive_correct; apply: (Hder k.+1 Hdy).
destruct (total_order_T x0 x) as [[H1|H2]|H3]; last 2 first.
    by case: Hneq.
  have H0 : (x <= x0 <= x0)%R by auto with real.
  have H : (x <= x <= x0)%R by auto with real.
  case: (Cor_Taylor_Lagrange x x0 n (fun n r => (Dn n r))
    (Hlim _ _ (Rgt_lt _ _ H3) Hx Hx0) x0 x H0 H) => [c [Hc Hc1]].
  exists c.
  have Hdc : dom c.
    move: Hdom; rewrite /connected; move/(_ x x0); apply=>//.
    by case: (Hc1 Hneq)=> [J|K]; lra.
  split=>//; split; last by case:(Hc1 Hneq);rewrite /=; [right|left]; intuition.
  rewrite sum_f_to_big in Hc.
  exact: Hc.
have H0 : (x0 <= x0 <= x)%R by auto with real.
have H : (x0 <= x <= x)%R by auto with real.
case: (Cor_Taylor_Lagrange x0 x n (fun n r => Dn n r)
  (Hlim _ _ (Rgt_lt _ _ H1) Hx0 Hx) x0 x H0 H) => [c [Hc Hc1]].
exists c.
have Hdc : dom c.
  move: Hdom; rewrite /connected; move/(_ x0 x); apply=>//.
  by case: (Hc1 Hneq)=> [J|K]; lra.
split=>//; split; last by case:(Hc1 Hneq);rewrite /=; [right|left]; intuition.
rewrite sum_f_to_big in Hc.
exact: Hc.
Qed.

End NDerive.

(******************************************************************************)
(** The sequel of the file is parameterized by an implementation of intervals *)
(******************************************************************************)

Module IntervalAux (I : IntervalOps).

(** The following predicate will be used by [Ztech]. *)
Definition isNNegOrNPos (X : I.type) : bool :=
  if I.sign_large X is Xund then false else true.

Lemma isNNegOrNPos_false (X : I.type) :
  I.convert X = IInan -> isNNegOrNPos X = false.
Proof.
move=> H; rewrite /isNNegOrNPos; have := I.sign_large_correct X.
by case: I.sign_large =>//; rewrite H; move/(_ Xnan I) =>//; case.
Qed.

Definition gt0 xi : bool :=
  if I.sign_strict xi is Xgt then true else false.

Definition apart0 xi : bool :=
  match I.sign_strict xi with
  | Xlt | Xgt => true
  | _ => false
  end.

Lemma gt0_correct X x :
  contains (I.convert X) (Xreal x) -> gt0 X -> (0 < x)%R.
Proof.
move=> Hx; rewrite /gt0.
have := I.sign_strict_correct X; case: I.sign_strict=>//.
by case/(_ _ Hx) =>/=.
Qed.

Lemma apart0_correct X x :
  contains (I.convert X) (Xreal x) -> apart0 X -> (x <> 0)%R.
Proof.
move=> Hx; rewrite /apart0.
have := I.sign_strict_correct X; case: I.sign_strict=>//;
  by case/(_ _ Hx) =>/=; auto with real.
Qed.

(*******************************************************)
(** Support results about [I.midpoint] and [not_empty] *)
(*******************************************************)

Definition Imid i : I.type := I.bnd (I.midpoint i) (I.midpoint i).

Lemma not_empty_Imid (X : I.type) :
  not_empty (I.convert X) -> not_empty (I.convert (Imid X)).
Proof.
case=>[v Hv].
rewrite /Imid I.bnd_correct.
apply: not_emptyE.
exists (I.convert_bound (I.midpoint X)).
red.
have e : exists x : ExtendedR, contains (I.convert X) x by exists (Xreal v).
have [-> _] := I.midpoint_correct X e.
by auto with real.
Qed.

Lemma Imid_subset (X : I.type) :
  not_empty (I.convert X) ->
  subset' (I.convert (Imid X)) (I.convert X).
Proof.
case=>[v Hv].
rewrite /Imid I.bnd_correct.
have HX : exists x : ExtendedR, contains (I.convert X) x by exists (Xreal v).
have [->] := I.midpoint_correct X HX.
case: I.convert =>[//|l u].
move => H [//|x].
intros [H1 H2].
by rewrite (Rle_antisym _ _ H2 H1).
Qed.

Lemma Imid_contains (X : I.type) :
  not_empty (I.convert X) ->
  contains (I.convert (Imid X)) (I.convert_bound (I.midpoint X)).
Proof.
move=>[v Hv].
rewrite /Imid I.bnd_correct.
have HX : exists x : ExtendedR, contains (I.convert X) x by exists (Xreal v).
have [-> Hreal] := I.midpoint_correct X HX.
split ; apply Rle_refl.
Qed.

Lemma Xreal_Imid_contains (X : I.type) :
  not_empty (I.convert X) ->
  contains (I.convert (Imid X)) (Xreal (proj_val (I.convert_bound (I.midpoint X)))).
Proof.
move=>[v Hv].
rewrite /Imid I.bnd_correct.
have HX : exists x : ExtendedR, contains (I.convert X) x by exists (Xreal v).
have [-> Hreal] := I.midpoint_correct X HX.
split ; apply Rle_refl.
Qed.

(******************************************************************************)
(** Correctness predicates dealing with reals only, weaker than [I.extension] *)
(******************************************************************************)

Lemma R_from_nat_correct :
  forall (b : I.type) (n : nat),
  contains (I.convert (I.fromZ (Z.of_nat n)))
           (Xreal (INR n)).
Proof. move=> b n; rewrite INR_IZR_INZ; exact: I.fromZ_correct. Qed.

Section PrecArgument.

Variable prec : I.precision.

Lemma mul_0_contains_0_l y Y X :
  contains (I.convert Y) y ->
  contains (I.convert X) (Xreal 0) ->
  contains (I.convert (I.mul prec X Y)) (Xreal 0).
Proof.
move=> Hy H0.
have H0y ry : (Xreal 0) = (Xreal 0 * Xreal ry)%XR by rewrite /= Rmult_0_l.
case: y Hy => [|ry] Hy; [rewrite (H0y 0%R)|rewrite (H0y ry)];
  apply: I.mul_correct =>//.
by case ->: (I.convert Y) Hy.
Qed.

Lemma mul_0_contains_0_r y Y X :
  contains (I.convert Y) y ->
  contains (I.convert X) (Xreal 0) ->
  contains (I.convert (I.mul prec Y X)) (Xreal 0).
Proof.
move=> Hy H0.
have Hy0 ry : (Xreal 0) = (Xreal ry * Xreal 0)%XR by rewrite /= Rmult_0_r.
case: y Hy => [|ry] Hy; [rewrite (Hy0 0%R)|rewrite (Hy0 ry)];
  apply: I.mul_correct=>//.
by case: (I.convert Y) Hy.
Qed.

Lemma pow_contains_0 (X : I.type) (n : Z) :
  (n > 0)%Z ->
  contains (I.convert X) (Xreal 0) ->
  contains (I.convert (I.power_int prec X n)) (Xreal 0).
Proof.
move=> Hn HX.
rewrite (_: (Xreal 0) = (Xpower_int (Xreal 0) n)); first exact: I.power_int_correct.
case: n Hn =>//= p Hp; rewrite pow_ne_zero //.
by zify; auto with zarith.
Qed.

Lemma subset_sub_contains_0 x0 (X0 X : I.type) :
  contains (I.convert X0) x0 ->
  subset' (I.convert X0) (I.convert X) ->
  contains (I.convert (I.sub prec X X0)) (Xreal 0).
Proof.
move=> Hx0 Hsub.
destruct x0 as [|x0].
rewrite I.sub_propagate_r //.
now destruct (I.convert X0).
replace (Xreal 0) with (Xreal x0 - Xreal x0)%XR.
apply I.sub_correct with (2 := Hx0).
now apply Hsub.
apply (f_equal Xreal).
now apply Rminus_diag_eq.
Qed.

End PrecArgument.
End IntervalAux.


(** * Verif_triang: A client of the stack functions *)

Require VC.Preface. (* Check for the right version of VST *)
Require Import VST.floyd.proofauto.
Require Import VST.floyd.library.
Require Import VC.stack.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

(** Here are some functions (in [stack.c]) that are clients of the stack ADT.  First, push the numbers 1,2,...,n onto a stack, then pop the numbers off the stack and add them up.  This computes the nth triangular number, 1+2+...+n = n(n+1)/2.

void push_increasing (struct stack *st, int n) {
  int i;
  i=0;
  while (i<n) {
     i++;
     push(st,i);
  }
}

int pop_and_add (struct stack *st, int n) {
  int i=0;
  int t, s=0;
  while (i<n) {
    t=pop(st);
    s += t;
    i++;
  }
  return s;
}

int main (void) {
  struct stack *st;
  int i,t,s;
  st = newstack();
  push_increasing(st, 10);
  s = pop_and_add(st, 10);
  return s;
}

Let's verify this program! *)

(* ================================================================= *)
(** ** Proofs with integers *)

(** The natural numbers have arithmetic axioms that are not very nice.
   For example, you might expect that [a-b+b=a], but that's not true: *)
Lemma nat_sub_add_yuck:
  ~ (forall a b: nat, a-b+b=a)%nat.
Proof.
intros.
intro.
specialize (H 0 1)%nat.
simpl in H. inversion H.
Qed.

(** This just shows that if the negative numbers did not exist, it would be
  necessary to construct them!  In reasoning about programs, as in many other
  kinds of mathematics, we should use the integers.  In Coq the type is called [Z]. *)
Lemma Z_sub_add_ok:
  forall a b : Z, a-b+b=a.
Proof. intros. lia. Qed.

(** The Z type does have an inductive definition . . . *)
Print Z.
(* Inductive Z : Set := Z0 : Z | Zpos : positive -> Z | Zneg : positive -> Z

    but we generally prefer to reason _abstractly_ about Z, using the lemmas
 in the Coq library (that the Coq developers proved from the inductive
 definition).  The induction principle on Z, that's automatically derived
 from this Inductive definition, is not the one we usually want to use! *)

(** Let's consider a recursive function on Z, the function that turns
   [5] into the list [5::4::3::2::1::nil].  In the natural numbers,
   that's easy to define: *)

Fixpoint decreasing_nat (n: nat) : list nat :=
 match n with S n' => n :: decreasing_nat n' | O => nil end.

(** But in the integers [Z], we cannot simply pattern-match on successor ... *)
Fail Fixpoint decreasing_Z (n: Z) : list Z :=
 match n with Z.succ n' => n :: decreasing_Z n' | 0 => nil end.
(** ... because Z.succ is a function, not a constructor. *)

(** There are two ways we might define a function to produce a decreasing
  list of Z.  First, we might use [Z.of_nat] and [Z.to_nat]: *)

Fixpoint decreasing_Z1_aux (n: nat) : list Z :=
  match n with
  | S n' => Z.of_nat n :: decreasing_Z1_aux n'
  | O => nil
  end.
Definition decreasing_Z1 (n: Z) : list Z :=
     decreasing_Z1_aux (Z.to_nat n).

(** This will work, but in doing proofs the frequent conversion
   between Z and nat will be awkward.  If possible, we'd like to stay
   in the integers as much as possible.  So here's another way: *)

Check Z_gt_dec. (*   : forall x y : Z, {x > y} + {~ x > y} *)

Function decreasing (n: Z) {measure Z.to_nat n}:=
 if Z_gt_dec n 0 then n :: decreasing (n-1) else nil.
Proof.
(** When you define a Function, you must provide a [measure], that is,
    a function from your argument-type (in this case Z) to the natural
    numbers, and then you must prove that each recursive call within
    the function body decreases the measure.  In this ecase, there's
    only one recursive call, so there's just one proof obligation:
    show that if [n>0] then  [Z.to_nat (n-1) < Z.to_nat n].  *)
lia.
Defined.  (* Terminate your [Function] declarations with [Defined] instead
 of [Qed], so that Coq will be able to use your function in computations. *)

(** **** Exercise: 2 stars, standard (Zinduction)

    Coq's standard induction principle for Z is not the one we usually
   want, so let us define a more natural induction scheme: *)
Lemma Zinduction: forall  (P: Z -> Prop),
  P 0 ->
  (forall i, 0 < i -> P (i-1) -> P i) ->
  forall n, 0 <= n -> P n.
Proof.
intros.
rewrite <- (Z2Nat.id n) in * by lia.
set (j := Z.to_nat n) in *. clearbody j.
Check inj_S.  (* Hint!  this may be useful *)
Print Z.succ.  (* Hint!  [Z.succ(x)] unfolds to [x+1] *)
(* FILL IN HERE *) Admitted.
(** [] *)

(* ----------------------------------------------------------------- *)
(** *** A theorem about the nth triangular number *)

Definition add_list: list Z -> Z := fold_right Z.add 0.

(** **** Exercise: 2 stars, standard (add_list_decreasing) *)

(** Theorem:  the sum of the list  [(n)::(n-1):: ... :: 2::1] is [n*(n+1)/2]. *)

Lemma add_list_decreasing_eq_alt: forall n,
  0 <= n ->
  (2 * (add_list (decreasing n)))%Z = (n * (n+1))%Z.
Proof.
  intros.
  pattern n; apply Zinduction.
  - reflexivity.
  - intros.
(** WARNING!  When using functions defined by [Function], don't unfold them!
   Temporarily remove the (* comment *) brackets from the next line to see
   what happens! *)
(*  unfold decreasing. *)

(** Instead of unfolding [decreasing] we use the equation that Coq automagically
   defines for the Function.  Try the command [Search decreasing.] to see all
   the reasoning principles that Coq  defined for the new [Function].  We will
   use this one: *)
Check decreasing_equation.

    rewrite decreasing_equation.

(** during the proof of this lemma, you may
find the [ring_simplify] tactic useful.  Read
about it in the Coq reference manual.  Basically,
it takes formulas with multiplication and addition,
and simplifies them.  But you can do this without
[ring_simplify], using just ordinary rewriting
with lemmas about Z.add and Z.mul.  *)
(* FILL IN HERE *) Admitted.

Lemma add_list_decreasing_eq: forall n,
  0 <= n ->
  add_list (decreasing n) = n * (n+1) / 2.
Proof.
  intros.
  apply Z.div_unique_exact.
(* FILL IN HERE *) Admitted.
(** [] *)

(* ----------------------------------------------------------------- *)
(** *** Definitions copied from Verif_stack.v

    We repeat here some material from Verif_stack.v.  Normally we
   would break the .c file into separate modules, and do our
   Verifiable C proofs in separate modules; but for this example we
   leave out the modules. Just skip down to "End of the material
   repeated from Verif_stack.v". *)

(**  Specification of linked lists in separation logic *)

Fixpoint listrep (il: list Z) (p: val) : mpred :=
 match il with
 | i::il' => EX y: val,
        malloc_token Ews (Tstruct _cons noattr) p *
        data_at Ews (Tstruct _cons noattr) (Vint (Int.repr i),y) p *
        listrep il' y
 | nil => !! (p = nullval) && emp
 end.

Lemma listrep_local_prop: forall il p, listrep il p |--
        !! (is_pointer_or_null p  /\ (p=nullval <-> il=nil)).
Proof.
induction il; intro; simpl.
entailer!. intuition.
Intros y.
entailer!.
split; intros. subst.
eapply field_compatible_nullval; eauto.
inversion H3.
Qed.
#[export] Hint Resolve listrep_local_prop : saturate_local.

Lemma listrep_valid_pointer:
  forall il p,
   listrep il p |-- valid_pointer p.
Proof.
(* FILL IN HERE *) Admitted.
#[export] Hint Resolve listrep_valid_pointer : valid_pointer.

(** Specification of stack data structure *)

Definition stack (il: list Z) (p: val) :=
 EX q: val,
  malloc_token Ews (Tstruct _stack noattr) p *
  data_at Ews (Tstruct _stack noattr) q p * listrep il q.

Lemma stack_local_prop: forall il p, stack il p |--  !! (isptr p).
Proof.
(* FILL IN HERE *) Admitted.
#[export] Hint Resolve stack_local_prop : saturate_local.

Lemma stack_valid_pointer:
  forall il p,
   stack il p |-- valid_pointer p.
Proof.
(* FILL IN HERE *) Admitted.
#[export] Hint Resolve stack_valid_pointer : valid_pointer.

Definition newstack_spec : ident * funspec :=
 DECLARE _newstack
 WITH gv: globals
 PRE [ ]
    PROP () PARAMS() GLOBALS(gv) SEP (mem_mgr gv)
 POST [ tptr (Tstruct _stack noattr) ]
    EX p: val, PROP ( ) RETURN (p) SEP (stack nil p; mem_mgr gv).

Definition push_spec : ident * funspec :=
 DECLARE _push
 WITH p: val, i: Z, il: list Z, gv: globals
 PRE [ tptr (Tstruct _stack noattr), tint ]
    PROP (Int.min_signed <= i <= Int.max_signed)
    PARAMS (p; Vint (Int.repr i)) GLOBALS(gv)
    SEP (stack il p; mem_mgr gv)
 POST [ tvoid ]
    PROP ( ) RETURN() SEP (stack (i::il) p; mem_mgr gv).

Definition pop_spec : ident * funspec :=
 DECLARE _pop
 WITH p: val, i: Z, il: list Z, gv: globals
 PRE [ tptr (Tstruct _stack noattr) ]
    PROP ()
    PARAMS (p) GLOBALS(gv)
    SEP (stack (i::il) p; mem_mgr gv)
 POST [ tint ]
    PROP ( ) RETURN (Vint (Int.repr i)) SEP (stack il p; mem_mgr gv).

(** (End of the material repeated from Verif_stack.v) *)

(* ================================================================= *)
(** ** Specification of the stack-client functions *)

(** Spend a few minutes studying these funspecs, and compare to the
 implementations in stack.c, until you understand why these might be
 appropriate specifications.  *)

Definition push_increasing_spec :=
 DECLARE _push_increasing
 WITH st: val, n: Z, gv: globals
 PRE [ tptr (Tstruct _stack noattr), tint ]
   PROP (0 <= n <= Int.max_signed)
   PARAMS (st; Vint (Int.repr n)) GLOBALS(gv)
   SEP (stack nil st; mem_mgr gv)
 POST [ tvoid ]
   PROP() RETURN() SEP (stack (decreasing n) st; mem_mgr gv).

Definition pop_and_add_spec :=
 DECLARE _pop_and_add
 WITH st: val, il: list Z, gv: globals
 PRE [ tptr (Tstruct _stack noattr), tint ]
   PROP (Zlength il <= Int.max_signed;
         Forall (Z.le 0) il;
         add_list il <= Int.max_signed)
   PARAMS (st; Vint (Int.repr (Zlength il))) GLOBALS(gv)
   SEP (stack il st; mem_mgr gv)
 POST [ tint ]
   PROP()
   RETURN (Vint (Int.repr (add_list il)))
   SEP (stack nil st; mem_mgr gv).

Definition main_spec :=
 DECLARE _main
 WITH gv: globals
 PRE [ ] main_pre prog tt gv
 POST [ tint ]
   PROP( ) RETURN (Vint (Int.repr 55)) SEP( TT ).

(** Putting all the funspecs together *)

Definition Gprog : funspecs :=
        ltac:(with_library prog [
                   newstack_spec; push_spec; pop_spec;
                   push_increasing_spec; pop_and_add_spec; main_spec
 ]).

(* ================================================================= *)
(** ** Proofs of the stack-client function-bodies *)

(** **** Exercise: 3 stars, standard (body_push_increasing) *)
Lemma body_push_increasing: semax_body Vprog Gprog
                         f_push_increasing push_increasing_spec.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard (add_list_lemmas) *)
Lemma add_list_app:
  forall al bl, add_list (al++bl) = add_list al + add_list bl.
(* FILL IN HERE *) Admitted.

Lemma add_list_nonneg:
 forall il,
  Forall (Z.le 0) il ->
  0 <= add_list il.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard (add_list_sublist_bounds) *)
Lemma add_list_sublist_bounds:
 forall lo hi K il,
  0 <= lo <= hi ->
  hi <= Zlength il ->
  Forall (Z.le 0) il ->
  0 <= add_list il <= K ->
  0 <= add_list (sublist lo hi il) <= K.
Proof.
(** Hint: you don't need induction.  Useful lemmas are, [sublist_same,
  sublist_split, add_list_nonneg, add_list_app, Forall_sublist],  and use
  the [hint] tactic to learn when the [list_solve] tactic will be useful. *)
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, standard (add_another)

    Suppose we have a list [il] of integers, [il = [5;4;3;2;1]],
   with [Znth 0 il = 5], [Znth 4 il = 1], and [Zlength il = 5],
   and we want to add them all up,  5+4+3+2+1=15.
  Suppose we've already added up the first [i] of them  (let [i=2] for example),
  that is, 5+4=9, and we want to add the next one, that is, the [ith] one.
  That is, we want to add [9+3].  How do we know that won't overflow
  the range of C-language signed integer arithmetic?

  The proof goes:  Every element of the list is nonnegative; the whole list
  adds up to a number <= Int.max_signed; and any sublist of an all-nonnegative
  list adds up to less-or-equal to the total of the whole list. *)

Lemma add_another:
 forall il,
   Forall (Z.le 0) il ->
   add_list il <= Int.max_signed ->
  forall i : Z,
  0 <= i < Zlength il ->
  Int.min_signed <= Int.signed (Int.repr (add_list (sublist 0 i il))) +
           Int.signed (Int.repr (Znth i il)) <= Int.max_signed.
Proof.
intros.
assert (0 <= add_list il). {
  (* FILL IN HERE *) admit.
}
 assert (0 <= add_list (sublist 0 i il) <= Int.max_signed). {
  (* FILL IN HERE *) admit.
 }
 assert (H4: 0 <= add_list (sublist 0 (i+1) il) <= Int.max_signed). {
  (* FILL IN HERE *) admit.
 }
 assert (0 <= Znth i il <= Int.max_signed). {
  replace (Znth i il) with (add_list (sublist i (i+1) il)).
  -
   (* FILL IN HERE *) admit.
  -
   (* FILL IN HERE *) admit.
}

(**   Next: [Int.signed (Int.repr (add_list (sublist 0 i il)))
      = add_list (sublist 0 i il)].
   To prove that, we'll use [Int.signed_repr]: *)
Check Int.signed_repr.
(*   :   forall z : Z,   Int.min_signed <= z <= Int.max_signed ->
                     Int.signed (Int.repr z) = z. *)
rewrite Int.signed_repr by rep_lia.
(** [rep_lia] is just like [lia], but it also knows the numeric values of
    representation-related constants such as Int.min_signed. *)
rewrite Int.signed_repr by rep_lia.

rewrite (sublist_split 0 i (i+1)) in H4 by list_solve.
rewrite add_list_app in H4.
rewrite sublist_len_1 in H4 by list_solve.
simpl in H4.
rep_lia.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, standard (body_pop_and_add) *)
Lemma body_pop_and_add: semax_body Vprog Gprog f_pop_and_add pop_and_add_spec.
Proof.
start_function.
forward.
forward.
forward_while (EX i:Z,
   PROP(0 <= i <= Zlength il)
   LOCAL (temp _st st;
          temp _i (Vint (Int.repr i));
          temp _n (Vint (Int.repr (Zlength il)));
         gvars gv)
   SEP (stack (sublist i (Zlength il) il) st; mem_mgr gv)).
+ (* Prove that the precondition implies the loop invariant *)
(* FILL IN HERE *) admit.
+ (* "type-check the expression": prove the loop test evaluates *)
entailer!.
+ (* Prove the loop body preserves the loop invariant *)
forward_call (st, Znth i il, sublist (i+1) (Zlength il) il, gv).
 (** This [forward_call] couldn't quite figure out the "Frame" for the
   function call. That is, it couldn't match up
   [stack (sublist i (Zlength il) il) st] with

    stack (Znth i il :: sublist (i + 1) (Zlength il) il) st.

   You have to help, by doing some rewrites with
   [sublist_split, sublist_len_1] that prove

  sublist i (Zlength il) il = Znth i il :: sublist (i+1) (Zlength il) il.

   When you've rewritten the goal into,

   stack (Znth i il :: sublist (i + 1) (Zlength il) il) st
   |-- stack (Znth i il :: sublist (i + 1) (Zlength il) il) st * fold_right_sepcon Frame

   then just do [cancel].  *)
(* FILL IN HERE *) admit.
(** And now we are ready to go forward through the C statement [ _s = _s + _t; ] *)
Fail forward.
(** oops!  we can't go [forward] through [ _s = _s + _t; ]
    because we forgot to mention [temp _s] in the loop invariant!
    Time to start over.

    By the way, this statement [ _s = _s + _t ] is exactly where [forward]
    will ask you to prove a subgoal in which you can use lemma [add_another]. *)
Abort.

(** Into this lemma, paste in the failed proof just above,
   but adjust the loop invariant: add a LOCAL assertion for [_s]. *)
Lemma body_pop_and_add: semax_body Vprog Gprog f_pop_and_add pop_and_add_spec.
Proof.
(** Hint: choose the loop invariant for [temp _s ???] in such a way
    that you can make use of Lemma add_another. *)
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, standard (body_main) *)
Lemma body_main: semax_body Vprog Gprog f_main main_spec.
Proof.
start_function.
(** We assume that [triang.c] is linked with an implementation of
    malloc/free.  That assumption is expressed by the [create_mem_mgr]
    axiom, which we can [sep_apply] here.  On the other hand, if we want
    a complete verified system including libraries, then instead of
    importing [floyd.library] we would actually link with a malloc/free
    implementation, but that's beyond the scope of this chapter. *)
sep_apply (create_mem_mgr gv).
(** You can see that this has produced the SEP conjunct [mem_mgr gv],
    which is useful to satisfy the precondition of [newstack],
    [push], [pop], etc. Now you can finish this proof.  *)

(* FILL IN HERE *) Admitted.
(** [] *)

(* 2022-09-05 15:05 *)