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

Section ycngstys.

Require Import Reals.
Require Import trajectory_def.
Require Import trajectory_const.
Require Import constants.
Require Import ycngftys.
Require Import rrho.

Unset Standard Proposition Elimination Names.

Variable intr : Trajectory.

Definition thetat : R -> R := theta intr.
Definition Rs (t : R) : R :=
  sqrt (Rsqr (xi intr t - xi intr 0) + Rsqr (yi intr t - yi intr 0)).

Axiom
  alphas_exists :
    { f : Differential_D2 |
       forall t : R,
       xi intr t = (Rs t * cos (f t) + xi intr 0)%R /\
       yi intr t = (Rs t * sin (f t) + yi intr 0)%R }.

Definition alphas := let (a,_) := alphas_exists in a.

Lemma alphas_def :
 forall t : R,
 xi intr t = (Rs t * cos (alphas t) + xi intr 0)%R /\
 yi intr t = (Rs t * sin (alphas t) + yi intr 0)%R.
unfold alphas in |- *; case alphas_exists; trivial.
Qed.

(**********)
Lemma Rsx : forall t : R, xi intr t = (xi intr 0 + Rs t * cos (alphas t))%R.
intros; generalize (alphas_def t); intro H; elim H; intros;
 rewrite Rplus_comm; assumption.
Qed.

Lemma Rsy : forall t : R, yi intr t = (yi intr 0 + Rs t * sin (alphas t))%R.
intros; generalize (alphas_def t); intro H; elim H; intros;
 rewrite Rplus_comm; assumption.
Qed.

Lemma Rs_x :
 forall t : R,
 cos (alphas t) <> 0%R -> Rs t = ((xi intr t - xi intr 0) / cos (alphas t))%R.
intros; rewrite Rsx; unfold Rminus, Rdiv in |- *;
 rewrite (Rplus_comm (xi intr 0)); rewrite Rplus_assoc;
 rewrite Rplus_opp_r; rewrite Rplus_0_r; rewrite Rmult_assoc;
 rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r; reflexivity | assumption ].
Qed.

Lemma Rs_y :
 forall t : R,
 sin (alphas t) <> 0%R -> Rs t = ((yi intr t - yi intr 0) / sin (alphas t))%R.
intros; rewrite Rsy; unfold Rminus, Rdiv in |- *;
 rewrite (Rplus_comm (yi intr 0)); rewrite Rplus_assoc;
 rewrite Rplus_opp_r; rewrite Rplus_0_r; rewrite Rmult_assoc;
 rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r; reflexivity | assumption ].
Qed.

(* With the two formulas above, you can prove the following result *)
(* Using the cos_sin_0's lemma                                     *)
Lemma Rs_derivable : derivable Rs.
unfold derivable in |- *; intro.
case (total_order_T (cos (alphas x)) 0); intro.
elim s; intro.
cut (cos (alphas x) <> 0%R).
intro;
 cut
  (exists eps : posreal,
     (forall h : R, (Rabs h < eps)%R -> cos (alphas (x + h)%R) <> 0%R)).
set (xi_p := fun t : R => xi intr t).
intro;
 cut (derivable_pt (fun t : R => ((xi_p t - xi_p 0) / cos (alphas t))%R) x).
intro X; unfold derivable_pt in X; elim X; intros l H1.
unfold derivable_pt in |- *; exists l.
unfold derivable_pt_abs in H1; unfold derivable_pt_lim in H1;
 unfold derivable_pt_abs in |- *; unfold derivable_pt_lim in |- *;
 intros.
elim (H1 eps H2); intros del H3.
elim H0; intros dom H4.
cut (0 < Rmin del dom)%R.
intro; exists (mkposreal (Rmin del dom) H5); intros.
repeat rewrite Rs_x.
unfold xi_p in H3; apply H3.
assumption.
apply Rlt_le_trans with (Rmin del dom); [ apply H7 | apply Rmin_l ].
apply H.
apply H4; apply Rlt_le_trans with (Rmin del dom); [ apply H7 | apply Rmin_r ].
unfold Rmin in |- *; case (Rle_dec del dom); intro.
apply (cond_pos del).
apply (cond_pos dom).
set (alphas_p := d2 alphas); reg.
unfold alphas_p in |- *; apply (cond_D1 alphas).
apply (xi_derivable intr x).
set (alphas_p := d2 alphas); set (f := fun t : R => cos (alphas_p t)).
cut
 (exists eps : posreal,
    (forall h : R, (Rabs h < eps)%R -> f (x + h)%R <> 0%R)).
intro; elim H0; intros.
exists x0; intros; unfold f in H1; apply H1; assumption.
apply continuous_neq_0.
unfold f in |- *; reg; apply derivable_continuous_pt; apply (cond_D1 alphas).
apply H.
red in |- *; intro; rewrite H in a; elim (Rlt_irrefl _ a).
cut (sin (alphas x) <> 0%R).
intro;
 cut
  (exists eps : posreal,
     (forall h : R, (Rabs h < eps)%R -> sin (alphas (x + h)%R) <> 0%R)).
set (yi_p := fun t : R => yi intr t).
intro;
 cut (derivable_pt (fun t : R => ((yi_p t - yi_p 0) / sin (alphas t))%R) x).
intro X; unfold derivable_pt in X.
elim X; intros l H1.
unfold derivable_pt in |- *; exists l.
unfold derivable_pt_abs in H1; unfold derivable_pt_lim in H1;
 unfold derivable_pt_abs in |- *; unfold derivable_pt_lim in |- *;
 intros.
elim (H1 eps H2); intros del H3.
elim H0; intros dom H4.
cut (0 < Rmin del dom)%R.
intro; exists (mkposreal (Rmin del dom) H5); intros.
repeat rewrite Rs_y.
unfold yi_p in H3; apply H3.
assumption.
apply Rlt_le_trans with (Rmin del dom); [ apply H7 | apply Rmin_l ].
apply H.
apply H4; apply Rlt_le_trans with (Rmin del dom); [ apply H7 | apply Rmin_r ].
unfold Rmin in |- *; case (Rle_dec del dom); intro.
apply (cond_pos del).
apply (cond_pos dom).
set (alphas_p := d2 alphas); reg.
unfold alphas_p in |- *; apply (cond_D1 alphas).
apply (yi_derivable intr x).
set (alphas_p := d2 alphas); set (f := fun t : R => sin (alphas_p t)).
cut
 (exists eps : posreal,
    (forall h : R, (Rabs h < eps)%R -> f (x + h)%R <> 0%R)).
intro; elim H0; intros.
exists x0; intros; unfold f in H1; apply H1; assumption.
apply continuous_neq_0.
unfold f in |- *; reg; apply derivable_continuous_pt; apply (cond_D1 alphas).
apply H.
assert (H := cos_sin_0_var (alphas x)); elim H; intro.
elim H0; assumption.
exact H0.
cut (cos (alphas x) <> 0%R).
intro;
 cut
  (exists eps : posreal,
     (forall h : R, (Rabs h < eps)%R -> cos (alphas (x + h)%R) <> 0%R)).
set (xi_p := fun t : R => xi intr t).
intro;
 cut (derivable_pt (fun t : R => ((xi_p t - xi_p 0) / cos (alphas t))%R) x).
intro X; unfold derivable_pt in X; elim X; intros l H1.
unfold derivable_pt in |- *; exists l.
unfold derivable_pt_abs in H1; unfold derivable_pt_lim in H1;
 unfold derivable_pt_abs in |- *; unfold derivable_pt_lim in |- *;
 intros.
elim (H1 eps H2); intros del H3.
elim H0; intros dom H4.
cut (0 < Rmin del dom)%R.
intro; exists (mkposreal (Rmin del dom) H5); intros.
repeat rewrite Rs_x.
unfold xi_p in H3; apply H3.
assumption.
apply Rlt_le_trans with (Rmin del dom); [ apply H7 | apply Rmin_l ].
apply H.
apply H4; apply Rlt_le_trans with (Rmin del dom); [ apply H7 | apply Rmin_r ].
unfold Rmin in |- *; case (Rle_dec del dom); intro.
apply (cond_pos del).
apply (cond_pos dom).
set (alphas_p := d2 alphas); reg.
unfold alphas_p in |- *; apply (cond_D1 alphas).
apply (xi_derivable intr x).
set (alphas_p := d2 alphas); set (f := fun t : R => cos (alphas_p t)).
cut
 (exists eps : posreal,
    (forall h : R, (Rabs h < eps)%R -> f (x + h)%R <> 0%R)).
intro; elim H0; intros.
exists x0; intros; unfold f in H1; apply H1; assumption.
apply continuous_neq_0.
unfold f in |- *; reg; apply derivable_continuous_pt; apply (cond_D1 alphas).
apply H.
red in |- *; intro; rewrite H in r; elim (Rlt_irrefl _ r).
Qed.

Definition alphas_p : R -> R := d2 alphas.

Lemma fct_der4 :
 forall t : R,
 derivable_pt ((Rs * comp cos alphas_p)%F + fct_cte (xi intr 0)) t.
intro; reg. apply (cond_D1 alphas).
apply Rs_derivable.
Qed.

(**********)
Lemma Dxi :
 forall t : R,
 derive_pt (xi intr) t (xi_derivable intr t) =
 (derive_pt Rs t (Rs_derivable t) * cos (alphas t) -
  Rs t * sin (alphas t) * derive_pt alphas t (cond_D1 alphas t))%R.
intro.
assert (H := fct_der4).
replace (derive_pt (xi intr) t (xi_derivable intr t)) with
 (derive_pt ((Rs * comp cos alphas_p)%F + fct_cte (xi intr 0)) t (H t)).
unfold plus_fct, mult_fct, comp, fct_cte in |- *.
set (H0 := Rs_derivable t).
cut (derivable_pt alphas_p t); [ intro X | apply (cond_D1 alphas) ].
replace (derive_pt alphas t (cond_D1 alphas t)) with (derive_pt alphas_p t X);
 [ idtac | apply pr_nu ].
reg.
unfold comp, alphas_p in |- *; ring.
unfold derive_pt in |- *.
case (H t).
case (xi_derivable intr t).
simpl.
intros.
eapply uniqueness_limite.
unfold derivable_pt_abs in d0.
apply d0.
unfold derivable_pt_lim in |- *; intros.
unfold derivable_pt_abs in d; unfold derivable_pt_lim in d.
elim (d eps H0); intros.
exists x1; intros.
unfold plus_fct, mult_fct, comp, fct_cte in |- *.
assert (H4 := H1 _ H2 H3).
replace
 ((Rs (t + h) * cos (alphas_p (t + h)) + xi intr 0 -
   (Rs t * cos (alphas_p t) + xi intr 0)) / h - x)%R with
 ((xi intr (t + h) - xi intr t) / h - x)%R.
apply H4.
rewrite (Rsx t).
rewrite (Rsx (t + h)).
replace
 (xi intr 0 + Rs (t + h) * cos (alphas (t + h)) -
  (xi intr 0 + Rs t * cos (alphas t)))%R with
 (Rs (t + h) * cos (alphas_p (t + h)) + xi intr 0 -
  (Rs t * cos (alphas_p t) + xi intr 0))%R.
reflexivity.
unfold alphas_p in |- *; ring.
Qed.

Lemma Dyi :
 forall t : R,
 derive_pt (yi intr) t (yi_derivable intr t) =
 (derive_pt Rs t (Rs_derivable t) * sin (alphas t) +
  Rs t * cos (alphas t) * derive_pt alphas t (cond_D1 alphas t))%R.
intro.
set (H := Rs_derivable t).
cut (derivable_pt alphas_p t); [ intro X | apply (cond_D1 alphas) ].
cut (derivable_pt ((Rs * comp sin alphas_p)%F + fct_cte (yi intr 0)) t);
 [ intro X0 | reg ].
replace (derive_pt (yi intr) t (yi_derivable intr t)) with
 (derive_pt ((Rs * comp sin alphas_p)%F + fct_cte (yi intr 0)) t X0).
replace (derive_pt alphas t (cond_D1 alphas t)) with (derive_pt alphas_p t X);
 [ idtac | apply pr_nu ].
unfold plus_fct, mult_fct, comp, fct_cte in |- *.
reg.
unfold comp, alphas_p in |- *; ring.
unfold derive_pt in |- *.
case X0.
case (yi_derivable intr t).
simpl.
intros.
eapply uniqueness_limite.
unfold derivable_pt_abs in d0.
apply d0.
unfold derivable_pt_lim in |- *; intros.
unfold derivable_pt_abs in d; unfold derivable_pt_lim in d.
elim (d eps H0); intros.
exists x1; intros.
unfold plus_fct, mult_fct, comp, fct_cte in |- *.
assert (H4 := H1 _ H2 H3).
replace
 ((Rs (t + h) * sin (alphas_p (t + h)) + yi intr 0 -
   (Rs t * sin (alphas_p t) + yi intr 0)) / h - x)%R with
 ((yi intr (t + h) - yi intr t) / h - x)%R.
apply H4.
rewrite (Rsy t).
rewrite (Rsy (t + h)).
replace
 (yi intr 0 + Rs (t + h) * sin (alphas (t + h)) -
  (yi intr 0 + Rs t * sin (alphas t)))%R with
 (Rs (t + h) * sin (alphas_p (t + h)) + yi intr 0 -
  (Rs t * sin (alphas_p t) + yi intr 0))%R.
reflexivity.
unfold alphas_p in |- *; ring.
Qed.

(**********)
Lemma DRs_cos :
 forall t : R,
 (derive_pt Rs t (Rs_derivable t) * cos (alphas t) -
  Rs t * sin (alphas t) * derive_pt alphas t (cond_D1 alphas t))%R =
 (vi intr * cos (thetat t))%R.
intro.
assert (H := Dxi t).
unfold xi in H.
assert (H0 := cond_x intr t).
cut
 (derive_pt (x intr) t (xi_derivable intr t) =
  derive_pt (x intr) t (cond_diff (x intr) t)); [ intro | apply pr_nu ].
rewrite H1 in H.
rewrite H0 in H.
unfold vi, thetat in |- *; symmetry  in |- *; assumption.
Qed.

Lemma DRs_sin :
 forall t : R,
 (derive_pt Rs t (Rs_derivable t) * sin (alphas t) +
  Rs t * cos (alphas t) * derive_pt alphas t (cond_D1 alphas t))%R =
 (vi intr * sin (thetat t))%R.
intro; assert (H := Dyi t).
unfold yi in H; assert (H0 := cond_y intr t).
cut
 (derive_pt (y intr) t (yi_derivable intr t) =
  derive_pt (y intr) t (cond_diff (y intr) t)); [ intro | apply pr_nu ].
rewrite H1 in H.
rewrite H0 in H.
unfold vi, thetat in |- *; symmetry  in |- *; assumption.
Qed.

(**********)
Lemma eq_plus_eq_is_eq :
 forall x y z t : R, x = y -> z = t -> (x + z)%R = (y + t)%R.
intros; rewrite H; rewrite H0; reflexivity.
Qed.

(**********)
Lemma DRs :
 forall t : R,
 derive_pt Rs t (Rs_derivable t) = (vi intr * cos (thetat t - alphas t))%R.
intro.
assert (H := DRs_cos t).
assert (H0 := DRs_sin t).
assert (H1 := Rmult_eq_compat_l (cos (alphas t)) _ _ H).
assert (H2 := Rmult_eq_compat_l (sin (alphas t)) _ _ H0).
replace (derive_pt Rs t (Rs_derivable t)) with
 (cos (alphas t) *
  (derive_pt Rs t (Rs_derivable t) * cos (alphas t) -
   Rs t * sin (alphas t) * derive_pt alphas t (cond_D1 alphas t)) +
  sin (alphas t) *
  (derive_pt Rs t (Rs_derivable t) * sin (alphas t) +
   Rs t * cos (alphas t) * derive_pt alphas t (cond_D1 alphas t)))%R.
replace (vi intr * cos (thetat t - alphas t))%R with
 (cos (alphas t) * (vi intr * cos (thetat t)) +
  sin (alphas t) * (vi intr * sin (thetat t)))%R.
apply eq_plus_eq_is_eq; assumption.
rewrite cos_minus; ring.
unfold Rminus in |- *.
repeat rewrite Rmult_plus_distr_l.
replace
 (cos (alphas t) * (derive_pt Rs t (Rs_derivable t) * cos (alphas t)) +
  cos (alphas t) *
  - (Rs t * sin (alphas t) * derive_pt alphas t (cond_D1 alphas t)) +
  (sin (alphas t) * (derive_pt Rs t (Rs_derivable t) * sin (alphas t)) +
   sin (alphas t) *
   (Rs t * cos (alphas t) * derive_pt alphas t (cond_D1 alphas t))))%R with
 (derive_pt Rs t (Rs_derivable t) *
  (Rsqr (sin (alphas t)) + Rsqr (cos (alphas t))) +
  cos (alphas t) *
  - (Rs t * sin (alphas t) * derive_pt alphas t (cond_D1 alphas t)) +
  sin (alphas t) *
  (Rs t * cos (alphas t) * derive_pt alphas t (cond_D1 alphas t)))%R;
 [ idtac | unfold Rsqr in |- *; ring ].
rewrite sin2_cos2; ring.
Qed.

(**********)
Lemma Rs_alphas :
 forall t : R,
 (Rs t * derive_pt alphas t (cond_D1 alphas t))%R =
 (vi intr * sin (thetat t - alphas t))%R.
intro.
assert (H := DRs_cos t).
assert (H0 := DRs_sin t).
assert (H1 := Rmult_eq_compat_l (- sin (alphas t)) _ _ H).
assert (H2 := Rmult_eq_compat_l (cos (alphas t)) _ _ H0).
replace (Rs t * derive_pt alphas t (cond_D1 alphas t))%R with
 (- sin (alphas t) *
  (derive_pt Rs t (Rs_derivable t) * cos (alphas t) -
   Rs t * sin (alphas t) * derive_pt alphas t (cond_D1 alphas t)) +
  cos (alphas t) *
  (derive_pt Rs t (Rs_derivable t) * sin (alphas t) +
   Rs t * cos (alphas t) * derive_pt alphas t (cond_D1 alphas t)))%R.
replace (vi intr * sin (thetat t - alphas t))%R with
 (- sin (alphas t) * (vi intr * cos (thetat t)) +
  cos (alphas t) * (vi intr * sin (thetat t)))%R.
apply eq_plus_eq_is_eq; assumption.
rewrite sin_minus; ring.
unfold Rminus in |- *.
repeat rewrite Rmult_plus_distr_l.
replace
 (- sin (alphas t) * (derive_pt Rs t (Rs_derivable t) * cos (alphas t)) +
  - sin (alphas t) *
  - (Rs t * sin (alphas t) * derive_pt alphas t (cond_D1 alphas t)) +
  (cos (alphas t) * (derive_pt Rs t (Rs_derivable t) * sin (alphas t)) +
   cos (alphas t) *
   (Rs t * cos (alphas t) * derive_pt alphas t (cond_D1 alphas t))))%R with
 (Rs t * derive_pt alphas t (cond_D1 alphas t) *
  (Rsqr (sin (alphas t)) + Rsqr (cos (alphas t))) +
  cos (alphas t) * - sin (alphas t) * derive_pt Rs t (Rs_derivable t) +
  sin (alphas t) * cos (alphas t) * derive_pt Rs t (Rs_derivable t))%R;
 [ idtac | unfold Rsqr in |- *; ring ].
rewrite sin2_cos2; ring.
Qed.

Lemma fct_der5 :
 forall t : R,
 derivable_pt (fun y : R => (Rs y * derive_pt alphas y (cond_D1 alphas y))%R)
   t.
intro; set (alpha_p := d2 alphas);
 set (f := fun x : R => derive_pt alpha_p x (cond_D1 alphas x)).
change (derivable_pt (fun y : R => (Rs y * f y)%R) t) in |- *.
reg.
apply (cond_D2 alphas).
apply Rs_derivable.
Qed.

(**********)
Lemma D_Rs_alphas1 :
 forall t : R,
 derive_pt (fun y : R => (Rs y * derive_pt alphas y (cond_D1 alphas y))%R) t
   (fct_der5 t) =
 (derive_pt Rs t (Rs_derivable t) * derive_pt alphas t (cond_D1 alphas t) +
  Rs t * derive_pt (derive alphas (cond_D1 alphas)) t (cond_D2 alphas t))%R.
intro.
set (f := fun x : R => derive_pt alphas x (cond_D1 alphas x)).
replace
 (derive_pt (fun y : R => (Rs y * derive_pt alphas y (cond_D1 alphas y))%R) t
    (fct_der5 t)) with
 (derive_pt (fun y : R => (Rs y * f y)%R) t (fct_der5 t));
 [ idtac | reflexivity ].
replace (derive_pt alphas t (cond_D1 alphas t)) with (f t);
 [ idtac | reflexivity ].
replace (derive_pt (derive alphas (cond_D1 alphas)) t (cond_D2 alphas t))
 with (derive_pt f t (cond_D2 alphas t)); [ idtac | reflexivity ].
cut (derivable_pt Rs t); [ intro X | apply Rs_derivable ].
cut (derivable_pt f t); [ intro X0 | apply (cond_D2 alphas) ].
reg.
replace (derive_pt f t (cond_D2 alphas t)) with (derive_pt f t X0);
 [ idtac | apply pr_nu ].
replace (derive_pt Rs t (Rs_derivable t)) with (derive_pt Rs t X);
 [ idtac | apply pr_nu ].
ring.
Qed.

(**********)
Lemma thetat_derivable : derivable thetat.
unfold thetat in |- *; apply (cond_diff (theta intr)).
Qed.

(**********)
Lemma D_Rs_alphas2 :
 forall t : R,
 derive_pt (fun y : R => (Rs y * derive_pt alphas y (cond_D1 alphas y))%R) t
   (fct_der5 t) =
 (vi intr * cos (thetat t - alphas t) *
  (derive_pt thetat t (thetat_derivable t) -
   derive_pt alphas t (cond_D1 alphas t)))%R.
intro.
cut (derivable_pt (fun x : R => (vi intr * sin (thetat x - alphas x))%R) t).
intro X.
replace
 (derive_pt (fun y : R => (Rs y * derive_pt alphas y (cond_D1 alphas y))%R) t
    (fct_der5 t)) with
 (derive_pt (fun x : R => (vi intr * sin (thetat x - alphas x))%R) t X).
set (f := d2 alphas).
cut (derivable_pt f t); [ intro X0 | apply (cond_D1 alphas) ].
cut (derivable_pt thetat t); [ intro X1 | apply thetat_derivable ].
reg.
unfold fct_cte, minus_fct in |- *.
replace (derive_pt f t (cond_D1 alphas t)) with (derive_pt f t X0);
 [ idtac | apply pr_nu ].
replace (derive_pt thetat t (thetat_derivable t)) with
 (derive_pt thetat t X1); [ idtac | apply pr_nu ].
ring.
unfold derive_pt in |- *.
case X; case (fct_der5 t); simpl; intros.
eapply uniqueness_limite.
unfold derivable_pt_abs in d0; apply d0.
unfold derivable_pt_lim in |- *; intros.
unfold derivable_pt_abs in d; unfold derivable_pt_lim in d; elim (d eps H);
 intros.
exists x1; intros.
do 2 rewrite <- Rs_alphas.
apply H0; assumption.
fold alphas_p in |- *; reg.
apply (cond_D1 alphas).
apply thetat_derivable.
Qed.

(**********)
Lemma D_Rs_2 :
 forall t : R,
 (derive_pt Rs t (Rs_derivable t) *
  (2 * derive_pt alphas t (cond_D1 alphas t) -
   derive_pt thetat t (thetat_derivable t)))%R =
 (- Rs t * derive_pt (derive alphas (cond_D1 alphas)) t (cond_D2 alphas t))%R.
intro.
assert (H := D_Rs_alphas1 t).
assert (H0 := D_Rs_alphas2 t).
assert (H1 := DRs t).
rewrite H in H0; rewrite <- H1 in H0.
assert
 (H2 :=
  Rplus_eq_compat_l
    (- derive_pt Rs t (Rs_derivable t) *
     (derive_pt thetat t (thetat_derivable t) -
      derive_pt alphas t (cond_D1 alphas t)) +
     - Rs t * derive_pt (derive alphas (cond_D1 alphas)) t (cond_D2 alphas t))
    _ _ H0).
cut
 ((- derive_pt Rs t (Rs_derivable t) *
   (derive_pt thetat t (thetat_derivable t) -
    derive_pt alphas t (cond_D1 alphas t)) +
   - Rs t * derive_pt (derive alphas (cond_D1 alphas)) t (cond_D2 alphas t) +
   (derive_pt Rs t (Rs_derivable t) * derive_pt alphas t (cond_D1 alphas t) +
    Rs t * derive_pt (derive alphas (cond_D1 alphas)) t (cond_D2 alphas t)))%R =
  (derive_pt Rs t (Rs_derivable t) *
   (2 * derive_pt alphas t (cond_D1 alphas t) -
    derive_pt thetat t (thetat_derivable t)))%R); [ intro | ring ].
cut
 ((- derive_pt Rs t (Rs_derivable t) *
   (derive_pt thetat t (thetat_derivable t) -
    derive_pt alphas t (cond_D1 alphas t)) +
   - Rs t * derive_pt (derive alphas (cond_D1 alphas)) t (cond_D2 alphas t) +
   derive_pt Rs t (Rs_derivable t) *
   (derive_pt thetat t (thetat_derivable t) -
    derive_pt alphas t (cond_D1 alphas t)))%R =
  (- Rs t * derive_pt (derive alphas (cond_D1 alphas)) t (cond_D2 alphas t))%R);
 [ intro | ring ].
rewrite H3 in H2; rewrite H4 in H2.
assumption.
Qed.

(**********)
Lemma Rsqr_DRs :
 forall t : R,
 (Rsqr (derive_pt Rs t (Rs_derivable t)) +
  Rsqr (Rs t) * Rsqr (derive_pt alphas t (cond_D1 alphas t)))%R =
 Rsqr (vi intr).
intro; rewrite <- Rsqr_mult; rewrite DRs; rewrite Rs_alphas;
 repeat rewrite Rsqr_mult; rewrite Rplus_comm;
 rewrite <- (Rmult_comm (Rsqr (cos (thetat t - alphas t))));
 rewrite <- (Rmult_comm (Rsqr (sin (thetat t - alphas t))));
 rewrite <- Rmult_plus_distr_r; rewrite sin2_cos2;
 rewrite Rmult_1_l; reflexivity.
Qed.

(**********)
Lemma Rs_pos : forall t : R, (0 <= Rs t)%R.
intro; unfold Rs in |- *; apply sqrt_positivity; apply Rplus_le_le_0_compat;
 apply Rle_0_sqr.
Qed.

Lemma Rs_0 : Rs 0 = 0%R.
unfold Rs in |- *; unfold Rminus in |- *; repeat rewrite Rplus_opp_r;
 repeat rewrite Rsqr_0; rewrite Rplus_0_r; rewrite sqrt_0;
 reflexivity.
Qed.

(**********)
Lemma D_Rs_0 : (0 <= derive_pt Rs 0 (Rs_derivable 0))%R.
case (Rtotal_order 0 (derive_pt Rs 0 (Rs_derivable 0%R))); intro.
left; assumption.
elim H; intro.
right; assumption.
generalize (derivable_derive Rs 0 (Rs_derivable 0%R)); intro; elim H1;
 intros l H2; rewrite H2 in H0.
generalize (derive_pt_eq_1 Rs 0 l (Rs_derivable 0%R) H2); intros;
 cut (0 < - (l / 2))%R.
intro H4; elim (H3 (- (l / 2))%R H4).
intros; cut ((x / 2)%R <> 0%R).
intro H6; cut (Rabs (x / 2) < x)%R.
intro H7; generalize (H5 (x / 2)%R H6 H7); intro H8; rewrite Rs_0 in H8;
 rewrite Rplus_0_l in H8; unfold Rminus in H8; rewrite Ropp_0 in H8;
 rewrite Rplus_0_r in H8;
 generalize (Rabs_def2 (Rs (x / 2) / (x / 2) + - l) (- (l / 2)) H8);
 intro H9; elim H9; intros;
 generalize
  (Rplus_lt_compat_r l (Rs (x / 2) / (x / 2) + - l) (- (l / 2)) H10);
 rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r;
 replace (- (l / 2) + l)%R with (l / 2)%R.
intro H12; cut (l / 2 < 0)%R.
intro H13; generalize (Rlt_trans (Rs (x / 2) / (x / 2)) (l / 2) 0 H12 H13);
 intro H14; unfold Rdiv in H14; cut (0 < x * / 2)%R.
intro H15;
 generalize
  (Rmult_lt_compat_r (x * / 2) (Rs (x * / 2) * / (x * / 2)) 0 H15 H14);
 rewrite Rmult_0_l; rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
rewrite Rmult_1_r; intro H16;
 elim (Rlt_irrefl 0 (Rle_lt_trans 0 (Rs (x * / 2)) 0 (Rs_pos (x * / 2)) H16)).
apply prod_neq_R0.
generalize (cond_pos x); intro H16; red in |- *; intro H17;
 rewrite H17 in H16; elim (Rlt_irrefl 0 H16).
apply Rinv_neq_0_compat; discrR.
apply Rmult_lt_0_compat;
 [ apply (cond_pos x) | apply Rinv_0_lt_compat; prove_sup0 ].
assert (Hyp : (0 < 2)%R).
prove_sup0.
unfold Rdiv in |- *;
 generalize (Rmult_lt_compat_r (/ 2) l 0 (Rinv_0_lt_compat 2 Hyp) H0);
 rewrite Rmult_0_l; intro H13; exact H13.
pattern l at 3 in |- *; rewrite double_var.
ring.
cut (0 < x / 2)%R.
intro H7; apply Rabs_def1.
pattern x at 1 in |- *; replace (pos x) with (2 * (x / 2))%R.
pattern (x / 2)%R at 1 in |- *; replace (x / 2)%R with (x / 2 + 0)%R.
replace (2 * (x / 2))%R with (x / 2 + x / 2)%R.
apply Rplus_lt_compat_l; assumption.
ring.
apply Rplus_0_r.
pattern (pos x) at 2 in |- *; rewrite double_var.
ring.
apply Rlt_trans with 0%R.
rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; apply (cond_pos x).
assumption.
unfold Rdiv in |- *; apply Rmult_lt_0_compat;
 [ apply (cond_pos x) | apply Rinv_0_lt_compat; prove_sup0 ].
unfold Rdiv in |- *; apply prod_neq_R0.
generalize (cond_pos x); intro H6; red in |- *; intro H7; rewrite H7 in H6;
 elim (Rlt_irrefl 0 H6).
apply Rinv_neq_0_compat; discrR.
assert (Hyp : (0 < 2)%R).
prove_sup0.
unfold Rdiv in |- *; rewrite <- Ropp_0; apply Ropp_lt_gt_contravar;
 generalize (Rmult_lt_compat_r (/ 2) l 0 (Rinv_0_lt_compat 2 Hyp) H0);
 rewrite Rmult_0_l; intro H4; assumption.
Qed.

Lemma eq_sym : forall x y : R, x = y -> y = x.
intros; rewrite H; reflexivity.
Qed.

(**********)
Lemma D_Rs_0_strong : (0 < derive_pt Rs 0 (Rs_derivable 0))%R.
case (Rtotal_order 0 (derive_pt Rs 0 (Rs_derivable 0%R))); intro.
assumption.
elim H; intro.
generalize (Rsqr_DRs 0); intro H1; rewrite <- H0 in H1; rewrite Rs_0 in H1;
 repeat rewrite Rsqr_0 in H1; rewrite Rplus_0_l in H1;
 rewrite Rmult_0_l in H1; generalize (eq_sym 0 (Rsqr (vi intr)) H1).
clear H1; intro H1; generalize (Rsqr_eq_0 (vi intr) H1).
intro H2; generalize (TypeSpeed_pos (vi intr)); intro H3; rewrite H2 in H3;
 elim (Rlt_irrefl 0 H3).
generalize D_Rs_0; intro H1;
 elim
  (Rlt_irrefl 0 (Rle_lt_trans 0 (derive_pt Rs 0 (Rs_derivable 0%R)) 0 H1 H0)).
Qed.

(**********)
Lemma D_alphas_0 :
 (2 * derive_pt alphas 0 (cond_D1 alphas 0))%R =
 derive_pt thetat 0 (thetat_derivable 0%R).
generalize (D_Rs_2 0); intro; rewrite Rs_0 in H; rewrite Ropp_0 in H;
 rewrite Rmult_0_l in H;
 generalize
  (Rmult_integral (derive_pt Rs 0 (Rs_derivable 0%R))
     (2 * derive_pt alphas 0 (cond_D1 alphas 0%R) -
      derive_pt thetat 0 (thetat_derivable 0%R)) H);
 intro H1; elim H1; intro; generalize D_Rs_0_strong;
 intro.
rewrite H0 in H2; elim (Rlt_irrefl 0 H2).
generalize
 (Rminus_diag_uniq_sym (derive_pt thetat 0 (thetat_derivable 0%R))
    (2 * derive_pt alphas 0 (cond_D1 alphas 0%R)) H0);
 intro; symmetry  in |- *; assumption.
Qed.

(**********)
Lemma D_Rs_pos_non_null :
 forall t : R,
 (0 < t)%R ->
 (forall x : R, (0 < x < t)%R -> (0 < derive_pt Rs x (Rs_derivable x))%R) ->
 (0 < Rs t)%R.
intros; generalize (derive_increasing_interv 0 t Rs Rs_derivable H H0);
 intros; cut (0 <= 0 <= t)%R;
 [ cut (0 <= t <= t)%R;
    [ intros; rewrite <- Rs_0; apply (H1 0%R t H3 H2 H)
    | split; [ left; assumption | right; reflexivity ] ]
 | split; [ right; reflexivity | left; assumption ] ].
Qed.

(* To prove the following axioms, you need more sophisticated analysis *)
Axiom
  D_Rs_pos :
    forall t : R,
    (0 <= t)%R ->
    (t < 2 / rho (vi intr))%R -> (0 < derive_pt Rs t (Rs_derivable t))%R.

Axiom
  D_abs_alpha :
    forall t : R,
    (0 <= t)%R ->
    (t < 2 / rho (vi intr))%R ->
    (- rho (vi intr) / 2 <= derive_pt alphas t (cond_D1 alphas t))%R /\
    (derive_pt alphas t (cond_D1 alphas t) <= rho (vi intr) / 2)%R.

Definition F (t : R) : R :=
  (2 * (vi intr / rho (vi intr)) * sin (rho (vi intr) * (t / 2)))%R.

Lemma F_derivable : derivable F.
unfold F in |- *; reg.
Qed.

(**********)
Lemma D_F :
 forall t : R,
 derive_pt F t (F_derivable t) = (vi intr * cos (rho (vi intr) * (t / 2)))%R.
intro; unfold F in |- *; reg.
unfold Rdiv in |- *;  field.
assert (H0 := rho_pos (vi intr)); red in |- *; intro; rewrite H in H0;
 elim (Rlt_irrefl 0 H0).
Qed.

(**********)
Lemma D_F_Rsqr_v :
 forall t : R,
 (Rsqr (derive_pt F t (F_derivable t)) +
  Rsqr (rho (vi intr) / 2) * Rsqr (F t))%R = Rsqr (vi intr).
intro; rewrite (D_F t); rewrite <- Rsqr_mult;
 cut
  ((rho (vi intr) / 2 * F t)%R = (vi intr * sin (rho (vi intr) * (t / 2)))%R).
intro H; rewrite H; repeat rewrite Rsqr_mult;
 replace
  (Rsqr (vi intr) * Rsqr (cos (rho (vi intr) * (t / 2))) +
   Rsqr (vi intr) * Rsqr (sin (rho (vi intr) * (t / 2))))%R with
  (Rsqr (vi intr) *
   (Rsqr (sin (rho (vi intr) * (t / 2))) +
    Rsqr (cos (rho (vi intr) * (t / 2)))))%R.
rewrite sin2_cos2; rewrite Rmult_1_r; reflexivity.
ring.
unfold F in |- *; unfold Rdiv in |- *; rewrite <- Rmult_assoc;
 replace (rho (vi intr) * / 2 * (2 * (vi intr * / rho (vi intr))))%R with
  (2 * / 2 * (rho (vi intr) * / rho (vi intr)) * vi intr)%R.
repeat rewrite <- Rinv_r_sym.
repeat rewrite Rmult_1_l; reflexivity.
generalize (rho_pos (vi intr)); intro; red in |- *; intro; rewrite H0 in H;
 elim (Rlt_irrefl 0 H).
discrR.
ring.
Qed.

Definition G (t : R) : R := (Rs t - F t)%R.

Lemma G_derivable : derivable G.
unfold G in |- *; reg.
apply F_derivable.
apply Rs_derivable.
Qed.

(**********)
Lemma D_G_alphas :
 forall t : R,
 (derive_pt G t (G_derivable t) *
  (derive_pt Rs t (Rs_derivable t) + derive_pt F t (F_derivable t)))%R =
 (- Rsqr (derive_pt alphas t (cond_D1 alphas t)) * G t * (Rs t + F t) +
  Rsqr (F t) *
  (Rsqr (rho (vi intr) / 2) - Rsqr (derive_pt alphas t (cond_D1 alphas t))))%R.
intro.
cut
 (derive_pt G t (G_derivable t) =
  (derive_pt Rs t (Rs_derivable t) - derive_pt F t (F_derivable t))%R).
intro; rewrite H;
 rewrite
  (Rsqr_minus_plus (derive_pt Rs t (Rs_derivable t))
     (derive_pt F t (F_derivable t))); unfold G in |- *;
 repeat rewrite Rmult_assoc; rewrite (Rsqr_minus_plus (Rs t) (F t)).
replace
 (- Rsqr (derive_pt alphas t (cond_D1 alphas t)) * (Rsqr (Rs t) - Rsqr (F t)) +
  Rsqr (F t) *
  (Rsqr (rho (vi intr) / 2) - Rsqr (derive_pt alphas t (cond_D1 alphas t))))%R
 with
 (- Rsqr (derive_pt alphas t (cond_D1 alphas t)) * Rsqr (Rs t) +
  Rsqr (F t) * Rsqr (rho (vi intr) / 2))%R.
apply
 Rplus_eq_reg_l
  with
    (Rsqr (derive_pt F t (F_derivable t)) +
     Rsqr (derive_pt alphas t (cond_D1 alphas t)) * Rsqr (Rs t))%R.
replace
 (Rsqr (derive_pt F t (F_derivable t)) +
  Rsqr (derive_pt alphas t (cond_D1 alphas t)) * Rsqr (Rs t) +
  (Rsqr (derive_pt Rs t (Rs_derivable t)) -
   Rsqr (derive_pt F t (F_derivable t))))%R with
 (Rsqr (derive_pt Rs t (Rs_derivable t)) +
  Rsqr (Rs t) * Rsqr (derive_pt alphas t (cond_D1 alphas t)))%R.
replace
 (Rsqr (derive_pt F t (F_derivable t)) +
  Rsqr (derive_pt alphas t (cond_D1 alphas t)) * Rsqr (Rs t) +
  (- Rsqr (derive_pt alphas t (cond_D1 alphas t)) * Rsqr (Rs t) +
   Rsqr (F t) * Rsqr (rho (vi intr) / 2)))%R with
 (Rsqr (derive_pt F t (F_derivable t)) +
  Rsqr (rho (vi intr) / 2) * Rsqr (F t))%R.
rewrite Rsqr_DRs; rewrite D_F_Rsqr_v; reflexivity.
ring.
ring.
ring.
unfold G in |- *.
cut (derivable_pt Rs t); [ intro X | apply Rs_derivable ].
cut (derivable_pt F t); [ intro X0 | apply F_derivable ].
reg.
replace (derive_pt F t (F_derivable t)) with (derive_pt F t X0);
 [ idtac | apply pr_nu ].
replace (derive_pt Rs t (Rs_derivable t)) with (derive_pt Rs t X);
 [ idtac | apply pr_nu ].
ring.
Qed.

(**********)
Lemma Rlt_1_PI2 : (1 < PI / 2)%R.
generalize PI_approx; intro; elim H; intros.
apply Rlt_le_trans with (PI_lb / 2)%R.
unfold PI_lb in |- *; unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2%R.
prove_sup.
rewrite Rmult_1_r; rewrite <- Rmult_assoc; rewrite Rinv_r_simpl_m;
 [ prove_sup | discrR ].
left; unfold Rdiv in |- *; repeat rewrite <- (Rmult_comm (/ 2));
 apply Rmult_lt_compat_l; [ apply Rinv_0_lt_compat; prove_sup | assumption ].
Qed.

(**********)
Lemma D_G_pos :
 forall t : R,
 (0 <= t)%R ->
 (t < 2 / rho (vi intr))%R ->
 (G t <= 0)%R -> (0 <= derive_pt G t (G_derivable t))%R.
intros.
case (Rcase_abs (derive_pt G t (G_derivable t))); intro.
generalize (D_G_alphas t); intro.
generalize (D_Rs_pos t H H0); intro.
cut (0 <= derive_pt F t (F_derivable t))%R.
intro.
generalize (Rs_pos t); intro.
cut (0 <= F t)%R.
intro.
cut
 (derive_pt G t (G_derivable t) *
  (derive_pt Rs t (Rs_derivable t) + derive_pt F t (F_derivable t)) < 0)%R.
intro.
cut
 (0 <=
  - Rsqr (derive_pt alphas t (cond_D1 alphas t)) * G t * (Rs t + F t) +
  Rsqr (F t) *
  (Rsqr (rho (vi intr) / 2) - Rsqr (derive_pt alphas t (cond_D1 alphas t))))%R.
intro.
rewrite <- H2 in H8.
elim
 (Rlt_irrefl 0
    (Rle_lt_trans 0
       (derive_pt G t (G_derivable t) *
        (derive_pt Rs t (Rs_derivable t) + derive_pt F t (F_derivable t))) 0
       H8 H7)).
apply Rplus_le_le_0_compat.
replace
 (- Rsqr (derive_pt alphas t (cond_D1 alphas t)) * G t * (Rs t + F t))%R with
 (Rsqr (derive_pt alphas t (cond_D1 alphas t)) * - G t * (Rs t + F t))%R.
repeat simple apply Rmult_le_pos.
apply Rle_0_sqr.
rewrite <- Ropp_0.
apply Ropp_ge_le_contravar.
apply Rle_ge; assumption.
apply Rplus_le_le_0_compat; assumption.
ring.
apply Rmult_le_pos.
apply Rle_0_sqr.
apply Rplus_le_reg_l with (Rsqr (derive_pt alphas t (cond_D1 alphas t))).
rewrite Rplus_0_r.
rewrite Rplus_comm.
unfold Rminus in |- *.
repeat rewrite Rplus_assoc.
rewrite Rplus_opp_l.
rewrite Rplus_0_r.
generalize (D_abs_alpha t H H0); intro.
elim H8; intros.
case (Rtotal_order 0 (derive_pt alphas t (cond_D1 alphas t))); intro.
apply Rsqr_incr_1.
assumption.
left; assumption.
unfold Rdiv in |- *; left; apply Rmult_lt_0_compat.
apply rho_pos.
apply Rinv_0_lt_compat; prove_sup0.
elim H11; intros.
rewrite <- H12.
rewrite Rsqr_0.
apply Rle_0_sqr.
rewrite (Rsqr_neg (derive_pt alphas t (cond_D1 alphas t))).
apply Rsqr_incr_1.
rewrite <- (Ropp_involutive (rho (vi intr) / 2)).
apply Ropp_ge_le_contravar.
apply Rle_ge.
replace (- (rho (vi intr) / 2))%R with (- rho (vi intr) / 2)%R.
assumption.
unfold Rdiv in |- *; ring.
rewrite <- Ropp_0.
apply Ropp_ge_le_contravar; apply Rle_ge; left; assumption.
unfold Rdiv in |- *; left; apply Rmult_lt_0_compat.
apply rho_pos.
apply Rinv_0_lt_compat; prove_sup0.
rewrite <- (Ropp_involutive 0).
replace
 (derive_pt G t (G_derivable t) *
  (derive_pt Rs t (Rs_derivable t) + derive_pt F t (F_derivable t)))%R with
 (-
  (- derive_pt G t (G_derivable t) *
   (derive_pt Rs t (Rs_derivable t) + derive_pt F t (F_derivable t))))%R.
apply Ropp_lt_gt_contravar.
rewrite Ropp_0.
apply Rmult_lt_0_compat.
rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; assumption.
apply Rplus_lt_le_0_compat; assumption.
ring.
unfold F in |- *.
repeat simple apply Rmult_le_pos.
left; prove_sup0.
unfold Rdiv in |- *; left; apply Rmult_lt_0_compat.
apply TypeSpeed_pos.
apply Rinv_0_lt_compat; apply rho_pos.
apply sin_ge_0.
unfold Rdiv in |- *; repeat simple apply Rmult_le_pos.
left; apply rho_pos.
assumption.
left; apply Rinv_0_lt_compat; prove_sup0.
left; apply Rlt_trans with 1%R.
unfold Rdiv in |- *.
apply Rmult_lt_reg_l with (2 * / rho (vi intr))%R.
apply Rmult_lt_0_compat;
 [ prove_sup0 | apply Rinv_0_lt_compat; apply rho_pos ].
rewrite Rmult_1_r.
replace (2 * / rho (vi intr) * (rho (vi intr) * (t * / 2)))%R with t.
assumption.
repeat rewrite Rmult_assoc.
rewrite Rmult_comm.
repeat rewrite Rmult_assoc.
rewrite <- Rinv_l_sym.
repeat rewrite <- Rmult_assoc.
rewrite <- Rinv_l_sym.
rewrite Rmult_1_r; symmetry  in |- *; apply Rmult_1_l.
red in |- *; generalize (rho_pos (vi intr)); intros; rewrite H7 in H6;
 elim (Rlt_irrefl 0 H6).
discrR.
apply Rlt_trans with (PI / 2)%R.
apply Rlt_1_PI2.
apply PI2_Rlt_PI.
rewrite D_F.
apply Rmult_le_pos.
left; apply TypeSpeed_pos.
apply cos_ge_0.
left; apply Rlt_le_trans with 0%R.
rewrite <- Ropp_0.
apply Ropp_lt_gt_contravar.
apply PI2_RGT_0.
unfold Rdiv in |- *; repeat simple apply Rmult_le_pos.
left; apply rho_pos.
assumption.
left; apply Rinv_0_lt_compat; prove_sup0.
left; apply Rlt_le_trans with 1%R.
apply Rmult_lt_reg_l with (2 / rho (vi intr))%R.
unfold Rdiv in |- *; apply Rmult_lt_0_compat;
 [ prove_sup0 | apply Rinv_0_lt_compat; apply rho_pos ].
rewrite Rmult_1_r.
replace (2 / rho (vi intr) * (rho (vi intr) * (t / 2)))%R with t.
assumption.
unfold Rdiv in |- *.
repeat rewrite Rmult_assoc.
rewrite (Rmult_comm 2).
repeat rewrite <- Rmult_assoc.
rewrite <- Rinv_l_sym.
repeat rewrite Rmult_assoc.
rewrite <- Rinv_l_sym.
rewrite Rmult_1_r; rewrite Rmult_1_l.
reflexivity.
discrR.
red in |- *; generalize (rho_pos (vi intr)); intros; rewrite H5 in H4;
 elim (Rlt_irrefl 0 H4).
left; apply Rlt_1_PI2.
apply Rge_le.
assumption.
Qed.

Lemma G_0 : G 0 = 0%R.
unfold G in |- *; rewrite Rs_0; unfold Rminus, F in |- *; unfold Rdiv in |- *;
 rewrite Rmult_0_l; rewrite Rmult_0_r; rewrite sin_0;
 repeat rewrite Rmult_0_r; rewrite Rplus_0_l; apply Ropp_0.
Qed.

(**********)
Axiom
  G_pos :
    forall t : R, (0 <= t)%R -> (t < 2 / rho (vi intr))%R -> (0 <= G t)%R.

(**************************)
(******* THEOREM **********)
(**************************)

Theorem YCNGSTYS :
 forall t : R,
 (0 <= t)%R ->
 (rho (vi intr) * t < 2)%R ->
 (2 * r (vi intr) * sin (rho (vi intr) * (t / 2)) <=
  sqrt (Rsqr (xi intr t - xi intr 0) + Rsqr (yi intr t - yi intr 0)))%R.
intros; generalize (rho_pos (vi intr)); intro H1;
 generalize (Rinv_0_lt_compat (rho (vi intr)) H1);
 intro H2;
 generalize (Rmult_lt_compat_l (/ rho (vi intr)) (rho (vi intr) * t) 2 H2 H0);
 intro H3; rewrite <- Rmult_assoc in H3; rewrite <- Rinv_l_sym in H3.
rewrite Rmult_1_l in H3; rewrite Rmult_comm in H3; generalize (G_pos t H H3);
 unfold G in |- *; intro H4;
 generalize (Rplus_le_compat_l (F t) 0 (Rs t - F t) H4);
 rewrite Rplus_0_r; intro H5; unfold Rminus in H5;
 rewrite <- Rplus_assoc in H5; rewrite Rplus_comm in H5;
 rewrite <- Rplus_assoc in H5; rewrite Rplus_opp_l in H5;
 rewrite Rplus_0_l in H5; unfold Rs, F in H5; unfold r in |- *;
 assumption.
red in |- *; intro H4; rewrite H4 in H1; elim (Rlt_irrefl 0 H1).
Qed.

End ycngstys.


From Cat Require Export Cat.
From Cat.Universal Require Import Initial Terminal Product Coproduct.
From Cat Require Export Instances.SETOID.

Set Implicit Arguments.

Class Reloid : Type :=
{
  carrier : Setoid';
  rel : carrier -> carrier -> Prop;
  Proper_rel :> Proper (equiv ==> equiv ==> iff) rel
}.

Coercion carrier : Reloid >-> Setoid'.

Ltac reloidob X := try intros until X;
match type of X with
| Reloid =>
  let a := fresh X "_rel" in
  let b := fresh X "_Proper_rel" in destruct X as [X a b]; setoidob X
| Ob _ => progress cbn in X; reloidob X
end.

Ltac reloidobs := repeat
match goal with
| X : Reloid |- _ => reloidob X
| X : Ob _ |- _ => reloidob X
end.

Class ReloidHom (X Y : Reloid) : Type :=
{
  func : SetoidHom X Y;
  pres_rel : Proper (@rel X ==> @rel Y) func
}.

Coercion func : ReloidHom >-> SetoidHom.

Ltac reloidhom f := try intros until f;
match type of f with
| ReloidHom _ _ =>
    let a := fresh f "_pres_rel" in destruct f as [f a]; setoidhom f
| Hom _ _ => progress cbn in f; reloidhom f
end.

Ltac reloidhoms := intros; repeat
match goal with
| f : ReloidHom _ _ |- _ => reloidhom f
| f : Hom _ _ |- _ => reloidhom f
| _ => idtac
end.

Ltac reloid := intros; repeat
match goal with
| |- Equivalence _ => solve_equiv
| |- Proper _ _ => proper
| _ => repeat (my_simpl || reloidobs || reloidhoms || cat)
end.

#[refine]
#[export]
Instance ReloidHomSetoid (X Y : Reloid) : Setoid (ReloidHom X Y) :=
{
  equiv := fun f g => forall x : X, f x == g x
}.
Proof. now solve_equiv. Defined.

#[refine]
#[export]
Instance ReloidComp {X Y Z : Reloid} (f : ReloidHom X Y) (g : ReloidHom Y Z) : ReloidHom X Z :=
{
  func := SetoidComp f g
}.
Proof. now reloid. Defined.

#[refine]
#[export]
Instance ReloidId (X : Reloid) : ReloidHom X X :=
{
  func := SetoidId X
}.
Proof. now reloid. Defined.

#[refine]
#[export]
Instance ReloidCat : Cat :=
{
  Ob := Reloid;
  Hom := ReloidHom;
  HomSetoid := ReloidHomSetoid;
  comp := @ReloidComp;
  id := @ReloidId;
}.
Proof. all: now reloid. Defined.

#[export]
Instance Reloid_init : Reloid :=
{
  carrier := SETOID_init;
  rel := relate_Empty;
}.

#[refine]
#[export]
Instance Reloid_create (X : Reloid) : ReloidHom Reloid_init X :=
{
  func := SETOID_create X
}.
Proof. now proper. Defined.

#[refine]
#[export]
Instance HasInit_Reloid : HasInit ReloidCat :=
{
  init := Reloid_init;
  create := Reloid_create
}.
Proof. easy. Defined.

#[export]
Instance HasStrictInit_Reloid : HasStrictInit ReloidCat.
Proof.
  intros A f.
  exists (create A); split.
  - now intros x; destruct (f x).
  - now apply equiv_initial.
Defined.

#[export]
Instance Reloid_term : Reloid :=
{
  carrier := SETOID_term;
  rel := relate_unit;
}.

#[refine]
#[export]
Instance Reloid_delete (X : Reloid) : ReloidHom X Reloid_term :=
{
  func := SETOID_delete X
}.
Proof. easy. Defined.

#[refine]
#[export]
Instance HasTerm_Reloid : HasTerm ReloidCat :=
{
  term := Reloid_term;
  delete := Reloid_delete;
}.
Proof. easy. Defined.

#[refine]
#[export]
Instance Reloid_product (X Y : Reloid) : Reloid :=
{
  carrier := SETOID_product X Y;
  rel := relate_prod' rel rel;
}.
Proof.
  intros [f1 Hf1] [f2 Hf2] [Hf1' Hf2'] [g1 Hg1] [g2 Hg2] [Hg1' Hg2']; cbn.
  now rewrite Hf1', Hf2', Hg1', Hg2'.
Defined.

#[refine]
#[export]
Instance Reloid_outl (X Y : Reloid) : ReloidHom (Reloid_product X Y) X :=
{
  func := SETOID_outl X Y
}.
Proof. now intros [] []; cbn. Defined.

#[refine]
#[export]
Instance Reloid_outr (X Y : Reloid) : ReloidHom (Reloid_product X Y) Y :=
{
  func := SETOID_outr X Y
}.
Proof. now intros [] []; cbn. Defined.

#[refine]
#[export]
Instance Reloid_fpair (X Y A : Reloid)
  (f : ReloidHom A X) (g : ReloidHom A Y)
  : ReloidHom A (Reloid_product X Y) :=
{
  func := SETOID_fpair f g
}.
Proof.
  now intros a1 a2 ra; cbn; split; apply pres_rel.
Defined.

#[refine]
#[export]
Instance HasProducts_Reloid : HasProducts ReloidCat :=
{
  product := Reloid_product;
  outl := Reloid_outl;
  outr := Reloid_outr;
  fpair := Reloid_fpair;
}.
Proof.
  now repeat split; cbn in *.
Defined.

#[refine]
#[export]
Instance Reloid_coproduct (X Y : Reloid) : Reloid :=
{
  carrier := SETOID_coproduct X Y;
  rel := relate_sum rel rel;
}.
Proof.
  now proper; destruct x, x0, y, y0; cbn in *; rewrite ?H, ?H0 in *.
Defined.

#[refine]
#[export]
Instance Reloid_finl (X Y : Reloid) : ReloidHom X (Reloid_coproduct X Y) :=
{
  func := SETOID_finl X Y;
}.
Proof. easy. Defined.

#[refine]
#[export]
Instance Reloid_finr (X Y : Reloid) : ReloidHom Y (Reloid_coproduct X Y) :=
{
  func := SETOID_finr X Y;
}.
Proof. easy. Defined.

#[refine]
#[export]
Instance Reloid_copair
  (X Y A : Reloid) (f : ReloidHom X A) (g : ReloidHom Y A)
  : ReloidHom (Reloid_coproduct X Y) A :=
{
  func := SETOID_copair f g
}.
Proof.
  now proper; destruct x, y; try apply pres_rel.
Defined.

#[refine]
#[export]
Instance HasCoproducts_Reloid : HasCoproducts ReloidCat :=
{
  coproduct := Reloid_coproduct;
  finl := Reloid_finl;
  finr := Reloid_finr;
  copair := Reloid_copair;
}.
Proof.
  split; cbn.
  - easy.
  - easy.
  - now intros P' h1 h2 HA HB [a | b]; cbn.
Defined.


(* This file is an automatic translation, the licence of the source can be found here: *)
(* https://github.com/herd/herdtools7/blob/master/LICENSE.txt *)
(* Translation of model Really minimal *)
From Coq Require Import Relations Ensembles String.
From RelationAlgebra Require Import lattice prop monoid rel kat.
From Catincoq.lib Require Import Cat proprel.
Section Model.
Variable c : candidate.
Definition events := events c.
Definition R := R c.
Definition W := W c.
Definition IW := IW c.
Definition FW := FW c.
Definition B := B c.
Definition RMW := RMW c.
Definition F := F c.
Definition rf := rf c.
Definition po := po c.
Definition int := int c.
Definition ext := ext c.
Definition loc := loc c.
Definition addr := addr c.
Definition data := data c.
Definition ctrl := ctrl c.
Definition amo := amo c.
Definition rmw := rmw c.
Definition unknown_set := unknown_set c.
Definition unknown_relation := unknown_relation c.
Definition M := R ⊔ W.
Definition emptyset : set events := empty.
Definition classes_loc : set events -> Ensemble (Ensemble events) := partition loc.
Definition tag2events := unknown_relation "tag2events".
Definition emptyset_0 : set events := domain 0.
Definition partition := classes_loc.
Definition tag2instrs := tag2events.
Definition po_loc := po ⊓ loc.
Definition rfe := rf ⊓ ext.
Definition rfi := rf ⊓ int.
Definition co0 := loc ⊓ ([IW] ⋅ top ⋅ [(W ⊓ !IW)] ⊔ [(W ⊓ !FW)] ⋅ top ⋅ [FW]).
Definition toid (s : set events) : relation events := [s].
Definition fencerel (B : set events) := (po ⊓ [top] ⋅ top ⋅ [B]) ⋅ po.
Definition ctrlcfence (CFENCE : set events) := (ctrl ⊓ [top] ⋅ top ⋅ [CFENCE]) ⋅ po.
Definition imply (A : relation events) (B : relation events) := !A ⊔ B.
Definition nodetour (R1 : relation events) (R2 : relation events) (R3 : relation events) := R1 ⊓ !(R2 ⋅ R3).
Definition singlestep (R : relation events) := nodetour R R R.
(* Definition of map already included in the prelude *)
Definition LKW := (*failed: try LKW with emptyset_0*) emptyset_0.
(* Definition of co_locs already included in the prelude *)
(* Definition of cross already included in the prelude *)
Definition generate_orders s pco := cross (co_locs pco (partition s)).
Definition generate_cos pco := generate_orders W pco.
Variable co : relation events.
Definition witness_conditions := generate_cos co0 co.
Definition model_conditions := True.
End Model.

Hint Unfold events R W IW FW B RMW F rf po int ext loc addr data ctrl amo rmw unknown_set unknown_relation M emptyset classes_loc tag2events emptyset_0 partition tag2instrs po_loc rfe rfi co0 toid fencerel ctrlcfence imply nodetour singlestep LKW generate_orders generate_cos witness_conditions model_conditions : cat.

Definition valid (c : candidate) :=
  exists co : relation (events c),
    witness_conditions c co /\
    True.

(* End of translation of model Really minimal *)


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*              Layers of VMM                                          *)
(*                                                                     *)
(*          Refinement proof for MALInit layer                         *)
(*                                                                     *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)

(** This file provide the contextual refinement proof between MBoot layer and MALInit layer*)
Require Import BootGenDef.
Require Import BootGenLemma.

(** * Definition of the refinement relation*)
Section Refinement.

  Section WITHMEM.

    Context `{Hstencil: Stencil}.
    Context `{Hmem: Mem.MemoryModel}.
    Context `{Hmwd: UseMemWithData mem}.

    Global Instance: LoadStoreProp' (HD:= mboot_data_prf).
    Proof.
      accessor_prop_tac.
    Qed.

    Lemma flatmem_load_correct0:
      forall (s: stencil) ι (m1 m2: mem) (d1: HDATAOps) (d2: LDATAOps) chunk n v b,
        FlatMem.load chunk (HP d1) n = v ->
        MatchExtcallStates (one_crel (CompatRelOps0:= rel_ops) HDATAOps LDATAOps) s ι m1 d1 m2 d2 ->
        0 <= n <= adr_max - size_chunk chunk ->
        (align_chunk chunk | n) ->
        find_symbol s FlatMem_LOC = Some b ->
        exists v',
          Mem.load (mem:= mwd LDATAOps) chunk (m2, d2) b n = Some v' /\
          val_inject ι v v'.
    Proof.
      intros. inv H0.
      inv match_match. inv H.
      rewrite H3 in H4; inv H4.
      assert (HOS1: n + size_chunk chunk <= adr_max).
      {
        revert H1; clear; intros.
        omega.
      }
      assert (HOS2: n >= 0) by omega.
      pose proof (size_chunk_pos chunk) as HOS3.
      destruct H0 as [v1[v2[HL1[HV1[HL2 HM]]]]].
      assert (HW1: adr_max = n + (adr_max - n)) by omega.
      rewrite HW1 in HL1, HL2. clear HW1.
      eapply Mem.loadbytes_split in HL1; try omega.
      eapply FlatMem.loadbytes_split in HL2; try omega.
      rewrite Z.add_0_l in HL1, HL2.
      destruct HL1 as (bs11 & bs12 & HL11 & HL12 & Hca1).
      destruct HL2 as (bs21 & bs22 & HL21 & HL22 & Hca2).
      assert (Heq1: length bs11 = length bs21).
      {
        erewrite Mem.loadbytes_length; eauto 1.
        erewrite FlatMem.loadbytes_length; eauto 1.
      }
      assert (Heq2: length bs12 = length bs22).
      {
        erewrite Mem.loadbytes_length; eauto 1.
        erewrite FlatMem.loadbytes_length; eauto 1.
      }
      clear HL21.
      assert (HW2: adr_max - n = size_chunk chunk + (adr_max - n - size_chunk chunk)) by omega.
      rewrite HW2 in HL12, HL22. clear HW2.
      eapply Mem.loadbytes_split in HL12; try omega.
      eapply FlatMem.loadbytes_split in HL22; try omega.
      destruct HL12 as (bs121 & bs122 & HL121 & HL122 & Hca11).
      destruct HL22 as (bs221 & bs222 & HL221 & HL222 & Hca21).
      assert (Heq3: length bs121 = length bs221).
      {
        erewrite Mem.loadbytes_length; eauto 1.
        erewrite FlatMem.loadbytes_length; eauto 1.
      }
      assert (Heq4: length bs122 = length bs222).
      {
        erewrite Mem.loadbytes_length; eauto 1.
        erewrite FlatMem.loadbytes_length; eauto 1.
      }
      clear HL222.
      exploit Mem.loadbytes_load; eauto.
      intros HL1'.
      erewrite FlatMem.loadbytes_load; eauto.
      simpl. lift_trivial.
      rewrite HL1'.
      refine_split'; eauto 1.
      eapply decode_val_inject; eauto.
      clear HL221.
      subst.
      eapply list_forall2_sep in HM; auto.
      destruct HM as [_ HM].
      eapply list_forall2_sep in HM; auto.
      apply HM.
    Qed.

    Ltac pattern2_refinement_simpl:=
      pattern2_refinement_simpl' (@relate_AbData).

    Lemma flatmem_store_correct0:
      forall v v' (s: stencil) ι (m1 m2: mem) (d1 d1': HDATAOps) d2 chunk n b,
        flatmem_store' d1 chunk n v = Some d1' ->
        MatchExtcallStates (one_crel (CompatRelOps0:= rel_ops) HDATAOps LDATAOps) s ι m1 d1 m2 d2 ->
        0 <= n <= adr_max - size_chunk chunk ->
        (align_chunk chunk | n) ->
        val_inject ι v v' ->
        find_symbol s FlatMem_LOC = Some b ->
        exists m2',
          Mem.store chunk m2 b n v' = Some m2' /\
          MatchExtcallStates (one_crel (CompatRelOps0:= rel_ops) HDATAOps LDATAOps) s ι m1 d1' m2' d2.
    Proof.
      intros. inv H0.
      inv match_match. inv H0.
      rewrite H6 in H4; inv H4.
      destruct H5 as [v1[v2[HL1[HV1[HL2 HM]]]]].
      assert (HV: Mem.valid_access m2 chunk b n Writable).
      {
        unfold Mem.valid_access.
        split; try assumption.
        unfold Mem.range_perm in *. intros.
        Transparent Z.sub.
        eapply HV1. omega.
      }
      Opaque Z.sub.
      pose proof (Mem.valid_access_store _ _ _ _ v' HV) as HST.
      destruct HST as [m2' HST].
      rewrite HST.
      refine_split'; eauto 1. functional inversion H.
      econstructor; eauto 1; pattern2_refinement_simpl.
      constructor. econstructor; try eassumption.
      Transparent Z.sub.
      assert (HW1: adr_max = n + (adr_max - n)) by omega.
      rewrite HW1 in HL1, HL2 |- *.
      pose proof (size_chunk_pos chunk) as HOS3.
      eapply Mem.loadbytes_split in HL1; try omega.
      eapply FlatMem.loadbytes_split in HL2; try omega.
      rewrite Z.add_0_l in HL1, HL2.
      destruct HL1 as (bs11 & bs12 & HL11 & HL12 & Hca1).
      destruct HL2 as (bs21 & bs22 & HL21 & HL22 & Hca2).
      assert (Heq1: length bs11 = length bs21).
      {
        erewrite Mem.loadbytes_length; eauto 1.
        erewrite FlatMem.loadbytes_length; eauto 1.
      }
      assert (Heq2: length bs12 = length bs22).
      {
        erewrite Mem.loadbytes_length; eauto 1.
        erewrite FlatMem.loadbytes_length; eauto 1.
      }
      assert (HW2: adr_max - n = size_chunk chunk + (adr_max - n - size_chunk chunk)) by omega.
      rewrite HW2 in HL12, HL22 |- *.
      eapply Mem.loadbytes_split in HL12; try omega.
      eapply FlatMem.loadbytes_split in HL22; try omega.
      destruct HL12 as (bs121 & bs122 & HL121 & HL122 & Hca11).
      destruct HL22 as (bs221 & bs222 & HL221 & HL222 & Hca21).
      assert (Heq3: length bs121 = length bs221).
      {
        erewrite Mem.loadbytes_length; eauto 1.
        erewrite FlatMem.loadbytes_length; eauto 1.
      }
      assert (Heq4: length bs122 = length bs222).
      {
        erewrite Mem.loadbytes_length; eauto 1.
        erewrite FlatMem.loadbytes_length; eauto 1.
      }
      exploit Mem.loadbytes_store_same; eauto.
      intros HL1'.
      refine_split'; eauto 1.
      + eapply Mem.loadbytes_concat; try omega.
        * erewrite Mem.loadbytes_store_other; eauto 1.
          right; right; left. reflexivity.
        * rewrite Z.add_0_l.
          eapply Mem.loadbytes_concat; try omega.
          {
            erewrite Mem.loadbytes_store_same; eauto 1.
          }
          {
            erewrite Mem.loadbytes_store_other; eauto 1.
            right; right; right. reflexivity.
          }
      + rewrite <- HW2. rewrite <- HW1.
        unfold Mem.range_perm in *. intros.
        eapply Mem.perm_store_1; eauto.
      + assert (HF1: FlatMem.store chunk (HP d1) n v = HP d1 {HP : FlatMem.store chunk (HP d1) n v}) by reflexivity.
        rewrite <- HF1. clear HF1.
        pose proof (FlatMem.loadbytes_store_same chunk (HP d1) n v _ refl_equal) as HL2'.
        destruct HL2' as [HL2'|HL2'].
        * assert (HF: FlatMem.loadbytes (FlatMem.store chunk (HP d1) n v) 0
                                        (n + (size_chunk chunk + (4294967296 - n - size_chunk chunk)))
                      = bs21 ++ encode_val chunk v ++ bs222).
          {
            eapply FlatMem.loadbytes_concat; try omega.
            - erewrite FlatMem.loadbytes_store_other; eauto 1.
              right; left. reflexivity.
            - rewrite Z.add_0_l.
              eapply FlatMem.loadbytes_concat; try omega.
              + unfold flatmem_store. simpl. assumption.
              + erewrite FlatMem.loadbytes_store_other; eauto 1.
                right; right. reflexivity.
          }
          rewrite HF.
          clear HF HL2' HL222 HL221 HL21. subst.
          eapply list_forall2_sep in HM; auto.
          destruct HM as [HM1 HM].
          eapply list_forall2_sep in HM; auto.
          destruct HM as [_ HM2].
          apply list_forall2_app; eauto 1.
          apply list_forall2_app; eauto 1.
          eapply encode_val_inject; eauto.
        * assert (HF: FlatMem.loadbytes (FlatMem.store chunk (HP d1) n v) 0
                                        (n + (size_chunk chunk + (4294967296 - n - size_chunk chunk)))
                      = bs21 ++ (list_repeat (length (encode_val chunk v)) Undef) ++ bs222).
          {
            eapply FlatMem.loadbytes_concat; try omega.
            - erewrite FlatMem.loadbytes_store_other; eauto 1.
              right; left. reflexivity.
            - rewrite Z.add_0_l.
              eapply FlatMem.loadbytes_concat; try omega.
              + unfold flatmem_store. simpl. assumption.
              + erewrite FlatMem.loadbytes_store_other; eauto 1.
                right; right. reflexivity.
          }
          rewrite HF.
          clear HF HL2' HL222 HL221 HL21. subst.
          eapply list_forall2_sep in HM; auto.
          destruct HM as [HM1 HM].
          eapply list_forall2_sep in HM; auto.
          destruct HM as [_ HM2].
          apply list_forall2_app; eauto 1.
          apply list_forall2_app; eauto 1.
          apply list_forall2_memval_undef_chunk.
    Qed.

  End WITHMEM.

End Refinement.


(** Here we define signatures for HITs *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.Combinatorics.FiniteSets.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.categories.HSET.All.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.

Require Import prelude.
Require Import syntax.containers.
Require Import syntax.W_types.

Definition hit_signature
  : UU
  := ∑ (point_constr : container)
       (path_arg : container),
     ∏ (s : shapes path_arg),
       W point_constr (positions path_arg s)
       ×
       W point_constr (positions path_arg s).

(*
nattrans

W C X
≃
y X ⇒ (X → W C X)

∏ (s : shapes path_arg), W point_constr (positions path_arg s)
≃
∏ (s : shapes path_arg),
  nattrans (yoneda (positions path_arg s)) (W point_constr)
 *)

Definition point_constr
           (Σ : hit_signature)
  : container
  := pr1 Σ.

Definition path_index
           (Σ : hit_signature)
  : hSet
  := shapes (pr12 Σ).

Definition path_arg
           (Σ : hit_signature)
           (s : path_index Σ)
  : hSet
  := positions (pr12 Σ) s.

Definition path_lhs
           (Σ : hit_signature)
           (s : path_index Σ)
  : W (point_constr Σ) (path_arg Σ s)
  := pr1 (pr22 Σ s).

Definition path_rhs
           (Σ : hit_signature)
           (s : path_index Σ)
  : W (point_constr Σ) (path_arg Σ s)
  := pr2 (pr22 Σ s).

Definition make_hit_signature
           (point_constr : container)
           (path_arg : container)
           (path_lhs : ∏ (s : shapes path_arg),
                       W point_constr (positions path_arg s))
           (path_rhs : ∏ (s : shapes path_arg),
                       W point_constr (positions path_arg s))
  : hit_signature
  := point_constr ,, (path_arg ,, λ s, path_lhs s ,, path_rhs s).

Definition is_finitary_hit
           (Σ : hit_signature)
  : UU
  := is_finitary (point_constr Σ) × is_finitary (pr12 Σ).


Require Import
        Coq.Strings.String
        Coq.Vectors.Vector.

Require Import
        Fiat.Computation
        Fiat.Narcissus.BinLib.CharString
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.WordFacts
        Fiat.Narcissus.Common.ComposeCheckSum
        Fiat.Narcissus.Common.ComposeIf
        Fiat.Narcissus.Common.ComposeOpt
        Fiat.Narcissus.Automation.Solver
        Fiat.Narcissus.Formats.CInt
        Fiat.Narcissus.Formats.NatOpt
        Fiat.Narcissus.Formats.FixListOpt
        compcert.lib.Integers.

Module IntFormatr := CInt.Make(Wordsize_32).

Import IntFormatr.

Instance ByteStringQueueMonoid : Monoid ByteString := ByteStringQueueMonoid.

Definition Simple_Format_Spec
           (p : int * list int) :=
        format_nat 8 (|snd p|)
  ThenC format_int Int.wordsize (fst p)
  ThenC format_list (format_int Int.wordsize) (snd p)
  DoneC.

Definition Simply_OK (p : int * list int) :=
  ((|snd p|) < pow2 8)%nat.

Definition Simple_Format_decoder
  : CorrectDecoderFor Simply_OK Simple_Format_Spec.
Proof.
  start_synthesizing_decoder.
  normalize_compose monoid.
  repeat first [apply innt_decode_correct; auto
               | solve [ intros; apply intrange]
               | intros; simpl; match goal with |- _ /\ _ => split; intuition eauto end
               | decode_step idtac].
  synthesize_cache_invariant.
  cbv beta; optimize_decoder_impl.
Defined.

Definition Simple_Format_decoder_impl :=
  Eval simpl in (fst (projT1 Simple_Format_decoder)).

Print Simple_Format_decoder_impl.

Lemma foo {C} {numBytes}
  : forall (v : Vector.t byte (S numBytes)) (k : int -> ByteString -> unit -> option (C * ByteString * unit)),
    (`(a, b0, d) <- decode_int
      (monoidUnit := ByteString_QueueMonoidOpt) 8 (build_aligned_ByteString v) tt;
       k a b0 d) =
    Let n := byteToInt32 (Vector.nth v Fin.F1) in
    k n (build_aligned_ByteString (Vector.tl v)) ().
Proof.
  unfold LetIn; intros.
  unfold decode_int, WordOpt.decode_word.
  rewrite aligned_decode_char_eq; simpl.
  f_equal.
  pattern numBytes, v; apply Vector.caseS; simpl; intros.
  destruct h.
  destruct intval0; simpl; intros; intuition eauto.
  - compute; apply mkint_eq; reflexivity.
  - repeat first [compute in intrange0; destruct intrange0; congruence
                 | destruct p as [p | p | ]; simpl
                 | compute; apply mkint_eq; reflexivity].
  - compute in intrange0; destruct p; destruct intrange0; congruence.
Qed.

Lemma foo2 {C} {numBytes}
  : forall (v : Vector.t byte (S numBytes)) (k : nat -> ByteString -> unit -> option (C * ByteString * unit)),
    (`(a, b0, d) <- decode_nat
      (monoidUnit := ByteString_QueueMonoidOpt) 8 (build_aligned_ByteString v) tt;
       k a b0 d) =
    Let n := BinInt.Z.to_nat (Byte.intval (Vector.nth v Fin.F1)) in
    k n (build_aligned_ByteString (Vector.tl v)) ().
Proof.
  intros.
  unfold decode_nat, WordOpt.decode_word.
  rewrite aligned_decode_char_eq; simpl.
  f_equal.
  pattern numBytes, v; apply Vector.caseS; simpl; intros.
  destruct h.
  destruct intval0; simpl; intros; intuition eauto.
  - repeat first [compute in intrange0; destruct intrange0; congruence
                 | destruct p as [p | p | ]; simpl
                 | compute; reflexivity].
Qed.

Lemma foo3 {C} {numBytes}
  : forall (v : Vector.t byte (S (S (S (S numBytes))))) (k : int -> ByteString -> unit -> option (C * ByteString * unit)),
    (`(a, b0, d) <- decode_int
      (monoidUnit := ByteString_QueueMonoidOpt) Int.wordsize (build_aligned_ByteString v) tt;
       k a b0 d) =
    Let n := wordToInt (Core.append_word (byteToWord (Vector.nth v (Fin.FS (Fin.FS (Fin.FS Fin.F1)))))
                                         (Core.append_word (byteToWord (Vector.nth v (Fin.FS (Fin.FS Fin.F1))))
                                            (Core.append_word (byteToWord (Vector.nth v (Fin.FS Fin.F1)))
                                                              (byteToWord (Vector.nth v Fin.F1)))))
    in
    k n (build_aligned_ByteString (Vector.tl (Vector.tl (Vector.tl (Vector.tl v))))) ().
Proof.
  unfold LetIn; intros.
  unfold decode_int, WordOpt.decode_word.
  unfold Int.wordsize, Wordsize_32.wordsize.
  rewrite DecodeBindOpt2_assoc.
  pose proof (@aligned_decode_char_eq' _ 3 v).
  match goal with
    |- context[Ifopt ?Z as _ Then _ Else _] => replace Z with
                                               (let (v', v'') := Vector_split 4 numBytes v in Some (VectorByteToWord v', build_aligned_ByteString v'')) by (rewrite <- H; reflexivity)
  end.
  unfold Vector_split, If_Opt_Then_Else, DecodeBindOpt2 at 1, If_Opt_Then_Else.
  unfold DecodeBindOpt2 at 1, If_Opt_Then_Else.
  repeat f_equal.
  rewrite Core.append_word_assoc; erewrite VectorByteToWord_cons; repeat f_equal.
  rewrite Core.append_word_assoc, <- !Eqdep_dec.eq_rect_eq_dec; eauto using Peano_dec.eq_nat_dec.
  f_equal.
  erewrite VectorByteToWord_cons; f_equal.
  rewrite <- !Eqdep_dec.eq_rect_eq_dec; eauto using Peano_dec.eq_nat_dec; f_equal.
  erewrite VectorByteToWord_cons; f_equal.
  rewrite <- !Eqdep_dec.eq_rect_eq_dec; eauto using Peano_dec.eq_nat_dec; f_equal.
  erewrite VectorByteToWord_cons; f_equal.
  rewrite <- !Eqdep_dec.eq_rect_eq_dec; eauto using Peano_dec.eq_nat_dec; f_equal.
  simpl; f_equal; rewrite !Vector_nth_tl, Vector_nth_hd; reflexivity.
  simpl; f_equal; rewrite !Vector_nth_tl, Vector_nth_hd; reflexivity.
  simpl; f_equal; rewrite !Vector_nth_tl, Vector_nth_hd; reflexivity.
  simpl; f_equal; rewrite Vector_nth_hd; reflexivity.
  Grab Existential Variables.
  omega.
  omega.
  omega.
Qed.

Definition ofbytes (hi himid hilo lo: byte) : int :=
  or (shl (repr (Byte.unsigned hi)) (repr 24))
     (or (shl (repr (Byte.unsigned himid)) (repr 16))
         (or (shl (repr (Byte.unsigned hilo)) (repr 8))
             (repr (Byte.unsigned lo)))).

Lemma wordToInt_ofbytes_eq
  : forall (hi himid hilo lo: byte),
    wordToInt (Core.append_word
                 (byteToWord lo)
                 (Core.append_word (byteToWord hilo) (Core.append_word (byteToWord himid)
                                                                       (byteToWord hi)))) =
    ofbytes hi himid hilo lo.
Proof.
Admitted.

Lemma foo4 {C} {numBytes}
  : forall (v : Vector.t byte (S (S (S (S numBytes))))) (k : int -> ByteString -> unit -> option (C * ByteString * unit)),
    (`(a, b0, d) <- decode_int
      (monoidUnit := ByteString_QueueMonoidOpt) Int.wordsize (build_aligned_ByteString v) tt;
       k a b0 d) =
    Let n := ofbytes (Vector.nth v Fin.F1)
                     (Vector.nth v (Fin.FS Fin.F1))
                     (Vector.nth v (Fin.FS (Fin.FS Fin.F1)))
                     (Vector.nth v (Fin.FS (Fin.FS (Fin.FS Fin.F1))))
    in
    k n (build_aligned_ByteString (Vector.tl (Vector.tl (Vector.tl (Vector.tl v))))) ().
Proof.
  intros; rewrite foo3.
  rewrite wordToInt_ofbytes_eq.
  reflexivity.
Qed.

Definition aligned_Simple_Format_decoder_impl (bs : Vector.t byte 32) :
  {n : option (int * list int * ByteString * ()) & n =
                                                        Simple_Format_decoder_impl (build_aligned_ByteString bs) ()}.
  eexists.
  symmetry; unfold Simple_Format_decoder_impl.
  erewrite (foo2 bs).
  apply f_equal; apply Coq.Logic.FunctionalExtensionality.functional_extensionality; intro.
  rewrite foo4.
  etransitivity.
  apply f_equal; apply Coq.Logic.FunctionalExtensionality.functional_extensionality; intro.
Abort.


(* begin hide *)
From Coq Require Import
     Arith.PeanoNat
     Logic.FunctionalExtensionality
     Lists.List
     Lia.

From Heapster Require Import
     Utils
     Permissions.

Import ListNotations.
(* end hide *)

(** * Memory model *)
(** ** Addresses *)
(** We use a block-offset address model. *)
Definition addr : Set := nat * nat.

(** Equality on addresses. *)
Definition eqb (a b : addr) : bool :=
  Nat.eqb (fst a) (fst b) && Nat.eqb (snd a) (snd b).

Lemma eqb_spec : forall x y, Bool.reflect (x = y) (eqb x y).
Proof.
  intros [x1 x2] [y1 y2]. destruct (eqb (x1, x2) (y1, y2)) eqn:?; constructor.
  - unfold eqb in Heqb. simpl in Heqb. symmetry in Heqb. apply Bool.andb_true_eq in Heqb.
    destruct Heqb. symmetry in H, H0.
    apply (Bool.reflect_iff _ _ (Nat.eqb_spec _ _)) in H.
    apply (Bool.reflect_iff _ _ (Nat.eqb_spec _ _)) in H0. subst. auto.
  - unfold eqb in Heqb. simpl in Heqb. apply Bool.andb_false_iff in Heqb.
    destruct Heqb.
    + intro. inversion H0. subst. rewrite Nat.eqb_refl in H. inversion H.
    + intro. inversion H0. subst. rewrite Nat.eqb_refl in H. inversion H.
Qed.

Lemma addr_dec : forall (a b : addr), {a = b} + {a <> b}.
Proof.
  intros [a1 a2] [b1 b2].
  destruct (Nat.eq_dec a1 b1); destruct (Nat.eq_dec a2 b2); subst; auto.
  - right. intros H. inversion H; subst. apply n. reflexivity.
  - right. intros H. inversion H; subst. apply n. reflexivity.
  - right. intros H. inversion H; subst. apply n. reflexivity.
Qed.

Lemma addr_neq_cases (b b' o o' : nat) :
  (b, o) <> (b', o') -> b <> b' \/ o <> o'.
Proof.
  intros.
  destruct (Nat.eq_dec b b'); destruct (Nat.eq_dec o o'); subst; auto.
Qed.

(** ** Memory definition *)
Inductive Value :=
| VNum : nat -> Value
| VPtr : addr -> Value.

Definition mem_block := nat -> option Value.

Variant logical_block :=
| LBlock (size : nat) (bytes : mem_block) : logical_block.

Definition memory := list (option logical_block).

(** ** Memory operations *)
(** Whether the block of [ptr] is allocated and is the offset of [ptr] within bounds. *)
Definition allocated (m : memory) (ptr : addr) : bool :=
  match nth_error m (fst ptr) with
  | Some (Some (LBlock size _)) => snd ptr <? size
  | _ => false
  end.

(** Read [m] at memory location [ptr]. [ptr] must be a valid location and allocated. *)
Definition read (m : memory) (ptr : addr) : option Value :=
  if allocated m ptr
  then match nth_error m (fst ptr) with
       | Some (Some (LBlock _ bytes)) => bytes (snd ptr)
       | _ => None
       end
  else None.

(** Returns the size of the block only if [ptr] has offset 0. *)
(** Note if we used [allocated] here then it doesn't work for size 0 blocks. *)
Definition sizeof (m : memory) (ptr : addr) : option nat :=
  if snd ptr =? 0
  then match nth_error m (fst ptr) with
       | Some (Some (LBlock size _)) => Some size
       | _ => None
       end
  else None.

(** Write [v] into [m] at address [ptr]. *)
Definition write (m : memory) (ptr : addr) (v : Value) : option memory :=
  if allocated m ptr
  then match nth_error m (fst ptr) with
       | Some (Some (LBlock size bytes)) =>
         Some (replace_list_index
                 m
                 (fst ptr)
                 (Some (LBlock size (fun o => if o =? snd ptr
                                           then Some v
                                           else bytes o))))
       | _ => None
       end
  else None.

(** Properties about memory operations *)
Lemma allocated_ptr_block m b o :
  allocated m (b, o) = true ->
  b < length m.
Proof.
  unfold allocated. simpl. intros.
  apply nth_error_Some. intro. rewrite H0 in H. inversion H.
Qed.

Lemma allocated_ptr_offset m b o size bytes :
  allocated m (b, o) = true ->
  nth_error m b = Some (Some (LBlock size bytes)) ->
  o < size.
Proof.
  unfold allocated. simpl. intros. rewrite H0 in H.
  rewrite <- (Bool.reflect_iff _ _ (Nat.ltb_spec0 _ _)) in H. auto.
Qed.

Lemma read_success_write m ptr v v' :
  read m ptr = Some v ->
  exists m', write m ptr v' = Some m'.
Proof.
  unfold read, write. intros.
  destruct (allocated m ptr), (nth_error m (fst ptr));
    try destruct o; try solve [inversion H].
  destruct l. eexists. reflexivity.
Qed.

Lemma write_success_read_eq m m' ptr v :
  write m ptr v = Some m' ->
  read m' ptr = Some v.
Proof.
  unfold read, write. intros.
  destruct (allocated m ptr) eqn:?, (nth_error m (fst ptr)) eqn:?;
           try destruct o; try solve [inversion H].
  destruct l. inversion H. clear H H1 m'. unfold allocated in *.
  rewrite nth_error_replace_list_index_eq.
  rewrite Heqo in Heqb. clear Heqo. rewrite Heqb. rewrite Nat.eqb_refl; auto.
Qed.

Lemma write_success_read_neq m m' ptr v :
  write m ptr v = Some m' ->
  forall ptr', ptr <> ptr' -> read m ptr' = read m' ptr'.
Proof.
  destruct ptr as [b o].
  unfold write. unfold read. simpl. intros.
  destruct (allocated m (b, o)) eqn:?; try solve [inversion H].
  destruct (nth_error m b) eqn:?; try solve [inversion H].
  destruct o0 eqn:?; try solve [inversion H].
  destruct l. inversion H; subst; clear H. destruct ptr' as [b' o']. simpl.
  pose proof (allocated_ptr_block _ _ _ Heqb0).
  destruct (addr_neq_cases _ _ _ _ H0).
  - unfold allocated. simpl. erewrite nth_error_replace_list_index_neq; eauto.
  - destruct (Nat.eq_dec b b').
    + subst. unfold allocated. simpl. rewrite nth_error_replace_list_index_eq; auto.
      rewrite Heqo0. destruct (o' <? size) eqn:?; auto.
      rewrite <- Nat.eqb_neq in H1. rewrite Nat.eqb_sym. rewrite H1. auto.
    + unfold allocated. simpl. erewrite nth_error_replace_list_index_neq; eauto.
Qed.

Lemma write_success_sizeof m m' ptr v :
  write m ptr v = Some m' ->
  forall ptr', sizeof m ptr' = sizeof m' ptr'.
Proof.
  destruct ptr as [b o].
  unfold write. unfold read. simpl. intros.
  destruct (allocated m (b, o)) eqn:?; try solve [inversion H].
  destruct (nth_error m b) eqn:?; try solve [inversion H].
  destruct o0 eqn:?; try solve [inversion H].
  destruct l. inversion H; subst; clear H. destruct ptr' as [b' o']. simpl.
  pose proof (allocated_ptr_block _ _ _ Heqb0).
  unfold sizeof. simpl. destruct (o' =? 0) eqn:?; auto.
  destruct (Nat.eq_dec b b').
  - subst. simpl. rewrite nth_error_replace_list_index_eq; auto.
    rewrite Heqo0. auto.
  - erewrite nth_error_replace_list_index_neq; eauto.
Qed.

Lemma write_success_length m m' ptr v :
  write m ptr v = Some m' ->
  length m = length m'.
Proof.
  destruct ptr as [b o].
  unfold write. unfold read. simpl. intros.
  destruct (allocated m (b, o)) eqn:?; try solve [inversion H].
  destruct (nth_error m b) eqn:?; try solve [inversion H].
  destruct o0 eqn:?; try solve [inversion H].
  destruct l. inversion H; subst; clear H.
  pose proof (allocated_ptr_block _ _ _ Heqb0).
  simpl. apply replace_list_index_length; auto.
Qed.

(** ** Helper definitions *)
(** [mem_at ptr v] creates a memory which is only defined at location [ptr]. *)
(** We use this for some sanity checks when we define memory permissions. *)
Definition mem_at (ptr : addr) (v : Value) : memory :=
  repeat None (fst ptr) ++ [Some (LBlock
                                    (snd ptr + 1)
                                    (fun o => if o =? snd ptr
                                           then Some v
                                           else None))].

(** Properties about [mem_at]. *)
Lemma allocated_mem_at ptr v : allocated (mem_at ptr v) ptr = true.
  destruct ptr as [b o]. unfold allocated, mem_at. simpl.
  induction b; simpl; auto. apply Nat.ltb_lt. lia.
Qed.

Lemma nth_error_mem_at ptr v :
  nth_error (mem_at ptr v) (fst ptr) =
  Some (Some (LBlock
                (snd ptr + 1)
                (fun o => if o =? snd ptr
                       then Some v
                       else None))).
Proof.
  destruct ptr as [b o]. simpl. induction b; auto.
Qed.

Lemma read_mem_at ptr v : read (mem_at ptr v) ptr = Some v.
Proof.
  destruct ptr as [b o]. unfold read.
  rewrite allocated_mem_at. rewrite nth_error_mem_at.
  rewrite Nat.eqb_refl. reflexivity.
Qed.

Lemma write_mem_at ptr v v' : write (mem_at ptr v) ptr v' = Some (mem_at ptr v').
Proof.
  destruct ptr as [b o]. unfold write.
  rewrite allocated_mem_at. rewrite nth_error_mem_at. f_equal.
  unfold mem_at. simpl.
  induction b; simpl; try solve [f_equal; auto].
  do 3 f_equal. apply functional_extensionality. intros.
  destruct (x =? o); auto.
Qed.

(** [replace_n] is used later for proving the [Free] rule. *)
Definition replace_n m b size bytes n : memory :=
  replace_list_index
    m b (Some (LBlock size (fun o => if andb (o <? size) (size - n <=? o)
                                  then None else bytes o))).

(** Properties of [replace_n]. *)
Lemma replace_n_0 m b size bytes :
  nth_error m b = Some (Some (LBlock size bytes)) ->
  replace_n m b size bytes 0 = m.
Proof.
  unfold replace_n. intros. f_equal.
  assert (b < length m).
  { apply nth_error_Some. intro. rewrite H in H0. inversion H0. }
  revert H H0. revert b.
  induction m; intros; simpl in *; try lia; auto.
  destruct b; f_equal; [| apply IHm; auto; lia].
  inversion H. rewrite Nat.sub_0_r.
  do 2 f_equal. apply functional_extensionality. intros.
  rewrite Nat.ltb_antisym. rewrite Bool.andb_negb_l. reflexivity.
Qed.

Lemma replace_n_same m b size bytes :
  replace_list_index m b (Some (LBlock (S size) (fun o : nat => if o <? S size then None else bytes o))) =
  replace_n m b (S size) bytes (S size).
Proof.
  unfold replace_n. do 4 f_equal. apply functional_extensionality. intros.
  rewrite Nat.sub_diag. simpl. rewrite Bool.andb_true_r. reflexivity.
Qed.

Lemma read_replace_n_neq ptr' n b len m bytes :
    b <> fst ptr' ->
    b < length m ->
    read m ptr' = read (replace_n m b len bytes n) ptr'.
Proof.
  unfold replace_n, read. intros Hneq Hlt.
  destruct (allocated m ptr') eqn:?.
  2: { unfold allocated in *.
       erewrite <- nth_error_replace_list_index_neq; eauto. rewrite Heqb0; auto. }
  pose proof (allocated_ptr_block _ _ _ Heqb0).
  unfold allocated in *. simpl.
  rewrite <- nth_error_replace_list_index_neq; eauto. rewrite Heqb0; auto.
Qed.

Lemma sizeof_replace_n ptr b m n size bytes :
  nth_error m b = Some (Some (LBlock size bytes)) ->
  b < length m ->
  sizeof m ptr = sizeof (replace_n m b size bytes n) ptr.
Proof.
  simpl. intros Hb Hlt. unfold replace_n, sizeof. destruct (snd ptr =? 0); auto.
  destruct (Nat.eq_dec (fst ptr) b).
  * rewrite e in *. simpl. rewrite nth_error_replace_list_index_eq; auto.
    rewrite Hb. auto.
  * simpl. erewrite <- nth_error_replace_list_index_neq; auto.
Qed.


Require Import Bedrock.Examples.AutoSep.

(** A very basic abstract predicate: pairs of words *)

Module Type PAIR.
  Parameter pair : W -> W -> W -> HProp.

  Axiom pair_extensional : forall a b p, HProp_extensional (pair a b p).

  Axiom pair_fwd : forall a b p,
    pair a b p ===> p =*> a * (p ^+ $4) =*> b.

  Axiom pair_bwd : forall a b p,
    p =*> a * (p ^+ $4) =*> b ===> pair a b p.
End PAIR.

Module Pair : PAIR.
  Open Scope Sep_scope.

  Definition pair (a b p : W) : HProp :=
    p =*> a * (p ^+ $4) =*> b.

  Theorem pair_extensional : forall a b p, HProp_extensional (pair a b p).
    reflexivity.
  Qed.

  Theorem pair_fwd : forall a b p,
    pair a b p ===> p =*> a * (p ^+ $4) =*> b.
    unfold pair; sepLemma.
  Qed.

  Theorem pair_bwd : forall a b p,
    p =*> a * (p ^+ $4) =*> b ===> pair a b p.
    unfold pair; sepLemma.
  Qed.
End Pair.

Import Pair.
Hint Immediate pair_extensional.

Definition firstS : spec := SPEC("p") reserving 0
  Al a, Al b,
  PRE[V] pair a b (V "p")
  POST[R] [| R = a |] * pair a b (V "p").

Definition updSecondS : spec := SPEC("p", "x") reserving 0
  Al a, Al b,
  PRE[V] pair a b (V "p")
  POST[_] pair a (V "x") (V "p").

Definition pair := bmodule "pair" {{
  bfunction "first"("p") [firstS]
    "p" <-* "p";;
    Return "p"
  end with bfunction "second"("p", "x") [updSecondS]
    "p" <- "p" + 4;;
    "p" *<- "x";;
    Return 0
  end
}}.

(*TIME Clear Timing Profile. *)

Definition hints : TacPackage.
  (*TIME idtac "pair:prepare". Time *)
  prepare pair_fwd pair_bwd.
Defined.

Theorem pairOk : moduleOk pair.
  (*TIME idtac "pair:verify". Time *)
  vcgen; abstract sep hints.
Qed.

(*TIME Print Timing Profile. *)