(** printing × $\times$ #×# *)
(** printing :> $:$ #:># *)
(** printing ≡ $\equiv$ #≡# *)
(** printing [*] $*$ #*# *)
(** printing ∧ $\wedge$ #∧# *)
(** printing ∀ $\forall$ #∀# *)
(** printing → $\rightarrow$ #→# *)
(** printing ∃ $\exists$ #∃# *)
(** printing ≤ $\le$ #≤# *)
(** printing θ $\theta$ #θ# *)
(** printing eeev $\epsilon_v$ #∊ᵥ# *)
(** printing eeew $\epsilon_w$ #∊w# *)
(** printing tm $t_m$ #tm# *)
(** printing IR $\mathbb{R}$ #IR# *)
(** printing CR $\mathbb{R}$ #CR# *)
(** printing tr $t_r$ #tr# *)
(** remove printing * *)

(** printing ' $ $ #'# *)

Set Suggest Proof Using.

Require Import Vector.

Require Import MathClasses.interfaces.canonical_names.
Require Import MCInstances.
Require Import ackermannSteering.
Require Import MCMisc.tactics.
Require Import CartIR.
Require Import ackermannSteering.
Require Import fastReals.interface.
Require Import fastReals.misc.
Require Import geometry2D.
Require Import geometry2DProps.
Require Import car.errorBounds.
Require Import ackermannSteeringProp.
Require Import MathClasses.orders.rings.
Require Import MathClasses.interfaces.orders.
Require Import atomicMoves.
Require Import IRMisc.LegacyIRRing.
Hint Unfold One_instance_IR : IRMC.

  Local Notation minxy := (lstart).
  Local Notation maxxy := (lend).
  Local Notation  "∫" := Cintegral.
  Local Notation ConfineRect := (Line2D).

Local Opaque CSine.
Local Opaque CCos.
Local Opaque Sine.
Local Opaque Cosine.
Local Opaque Sin.
Local Opaque Cos.

Section Wriggle.
(** * The Wriggle move
Now consider a
#<href="https://rigtriv.wordpress.com/2007/10/01/parallel-parking/">wiggle motion</a>#
and characterize the the change in car's position and orientation caused
by this motion.
The word "wriggle" was perhaps coined by Nelson in his 1967 book Tensor analysis.
Informally it denotes the following motion :

  -steer (i.e rotate the steering wheel with brakes firmly pushed),
  -drive (while keeping the steering wheel fixed),
  -reverse steer,
  -reverse drive

  Wiggle is parametrized by a nonzero [turnCurvature] and a drive distance,
  both of which may be signed.
  Update : Althought the drive and reverse drive were supposed to be of same length, we will
  refrain from assuming this as much as possible.
  *)

Variable α : IR.
Hypothesis tcNZ : α[#]0.
Variable d1 : IR.

Local Notation turnRadius (*: IR *) := (f_rcpcl α tcNZ).
(** In our formalism, wriggle is a composition of the following 2 atomic moves.
Update: d1 and d2 be nevative, so the prefix
"rev" is only relative and does not mean backward driving
  *)

Definition steerAndDrive : DAtomicMove IR :=
  existT _
          {|am_tc := α; am_distance := d1 |}
          (inr tcNZ).
  (*note that [revSteerAndrevDrive] is not the same as
  - steerAndDrive*)
Definition revSteerAndrevDrive (d2 : IR) : DAtomicMove  IR:=
   existT _
     {|am_tc := -α; am_distance := -d2 |}
      (inr (tcnegNZ _ tcNZ)).
(** the distance covered during driving and
  reverse driving is exactly the same.
  TODO: let them be slightly different, e.g. upto epsilon
 *)
Definition WriggleG (d2 : IR) : list (DAtomicMove  IR) :=
  [steerAndDrive; revSteerAndrevDrive d2].

Definition Wriggle : list (DAtomicMove  IR) :=  WriggleG d1.

(*
Add Ring tempRingIR : (stdlib_ring_theory IR).
 *)

Hint Unfold One_instance_IR : IRMC.

(** i, m, f respectively stand for initial,
  middle, final
 *)

Lemma WriggleGState : forall d2 init,
  let θi := θ2D init in
  let θm := θi +  α * d1 in
  let θf := θi +  α * (d1+d2) in
  let pf := pos2D init +
    (2*(unitVecT θm) - (unitVecT  θf) - (unitVecT θi))
    *{|X:=1;Y:=-1|}*'turnRadius in
  stateAfterAtomicMoves (WriggleG d2) init
  = {|pos2D := pf ; θ2D:= θf|}.
Proof using.
  intros ? ? ? ? ?. simpl.
  unfold stateAfterAtomicMove. simpl.
  split; simpl; [| subst  θi θm θf; simpl;
  IRring].
  unfold recipT, RecipTIR.
  rewrite reciprocalNeg with (xp:=tcNZ).
  fold Negate_instance_IR.
  fold (@negate IR _).
  assert
    (θ2D init + α * d1 + - α * - d2
    = θ2D init + α * (d1+d2)) as H by IRring.
  rewrite H.
  fold θi.
  fold θm.
  fold θf.
  split; simpl; try IRring.
Qed.

Lemma WriggleState : forall init,
   let θi := θ2D init in
  let θm := θi +  α * d1 in
  let θf := θi + 2 * α * d1 in
   let pf := pos2D init +
     (2*(unitVecT θm) - (unitVecT  θf) - (unitVecT θi))
     *{|X:=1;Y:=-1|}*'turnRadius in
  stateAfterAtomicMoves Wriggle init
   = {|pos2D := pf ; θ2D:= θf|}.
Proof using.
  intros.
  unfold Wriggle.
  rewrite WriggleGState. subst  θf θi θm pf.
  assert (α * (d1 + d1) = 2 * α * d1) as Ht  by IRring.
  repeat split; simpl;
  rewrite Ht; auto.
Qed.

End Wriggle.

Require Import firstQuadrant.

Section FirstQuadWriggle.
(**  The lemmas [SidewaysAuxSpace] above reduces
  the problem of computing the space needec by the
  [SidewaysAux] move to just doing that for the
  [Wriggle] move, which constitutes the first 2 out
  of the 5 atomic moves in [SidewaysAux].
  WLOG, we consider the car's initial state to be ((0,0),0),
  which means it is at origin, and its forward direction
  points along the X axis.
  *)
Variable α : IR.
Hypothesis αPos : α[#]0.
Variable d : IR.
(*Variable initθ : IR. *)
(*Hypothesis dNN : 0≤d.
Hypothesis  adNN : 0≤α*d.*)

Hypothesis firstQuadW: 0 ≤ 2*α*d ≤ ½ * π.

Lemma adNN : 0 ≤  α * d.
Proof using firstQuadW.
  destruct firstQuadW as [H _].
  setoid_rewrite <- (@simple_associativity IR _ mult _ _) in H.
  apply halfNonNegIR in H. assumption.
Qed.

(*Local Lemma is not supported prior to 8.5beta3*)
Local Definition firstQuadW1: ∀ θ : ℝ,
0 ≤ θ ≤ (α * d)
-> 0 ≤ θ ≤ ½ * π.
Proof using firstQuadW αPos.
  intros ? Hh.
  eapply inBetweenExpand;
    [apply Hh |].
  clear Hh.
  split;[reflexivity|].
  eapply transitivity;[| apply firstQuadW].
  rewrite <- (@simple_associativity _ _ mult _ _ _).
  apply rings.RingLeProp2.
  apply adNN.
Qed.

Local Definition firstQuadW2: ∀ θ : ℝ,
(α * d) ≤ θ ≤ 2*α * d
-> 0 ≤ θ ≤ ½ * π.
Proof using firstQuadW αPos.
  intros ? Hh.
  eapply inBetweenExpand;
    [apply Hh |].
  clear Hh.
  split;[apply adNN|].
  tauto.
Qed.

Require Import MCMisc.rings.
Lemma adPiBy2:  α *  d ≤ ½ * Pi.
Proof using  firstQuadW αPos.
  eapply transitivity;[| apply firstQuadW].
  rewrite <- (@simple_associativity _ _ mult _ _).
  apply RingLeProp2.
  apply adNN; auto.
Qed.

Local Notation  αNZ := (αPos: α[#]0).
Local Notation init  := (0:Rigid2DState IR).

Local Notation SWriggle := (Wriggle α αNZ d).

Local Notation tr := ((@f_rcpcl ℝ α αPos)).

Require Import MathClasses.interfaces.canonical_names.

Local Opaque Min.
Local Opaque Max.
Variable cd : CarDimensions ℝ.
Hypothesis nTriv : plausibleCarDim cd.
Lemma WriggleFirstQSpace :  ∀  (confineRect: Line2D IR),
  let sm:={|
       pos2D := ('tr) * {|
                   X := sin (α * d);
                   Y := (1 - cos (α * d))|} ;
          θ2D := α * d |} in
  (∀ θ : ℝ,
   (0 ≤ θ ≤ (α * d)
      → carMinMaxXYAtθ 0 cd tr θ ⊆ confineRect)
   ∧
   (α * d ≤ θ ≤ (2* α * d)
    → carMinMaxXYAtθ sm cd (-tr) θ ⊆ confineRect))
  <->
  carConfinedDuringAMs cd confineRect SWriggle init.
Proof using All.
  intros ? ?. unfold Wriggle, WriggleG.
  unfold carConfinedDuringAMs.
  (*to stop reduction*)
  match goal with
  [|- context [?h::nil]] => remember (h::nil) as hh
  end.
  simpl. subst hh.
  setoid_rewrite carConfinedDuringAMsSingle.
  simpl. unfold stateAfterAtomicMove.
  simpl. unfold confinedTurningAM. simpl.
(*  SearchAbout ((∀ a:?A, ?P a <-> ?Q a)). *)
  setoid_rewrite  conjunction_under_forall.
(*  SearchAbout ((∀ a:?A, ?P a /\ ?Q a)).  *)
  apply iff_under_forall.
  intro θ.
  match goal with
  [|- ?l ↔ _] => remember l as ll
  end.
  unfold inBetweenR. simpl in *.
  setoid_rewrite plus_0_l.
  setoid_rewrite plus_0_l.
  setoid_rewrite  reciprocalNeg with (xp:=αNZ).
  setoid_rewrite Sin_zero.
  setoid_rewrite Cos_zero.
  (*fold Zero_instance_IR.
  fold (@zero IR _).
  setoid_rewrite minus_0_r. *)
  setoid_rewrite cg_inv_zero.
  setoid_rewrite negate_mult_negate.
  setoid_rewrite leEq_imp_Min_is_lft;
    [| exact adNN
     | apply flip_le_minus_l; rewrite plus_negate_r
      ;exact adNN].
  setoid_rewrite leEq_imp_Max_is_rht;
    [| exact adNN
     | apply flip_le_minus_l; rewrite plus_negate_r
      ;exact adNN].
  fold (Le_instance_IR).
  fold (@le IR _).
  setoid_rewrite  (@commutativity _ _ _ mult _ _ tr).
  setoid_rewrite rings.RingProp3.
  setoid_rewrite  (@simple_associativity _ _ mult _ _ _).
  subst ll.
  apply and_iff_compat_lr.
  split;apply iff_under_imp;intros Hb;
  rewrite carMinMaxXYAM; try tauto;
  [apply firstQuadW1 | apply firstQuadW2]; assumption.
Qed.

Require Import MathClasses.interfaces.vectorspace.

(*
Add Ring tempRingIR : (stdlib_ring_theory IR).
*)

(** see [confineRect1] for a compact, but equivalent definition *)
Definition confineRect1Raw (θ:IR): Line2D IR
 := {|
   minxy := {|
             X := ⟨ {|
                    X := - lengthBack cd;
                    Y := tr - width cd |},
                  unitVec θ ⟩;
             Y := (⟨ {|
                     X := - tr - width cd;
                     Y := - lengthBack cd |},
                   unitVec θ ⟩) + tr |};
   maxxy := {|
           X := ⟨ {|
                  X := lengthFront cd;
                  Y := tr + width cd |},
                unitVec θ ⟩;
           Y := (⟨ {|
                   X := - tr + width cd;
                   Y := lengthFront cd |},
                 unitVec θ ⟩) + tr |} |}.

Definition confineRect2Raw (θ:IR): Line2D IR
 := ' (' tr * {| X := 2 * sin (α * d);
                  Y := 1 - 2 * cos (α * d) |}) +
     {|
     minxy := {|
               X := (⟨ {|
                       X := - lengthBack cd;
                       Y := - tr - width cd |},
                     unitVec θ ⟩);
               Y := (⟨ {|
                       X := tr - width cd;
                       Y := - lengthBack cd |},
                     unitVec θ ⟩)|};
     maxxy := {|
             X := (⟨ {|
                     X := lengthFront cd;
                     Y := - tr + width cd |},
                   unitVec θ ⟩);
             Y := (⟨ {|
                     X := tr + width cd;
                     Y := lengthFront cd |},
                   unitVec θ ⟩)|}
                   |}.

Lemma WriggleMove1FirstQSpace2 :  ∀  (confineRect: Line2D IR),
(∀ θ:IR, 0 ≤ θ ≤ α * d
 →  confineRect1Raw θ ⊆ confineRect)
  <->
  carConfinedDuringAM cd confineRect (steerAndDrive α αNZ d) init.
Proof using All.
  intros ?. unfold confineRect1Raw, confineRect2Raw.
  simpl.
  apply iff_under_forall.
  intro θ. simpl.
  remember (f_rcpcl α αPos) as trr.
  clear Heqtrr.
  unfold inBetweenR.
  rewrite plus_0_l.
  rewrite leEq_imp_Min_is_lft;
    [| exact adNN].
  rewrite leEq_imp_Max_is_rht;
    [| exact adNN].
  apply iff_under_imp. intros Hb.
  rewrite carMinMaxXYAM;
  [| assumption |apply firstQuadW1; exact Hb].
  eapply po_properL; eauto with typeclass_instances.
  rewrite <- carMinMaxXYAtθ2Same.
  unfold carMinMaxXYAtθ2.
  simpl.
  rewrite Sin_zero.
  rewrite Cos_zero.
  fold Zero_instance_IR.
  fold (@zero IR _).
  fold One_instance_IR.
  fold (@one IR _).
  rewrite preserves_0.
  unfold inprod, InProductCart2D;split; split; simpl;
    try IRring.
Qed.

Lemma WriggleFirstQSpace2 :  ∀  (confineRect: Line2D IR),
(∀ θ:IR,
(0 ≤ θ ≤ α * d
 →  confineRect1Raw θ ⊆ confineRect)
∧ (α * d ≤ θ ≤ 2 * α * d
   → confineRect2Raw θ
     ⊆ confineRect))
  <->
  carConfinedDuringAMs cd confineRect SWriggle init.
Proof using All.
  intros ?. unfold confineRect1Raw, confineRect2Raw.
  rewrite <- WriggleFirstQSpace.
  apply iff_under_forall.
  intro θ.
  remember (f_rcpcl α αPos) as trr.
  clear Heqtrr.
  apply and_iff_compat_lr.
  eapply andWeakenL.
  exact (@iff_under_imp2 _ _ _).
  apply and_comm.
  eapply andWeakenL.
  exact (@iff_under_imp2 _ _ _).
  eapply andWeakenL.
  apply po_properL; eauto with typeclass_instances.
  apply and_comm.
  eapply andWeakenL.
  apply po_properL; eauto with typeclass_instances.
  rewrite <- carMinMaxXYAtθ2Same.
  rewrite <- carMinMaxXYAtθ2Same.
  unfold carMinMaxXYAtθ2.
  simpl.
  rewrite Sin_zero.
  rewrite Cos_zero.
  fold Zero_instance_IR.
  fold (@zero IR _).
  fold One_instance_IR.
  fold (@one IR _).
  rewrite preserves_0.
  unfold inprod, InProductCart2D;split; split; split; simpl;
    try IRring.
Qed.

End FirstQuadWriggle.

(**
In the above lemma [WriggleFirstQSpace2] each of
the 8 coordinates were of the form <..,unitVec θ>.
So, it was a linear some of sine and cosine of θ.
As θ varies, it is hard to find when it achieves an extrema.
Using Cartesian to polar conversion, each of the above
coordinate can be represemnted in the form
c1*cos(θ+β)+c2, where c1 and c2 are constants,
and β is an angle in the first quadrant.
It is much easier to characterize the extremas in this
representation. For example cosine of 0 is 1, and it decreases from 0 to π.

Because cartesian to polar conversion is currently
    only defined for rational coordinates, we now
    assume that the turn radius and the car's dimensions
    are rationals.
    Eventually, they can be real-valued coordinates,
    as long as the X coordinate is constructively away from 0, or equal to 0.

In the  "constant times cosine" explained above, the value
in the representation, the angle β can for
the 4 coordinates can only take one of the following
4 values, or ½ * π -  one of these values: *)

Require Import robots.car.exampleDimensions.

Section FirstQuadWriggleQ.

(**We will typically use the maximum turn curvature α,
is based on the geometry of the car.*)
Variable α : Q.
Hypothesis αPos : ('α[#](0:IR)).

(** Unlike α and cd, [d] will be determined from a solution to an optimization problem.
The ideal value may be irrational. Being forced to use a rational value may complicate
the proofs, and may foil the idea of dealing with inaccuracies separately.
Making it a real number should not break proofs. This value is not needed in polar
conversion. *)
Variable d : Q.

Variable cd : CarDimensions Q.
Hypothesis ntriv : nonTrivialCarDim (cd).
Hypothesis firstQuadW: (0:IR) ≤ (2*'α*'d) ≤ ½ * π.
Let tr :Q := Qinv α.

Let αNZ := αPos.

Local Definition trComplicated : 'tr = f_rcpcl ('α) αNZ.
Proof using αPos.
  apply QinvIRinv1.
Qed.

Require Import CartIR2.

Let βMinusBack : Cart2D Q := βMinusBack cd tr.
Let βMinusFront : Cart2D Q := βMinusFront cd tr.
Let βPlusBack : Cart2D Q := βPlusBack cd tr.
Let βPlusFront : Cart2D Q := βPlusFront cd tr.

Local Notation init  := (0:Rigid2DState IR).
Local Notation SWriggle := (Wriggle ('α) αNZ ('d)).

Local Definition trr :IR := 'tr.

Definition constW1 := {|X := 0; Y := trr|}.

Definition constW2 := (' trr * {| X := 2 * Sin ('α * 'd);
                  Y := 1 - 2 * Cos ('α * 'd) |}).

Definition confineRect1 (θ:IR): Line2D IR
 := 'constW1 +
 {|
     minxy :=  decodeAsCosXY (minXYPos cd tr) θ;
     maxxy := decodeAsCosXY (maxXYPos cd tr) θ  |}.

Definition confineRect2 (θ:IR): Line2D IR
 := 'constW2 +
 {|
     minxy :=  decodeAsCosXY (minXYNeg cd tr) θ ;
     maxxy := decodeAsCosXY (maxXYNeg cd tr)  θ|}.

Lemma confineRectCorrect: ∀ θ:IR,
confineRect1 θ = confineRect1Raw ('α) αPos ('cd) θ
/\ confineRect2 θ = confineRect2Raw ('α) αPos ('d) ('cd) θ.
Proof using.
  intro.
  unfold confineRect1, confineRect2, confineRect1Raw, confineRect2Raw.
  unfold decodeAsCosXY, decodeAsCos. simpl.
  fold CosClassIR SinClassIR.
  fold (@cos IR _) (@sin IR _).
  do 4 (rewrite <- unitVDot).
  do 4 (rewrite <- unitVDot2).
  do 8 (rewrite multDotRight).
  pose proof CartToPolarCorrect90Minus as Hr.
  unfold norm, NormCart2DQ in Hr.
  do 4 (rewrite <- Hr). clear Hr.
  pose proof CartToPolarCorrect as Hr.
  unfold norm, NormCart2DQ in Hr.
  do 4 (rewrite <- Hr). clear Hr.
  replace (@cast _ _ (@castCart Q IR _)) with (@castCart Q IR _);[| reflexivity].
  unfold castCart. simpl.
  pose proof  (@preserves_plus _ _ _ _ _ _ _ _ _ _ _ _
   (cast Q IR) _ tr) as Hh.
   unfold transpose.
   simpl.
  repeat rewrite Hh.
  rewrite  preserves_negate.
  fold αNZ.
  repeat rewrite <- trComplicated.
  fold trr.
   unfold inprod, InProductCart2D;split; split; split; simpl;
    try IRring.
Qed.

(** Now lets consider all 4 sides one by one. They are
too different to handle simulaneously *)

Definition isBoundLeftWriggle1 (minx: IR) :=
forall θ:IR,
(0 ≤ θ ≤ 'α * 'd
 → minx ≤ X (minxy (confineRect1 θ))).

Definition isBoundLeftWriggle2 (minx: IR) :=
forall θ:IR,
('α * 'd ≤ θ ≤ 2 * 'α * 'd
   → minx ≤ X (minxy (confineRect2 θ))).

Definition isBoundLeftWriggle (minx: IR) :=
isBoundLeftWriggle1 minx
∧ isBoundLeftWriggle2 minx.

(** The turn center cannot be inside the car. for that,
one of the front wheels have to rotate by more than 90 along
the vertical axis.
*)
Hypothesis turnCentreOut : (Qle (width cd) tr).

(** TODO: reuse *)
Lemma firstQuadβMinusBack:
 (0:IR) ≤ ' polarTheta βMinusBack ≤  (½ * π).
Proof using ntriv turnCentreOut.
  apply firstQuadβMinusBack; auto.
Qed.

Lemma firstQuadβPlusFront:
 (0:IR) ≤ ' polarTheta βPlusFront ≤  (½ * π).
Proof using ntriv turnCentreOut.
  apply firstQuadβPlusFront; auto.
Qed.

Lemma firstQuadβPlusBack:
 (0:IR) ≤ ' polarTheta βPlusBack ≤  (½ * π).
Proof using ntriv turnCentreOut.
  apply firstQuadβPlusBack; auto.
Qed.

Lemma firstQuadβMinusFront:
 (0:IR) ≤ ' polarTheta βMinusFront ≤  (½ * π).
Proof using ntriv turnCentreOut.
  apply firstQuadβMinusFront; auto.
Qed.

Lemma βPlusBackLt90:
 ' polarTheta βPlusBack [<]  (½ * π).
Proof using ntriv turnCentreOut.
Abort.

Require Import MathClasses.orders.semirings.
Require Import MCMisc.rings.
(**During the first of the 2 atomic moves of Wriggle,
  the car's leftmost point shifts right. Hence, the
  leftmost position of the leftmost point of the car
  occurs at the starting position. So we can ignore the
  rest of the move while analyzing the extra space needed
  on the left side.*)
Lemma confineRect1LeftMonotoneRight (minx β: IR) :
minx ≤ X (minxy (confineRect1 β))
→ 0 ≤ β ≤  (½ * π)
→ (forall θ:IR,
    β ≤ θ ≤  (½ * π) (* 'α * 'd *)
     → minx ≤ X (minxy (confineRect1 θ))).
Proof using firstQuadW ntriv turnCentreOut.
  simpl.
  setoid_rewrite plus_0_l.
  intros Hh Hbb ? Hb.
  apply flip_le_negate.
  rewrite negate_involutive.
  apply flip_le_negate in Hh.
  rewrite negate_involutive in Hh.
  eapply transitivity;[| apply Hh].
  apply (@order_preserving _ _ _ _ _ _ _);
    [apply OrderPreserving_instance_0;
     apply Cart2DRadNNegIR |].
(*   apply firstQuadW1 in Hb; trivial ;[]. *)
  apply Cos_resp_leEq.
  - apply plus_resp_nonneg;[tauto|].
    apply firstQuadβMinusBack.
  - rewrite (divideBy2 Pi).
    apply plus_le_compat;[tauto| apply firstQuadβMinusBack].
  - apply plus_le_compat;[tauto| reflexivity].
Qed.

Require Import CartIR.
Require Import IRTrig.
Require Import CoRNMisc.

(** The second move is much more difficult to analyse
w.r.t the leftmost point. The leftmost position
of the leftmost point of the car can be at:

1) beginning of the move : if the car's rear plane is far away from the line joining the rear wheels (i.e. [lengthBack] is large), e.g. when a large
rigid trailer is attached to the back of the car.

2) somewhere in the middle of the move

3) at the end of the move, assuming usual dimensions of
a car with no rear attachments.

It turns that the earlier hypothesis that the car needs
to turn by atmost 90 degrees while coming out of the parallel
parking was too conservative. Pictorial inuition seems
to suggest that the car need not turn by more than
[polarTheta βPlusFront]. See [maxTurnNeededConjecture] below.

onenote:https://d.docs.live.net/946e75b47b19a3b5/Documents/PhD6/ParallelParking.one#...into%203=%20to%20two&section-id={13BDE595-ACF2-4791-AAFC-6284FF953450}&page-id={670C8178-E541-483C-91A7-35F29052CCF3}&end

This is because because from that angle to 90 degrees,
the car's space requirement along the left, right and
bottom sides seem to decrease.

If so, assuming
that [lengthBack ≤ lengthFront] implies that
the 3rd case will always hold.
 *)

Definition isMaxTurnNeeded (θmax : IR) :=
∀ (minx maxx miny: IR),
(minx ≤ X (minxy (confineRect1 θmax))
/\ miny ≤ Y (minxy (confineRect1 θmax))
/\ X (maxxy (confineRect1 θmax)) ≤ maxx
)
→ (∀ θ:IR,
    θmax ≤ θ ≤ ½ * π
     →
    (minx ≤ X (minxy (confineRect1 θ))
    /\ miny ≤ Y (minxy (confineRect1 θ))
    /\ X (maxxy (confineRect1 θ)) ≤ maxx
    )
     ).

Local Opaque confineRect1.
Definition extraHyp1 : Prop :=
((½ * π ) ≤ (' polarTheta βPlusFront + ' polarTheta βPlusBack)).
Lemma maxTurnNeededConjecture (minx maxx miny: IR) :
extraHyp1
→
isMaxTurnNeeded ('polarTheta βPlusFront).
Proof using firstQuadW ntriv turnCentreOut.
  intro Has. unfold extraHyp1 in Has. simpl.
  intros ? ? ? H ? Hb.
  split;[| split].
  - eapply confineRect1LeftMonotoneRight;
      [ | | apply Hb];[tauto | ].
    apply firstQuadβPlusFront.
  - apply proj2 in H. apply proj1 in H.
    revert H.
Local Transparent confineRect1.
    unfold confineRect1. simpl.
    rewrite <- (negate_swap_r _ (½ * π )).
    rewrite (@simple_associativity _ _ plus _ _ ).
    rewrite (@simple_associativity _ _ plus _ _ ).
    rewrite CosMinusSwap.
    setoid_rewrite CosMinusSwap at 2.
    rewrite PiBy2DesugarIR.
    setoid_rewrite Cos_HalfPi_minus.
    intros Hh.
    eapply transitivity;[apply Hh|].
    apply (@order_preserving _ _ _ _ _ _ _ _).
    apply flip_le_negate.
    apply (@order_preserving _ _ _ _ _ _ _);
    [apply OrderPreserving_instance_0;
      apply Cart2DRadNNegIR |].
    clear Hh.
    rewrite <- Pi_minus_Sin.
    setoid_rewrite <- Pi_minus_Sin at 2.
    apply Sin_resp_leEq.
    + eapply transitivity;[apply MinusPiBy2Le0|].
      apply flip_le_minus_l.
      rewrite negate_involutive.
      setoid_rewrite plus_0_l.
      rewrite (divideBy2 Pi).
      apply plus_le_compat; [tauto| apply
        firstQuadβPlusBack].
    + apply flip_le_minus_l.
      rewrite commutativity.
      apply flip_le_minus_l.
      eapply transitivity;[| apply Has].
      apply eq_le.
      rewrite (divideBy2 π) at 1.
      rewrite PiBy2DesugarIR.
      IRring.
    + apply (@order_preserving _ _ _ _ _ _ _ _).
      apply flip_le_negate.
      rewrite commutativity.
      setoid_rewrite commutativity at 2.
      apply (@order_preserving _ _ _ _ _ _ _ _).
      tauto.
  - apply proj2 in H. apply proj2 in H.
    revert H.
    unfold confineRect1. simpl.
    rewrite plus_0_l.
    rewrite plus_0_l.
    intros Hh.
    eapply transitivity;[|apply Hh].
    apply (@order_preserving _ _ _ _ _ _ _);
      [apply OrderPreserving_instance_0;
       apply Cart2DRadNNegIR |].
    clear Hh. unfold βPlusFront.
    rewrite plus_negate_r.
    rewrite Cos_zero. apply Cos_leEq_One.
Qed.

(** intuitively, it says that while turning left
at min radius, the rightmost position of the rightmost
point of the car is achieved after the bottommost
position of the bottommost point of the car is achieved.*)
Lemma extraHyp1If :
((lengthBack cd)/(tr + width cd)≤(tr + width cd)/(lengthFront cd))%Q
-> extraHyp1.
Abort.

(**This is definitely true for the geometry of Mazda 3 sedan*)

Definition thisCarHasSameGeometryAs (cg : CarGeometry Q) :=
  cd ≡ carDim cg /\ tr ≡ minTR cg.

Lemma Mazda3Hyp1True :
thisCarHasSameGeometryAs ('Mazda3Sedan2014sGT)
-> extraHyp1.
Proof using Type*.
  intro H.
  unfold extraHyp1.
  rewrite <- PiBy2IRCR.
  unfold cast, Cart_CR_IR.
  setoid_rewrite <- CR_plus_asIR.
  apply CR_leEq_as_IR.
  unfold βPlusFront, βPlusBack.
  destruct H as [Hl Hr].
  subst.
  rewrite Hr. clear Hr.
  apply CRweakenLt.
  unfold lt, CRlt. exists 1%nat.
  simpl. vm_compute. reflexivity.
Qed.

(** In fact, it is true by a large margin; Not only is it greater than
half pi, it is also greater than quarter 72/100 Pi.
On the other hand, it is less than  75/100 Pi.
*)
Lemma Mazda3Hyp1TrueByLargeMargin :
thisCarHasSameGeometryAs ('Mazda3Sedan2014sGT)
-> (('(Qmake 72 100) * π ) < ( polarTheta βPlusFront +  polarTheta βPlusBack)).
Proof using Type*.
  intro H. destruct H as [Hl Hr].
  unfold βPlusFront, βPlusBack.
  subst.
  rewrite Hr. clear Hr.
  unfold lt, CRlt. exists 4%nat.
  simpl. vm_compute. reflexivity.
Qed.

(** this version may not need any additional hypothesis,
  but it may not be strong enough for the remaining proofs. *)
Lemma conjecture2 :
isMaxTurnNeeded (Max ('polarTheta βPlusFront)
((½ * π ) - 'polarTheta βPlusBack)).
Abort.

(** Note that [lengthFront] and [lengthBack]
    are measured w.r.t the line joining the 2 rear wheels.
    This is a reasonable assumption for a car without
    any rear attachments. *)
Hypothesis lengthFrontGreater:
  (lengthBack cd <= lengthFront cd)%Q.

(** This is a direct consequence of the above hypothesis
  [lengthFrontGreater] *)
Lemma FrontLeBack :
  (' polarTheta βPlusFront) ≤ (' polarTheta βPlusBack).
Proof using firstQuadW lengthFrontGreater ntriv turnCentreOut.

  unfold cast, Cart_CR_IR.
  apply CR_leEq_as_IR.
  unfold nonTrivialCarDim in ntriv.
  apply polarFirstQuadIncreasing; simpl;
  autounfold with QMC; [tauto| tauto|].
  autounfold with QMC in ntriv.
  apply Q.Qmult_le_compat_l;[| lra].
  apply  Q.Qdiv_flip_le; lra.
Qed.

Lemma βPlusMinusBack :
'(polarTheta βMinusBack) [<] cast CR IR (polarTheta βPlusBack).
Proof using firstQuadW ntriv.
  unfold cast, Cart_CR_IR.
  apply CRasIRless.
  unfold nonTrivialCarDim in ntriv.
  apply polarFirstQuadIncreasingStrict; simpl;
  autounfold with QMC; [tauto| tauto|].
  autounfold with QMC in ntriv.
  apply Qmult_lt_r;[| lra].
  apply Qinv_lt_0_compat; lra.
Qed.

(*exact same proof as [βPlusMinusBack] above.*)
Lemma βPlusMinusFront :
'(polarTheta βMinusFront) [<] cast CR IR (polarTheta βPlusFront).
Proof using firstQuadW ntriv.
  unfold cast, Cart_CR_IR.
  apply CRasIRless.
  unfold nonTrivialCarDim in ntriv.
  apply polarFirstQuadIncreasingStrict; simpl;
  autounfold with QMC; [tauto| tauto|].
  autounfold with QMC in ntriv.
  apply Qmult_lt_r;[| lra].
  apply Qinv_lt_0_compat; lra.
Qed.

Definition leftBoundWriggle1 : IR :=
  (X (minxy (confineRect1 0))).
Definition leftBoundWriggle2 : IR :=
  (X (minxy (confineRect2 (2 * 'α * 'd)))).

Definition leftBound : IR :=
(min leftBoundWriggle1 leftBoundWriggle2).

Lemma dNN : 0 ≤ ' α * ' d.
Proof using firstQuadW.
  apply adNN. assumption.
Qed.

(** derive [firstQuadW] from this.*)
Hypothesis maxNeededTurn
  : (0 : ℝ) ≤ 2 * ' α * ' d ≤ (' polarTheta βPlusFront).

Lemma leftBoundWriggle1Correct:
isBoundLeftWriggle1 leftBoundWriggle1.
Proof using firstQuadW ntriv turnCentreOut αPos.
  pose proof dNN.
  intros θ Hb. unfold leftBoundWriggle1.
  eapply confineRect1LeftMonotoneRight;
      [reflexivity| |eapply firstQuadW1; eauto].
  split;[reflexivity|].
  rewrite PiBy2DesugarIR. apply PiBy2Ge0.
Qed.

Lemma leftBoundWriggle2Correct:
isBoundLeftWriggle2 leftBoundWriggle2.
Proof using firstQuadW lengthFrontGreater maxNeededTurn ntriv
      turnCentreOut αPos.
  pose proof dNN as Hdnn.
  intros θ Hb. unfold leftBoundWriggle2.
  simpl.
  apply (@order_preserving _ _ _ _ _ _ _ _).
  apply flip_le_negate.
  apply (@order_preserving _ _ _ _ _ _ _);
      [apply OrderPreserving_instance_0;
       apply Cart2DRadNNegIR |].
  rewrite CosMinusSwap.
  setoid_rewrite CosMinusSwap at 2.
  apply Cos_resp_leEq.
  - apply flip_le_minus_l.
    rewrite negate_involutive.
    setoid_rewrite plus_0_l.
    eapply transitivity;[|
      apply FrontLeBack].
    apply maxNeededTurn.

  - rewrite (divideBy2 Pi).
    apply plus_le_compat;
        [apply firstQuadβPlusBack|].
    rewrite PiBy2DesugarIR.
    apply flip_le_negate.
    rewrite negate_involutive.
    eapply transitivity;[
        apply MinusPiBy2Le0|].
        destruct Hb.
    eapply transitivity;[|apply H].
    apply dNN; eauto.

  - apply (@order_preserving _ _ _ _ _ _ _ _).
    apply flip_le_negate.
    tauto.
Qed.

Lemma leftBoundCorrect:
isBoundLeftWriggle leftBound.
Proof using firstQuadW lengthFrontGreater maxNeededTurn
      ntriv turnCentreOut αNZ.
  unfold leftBound.
  split; intros θ H.
  - eapply transitivity;[apply Min_leEq_lft|].
    apply leftBoundWriggle1Correct. assumption.
  - eapply transitivity;[apply Min_leEq_rht|].
    apply leftBoundWriggle2Correct. assumption.
Qed.

Require Import geometry2D.

Definition isBoundRightWriggle1 (maxx: IR) :=
forall θ:IR,
(0 ≤ θ ≤ 'α * 'd
 → X (maxxy (confineRect1 θ)) ≤ maxx).

Definition isBoundRightWriggle2 (maxx: IR) :=
forall θ:IR,
 ('α * 'd ≤ θ ≤ 2 * 'α * 'd
   →  X (maxxy (confineRect2 θ)) ≤ maxx).

Definition isBoundRight (maxx: IR) :=
isBoundRightWriggle1 maxx /\ isBoundRightWriggle2 maxx.
(** As shown below in [rightBoundCorrect],
The extrema is achieved at the end of the first move. *)

Definition rightBound : IR :=
  (X (maxxy (confineRect1 ('α * 'd)))).

(*the equations for the the motion of the front RHS
corner of the car for the 1st and the 2nd move must agree
at the transition time.*)
Lemma transitionMaxX :
trr * (2 * Sin (' α * ' d)) +
' (| βMinusFront |)
* Cos (' α * ' d + ' polarTheta βMinusFront)
= ' (| βPlusFront |) *
Cos (' α * ' d - ' polarTheta βPlusFront).
Proof using.
  fold CosClassIR.
  fold (@cos IR _).
  fold SinClassIR.
  fold (@sin IR _).
  rewrite <- unitVDot.
  rewrite <- unitVDot2.
  do 2 rewrite multDotRight.
  pose proof CartToPolarCorrect as H.
  simpl in H. unfold norm, NormCart2DQ in H.
  rewrite <- H.
  rewrite <- H.
  unfold inprod, InProductCart2D.
  simpl.
  (* the above part was copied from [LeftBoundEqSimpl]*)
  unfold trr.
  rewrite preserves_minus.
  rewrite preserves_plus.
  IRring.
Qed.

(**actually only half of [maxNeededTurn] is needed.
*)
Lemma rightBoundWriggle1Correct
  : isBoundRightWriggle1 rightBound.
Proof using firstQuadW maxNeededTurn ntriv turnCentreOut.
  unfold  rightBound.
  intros ? Hb. simpl.
  do 2 rewrite plus_0_l.
  apply (@order_preserving _ _ _ _ _ _ _);
      [apply OrderPreserving_instance_0;
       apply Cart2DRadNNegIR |].
  rewrite CosMinusSwap.
  setoid_rewrite CosMinusSwap at 2.
  apply Cos_resp_leEq.
  - apply flip_le_minus_l.
    rewrite negate_involutive.
    setoid_rewrite plus_0_l.
    eapply transitivity;[|
      apply maxNeededTurn].
    rewrite <- (@simple_associativity _ _ plus _ _).
    apply rings.RingLeProp2.
    destruct Hb. eapply transitivity; eauto.
  - rewrite (divideBy2 Pi).
    apply plus_le_compat;
      [apply firstQuadβPlusFront|].
    rewrite PiBy2DesugarIR.
    apply flip_le_negate.
    rewrite negate_involutive.
    eapply transitivity;[
      apply MinusPiBy2Le0|].
    apply Hb.
  - apply (@order_preserving _ _ _ _ _ _ _ _).
    apply flip_le_negate.
    tauto.
Qed.

Lemma rightBoundWriggle2Correct
  : isBoundRightWriggle2 rightBound.
Proof using firstQuadW maxNeededTurn ntriv turnCentreOut αPos.
  unfold  rightBound.
  intros ? Hb. simpl.
  rewrite plus_0_l. fold βMinusFront βPlusFront.
  rewrite <- transitionMaxX.
  apply (@order_preserving _ _ _ _ _ _ _ _).
  apply (@order_preserving _ _ _ _ _ _ _);
      [apply OrderPreserving_instance_0;
       apply Cart2DRadNNegIR |].
  apply Cos_resp_leEq.
  - apply plus_resp_nonneg;[|apply firstQuadβMinusFront].
    apply dNN; auto.
  - rewrite (divideBy2 Pi).
    apply plus_le_compat;[|apply firstQuadβMinusFront].
    eapply transitivity;[apply Hb|]. tauto.
  - apply plus_le_compat;[tauto| reflexivity].
Qed.

Lemma rightBoundCorrect
  : isBoundRight rightBound.
Proof using  firstQuadW maxNeededTurn ntriv turnCentreOut αPos.
  split;[apply rightBoundWriggle1Correct |apply rightBoundWriggle2Correct].
Qed.

Definition isBoundBottomWriggle1 (miny: IR) :=
forall θ:IR,
(0 ≤ θ ≤ 'α * 'd
 → miny ≤ Y (minxy (confineRect1 θ))).

Definition isBoundBottomWriggle2 (miny: IR) :=
forall θ:IR,
('α * 'd ≤ θ ≤ 2 * 'α * 'd
   → miny ≤ Y (minxy (confineRect2 θ))).

Definition isBoundBottom (miny: IR) :=
isBoundBottomWriggle1 miny ∧ isBoundBottomWriggle2 miny.

Definition bottomBoundWriggle2 :IR :=
(Y (minxy (confineRect2 (2 * 'α * 'd)))).

Let adNN := adNN ('α)  ('d) firstQuadW.
Lemma bottomBoundWriggle2Correct :
  isBoundBottomWriggle2 bottomBoundWriggle2.
Proof using  firstQuadW ntriv turnCentreOut αPos.
  unfold bottomBoundWriggle2.
  intro. simpl.
  intro Hb.
  pose proof (firstQuadW2 _ αPos _ firstQuadW _  Hb)
    as Ht.
  apply (@order_preserving _ _ _ _ _ _ _ _).
    apply (@order_preserving _ _ _ _ _ _ _);
      [apply OrderPreserving_instance_0;
       apply Cart2DRadNNegIR |].
  apply Cos_resp_leEq.
  - apply plus_resp_nonneg;[apply Ht|].
    apply flip_le_minus_r.
    setoid_rewrite plus_0_l.
    apply firstQuadβMinusBack.
  - rewrite (divideBy2 Pi).
    apply plus_le_compat;
      [apply firstQuadW|].
    apply nonneg_minus_compat;[| reflexivity].
    apply firstQuadβMinusBack.
  - apply plus_le_compat;
      [apply Hb| reflexivity]; fail.
Qed.

Require Import MathClasses.interfaces.additional_operations.

Definition minYCriticalAngle : IR
  := (½ * π - ' polarTheta βPlusBack).

Section MinYCases.

(*
Hypothesis case2 : minYCriticalAngle [<] 'α * 'd.

Let increase1 := Y (minxy (confineRect1 ('α * 'd))) -
(Y (minxy (confineRect1 minYCriticalAngle))).

Let decrease2 :=
Y (minxy (confineRect2 ( 'α * 'd))) -
(Y (minxy (confineRect2 (2* 'α * 'd)))).

Section MCring.

  Add Ring tempRingIR : (stdlib_ring_theory IR).

Lemma Increase1LeDecrease:
  increase1 ≤ decrease2.
Proof.
  subst increase1 decrease2.
  rewrite (proj1 (confineRectCorrect _)).
  rewrite (proj2 (confineRectCorrect _)).
  rewrite (proj2 (confineRectCorrect _)).
  simpl. fold αNZ.
  rewrite <-trComplicated.
  replace (½ * π - ' polarTheta βPlusBack) with
    minYCriticalAngle;[| reflexivity].
  rewrite plus_negate_r.
  rewrite Cos_zero.
  setoid_rewrite mult_1_r.
  simpl.
  rewrite <- (@simple_associativity _ _ mult _ _ _ _).
  rewrite unitVDoubleAsCos.
  rewrite nat_pow.nat_pow_2.
  unfold inprod, InProductCart2D. simpl.
  fold trr.
  match goal with
  [|- ?l ≤ _] =>
  ring_simplify l
  end.
  ring_simplify (trr * (1 - 2 * cos (' α * ' d)) +
  ((trr - ' width cd) * cos (' α * ' d) + - ' lengthBack cd * sin (' α * ' d))).
  setoid_rewrite (@commutativity _ _ _ plus _ _) at 10.
  rewrite <- flip_le_minus_l.
  match goal with
  [|- ?l ≤ _] =>
  ring_simplify l
  end.
  rewrite  negate_swap_l.
  apply flip_le_negate.
  rewrite plus_mult_distr_l.
  rewrite mult_1_r.
  rewrite <- (@simple_associativity _ _ plus _ _).
  apply (@order_preserving _ _ _ _ _ _ _ _ _).
  apply flip_le_negate.
  rewrite negate_involutive.
  rewrite <- negate_mult_distr_r.
  rewrite  negate_plus_distr.
  rewrite negate_involutive.
  rewrite <- negate_mult_distr_l.
  rewrite <- negate_swap_l.
  rewrite negate_mult_distr_r.
  rewrite <- negate_swap_r.
  rewrite plus_mult_distr_l.
  rewrite mult_1_r.
  rewrite commutativity.
  remember (cos (' α * ' d)) as c.
  remember (sin (' α * ' d)) as s.
  match goal with
  [|- _ ≤ ?l] =>
    assert (l= trr - ' width cd
    + 2*c*(trr - ((trr - ' width cd)*c - ( ' lengthBack cd)*s))
    ) as H by ring
  end.
  rewrite H. clear H.
  subst c s.
  assert (
  ((trr - ' width cd) * cos (' α * ' d) - ' lengthBack cd * sin (' α * ' d))
  =
   ⟨ {|X:=1;Y:=-1|} *  transpose ('βMinusBack) , unitVec (' α * ' d)⟩
  ) as H by
  (unfold inprod, InProductCart2D; simpl;
  rewrite preserves_minus; fold trr; ring).
  rewrite H.
  rewrite CartToPolarCorrect90Minus.
  rewrite (@commutativity _ _ _ (@mult (@Cart2D IR) _) _ _).
  rewrite <- (@simple_associativity _ _  (@mult (@Cart2D IR) _) _ _).
  rewrite <- multDotLeft.
  rewrite (@commutativity _ _ _ (@mult (@Cart2D IR) _) _ _).
  rewrite  unitVDot2.
  (*further simplification may lead to a characterization of
  the [min] in [bottomBoundCase2] below.
  however, this seems too complicated.
  *)
Abort.

End  MCring.

*)

Definition bottomBoundWriggle1Case1 :IR :=
(Y (minxy (confineRect1 ('α * 'd)))).

Lemma bottomBoundWriggle1Case1Correct :
('α * 'd ≤ minYCriticalAngle)
-> isBoundBottomWriggle1 bottomBoundWriggle1Case1.
Proof using  firstQuadW ntriv turnCentreOut αPos.
  simpl. intros Hu ?. simpl.
  intro Hb.
  pose proof (firstQuadW1 _ αPos _ firstQuadW _  Hb)
    as Ht.
  unfold bottomBoundWriggle1Case1. simpl.
  apply (@order_preserving _ _ _ _ _ _ _ _).
  apply flip_le_negate.
    apply (@order_preserving _ _ _ _ _ _ _);
      [apply OrderPreserving_instance_0;
       apply Cart2DRadNNegIR |].
  rewrite CosMinusSwap.
  setoid_rewrite CosMinusSwap at 2.
  apply Cos_resp_leEq.
  - apply flip_le_minus_r.
    setoid_rewrite plus_0_l.
    apply Hu.
  - rewrite (divideBy2 Pi).
    apply plus_le_compat;[|].
    + apply nonneg_minus_compat;[|reflexivity].
      apply firstQuadβPlusBack.
    + rewrite PiBy2DesugarIR.
      eapply transitivity;[|apply PiBy2Ge0].
      apply flip_le_negate.
      rewrite negate_involutive.
      setoid_rewrite negate_0.
      apply Ht.
  - apply plus_le_compat;
      [reflexivity|].
    apply flip_le_negate.
    apply Hb.
Qed.

Definition bottomBoundWriggle1Case2 :IR :=
(Y (minxy (confineRect1 minYCriticalAngle))).

Lemma bottomBoundWriggle1Case2Correct:
(minYCriticalAngle ≤ 'α * 'd )
-> isBoundBottomWriggle1 bottomBoundWriggle1Case2.
Proof using firstQuadW αPos.
  simpl. intros Hu ?. unfold bottomBoundWriggle1Case2.
  simpl.
  intro Hb.
  unfold minYCriticalAngle. unfold βPlusBack.
  rewrite plus_negate_r.
  rewrite Cos_zero.
  pose proof (firstQuadW1 _ αPos _ firstQuadW _  Hb)
    as Ht.
  apply (@order_preserving _ _ _ _ _ _ _ _).
  apply flip_le_negate.
    apply (@order_preserving _ _ _ _ _ _ _);
      [apply OrderPreserving_instance_0;
       apply Cart2DRadNNegIR |].
  apply Cos_leEq_One.
Qed.

Definition bottomBoundCase1 : IR :=
  bottomBoundWriggle2.

Definition bottomBoundCase2 : IR :=
  min
    bottomBoundWriggle1Case2
    bottomBoundCase1.

(*the equations for the the motion of the car for the 1st and the 2nd move must agree
at the transition time.*)
Lemma transitionMinY :
Y (minxy (confineRect2 (' α * ' d)))
= Y (minxy (confineRect1 (' α * ' d))).
Proof using αPos.
  rewrite  (proj2 (confineRectCorrect _)).
  rewrite  (proj1 (confineRectCorrect _)).
  simpl. fold αNZ.
  rewrite <- trComplicated.
  unfold inprod, InProductCart2D.
  simpl.
  IRring.
Qed.

Lemma bottomBoundCase1Correct :
('α * 'd ≤ minYCriticalAngle)
-> isBoundBottom bottomBoundCase1.
Proof using firstQuadW ntriv turnCentreOut αPos.
  intros Hu.
  split; intro.
- intros Hb. eapply transitivity;
    [|apply bottomBoundWriggle1Case1Correct; trivial; fail].
  unfold bottomBoundCase1.
  rewrite <- transitionMinY.
  apply bottomBoundWriggle2Correct.
  split;[reflexivity|].
  rewrite <- (@simple_associativity _ _ mult _ _ _).
  apply rings.RingLeProp2.
  destruct Hb. eapply transitivity; eauto.
- intros Hb.
  apply bottomBoundWriggle2Correct. auto.
Qed.

Lemma bottomBoundCase2Correct :
(minYCriticalAngle ≤ 'α * 'd)
-> isBoundBottom bottomBoundCase2.
Proof using firstQuadW ntriv turnCentreOut αPos.
  intros Hu.
  split; intro.
- intros Hb. eapply transitivity;
    [apply Min_leEq_lft|].
  apply bottomBoundWriggle1Case2Correct; trivial.
- intros Hb.
  eapply transitivity;
    [apply Min_leEq_rht|].
  apply bottomBoundWriggle2Correct; auto.
Qed.

End  MinYCases.

(** Even though the extra space needed in the upward direction
 is not at all a concern, some bound, possibly very sloppy,
  is needed because most lemmas
 about space analysis of a sequence of moves are in terms of bounds
 in all 4 directions. *)
Definition isBoundUpWriggle1 (maxy: IR) :=
forall θ:IR,
(0 ≤ θ ≤ 'α * 'd
 → Y (maxxy (confineRect1 θ)) ≤ maxy).

Definition isBoundUpWriggle2 (maxy: IR) :=
forall θ:IR,
 ('α * 'd ≤ θ ≤ 2 * 'α * 'd
   →  Y (maxxy (confineRect2 θ)) ≤ maxy).

Definition isBoundUp (maxy: IR) :=
isBoundUpWriggle1 maxy /\ isBoundUpWriggle2 maxy.

Definition upBoundWriggle1 : IR :=
Y (maxxy (confineRect1 ('α * 'd))).

Lemma upBoundWriggle1Correct
  : isBoundUpWriggle1 upBoundWriggle1.
Proof using  firstQuadW maxNeededTurn ntriv turnCentreOut αPos.
  pose proof dNN as Hdnn.
  intros ? Hb. unfold upBoundWriggle1. simpl.
  apply (@order_preserving _ _ _ _ _ _ _ _).
  apply flip_le_negate.
  apply (@order_preserving _ _ _ _ _ _ _);
      [apply OrderPreserving_instance_0;
       apply Cart2DRadNNegIR |].
  apply Cos_resp_leEq.
  - apply nonneg_plus_compat; unfold PropHolds;
      [ eapply firstQuadW1; eauto|].
    apply flip_le_minus_l.
    rewrite negate_involutive.
    setoid_rewrite plus_0_l.
    apply firstQuadβMinusFront.
  - rewrite (divideBy2 Pi).
    apply plus_le_compat;
      [ apply adPiBy2; assumption|].
    apply flip_le_minus_l.
    rewrite (@commutativity _ _ _ plus _ _).
    apply RingLeProp1.
    apply firstQuadβMinusFront.
  - apply plus_le_compat; unfold PropHolds;
      [| reflexivity].
    tauto.
Qed.

(**perhaps a sloppy bound, but as mentioned above, the extra space
used at the upward side is not a concern at all.
It appears that in some cases, this bound is tight, and the
highest point of the circle is achieved.
*)
Definition upBoundWriggle2 : IR :=
(trr * (1 - 2 * Cos (' α * ' d)) +' (| βPlusFront |)).

Lemma upBoundWriggle2Correct
  : isBoundUpWriggle2 upBoundWriggle2.
Proof using.
  intros ? Hb. unfold upBoundWriggle2. simpl.
  apply (@order_preserving _ _ _ _ _ _ _ _).
  unfold βPlusFront.
  setoid_rewrite <- (mult_1_r (' (| ackermannSteering.βPlusFront cd tr|))) at 3.
  apply (@order_preserving _ _ _ _ _ _ _);
      [apply OrderPreserving_instance_0;
       apply Cart2DRadNNegIR |].
  apply Cos_leEq_One.
Qed.

(**perhaps a sloppy bound, but as mentioned above, the extra space
used at the upward side is not a concern at all. *)
Definition upBound  :IR :=
max upBoundWriggle1 upBoundWriggle2.

Lemma upBoundCorrect
  : isBoundUp upBound.
Proof using  firstQuadW maxNeededTurn ntriv turnCentreOut αPos.
  unfold upBound.
  split; intros θ H.
  - eapply transitivity;[|apply lft_leEq_Max].
    apply upBoundWriggle1Correct. assumption.
  - eapply transitivity;[|apply rht_leEq_Max].
    apply upBoundWriggle2Correct. assumption.
Qed.

(** the 2 definitions below, and the corresponding correctness lemmas
summarize the proofs so far in this section. *)
Definition WriggleMove1SpaceFirstQ (bottomBound : IR): ConfineRect IR :=
{| minxy := {| X := leftBoundWriggle1 ; Y:= bottomBound |};
  maxxy := {| X := rightBound ; Y:= upBoundWriggle1 |}
|}.

Definition WriggleSpaceFirstQ (bottomBound : IR): Line2D IR :=
{| minxy := {| X := leftBound ; Y:= bottomBound|};
  maxxy := {| X := rightBound ; Y:= upBound |}
|}.

  Local Opaque confineRect1.
  Local Opaque confineRect2.

Lemma WriggleMove1SpaceFirstQCase1Correct :
('α * 'd ≤ minYCriticalAngle)
→ carConfinedDuringAM ('cd)
    (WriggleMove1SpaceFirstQ bottomBoundWriggle1Case1)
    (steerAndDrive ('α) αNZ ('d))
    (0 : Rigid2DState ℝ).
Proof using  firstQuadW maxNeededTurn ntriv turnCentreOut αPos.
  pose proof dNN as Hdnn.
  pose proof ntriv as plaus.
  apply nonTrivialCarDimPlausible in plaus.
  intro Hcase1. simpl.
  apply WriggleMove1FirstQSpace2; auto.
  intro. unfold αNZ.
  rewrite <- (proj1 (confineRectCorrect _)).
  intro Hb; split; split; simpl; revert Hb; revert θ;
  try apply leftBoundWriggle1Correct;
  try apply rightBoundWriggle1Correct;
  try apply upBoundWriggle1Correct;
  try apply bottomBoundWriggle1Case1Correct;
  auto.
Qed.

Lemma WriggleMove1SpaceFirstQCase2Correct :
(minYCriticalAngle ≤ 'α * 'd)
→ carConfinedDuringAM ('cd)
    (WriggleMove1SpaceFirstQ bottomBoundWriggle1Case2)
    (steerAndDrive ('α) αNZ ('d))
    (0 : Rigid2DState ℝ).
Proof using firstQuadW maxNeededTurn ntriv turnCentreOut αPos.
  pose proof dNN as Hdnn.
  pose proof ntriv as plaus.
  apply nonTrivialCarDimPlausible in plaus.
  intro Hcase1. simpl.
  apply WriggleMove1FirstQSpace2; auto.
  intro. unfold αNZ.
  rewrite <- (proj1 (confineRectCorrect _)).
  intro Hb; split; split; simpl; revert Hb; revert θ;
  try apply leftBoundWriggle1Correct;
  try apply rightBoundWriggle1Correct;
  try apply upBoundWriggle1Correct;
  try apply bottomBoundWriggle1Case2Correct;
  auto.
Qed.

Lemma WriggleSpaceFirstQCase1Correct :
('α * 'd ≤ minYCriticalAngle)
→ carConfinedDuringAMs ('cd)
    (WriggleSpaceFirstQ bottomBoundCase1)
    SWriggle
    (0 : Rigid2DState ℝ).
Proof using firstQuadW lengthFrontGreater maxNeededTurn ntriv
turnCentreOut.
  pose proof dNN as Hdnn.
  intro Hcase1.
  pose proof ntriv as plaus.
  apply nonTrivialCarDimPlausible in plaus.
  apply WriggleFirstQSpace2; try assumption; [].
  intro. unfold αNZ.
  rewrite <- (proj1 (confineRectCorrect _)).
  rewrite <- (proj2 (confineRectCorrect _)).
  split; intro Hb; split; split; simpl; revert Hb; revert θ;
  try apply leftBoundCorrect;
  try apply rightBoundCorrect;
  try apply upBoundCorrect;
  try apply bottomBoundCase1Correct;
  auto.
Qed.

Lemma WriggleSpaceFirstQCase2Correct :
(minYCriticalAngle ≤ 'α * 'd)
→ carConfinedDuringAMs ('cd)
    (WriggleSpaceFirstQ bottomBoundCase2)
    SWriggle
    (0 : Rigid2DState ℝ).
Proof using firstQuadW lengthFrontGreater maxNeededTurn ntriv
turnCentreOut.
  pose proof dNN as Hdnn.
  intro Hcase1.
  pose proof ntriv as plaus.
  apply nonTrivialCarDimPlausible in plaus.
  apply WriggleFirstQSpace2; try assumption; [].
  intro. unfold αNZ.
  rewrite <- (proj1 (confineRectCorrect _)).
  rewrite <- (proj2 (confineRectCorrect _)).
  split; intro Hb; split; split; simpl; revert Hb; revert θ;
  try apply leftBoundCorrect;
  try apply rightBoundCorrect;
  try apply upBoundCorrect;
  try apply bottomBoundCase2Correct;
  auto.
Qed.

  Local Transparent confineRect1.
  Local Transparent confineRect2.

(**can some reasonable assumption replace [min] by either of its arguments?*)
Lemma LeftBoundSimpl : leftBound =
min
  (- ' lengthBack cd) (**initial state , i.e. start of the first move*)
  ( 2 * 'tr   * Sin (' α * ' d)
     -⟨ '{| X := lengthBack cd; Y := tr + width cd |},unitVec (2 * ' α * ' d)⟩) .
     (**end of the second move*)
Proof using αPos.
  match goal with
  [|- _= ?r] => remember r as rr
  end.
  unfold leftBound, leftBoundWriggle1, leftBoundWriggle2.
  rewrite  (proj2 (confineRectCorrect _)).
  rewrite  (proj1 (confineRectCorrect _)).
  simpl. fold αNZ.
  rewrite <- trComplicated.
  subst rr.
  unfold inprod, InProductCart2D.
  simpl.
  fold CosClassIR.
  fold (@cos IR _).
  rewrite Cos_zero.
  rewrite Sin_zero.
  unfold trr.
  rewrite preserves_plus.
  apply Min_wd_unfolded; split; simpl; IRring.
Qed.

(** achieved at end of 1st move *)
Lemma RightBoundSimpl : rightBound =
⟨ ' {| X :=  lengthFront cd; Y :=  tr +  width cd |} , unitVec (' α * ' d)⟩.
Proof using αPos.
  match goal with
  [|- _= ?r] => remember r as rr
  end.
  unfold rightBound.
  rewrite  (proj1 (confineRectCorrect _)).
  simpl. fold αNZ.
  rewrite <- trComplicated.
  subst rr.
  unfold inprod, InProductCart2D.
  simpl.
  rewrite preserves_plus.
  reflexivity.
Qed.

(** achieved at end of 2nd move *)
Lemma BottomBoundCase1Simpl : bottomBoundCase1 =
' tr * (1 - 2 * cos (' α * ' d)) +
(⟨ '{| X :=  tr -  width cd; Y := - lengthBack cd |}, unitVec (2 * ' α * ' d) ⟩).
Proof using αPos.
  match goal with
  [|- _= ?r] => remember r as rr
  end.
  unfold bottomBoundCase1, bottomBoundWriggle2.
  rewrite  (proj2 (confineRectCorrect _)).
  simpl.  fold αNZ.
  rewrite <- trComplicated.
  subst rr.
  unfold inprod, InProductCart2D.
  simpl.
  rewrite preserves_plus.
  do 2 rewrite preserves_negate.
  reflexivity.
Qed.

(**can some reasonable assumption replace [min] by either of its arguments?*)
Lemma BottomBoundCase2Simpl : bottomBoundCase2 =
min (trr - ' (| βPlusBack |)) (** extrema inside the 1st move*)
    bottomBoundCase1. (** end of 2nd move *)
Proof using αPos.
  unfold bottomBoundCase2, bottomBoundWriggle1Case2 .
  apply Min_wd_unfolded; split;[| reflexivity].
  simpl. unfold minYCriticalAngle.
  unfold βPlusBack.
  rewrite plus_negate_r.
  rewrite Cos_zero.
  IRring.
Qed.

(**subtract the initially needed space*)
Definition leftExtraSpaceWriggle :IR :=
-(leftBound - (- 'lengthBack cd)).

Definition rightExtraSpaceWriggle :IR :=
(rightBound - 'lengthFront cd).

Definition extraSpaceXWriggle :IR :=
leftExtraSpaceWriggle + rightExtraSpaceWriggle.

Lemma rightExtraSpaceSimpl : rightExtraSpaceWriggle =
⟨ ' {| X := lengthFront cd; Y := tr + width cd |}, unitVec (' α * ' d) ⟩ -
' lengthFront cd .
Proof using αPos.
  unfold rightExtraSpaceWriggle.
  rewrite  RightBoundSimpl.
  reflexivity.
Qed.

Lemma leftExtraSpaceSimpl1 : leftExtraSpaceWriggle =
max 0
  (⟨'βPlusBack , unitVec (2 * ' α * ' d)⟩
     - ' lengthBack cd
     - 2 * ' tr * Sin (' α * ' d)).
Proof using αPos.
  hideRight.
  unfold leftExtraSpaceWriggle.
  rewrite <- negate_swap_r.
  rewrite <- negate_plus_distr.
  rewrite  LeftBoundSimpl.
  rewrite <- Min_plusl.
  rewrite plus_negate_r.
  rewrite negateMinAsMax.
  subst. unfold βPlusBack, ackermannSteering.βPlusBack.
  apply Max_wd_unfolded; IRring.
Qed.

Definition leftExtraSpaceTerm :=
⟨'{|X := tr + width cd; Y:= -lengthBack cd|}, unitVec (' α * ' d)⟩.

Lemma leftExtraSpaceSimpl2 :
(⟨' βPlusBack, unitVec (2 * ' α * ' d)⟩
     - ' lengthBack cd
     - 2 * ' tr * Sin (' α * ' d))
 =
(2 * sin (' α * ' d) * (leftExtraSpaceTerm - 'tr)).
Proof using αPos.
  hideRight.
  pose proof (unitVDouble (' α * ' d)) as Hh.
  rewrite  (@simple_associativity _ _ mult _ _ _) in Hh.
  rewrite Hh. clear Hh.
  subst.
  unfold leftExtraSpaceTerm.
  simpl.
  rewrite nat_pow.nat_pow_2.
  unfold inprod, InProductCart2D. simpl.
  rewrite preserves_negate.
  IRring.
Qed.

Lemma leftExtraSpaceTermSimpl : leftExtraSpaceTerm =
  (' (| βPlusBack |) * cos (' α * ' d + (½ * π - ' polarTheta βPlusBack))).
Proof using.
  unfold leftExtraSpaceTerm.
  hideRight. simpl.
  subst.
  fold CosClassIR.
  fold (@cos IR _).
  rewrite <- unitVDot2.
  rewrite multDotRight.
  pose proof CartToPolarCorrect90Minus as Hr.
  unfold norm, NormCart2DQ in Hr.
  rewrite <- Hr.
  unfold inprod, InProductCart2D. simpl.
  rewrite preserves_plus.
  rewrite preserves_negate.
  IRring.
Qed.

(**from the above representation, it is clear that at small angles,
  [leftExtraSpaceTerm] is closer to [| βPlusBack |], which is slight larger than
  [tr+width cd], and hence larger than [tr]. Hence the second argument
  of [max] in [leftExtraSpaceSimpl2 ]will be positive.

  On the other hand, when [' α * ' d] is large, [cos] will be closer to [0],
  and [max] will be equal to the left argument, i.e. minima achieved at
  the initial position.
  Note that [(½ * π - ' polarTheta βPlusBack)] typically a small angle.
  See [Mazda3βPlusBack] below.
  *)

Let cyyQ : Q :=  ((width cd)^2 + (lengthBack cd)^2 + 2* tr* (width cd))%mc.

Let cyy : CR :=  √cyyQ.

Lemma cyyQNonneg: (0  ≤ cyyQ).
Proof using ntriv turnCentreOut.
  unfold nonTrivialCarDim in ntriv.
  autounfold with QMC in ntriv.

  destruct ntriv as [H11 H12]. destruct H12 as [H21 H22].
  apply Qlt_le_weak  in H11.
  apply Qlt_le_weak  in H21.
  apply Qlt_le_weak  in H22.
  unfold cyyQ.
  rewrite nat_pow.nat_pow_2.
  rewrite nat_pow.nat_pow_2.
  autounfold with QMC.
  pose proof (Qmult_le_0_compat _ _ H22 H22).
  pose proof (Qmult_le_0_compat _ _ H21 H21).
  assert (0 <= tr)%Q as X by lra.
  pose proof (Qmult_le_0_compat _ _  X H21).
  lra.
Qed.

Lemma cyyCorrect:
√ ('(tr * tr) + cyy * cyy) = (| βPlusBack | : CR).
Proof using ntriv turnCentreOut.
  simpl. unfold cyy. unfold CanonicalNotations.norm, NormSpace_instance_Cart2D.
  unfold sqrtFun, rational_sqrt_SqrtFun_instance, CRsqrt_SqrtFun_instance.
  rewrite <- CRsqrt_Qsqrt.
  rewrite <- CRsqrt_Qsqrt.
  apply ProperCRsqrt.
  let tac := (apply CRle_Qle;apply cyyQNonneg) in
    rewrite <- CRsqrt_mult;[rewrite CRsqrt_ofsqr_nonneg;[|tac]| tac|tac].
  fold (cast Q CR).
  rewrite <- (@preserves_plus Q CR _ _ _ _ _ _ _ _ _ _ _ _ ).
  apply sm_proper.
  unfold cyyQ.
  rewrite nat_pow.nat_pow_2.
  rewrite nat_pow.nat_pow_2.
  autounfold with QMC.
  simpl.
  autounfold with QMC.
  ring.
Qed.

Definition leftCriticalAngle :IR :=
' arctan (cyy * ' (/ tr)) - (½ * π - ' polarTheta βPlusBack).

Lemma leftCriticalAngleVsMiny :
leftCriticalAngle = ' arctan (cyy * ' (/ tr)) - minYCriticalAngle.
Proof using.
  reflexivity.
Qed.

Lemma nonTrivialExtraSpaceIf :
' α * ' d ≤ leftCriticalAngle
→ 'tr ≤ leftExtraSpaceTerm.
Proof using  ntriv turnCentreOut αPos firstQuadW.
  unfold leftCriticalAngle.
  intro. rewrite leftExtraSpaceTermSimpl.
  unfold nonTrivialCarDim in ntriv.
  autounfold with QMC in ntriv.
  eapply transitivity.
  - apply eq_le.
    apply cos_o_arctan_east2Q with (cy:=cyy).
    lra.
  - unfold leftExtraSpaceTerm. rewrite cyyCorrect.
    apply (@order_preserving _ _ _ _ _ _ _);
      [apply OrderPreserving_instance_0;
       apply Cart2DRadNNegIR |].
    apply Cos_resp_leEq.
    + apply plus_resp_nonneg; [apply dNN; auto|].
      apply flip_le_minus_r.
      setoid_rewrite plus_0_l.
      apply firstQuadβPlusBack.
    + rewrite arctan_correct_CR.
      rewrite (divideBy2 Pi).
      eapply transitivity.
      * apply less_leEq. apply ArcTan_range.
      * rewrite PiBy2DesugarIR. apply RingLeProp1.
        apply PiBy2Ge0.
    + apply flip_le_minus_r. assumption.
Qed.

Lemma trivialExtraSpaceIf :
leftCriticalAngle ≤ ' α * ' d
→ leftExtraSpaceTerm ≤ 'tr.
Proof using firstQuadW ntriv turnCentreOut αPos.
  pose proof dNN as Hdnn.
  unfold nonTrivialCarDim in ntriv.
  autounfold with QMC in ntriv.
  unfold leftCriticalAngle.
  intro.  rewrite leftExtraSpaceTermSimpl.
  eapply transitivity.
  Focus 2.
  - apply eq_le. symmetry.
    apply cos_o_arctan_east2Q with (cy:=cyy). lra.
  - rewrite cyyCorrect.
    apply (@order_preserving _ _ _ _ _ _ _);
      [apply OrderPreserving_instance_0;
       apply Cart2DRadNNegIR |].
    apply Cos_resp_leEq.
    + rewrite arctan_correct_CR.
      apply ArcTan_nonneg.
      rewrite <- CRasIR0.
      apply CR_leEq_as_IR.
      apply nonneg_mult_compat; unfold PropHolds.
      * unfold cyy. rewrite <- CRsqrt_Qsqrt.
        apply CRsqrt_nonneg.
        apply preserves_nonneg.
        unfold PropHolds.
        apply cyyQNonneg.
      * apply preserves_nonneg.
        unfold PropHolds.
        apply Qinv_le_0_compat.
        unfold nonTrivialCarDim in ntriv.
        autounfold with QMC in ntriv.
        simpl in ntriv.
        lra.
    + rewrite (divideBy2 Pi).
      apply plus_le_compat;[apply adPiBy2; assumption|].
      apply  flip_le_minus_r.
      rewrite negate_involutive.
      rewrite (@commutativity _ _ _ plus _ _).
      apply RingLeProp1.
      apply firstQuadβPlusBack.

    + apply flip_le_minus_l. assumption.
Qed.

Definition leftCriticalAngleCR :CR :=
 arctan (cyy * ' (/ tr)) - (½ * π - polarTheta βPlusBack).

Lemma leftCriticalAngleCRCorrect :
'leftCriticalAngleCR = leftCriticalAngle.
Proof using.
  unfold leftCriticalAngleCR, leftCriticalAngle.
  rewrite CR_minus_asIR.
  rewrite CR_minus_asIR.
  rewrite <- PiBy2IRCR.
  reflexivity.
Qed.

(** for Mazda 3, it is between 23 and 24 degrees *)
Lemma Mazda3LeftCriticalAngle:
thisCarHasSameGeometryAs ('Mazda3Sedan2014sGT)
-> ('(Qmake 27 180) * π ) < leftCriticalAngleCR < ('(Qmake 28 180) * π ).
Proof using Type*.
  intro H. destruct H as [Hl Hr].
  unfold leftCriticalAngleCR.
  unfold cyy, cyyQ, βPlusBack.
  subst.
  rewrite Hr. clear Hr.
(*
match goal with
[|- _ < ?r < _]
  => let t:=eval vm_compute in (approximateAngleAsDegrees r) in idtac t
end.
*)
  unfold lt, CRlt.
  split; exists 10%nat;
  simpl; vm_compute; [reflexivity | reflexivity].
Qed.

(** lets consider the two subcomponents of the above angle *)
Lemma Mazda3LeftCriticalAngle1:
thisCarHasSameGeometryAs ('Mazda3Sedan2014sGT)
-> ('(Qmake 38 180) * π ) < arctan (cyy * ' (/ tr)) < ('(Qmake 39 180) * π ).
Proof using Type*.
  intro H. destruct H as [Hl Hr].
  unfold leftCriticalAngleCR.
  unfold cyy, cyyQ.
  subst.
  rewrite Hr. clear Hr.
(*
match goal with
[|- _ < ?r < _]
  => let t:=eval vm_compute in (approximateAngleAsDegrees r) in idtac t
end.
*)
  unfold lt, CRlt.
  split; exists 10%nat;
  simpl; vm_compute; reflexivity.
Qed.

Lemma Mazda3βPlusBack:
thisCarHasSameGeometryAs ('Mazda3Sedan2014sGT)
-> ('(Qmake 79 180) * π ) < polarTheta βPlusBack < ('(Qmake 80 180) * π ).
Proof using Type*.
  intro H. destruct H as [Hl Hr].
  unfold leftCriticalAngleCR.
  unfold βPlusBack.
  subst.
  rewrite Hr. clear Hr.
  unfold lt, CRlt.
  split; exists 10%nat;
  simpl; vm_compute; reflexivity.
Qed.

(**
These compute fast now:

Eval vm_compute in
 (approximate (CRPiInv) (QposMake 1 1000)).

Eval vm_compute in
  (approximateAngleAsDegrees
    (polarTheta
      (βPlusFront
        ('carDim Mazda3Sedan2014sGT)
        (' minTR Mazda3Sedan2014sGT)
         ))).
*)

Lemma Mazda3βPlusFront:
thisCarHasSameGeometryAs ('Mazda3Sedan2014sGT)
-> ('(Qmake 52 180) * π ) < polarTheta βPlusFront < ('(Qmake 53 180) * π ).
Proof using Type*.
  intro H. destruct H as [Hl Hr].
  unfold leftCriticalAngleCR.
  unfold βPlusFront.
  subst.
  rewrite Hr. clear Hr.
(*
match goal with
[|- _ < ?r < _]
  => let t:=eval vm_compute in (approximateAngleAsDegrees r) in idtac t
end.
*)
  unfold lt, CRlt.
  split; exists 19%nat;
  simpl; vm_compute; reflexivity.
Qed.

Section LeftNontrivialCase.

(** It almost-suffices to just consider this case, which is defined by
  [' α * ' d ≤ leftCriticalAngle].
We know that it suffices to pick ['d] such that [2*' α * ' d ≤ polarTheta βPlusFront].
The latter is about 51 degrees. [' α * ' d] is half of that, so we loose nothing if
we consider the case when [' α * ' d ≤ 26].
[leftCriticalAngle] is around 24 degrees for Mazda3.
Therefore, ensuring [' α * ' d ≤ 24] may be only slightly suboptimal.
Note that we get to control [d].
Also, as the available space gets smaller, other constraints will anyways force us
to choose a smaller positive value of [d], reaching 0 in the limit.

  In this case, the [max] in
  [leftExtraSpaceSimpl2] above can be simplified to its RHS.
*)

Lemma leftExtraSpaceWriggleSimplCase1 :
' α * ' d ≤ leftCriticalAngle
→ leftExtraSpaceWriggle =
    (2 * sin (' α * ' d) * (leftExtraSpaceTerm - 'tr)).
Proof using firstQuadW ntriv turnCentreOut αPos.
  pose proof dNN as Hdnn.
  intro.
  rewrite leftExtraSpaceSimpl1.
  rewrite leftExtraSpaceSimpl2.
  apply leEq_imp_Max_is_rht.
  rewrite <- (@simple_associativity _ _ mult _ _ ).
  apply RingLeProp3.
  apply nonneg_mult_compat; unfold PropHolds.
  - apply Sin_nonneg;[apply dNN; assumption|].
    eapply transitivity;[apply adPiBy2; assumption|].
    apply PiBy2LePiMC.
  - apply flip_le_minus_r. rewrite plus_0_l.
    apply nonTrivialExtraSpaceIf. assumption.
Qed.

Definition extraSpaceXWriggleCase1 :IR :=
(2 * sin (' α * ' d) * (leftExtraSpaceTerm - 'tr)) + rightExtraSpaceWriggle.

Lemma extraSpaceXWriggleCase1Correct :
' α * ' d ≤ leftCriticalAngle
→ extraSpaceXWriggleCase1 = extraSpaceXWriggle.
Proof using firstQuadW ntriv turnCentreOut αPos.
  unfold extraSpaceXWriggleCase1, extraSpaceXWriggle.
  intro H. rewrite leftExtraSpaceWriggleSimplCase1;[| assumption].
  reflexivity.
Qed.

Definition extraSpaceX1 `{CosClass R} `{Ring R}
`{Cast (Cart2D Q) (Polar2D R)}
`{Cast Q R}
(θ:R) :=
let βb : Polar2D R:= ' βPlusBack in
let βf : Polar2D R:= ' βMinusFront in
(rad βb) * cos (2 *  θ - (Vector.θ βb))
+ (rad βf) * cos ( θ  +  (Vector.θ βf))
 - '(totalLength cd).

Require Import implCR.

Lemma preserves_extraSpaceX1 : forall (θ:CR),
  'extraSpaceX1 θ = extraSpaceX1 (('θ):IR).
Proof using.
  intros ?.
  unfold extraSpaceX1.
  autounfold with IRMC.
  simpl.
  unfold cast, Cast_instace_Q_IR, Cart_CR_IR, Cart2PolarCR, Cart2Polar.
  unfold CosClassCR.
  autorewrite with CRtoIR.
  reflexivity.
Qed.

Definition rightExtraSpaceW  `{CosClass R} `{Ring R}
`{Cast (Cart2D Q) (Polar2D R)}
`{Cast Q R}
(θ:R) :=
let βf : Polar2D R:= ' βPlusFront in
 (rad βf) * cos ( θ  -  (Vector.θ βf))
 - '(lengthFront cd).

Lemma rightExtraSpaceSimpl2 :
  rightExtraSpaceWriggle
  = rightExtraSpaceW (' α * ' d).
Proof using αNZ.
  rewrite rightExtraSpaceSimpl.
  unfold rightExtraSpaceW.
  pose proof (unitVDotRAsPolar βPlusFront) as Hh.
  simpl in Hh.
  setoid_rewrite CosMinusSwap.
  setoid_rewrite <- Hh.
  unfold inprod, InProductCart2D.
  simpl.
  reflexivity.
Qed.

Lemma extraSpaceXWriggleCase1Simpl2:
extraSpaceXWriggleCase1
= extraSpaceX1 (' α * ' d).
Proof using αPos.
  simpl. unfold extraSpaceX1.
  hideRight.
  unfold extraSpaceXWriggleCase1.
  rewrite <- leftExtraSpaceSimpl2.
  rewrite unitVDotRAsPolar.
  simpl.
  unfold cos, CosClassIR.
  rewrite CosMinusSwap.
  subst.
  rewrite <- (@simple_associativity _ _ plus _ _).
  rewrite <- (@simple_associativity _ _ plus _ _).
  rewrite <- (@simple_associativity _ _ plus _ _).
  rewrite  (@simple_associativity _ _ mult _ 2).
  apply sg_op_proper;[reflexivity|].
  rewrite (@commutativity _ _ _ plus _ _).
  unfold totalLength.
  rewrite preserves_plus.
  rewrite negate_plus_distr.
  rewrite  (@simple_associativity _ _ plus _ _).
  apply sg_op_proper ;[|reflexivity].
  rewrite rightExtraSpaceSimpl.
  pose proof (unitVDotRAsPolarNegY βMinusFront) as Hh.
  simpl in Hh.
  rewrite (@commutativity _ _ _ plus _ (' α * ' d )).
  rewrite <- Hh.
  unfold inprod, InProductCart2D.
  simpl.
  autorewrite with Q2RMC.
  IRring.
Qed.

(** extra needed space is a continuous function over θ,
which is  (' α * ' d) *)
Definition extraSpaceX1Continuous: ℝ-c->ℝ :=
linearCosine  ('| βPlusBack |) 2 (- ' polarTheta βPlusBack)
[+] linearCosine  ('| βMinusFront |) 1 (' polarTheta βMinusFront)
[+] RConst (- '(totalLength cd)).

Lemma extraSpaceX1ContinuousCorrect:
crepresents extraSpaceX1Continuous extraSpaceX1.
Proof using.
  intros ?. unfold extraSpaceX1Continuous, extraSpaceX1.
  rewrite IContRPlusAp.
  rewrite IContRPlusAp.
  rewrite linearCosineAp.
  rewrite linearCosineAp.
  simpl. rewrite mult_1_l.
  IRring.
Qed.

Definition extraSpaceX1Deriv (θ:IR) :=
2* ' (| βPlusBack |) * sin (' polarTheta βPlusBack - 2 *  θ)
- ' (| βMinusFront |) * sin ( θ  +  ' polarTheta βMinusFront).

(** derivative of extra needed space is a continuous function over θ,
which is  (' α * ' d) *)
Definition extraSpaceX1DerivContinuous: ℝ-c->ℝ :=
linearSine  (('| βPlusBack |) * (-2)) 2 (- ' polarTheta βPlusBack)
[+] linearSine  (('| βMinusFront |) * (-1)) 1 (' polarTheta βMinusFront).

Lemma extraSpaceX1DerivContinuousCorrect:
crepresents extraSpaceX1DerivContinuous extraSpaceX1Deriv.
Proof using.
  intros ?. unfold extraSpaceX1DerivContinuous, extraSpaceX1Deriv.
  rewrite IContRPlusAp.
  rewrite linearSineAp.
  rewrite linearSineAp.
  simpl.
   rewrite mult_1_l.
  rewrite SinMinusSwap.
  IRring.
Qed.

Lemma XSpaceDerivCorrect :
  isIDerivativeOf extraSpaceX1DerivContinuous extraSpaceX1Continuous.
Proof using.
  unfold extraSpaceX1DerivContinuous, extraSpaceX1Continuous.
  eapply isIDerivativeOfWdl;
    [apply cm_rht_unit_unfolded|].
  apply TContRDerivativePlus;[|apply TContRDerivativeConst].
  apply TContRDerivativePlus; apply linearCosSineDeriv.
Qed.

Definition XSpaceMonotoneUB `{Ring R}
`{Cast (Cart2D Q) (Polar2D R)}
`{Cast Q R} :=
let βb : Polar2D R:= ' βPlusBack in
let βf : Polar2D R:= ' βMinusFront in
(θ βb - θ βf) * '(Qmake 1 3).

Lemma preserves_XSpaceMonotoneUB :
  (XSpaceMonotoneUB:IR) = '(XSpaceMonotoneUB:CR).
Proof using.
  unfold XSpaceMonotoneUB.
  autounfold with IRMC.
  simpl.
  unfold cast, Cast_instace_Q_IR, Cart_CR_IR, Cart2PolarCR, Cart2Polar.
  unfold CosClassCR.
  autorewrite with CRtoIR.
  reflexivity.
Qed.

(*
Definition XSpaceMonotoneUB :=
 ((' polarTheta βPlusBack - ' polarTheta βMinusFront) * '(Qmake 1 3)).
*)

Lemma βMinusFrontLeβPlusBack :
  ((' polarTheta βMinusFront:IR) [<] ' polarTheta βPlusBack).
Proof using firstQuadW lengthFrontGreater ntriv turnCentreOut.
  eapply less_leEq_trans; [apply βPlusMinusFront|].
  apply FrontLeBack.
Qed.

Lemma XSpaceMonotoneUBPos : 0[<]XSpaceMonotoneUB.
Proof.
  unfold XSpaceMonotoneUB.
  apply mult_resp_pos.
- apply shift_less_minus.
  eapply less_wdl;
    [|symmetry; apply plus_0_l].
  apply βMinusFrontLeβPlusBack.
- apply Qpos_adaptor. compute. reflexivity.
Qed.

Lemma XSpaceMonotoneUBFirstQuad :
0 ≤ XSpaceMonotoneUB ≤ ½ * π.
Proof using firstQuadW lengthFrontGreater ntriv turnCentreOut.
  split;[apply less_leEq,XSpaceMonotoneUBPos| ].
  unfold XSpaceMonotoneUB.
  apply le_1_mult_le_compat_r;
    [apply preserves_le_1;compute; intro; discriminate
      |apply flip_nonneg_minus, less_leEq, βMinusFrontLeβPlusBack |].
  rewrite <- (plus_0_r  (½ * π)).
  apply plus_le_compat;
    [apply firstQuadβPlusBack|].
  apply flip_nonneg_negate.
  apply firstQuadβMinusFront.
Qed.

Lemma XSpaceDerivPosIf : forall (θ:IR),
0 ≤ θ
→ θ [<] XSpaceMonotoneUB
→ ' (| βMinusFront |) ≤  2 * ' (| βPlusBack |)
→ 0 [<] extraSpaceX1Deriv θ.
Proof using firstQuadW lengthFrontGreater ntriv turnCentreOut.
  intros ? h1l h1r h2.
  unfold extraSpaceX1Deriv.
  apply shift_less_minus.
  eapply less_wdl;[|symmetry; apply plus_0_l].
  apply mult_resp_leEq_less; try assumption;[| |].
- apply normIRPosAux. apply QNormSqrPosX.
  simpl. apply ntriv.
- apply Sin_nonneg;[| rewrite (divideBy2 Pi)].
  + apply nonneg_plus_compat; unfold PropHolds;
      [assumption |].
    apply firstQuadβMinusFront.
  + apply plus_le_compat;
      [| apply firstQuadβMinusFront].
    eapply transitivity;[ apply less_leEq; apply h1r |].
    apply XSpaceMonotoneUBFirstQuad.
- apply Sin_resp_less.
  + eapply transitivity;[apply MinusPiBy2Le0|].
    apply nonneg_plus_compat; unfold PropHolds;
    [ assumption|].
    apply firstQuadβMinusFront.
  + apply shift_less_minus.
    eapply less_wdl;[ | apply PlusShuffle3r].
    unfold XSpaceMonotoneUB in h1r.
    rename h1r into H.
    apply shift_plus_less.
    apply (@mult_resp_less_lft _ _ _ 3) in H.
    Focus 2.
      eapply less_wdr;
      [|apply (@preserves_3 Q IR  _ _ _ _ _ _ _ _ _ _ (cast Q IR) _)].
      apply Qpos_adaptor.
      compute. reflexivity.
    assert (3 * θ= θ + 2 * θ) as Heq by IRring.
    eapply less_wdl;[| apply Heq]. clear Heq.
    eapply less_leEq_trans;[apply H|].
    apply eq_le. clear.
    fold (@Mult_instance_IR).
    fold (@mult IR _).
    rewrite  MultShuffle3l.
    rewrite <- (@preserves_3 Q IR  _ _ _ _ _ _ _ _ _ _ (cast Q IR) _).
    rewrite <- (@simple_associativity _ _ mult _ _ _ ).
    rewrite <- (preserves_mult).
    assert  (3 * (1 # 3)%Q = 1) as Heq by (compute; reflexivity).
    rewrite Heq. clear Heq.
    rewrite (@preserves_1 Q IR  _ _ _ _ _ _ _ _ _ _ (cast Q IR) _).
    rewrite mult_1_r.
    reflexivity.
  + rewrite <- PiBy2DesugarIR.
    rewrite <- (plus_0_r  (½ * π)).
    apply plus_le_compat;
      [apply firstQuadβPlusBack|].
    apply flip_nonneg_negate.
    rewrite <- RingProp3.
    apply nonneg_plus_compat; apply h1l.
Qed.

(** TODO : reuse the lemma [XSpaceDerivPosIf] above instead *)
Lemma XSpaceDerivNNegIf : forall (θ:IR),
0 ≤ θ ≤ XSpaceMonotoneUB
→ ' (| βMinusFront |) ≤  2 * ' (| βPlusBack |)
→ 0 ≤ extraSpaceX1Deriv θ.
Proof using firstQuadW lengthFrontGreater ntriv turnCentreOut maxNeededTurn.
  intros ? h1 h2.
  unfold extraSpaceX1Deriv.
  apply flip_nonneg_minus.
  apply mult_le_compat;
    [apply Cart2DRadNNegIR;fail | | assumption; fail|].
- apply Sin_nonneg;[| rewrite (divideBy2 Pi)].
  + apply nonneg_plus_compat; unfold PropHolds.
    tauto. apply firstQuadβMinusFront.
  + apply plus_le_compat;
      [| apply firstQuadβMinusFront].
    eapply transitivity;[ apply h1 |].
    apply XSpaceMonotoneUBFirstQuad.

- apply Sin_resp_leEq.
  + eapply transitivity;[apply MinusPiBy2Le0|].
    apply nonneg_plus_compat; unfold PropHolds.
    tauto. apply firstQuadβMinusFront.
  + rewrite <- PiBy2DesugarIR.
    rewrite <- (plus_0_r  (½ * π)).
    apply plus_le_compat;
      [apply firstQuadβPlusBack|].
    apply flip_nonneg_negate.
    rewrite <- RingProp3.
    apply nonneg_plus_compat; apply h1.
  + apply flip_le_minus_l. rewrite negate_involutive.
    rewrite <- PlusShuffle3r.
    apply flip_le_minus_r.
    unfold XSpaceMonotoneUB in h1.
    specialize (proj2 h1). clear.
    intro H.
    apply (@order_preserving IR IR _ _ _ _ (mult 3)) in H;
      [|apply semirings.OrderPreserving_instance_0].
    Focus 2. unfold PropHolds.
      rewrite <- (@preserves_3 Q IR  _ _ _ _ _ _ _ _ _ _ (cast Q IR) _).
      apply preserves_nonneg. compute. intro ; discriminate.
    assert (θ + 2 * θ= 3 * θ) as Heq by IRring.
    rewrite Heq. clear Heq.
    eapply transitivity;[apply H|].
    apply eq_le. clear.
    rewrite  MultShuffle3l.
    rewrite <- (@preserves_3 Q IR  _ _ _ _ _ _ _ _ _ _ (cast Q IR) _).
    rewrite <- (@simple_associativity _ _ mult _ _ _ ).
    rewrite <- (preserves_mult).
    assert  (3 * (1 # 3)%Q = 1) as Heq by (compute; reflexivity).
    rewrite Heq. clear Heq.
    rewrite (@preserves_1 Q IR  _ _ _ _ _ _ _ _ _ _ (cast Q IR) _).
    rewrite mult_1_r.
    reflexivity.
Qed.

Lemma isDerivX1space :
  isDerivOf extraSpaceX1Deriv extraSpaceX1.
Proof using.
  eexists; eexists; dands; eauto using extraSpaceX1ContinuousCorrect,
  extraSpaceX1DerivContinuousCorrect.
  constructor.
  apply XSpaceDerivCorrect.
Qed.

Lemma derivNonegMonotoneXspace : ∀ a b,
a ≤ b
→ (∀ θ, a≤θ≤b -> 0 ≤ extraSpaceX1Deriv θ)
→ extraSpaceX1 a ≤  extraSpaceX1 b.
Proof using.
  intros. eapply nonDecIfDerivNonNeg; eauto.
  apply isDerivX1space.
Qed.

Definition extraSpaceX1DerivUB `{Ring R}
`{Cast (Cart2D Q) (Polar2D R)} :=
let βb : Polar2D R:= ' βPlusBack in
let βf : Polar2D R:= ' βMinusFront in
2*(rad βb) + (rad βf).

Hint Resolve  Cart2DRadNNegIR RingLeProp3 : CoRN.
Lemma X1spaceDerivUB :
∀ θ:IR,
 extraSpaceX1Deriv θ ≤ extraSpaceX1DerivUB.
Proof using.
  intros ?.
  unfold extraSpaceX1Deriv.
  apply plus_le_compat; unfold rad; simpl.
- rewrite <- (mult_1_r (2 * ' (| βPlusBack |))) at 2.
  apply order_preserving;
    [| apply Sin_leEq_One].
  apply semirings.OrderPreserving_instance_0 .
  apply RingLeProp3.
  apply Cart2DRadNNegIR.
- rewrite negate_mult_distr_r.
  rewrite <- (mult_1_r (' (| βMinusFront |))) at 2.
  apply order_preserving.
  + apply semirings.OrderPreserving_instance_0 .
    apply Cart2DRadNNegIR.
  + eapply transitivity.
    apply inv_leEq_AbsIR.
    apply AbsIR_Sin_leEq_One.
Qed.

(** if the car doesn't move at all, no extra space is needed *)
Lemma extraSpaceX1_0 : extraSpaceX1 0 = (0:IR).
Proof using.
  unfold extraSpaceX1.
  rewrite (commutativity 0).
  unfold cos, CosClassIR.
  rewrite CosMinusSwap.
  setoid_rewrite <- (unitVDotRAsPolar βPlusBack).
  setoid_rewrite <- (unitVDotRAsPolarNegY βMinusFront).
  rewrite mult_0_r.
  unfold unitVec.
  rewrite Cos_zero.
  rewrite Sin_zero.
  unfold totalLength.
  unfold inprod, InProductCart2D.
  simpl.
  autorewrite with Q2RMC.
  IRring.
Qed.

Lemma extraSpaceX10UB :
∀ θ:IR,
0 ≤ θ
→ extraSpaceX1 θ
  ≤ extraSpaceX1DerivUB * θ .
Proof using.
  intros ? ?.
  rewrite <- (minus_0_r θ) at 2.
  eapply transitivity;
    [| eapply isDerivUB]; try assumption; [| apply isDerivX1space|].
- rewrite extraSpaceX1_0. rewrite minus_0_r. reflexivity.
- intros. apply X1spaceDerivUB.
Qed.

Lemma XSpaceDerivNNegIfHyp:
(' (| βMinusFront |) ≤  2 * ' (| βPlusBack |))
↔ (normSqr (βMinusFront) ≤ 4 * normSqr ( βPlusBack)).
Abort.

Lemma XSpaceDerivNNegIf2 : forall (θ:IR),
½* ' (| βPlusBack |) * ' (| βMinusFront |)
≤  (sin (' polarTheta βPlusBack - 2 *  θ))
→
0 ≤ extraSpaceX1Deriv θ.
Abort.

Lemma Mazda3βMinusFront:
thisCarHasSameGeometryAs ('Mazda3Sedan2014sGT)
-> ('(Qmake 38 180) * π ) < polarTheta βMinusFront < ('(Qmake 39 180) * π ).
Proof using Type*.
  intro H. destruct H as [Hl Hr].
  unfold leftCriticalAngleCR.
  unfold βMinusFront.
  subst.
  rewrite Hr. clear Hr.
(*
match goal with
[|- _ < ?r < _]
  => let t:=eval vm_compute in (approximateAngleAsDegrees r) in idtac t
end.
*)
  unfold lt, CRlt.
  split; exists 18%nat;
  simpl; vm_compute; reflexivity.
Qed.

(*
Check Mazda3βPlusBack.
Mazda3βPlusBack
     : thisCarHasSameGeometryAs (' Mazda3Sedan2014sGT)
       → ' (79 # 180)%Q * π < polarTheta βPlusBack <
         ' (80 # 180)%Q * π
*)

Lemma Mazda3Ratio:
thisCarHasSameGeometryAs (' Mazda3Sedan2014sGT)
->(normSqr (βMinusFront) ≤ 4 * normSqr ( βPlusBack)).
Proof using Type*.
  intro.
  destruct H.
  unfold βMinusFront, βPlusBack.
  subst.
  rewrite H0.
  Local Opaque Qle.
  cbv.
  (** this is true by a large margin
  (34484 # 1 <= 130832 # 1)%Q *)
  Local Transparent Qle.
  compute. intro. discriminate.
Qed.

(** is it provable using existing assumptions?
While this is likely to be true for most cars, so far
we never assumed any upper bound on [lengthFront].
When it becomes too large in comparison to other dimensions,
this may not hold.

If we dont want to assume this for all cars,
it may still be possible to prove
the unitial monotonicity by replacing sin by 1 or -1 depending
on which side of ≤ it occurs.
*)
Lemma extraSpaceX1IfNormSqr:
(normSqr (βMinusFront) ≤ 4 * normSqr ( βPlusBack)).
Proof.
  unfold normSqr. simpl.
  apply flip_nonneg_minus.
  autounfold with QMC.
  ring_simplify.
Abort.

Lemma  βPlusBackNormSqrPos :
  0< normSqr βPlusBack.
Proof using ntriv.
  simpl.
  apply QNormSqrPosX.
  simpl.
  apply ntriv.
Qed.

End LeftNontrivialCase.

End FirstQuadWriggleQ.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** This file centralizes the lemmas about [Z], classifying them
    according to the way they can be used in automatic search  *)

(** Lemmas which clearly leads to simplification during proof search are *)
(** declared as Hints. A definite status (Hint or not) for the other lemmas *)
(** remains to be given *)

(** Structure of the file *)
(** - simplification lemmas (only those are declared as Hints) *)
(** - reversible lemmas relating operators *)
(** - useful Bottom-up lemmas              *)
(** - irreversible lemmas with meta-variables *)
(** - unclear or too specific lemmas       *)
(** - lemmas to be used as rewrite rules   *)

(** Lemmas involving positive and compare are not taken into account *)

Require Import BinInt.
Require Import Zorder.
Require Import Zmin.
Require Import Zabs.
Require Import Zcompare.
Require Import Znat.
Require Import auxiliary.
Require Import Zmisc.
Require Import Wf_Z.

(************************************************************************)
(** *                 Simplification lemmas                             *)

(** No subgoal or smaller subgoals                                     *)

Hint Resolve
  (** ** Reversible simplification lemmas (no loss of information)      *)
  (** Should clearly be declared as hints                               *)

  (** Lemmas ending by eq *)
  Zsucc_eq_compat (* :(n,m:Z)`n = m`->`(Zs n) = (Zs m)` *)

  (** Lemmas ending by Zgt *)
  Zsucc_gt_compat (* :(n,m:Z)`m > n`->`(Zs m) > (Zs n)` *)
  Zgt_succ (* :(n:Z)`(Zs n) > n` *)
  Zorder.Zgt_pos_0 (* :(p:positive)`(POS p) > 0` *)
  Zplus_gt_compat_l (* :(n,m,p:Z)`n > m`->`p+n > p+m` *)
  Zplus_gt_compat_r (* :(n,m,p:Z)`n > m`->`n+p > m+p` *)

  (** Lemmas ending by Zlt *)
  Zlt_succ (* :(n:Z)`n < (Zs n)` *)
  Zsucc_lt_compat (* :(n,m:Z)`n < m`->`(Zs n) < (Zs m)` *)
  Zlt_pred (* :(n:Z)`(Zpred n) < n` *)
  Zplus_lt_compat_l (* :(n,m,p:Z)`n < m`->`p+n < p+m` *)
  Zplus_lt_compat_r (* :(n,m,p:Z)`n < m`->`n+p < m+p` *)

  (** Lemmas ending by Zle *)
  Zle_0_nat (* :(n:nat)`0 <= (inject_nat n)` *)
  Zorder.Zle_0_pos (* :(p:positive)`0 <= (POS p)` *)
  Zle_refl (* :(n:Z)`n <= n` *)
  Zle_succ (* :(n:Z)`n <= (Zs n)` *)
  Zsucc_le_compat (* :(n,m:Z)`m <= n`->`(Zs m) <= (Zs n)` *)
  Zle_pred (* :(n:Z)`(Zpred n) <= n` *)
  Zle_min_l (* :(n,m:Z)`(Zmin n m) <= n` *)
  Zle_min_r (* :(n,m:Z)`(Zmin n m) <= m` *)
  Zplus_le_compat_l (* :(n,m,p:Z)`n <= m`->`p+n <= p+m` *)
  Zplus_le_compat_r (* :(a,b,c:Z)`a <= b`->`a+c <= b+c` *)
  Zabs_pos (* :(x:Z)`0 <= |x|` *)

  (** ** Irreversible simplification lemmas *)
  (** Probably to be declared as hints, when no other simplification is possible *)

  (** Lemmas ending by eq *)
  BinInt.Z_eq_mult (* :(x,y:Z)`y = 0`->`y*x = 0` *)
  Zplus_eq_compat (* :(n,m,p,q:Z)`n = m`->`p = q`->`n+p = m+q` *)

  (** Lemmas ending by Zge *)
  Zorder.Zmult_ge_compat_r (* :(a,b,c:Z)`a >= b`->`c >= 0`->`a*c >= b*c` *)
  Zorder.Zmult_ge_compat_l (* :(a,b,c:Z)`a >= b`->`c >= 0`->`c*a >= c*b` *)
  Zorder.Zmult_ge_compat (* :
      (a,b,c,d:Z)`a >= c`->`b >= d`->`c >= 0`->`d >= 0`->`a*b >= c*d` *)

  (** Lemmas ending by Zlt *)
  Zorder.Zmult_gt_0_compat (* :(a,b:Z)`a > 0`->`b > 0`->`a*b > 0` *)
  Zlt_lt_succ (* :(n,m:Z)`n < m`->`n < (Zs m)` *)

  (** Lemmas ending by Zle *)
  Zorder.Zmult_le_0_compat (* :(x,y:Z)`0 <= x`->`0 <= y`->`0 <= x*y` *)
  Zorder.Zmult_le_compat_r (* :(a,b,c:Z)`a <= b`->`0 <= c`->`a*c <= b*c` *)
  Zorder.Zmult_le_compat_l (* :(a,b,c:Z)`a <= b`->`0 <= c`->`c*a <= c*b` *)
  Zplus_le_0_compat (* :(x,y:Z)`0 <= x`->`0 <= y`->`0 <= x+y` *)
  Zle_le_succ (* :(x,y:Z)`x <= y`->`x <= (Zs y)` *)
  Zplus_le_compat (* :(n,m,p,q:Z)`n <= m`->`p <= q`->`n+p <= m+q` *)

  : zarith.

(**********************************************************************)
(** *        Reversible lemmas relating operators                     *)
(** Probably to be declared as hints but need to define precedences   *)

(** ** Conversion between comparisons/predicates and arithmetic operators *)

(** Lemmas ending by eq *)
(**
<<
Zegal_left: (x,y:Z)`x = y`->`x+(-y) = 0`
Zabs_eq: (x:Z)`0 <= x`->`|x| = x`
Zeven_div2: (x:Z)(Zeven x)->`x = 2*(Zdiv2 x)`
Zodd_div2: (x:Z)`x >= 0`->(Zodd x)->`x = 2*(Zdiv2 x)+1`
>>
*)

(** Lemmas ending by Zgt *)
(**
<<
Zgt_left_rev: (x,y:Z)`x+(-y) > 0`->`x > y`
Zgt_left_gt: (x,y:Z)`x > y`->`x+(-y) > 0`
>>
*)

(** Lemmas ending by Zlt *)
(**
<<
Zlt_left_rev: (x,y:Z)`0 < y+(-x)`->`x < y`
Zlt_left_lt: (x,y:Z)`x < y`->`0 < y+(-x)`
Zlt_O_minus_lt: (n,m:Z)`0 < n-m`->`m < n`
>>
*)

(** Lemmas ending by Zle *)
(**
<<
Zle_left: (x,y:Z)`x <= y`->`0 <= y+(-x)`
Zle_left_rev: (x,y:Z)`0 <= y+(-x)`->`x <= y`
Zlt_left: (x,y:Z)`x < y`->`0 <= y+(-1)+(-x)`
Zge_left: (x,y:Z)`x >= y`->`0 <= x+(-y)`
Zgt_left: (x,y:Z)`x > y`->`0 <= x+(-1)+(-y)`
>>
*)

(** ** Conversion between nat comparisons and Z comparisons *)

(** Lemmas ending by eq *)
(**
<<
inj_eq: (x,y:nat)x=y->`(inject_nat x) = (inject_nat y)`
>>
*)

(** Lemmas ending by Zge *)
(**
<<
inj_ge: (x,y:nat)(ge x y)->`(inject_nat x) >= (inject_nat y)`
>>
*)

(** Lemmas ending by Zgt *)
(**
<<
inj_gt: (x,y:nat)(gt x y)->`(inject_nat x) > (inject_nat y)`
>>
*)

(** Lemmas ending by Zlt *)
(**
<<
inj_lt: (x,y:nat)(lt x y)->`(inject_nat x) < (inject_nat y)`
>>
*)

(** Lemmas ending by Zle *)
(**
<<
inj_le: (x,y:nat)(le x y)->`(inject_nat x) <= (inject_nat y)`
>>
*)

(** ** Conversion between comparisons *)

(** Lemmas ending by Zge *)
(**
<<
not_Zlt: (x,y:Z)~`x < y`->`x >= y`
Zle_ge: (m,n:Z)`m <= n`->`n >= m`
>>
*)

(** Lemmas ending by Zgt *)
(**
<<
Zle_gt_S: (n,p:Z)`n <= p`->`(Zs p) > n`
not_Zle: (x,y:Z)~`x <= y`->`x > y`
Zlt_gt: (m,n:Z)`m < n`->`n > m`
Zle_S_gt: (n,m:Z)`(Zs n) <= m`->`m > n`
>>
*)

(** Lemmas ending by Zlt *)
(**
<<
not_Zge: (x,y:Z)~`x >= y`->`x < y`
Zgt_lt: (m,n:Z)`m > n`->`n < m`
Zle_lt_n_Sm: (n,m:Z)`n <= m`->`n < (Zs m)`
>>
*)

(** Lemmas ending by Zle *)
(**
<<
Zlt_ZERO_pred_le_ZERO: (x:Z)`0 < x`->`0 <= (Zpred x)`
not_Zgt: (x,y:Z)~`x > y`->`x <= y`
Zgt_le_S: (n,p:Z)`p > n`->`(Zs n) <= p`
Zgt_S_le: (n,p:Z)`(Zs p) > n`->`n <= p`
Zge_le: (m,n:Z)`m >= n`->`n <= m`
Zlt_le_S: (n,p:Z)`n < p`->`(Zs n) <= p`
Zlt_n_Sm_le: (n,m:Z)`n < (Zs m)`->`n <= m`
Zlt_le_weak: (n,m:Z)`n < m`->`n <= m`
Zle_refl: (n,m:Z)`n = m`->`n <= m`
>>
*)

(** ** Irreversible simplification involving several comparaisons *)
(**    useful with clear precedences *)

(** Lemmas ending by Zlt *)
(**
<<
Zlt_le_reg :(a,b,c,d:Z)`a < b`->`c <= d`->`a+c < b+d`
Zle_lt_reg : (a,b,c,d:Z)`a <= b`->`c < d`->`a+c < b+d`
>>
*)

(** ** What is decreasing here ? *)

(** Lemmas ending by eq *)
(**
<<
Zplus_minus: (n,m,p:Z)`n = m+p`->`p = n-m`
>>
*)

(** Lemmas ending by Zgt *)
(**
<<
Zgt_pred: (n,p:Z)`p > (Zs n)`->`(Zpred p) > n`
>>
*)

(** Lemmas ending by Zlt *)
(**
<<
Zlt_pred: (n,p:Z)`(Zs n) < p`->`n < (Zpred p)`
>>
*)

(**********************************************************************)
(** *                Useful Bottom-up lemmas                          *)

(** ** Bottom-up simplification: should be used *)

(** Lemmas ending by eq *)
(**
<<
Zeq_add_S: (n,m:Z)`(Zs n) = (Zs m)`->`n = m`
Zsimpl_plus_l: (n,m,p:Z)`n+m = n+p`->`m = p`
Zplus_unit_left: (n,m:Z)`n+0 = m`->`n = m`
Zplus_unit_right: (n,m:Z)`n = m+0`->`n = m`
>>
*)

(** Lemmas ending by Zgt *)
(**
<<
Zsimpl_gt_plus_l: (n,m,p:Z)`p+n > p+m`->`n > m`
Zsimpl_gt_plus_r: (n,m,p:Z)`n+p > m+p`->`n > m`
Zgt_S_n: (n,p:Z)`(Zs p) > (Zs n)`->`p > n`
>>
*)

(** Lemmas ending by Zlt *)
(**
<<
Zsimpl_lt_plus_l: (n,m,p:Z)`p+n < p+m`->`n < m`
Zsimpl_lt_plus_r: (n,m,p:Z)`n+p < m+p`->`n < m`
Zlt_S_n: (n,m:Z)`(Zs n) < (Zs m)`->`n < m`
>>
*)

(** Lemmas ending by Zle *)
(** << Zsimpl_le_plus_l: (p,n,m:Z)`p+n <= p+m`->`n <= m`
Zsimpl_le_plus_r: (p,n,m:Z)`n+p <= m+p`->`n <= m`
Zle_S_n: (n,m:Z)`(Zs m) <= (Zs n)`->`m <= n` >> *)

(** ** Bottom-up irreversible (syntactic) simplification *)

(** Lemmas ending by Zle *)
(**
<<
Zle_trans_S: (n,m:Z)`(Zs n) <= m`->`n <= m`
>>
*)

(** ** Other unclearly simplifying lemmas *)

(** Lemmas ending by Zeq *)
(**
<<
Zmult_eq: (x,y:Z)`x <> 0`->`y*x = 0`->`y = 0`
>>
*)

(* Lemmas ending by Zgt *)
(**
<<
Zmult_gt: (x,y:Z)`x > 0`->`x*y > 0`->`y > 0`
>>
*)

(* Lemmas ending by Zlt *)
(**
<<
pZmult_lt: (x,y:Z)`x > 0`->`0 < y*x`->`0 < y`
>>
*)

(* Lemmas ending by Zle *)
(**
<<
Zmult_le: (x,y:Z)`x > 0`->`0 <= y*x`->`0 <= y`
OMEGA1: (x,y:Z)`x = y`->`0 <= x`->`0 <= y`
>>
*)

(**********************************************************************)
(** *        Irreversible lemmas with meta-variables                  *)
(** To be used by EAuto                                               *)

(* Hints Immediate *)
(** Lemmas ending by eq *)
(**
<<
Zle_antisym: (n,m:Z)`n <= m`->`m <= n`->`n = m`
>>
*)

(** Lemmas ending by Zge *)
(**
<<
Zge_trans: (n,m,p:Z)`n >= m`->`m >= p`->`n >= p`
>>
*)

(** Lemmas ending by Zgt *)
(**
<<
Zgt_trans: (n,m,p:Z)`n > m`->`m > p`->`n > p`
Zgt_trans_S: (n,m,p:Z)`(Zs n) > m`->`m > p`->`n > p`
Zle_gt_trans: (n,m,p:Z)`m <= n`->`m > p`->`n > p`
Zgt_le_trans: (n,m,p:Z)`n > m`->`p <= m`->`n > p`
>>
*)

(** Lemmas ending by Zlt *)
(**
<<
Zlt_trans: (n,m,p:Z)`n < m`->`m < p`->`n < p`
Zlt_le_trans: (n,m,p:Z)`n < m`->`m <= p`->`n < p`
Zle_lt_trans: (n,m,p:Z)`n <= m`->`m < p`->`n < p`
>>
*)

(** Lemmas ending by Zle *)
(**
<<
Zle_trans: (n,m,p:Z)`n <= m`->`m <= p`->`n <= p`
>>
*)

(**********************************************************************)
(** *               Unclear or too specific lemmas                    *)
(** Not to be used ?                                                  *)

(** ** Irreversible and too specific (not enough regular) *)

(** Lemmas ending by Zle *)
(**
<<
Zle_mult: (x,y:Z)`x > 0`->`0 <= y`->`0 <= y*x`
Zle_mult_approx: (x,y,z:Z)`x > 0`->`z > 0`->`0 <= y`->`0 <= y*x+z`
OMEGA6: (x,y,z:Z)`0 <= x`->`y = 0`->`0 <= x+y*z`
OMEGA7: (x,y,z,t:Z)`z > 0`->`t > 0`->`0 <= x`->`0 <= y`->`0 <= x*z+y*t`
>>
*)

(** ** Expansion and too specific ? *)

(** Lemmas ending by Zge *)
(**
<<
Zge_mult_simpl: (a,b,c:Z)`c > 0`->`a*c >= b*c`->`a >= b`
>>
*)

(** Lemmas ending by Zgt *)
(**
<<
Zgt_mult_simpl: (a,b,c:Z)`c > 0`->`a*c > b*c`->`a > b`
Zgt_square_simpl: (x,y:Z)`x >= 0`->`y >= 0`->`x*x > y*y`->`x > y`
>>
*)

(** Lemmas ending by Zle *)
(**
<<
Zle_mult_simpl: (a,b,c:Z)`c > 0`->`a*c <= b*c`->`a <= b`
Zmult_le_approx: (x,y,z:Z)`x > 0`->`x > z`->`0 <= y*x+z`->`0 <= y`
>>
*)

(** ** Reversible but too specific ? *)

(** Lemmas ending by Zlt *)
(**
<<
Zlt_minus: (n,m:Z)`0 < m`->`n-m < n`
>>
*)

(**********************************************************************)
(** *               Lemmas to be used as rewrite rules                *)
(** but can also be used as hints                                     *)

(** Left-to-right simplification lemmas (a symbol disappears) *)

(**
<<
Zcompare_n_S: (n,m:Z)(Zcompare (Zs n) (Zs m))=(Zcompare n m)
Zmin_n_n: (n:Z)`(Zmin n n) = n`
Zmult_1_n: (n:Z)`1*n = n`
Zmult_n_1: (n:Z)`n*1 = n`
Zminus_plus: (n,m:Z)`n+m-n = m`
Zle_plus_minus: (n,m:Z)`n+(m-n) = m`
Zopp_Zopp: (x:Z)`(-(-x)) = x`
Zero_left: (x:Z)`0+x = x`
Zero_right: (x:Z)`x+0 = x`
Zplus_inverse_r: (x:Z)`x+(-x) = 0`
Zplus_inverse_l: (x:Z)`(-x)+x = 0`
Zopp_intro: (x,y:Z)`(-x) = (-y)`->`x = y`
Zmult_one: (x:Z)`1*x = x`
Zero_mult_left: (x:Z)`0*x = 0`
Zero_mult_right: (x:Z)`x*0 = 0`
Zmult_Zopp_Zopp: (x,y:Z)`(-x)*(-y) = x*y`
>>
*)

(** Right-to-left simplification lemmas (a symbol disappears) *)

(**
<<
Zpred_Sn: (m:Z)`m = (Zpred (Zs m))`
Zs_pred: (n:Z)`n = (Zs (Zpred n))`
Zplus_n_O: (n:Z)`n = n+0`
Zmult_n_O: (n:Z)`0 = n*0`
Zminus_n_O: (n:Z)`n = n-0`
Zminus_n_n: (n:Z)`0 = n-n`
Zred_factor6: (x:Z)`x = x+0`
Zred_factor0: (x:Z)`x = x*1`
>>
*)

(** Unclear orientation (no symbol disappears) *)

(**
<<
Zplus_n_Sm: (n,m:Z)`(Zs (n+m)) = n+(Zs m)`
Zmult_n_Sm: (n,m:Z)`n*m+n = n*(Zs m)`
Zmin_SS: (n,m:Z)`(Zs (Zmin n m)) = (Zmin (Zs n) (Zs m))`
Zplus_assoc_l: (n,m,p:Z)`n+(m+p) = n+m+p`
Zplus_assoc_r: (n,m,p:Z)`n+m+p = n+(m+p)`
Zplus_permute: (n,m,p:Z)`n+(m+p) = m+(n+p)`
Zplus_Snm_nSm: (n,m:Z)`(Zs n)+m = n+(Zs m)`
Zminus_plus_simpl: (n,m,p:Z)`n-m = p+n-(p+m)`
Zminus_Sn_m: (n,m:Z)`(Zs (n-m)) = (Zs n)-m`
Zmult_plus_distr_l: (n,m,p:Z)`(n+m)*p = n*p+m*p`
Zmult_minus_distr: (n,m,p:Z)`(n-m)*p = n*p-m*p`
Zmult_assoc_r: (n,m,p:Z)`n*m*p = n*(m*p)`
Zmult_assoc_l: (n,m,p:Z)`n*(m*p) = n*m*p`
Zmult_permute: (n,m,p:Z)`n*(m*p) = m*(n*p)`
Zmult_Sm_n: (n,m:Z)`n*m+m = (Zs n)*m`
Zmult_Zplus_distr: (x,y,z:Z)`x*(y+z) = x*y+x*z`
Zmult_plus_distr: (n,m,p:Z)`(n+m)*p = n*p+m*p`
Zopp_Zplus: (x,y:Z)`(-(x+y)) = (-x)+(-y)`
Zplus_sym: (x,y:Z)`x+y = y+x`
Zplus_assoc: (x,y,z:Z)`x+(y+z) = x+y+z`
Zmult_sym: (x,y:Z)`x*y = y*x`
Zmult_assoc: (x,y,z:Z)`x*(y*z) = x*y*z`
Zopp_Zmult: (x,y:Z)`(-x)*y = (-(x*y))`
Zplus_S_n: (x,y:Z)`(Zs x)+y = (Zs (x+y))`
Zopp_one: (x:Z)`(-x) = x*(-1)`
Zopp_Zmult_r: (x,y:Z)`(-(x*y)) = x*(-y)`
Zmult_Zopp_left: (x,y:Z)`(-x)*y = x*(-y)`
Zopp_Zmult_l: (x,y:Z)`(-(x*y)) = (-x)*y`
Zred_factor1: (x:Z)`x+x = x*2`
Zred_factor2: (x,y:Z)`x+x*y = x*(1+y)`
Zred_factor3: (x,y:Z)`x*y+x = x*(1+y)`
Zred_factor4: (x,y,z:Z)`x*y+x*z = x*(y+z)`
Zminus_Zplus_compatible: (x,y,n:Z)`x+n-(y+n) = x-y`
Zmin_plus: (x,y,n:Z)`(Zmin (x+n) (y+n)) = (Zmin x y)+n`
>>
*)

(** nat <-> Z *)
(**
<<
inj_S: (y:nat)`(inject_nat (S y)) = (Zs (inject_nat y))`
inj_plus: (x,y:nat)`(inject_nat (plus x y)) = (inject_nat x)+(inject_nat y)`
inj_mult: (x,y:nat)`(inject_nat (mult x y)) = (inject_nat x)*(inject_nat y)`
inj_minus1:
 (x,y:nat)(le y x)->`(inject_nat (minus x y)) = (inject_nat x)-(inject_nat y)`
inj_minus2: (x,y:nat)(gt y x)->`(inject_nat (minus x y)) = 0`
>>
*)

(** Too specific ? *)
(**
<<
Zred_factor5: (x,y:Z)`x*0+y = y`
>>
*)


Require Import VST.floyd.proofauto.
Require Import sha.sha.
Require Import sha.SHA256.
Require Import sha.spec_sha.
Require Import sha.sha_lemmas.
Require Import sha.bdo_lemmas.
Local Open Scope logic.

Definition block_data_order_loop2 :=
   nth 1 (loops (fn_body f_sha256_block_data_order)) Sskip.

Fixpoint Xarray' (b: list int) (i k: nat) : list int :=
 match k with
 | O => nil
 | S k' => W (nthi b) (Z.of_nat i - 16 + (16-(Z.of_nat k)- Z.of_nat i) mod 16) ::
                 Xarray' b i k'
 end.

Definition Xarray (b: list int) (i: nat) := Xarray' b i 16.

Lemma Xarray_simpl:
   forall b, Zlength b = 16 -> Xarray b 16 = b.
Proof.
intros.
apply Zlength_length in H; [ simpl in H | computable].
assert (forall n, (n<=16)%nat -> Xarray' b 16 n = skipn (16-n) b);
 [ | apply H0; auto ].
induction n; intros.
clear H0. rewrite skipn_short by omega. reflexivity.

unfold Xarray'; fold Xarray'.
rewrite IHn by omega. clear IHn.
change (Z.of_nat 16) with 16%Z.

assert (H1: firstn 1 (skipn (16 - S n) b) =
            W (nthi b) (16 - 16 + (Z.of_nat (16 - S n) - 16) mod 16) :: nil). {
 unfold firstn.
 destruct (skipn (16 - S n) b) eqn:?.
 pose proof (skipn_length b (16 - S n)).
 rewrite Heql in H1.
 simpl length in H1.
 omega.
 f_equal.
 pose proof (nth_skipn 0 (16 - S n)%nat b Int.zero).
 rewrite Heql in H1.
 unfold nth at 1 in H1.
 subst.
 rewrite Z.sub_diag. rewrite Z.add_0_l.
 rewrite plus_0_l.
 rewrite Zminus_mod.
 rewrite Z.mod_same by omega. rewrite Z.sub_0_r.
 rewrite Z.mod_mod by omega.
 assert (0 <= (Z.of_nat (16 - S n))mod 16 < 16)%Z by (apply Z.mod_pos_bound; omega).
 rewrite W_equation.
 rewrite if_true by  omega.
 rewrite Z.mod_small.
 unfold nthi.
 rewrite Nat2Z.id.
 reflexivity.
 split; try omega.
 change (Z.of_nat (16 - S n) < Z.of_nat 16)%Z.
 apply Nat2Z.inj_lt.
 omega.
}
assert (H2 := skipn_skipn 1 (16 - S n) b).
replace (16 - S n + 1)%nat with (16 - n)%nat in H2 by omega.
rewrite <- H2.
rewrite <- (firstn_skipn 1 (skipn (16 - S n) b)) at 2.
rewrite H1.
unfold app.
rewrite Nat2Z.inj_sub by omega.
reflexivity.
Qed.

Lemma length_Xarray:
  forall b i, Zlength (Xarray b i) = 16.
Proof.
intros. reflexivity.
Qed.

Lemma nth_Xarray:
  forall b i k,
     (0 <= k < 16)%Z ->
  nthi (Xarray b i) k = W (nthi b) (Z.of_nat i - 16 + (k- Z.of_nat i) mod 16)%Z .
Proof.
intros.
unfold nthi at 1.
remember (Z.to_nat k) as k'.
rewrite <- (Nat2Z.id k') in Heqk'.
apply Z2Nat.inj in Heqk'; try omega.
subst k.
assert (k'<16)%nat by omega.
clear H.
do 16 (destruct k'; try reflexivity).
elimtype False; omega.
Qed.

Lemma extract_from_b:
  forall b i n,
    Zlength b = 16 ->
    (16 <= i < 64) ->
    (0 <= n < 16) ->
    nthi (Xarray b (Z.to_nat i)) ((i + n) mod 16) = W (nthi b) (i - 16 + n).
Proof.
intros.
rewrite nth_Xarray by (apply Z.mod_pos_bound; omega).
f_equal.
f_equal.
rewrite Z2Nat.id by omega. auto.
rewrite Z2Nat.id by omega.
rewrite Zminus_mod.
rewrite Zmod_mod.
rewrite Zplus_mod.
rewrite <- Zminus_mod.
rewrite (Zmod_small n) by omega.
replace (i mod 16 + n - i) with (i mod 16 - i + n) by omega.
rewrite Zplus_mod.
rewrite Zminus_mod.
rewrite Zmod_mod.
rewrite Z.sub_diag.
rewrite (Zmod_small 0) by omega.
rewrite Z.add_0_l.
repeat rewrite Zmod_mod.
apply Zmod_small; omega.
Qed.

Global Opaque Xarray.

Lemma Xarray_update:
 forall i b,
  Zlength b = LBLOCKz ->
  16 <= i < 64 ->
   upd_Znth (i mod 16) (map Vint (Xarray b (Z.to_nat i)))
          (Vint (W (nthi b) i))
  = map Vint (Xarray b (Z.to_nat i+1)).
Proof.
intros.
unfold upd_Znth.
rewrite !sublist_map.
rewrite <- !map_cons, <- !map_app.
f_equal.
repeat match type of H0 with
| (64 <= _ < _)%Z => elimtype False; omega
| (?A <= _ < _)%Z =>
 assert (H9: i=A \/ (A+1 <= i < 64)%Z) by omega;
 clear H0; destruct H9 as [H0|H0];
 [subst i; reflexivity
 | simpl in H0 ]
end.
Qed.

Lemma W_unfold:
  forall i b,
  16 <= i < 64 ->
   W (nthi b) (i) =
    Int.add (W (nthi b) (i - 16 + 0))
             (Int.add
                (Int.add (sigma_0 (W (nthi b) (i - 16 + 1)))
                   (sigma_1 (W (nthi b) (i - 16 + 14))))
                (W (nthi b) (i - 16 + 9))).
Proof.
 intros.
 rewrite W_equation.
 rewrite if_false by omega.
  rewrite Z.add_0_r;
      rewrite (Int.add_commut (W (nthi b) (i - 16)));
      repeat rewrite <- Int.add_assoc; f_equal;
      rewrite Int.add_commut; repeat rewrite Int.add_assoc; f_equal;
        [do 2 f_equal; omega | ];
      f_equal; [do 2 f_equal; omega | f_equal; omega].
Qed.

Lemma sha256_block_data_order_loop2_proof:
  forall (Espec : OracleKind)
     (b: list int) ctx (regs: list int) gv Xv
     (Hregs: length regs = 8%nat),
     Zlength b = LBLOCKz ->
     semax (func_tycontext f_sha256_block_data_order Vprog Gtot nil)
 (PROP ()
   LOCAL (temp _ctx ctx; temp _i (Vint (Int.repr 16));
               temp _a (Vint (nthi (Round regs (nthi b) (LBLOCKz-1)) 0));
               temp _b (Vint (nthi (Round regs (nthi b) (LBLOCKz-1)) 1));
               temp _c (Vint (nthi (Round regs (nthi b) (LBLOCKz-1)) 2));
               temp _d (Vint (nthi (Round regs (nthi b) (LBLOCKz-1)) 3));
               temp _e (Vint (nthi (Round regs (nthi b) (LBLOCKz-1)) 4));
               temp _f (Vint (nthi (Round regs (nthi b) (LBLOCKz-1)) 5));
               temp _g (Vint (nthi (Round regs (nthi b) (LBLOCKz-1)) 6));
               temp _h (Vint (nthi (Round regs (nthi b) (LBLOCKz-1)) 7));
               gvars gv; lvar _X (tarray tuint LBLOCKz) Xv)
   SEP ( K_vector gv;
           data_at Tsh (tarray tuint LBLOCKz) (map Vint b) Xv))
  block_data_order_loop2
  (normal_ret_assert
    (PROP ()
     LOCAL(temp _ctx ctx;
                temp _a (Vint (nthi (Round regs (nthi b) 63) 0));
                temp _b (Vint (nthi (Round regs (nthi b) 63) 1));
                temp _c (Vint (nthi (Round regs (nthi b) 63) 2));
                temp _d (Vint (nthi (Round regs (nthi b) 63) 3));
                temp _e (Vint (nthi (Round regs (nthi b) 63) 4));
                temp _f (Vint (nthi (Round regs (nthi b) 63) 5));
                temp _g (Vint (nthi (Round regs (nthi b) 63) 6));
                temp _h (Vint (nthi (Round regs (nthi b) 63) 7));
                gvars gv; lvar _X (tarray tuint LBLOCKz) Xv)
     SEP (K_vector gv;
            data_at_ Tsh (tarray tuint LBLOCKz) Xv))).
Proof.
intros.
unfold block_data_order_loop2; simpl nth.
rewrite semax_skip_seq.
match goal with
 | |- context [Ssequence ?s1 (Sloop (Ssequence (Sifthenelse ?e Sskip Sbreak) ?s2) ?s3)] =>
      fold (Sfor s1 e s2 s3)
 end.
abbreviate_semax.
change 16%nat with LBLOCK.

forward_for_simple_bound 64%Z
   (EX i:Z,
    PROP ((16 <= i)%Z )
    LOCAL  (temp _ctx ctx;
                  temp _a (Vint (nthi (Round regs (nthi b) (i - 1)) 0));
                  temp _b (Vint (nthi (Round regs (nthi b) (i - 1)) 1));
                  temp _c (Vint (nthi (Round regs (nthi b) (i - 1)) 2));
                  temp _d (Vint (nthi (Round regs (nthi b) (i - 1)) 3));
                  temp _e (Vint (nthi (Round regs (nthi b) (i - 1)) 4));
                  temp _f (Vint (nthi (Round regs (nthi b) (i - 1)) 5));
                  temp _g (Vint (nthi (Round regs (nthi b) (i - 1)) 6));
                  temp _h (Vint (nthi (Round regs (nthi b) (i - 1)) 7));
                  lvar _X (tarray tuint LBLOCKz) Xv;
                  gvars gv)
     SEP (K_vector gv;
       data_at Tsh (tarray tuint LBLOCKz) (map Vint (Xarray b (Z.to_nat i))) Xv)).
*
forward. (* skip; *)
Exists 16.
entailer!.
rewrite Xarray_simpl; auto.
*
Intros.
destruct H0 as [_ H2].
assert (H0: LBLOCKz <= i < 64) by (change LBLOCKz with 16%Z; omega).
clear H2 H1.
(*assert (H': length b = 16%nat) by (apply Zlength_length in H; auto). *)
assert (LBE := LBLOCK_zeq).
change LBLOCKz with 16%Z in H0.
change (tarray tuint LBLOCKz) with (tarray tuint 16).
change LBLOCKz with 16%Z in H.
forward.	(*s0 = X[(i+1)&0x0f]; *)
autorewrite with sublist. rewrite Zland_15.
forward. (* s0 = sigma0(s0); *)
rewrite extract_from_b by auto; rewrite Int.and_mone; rewrite <- sigma_0_eq.

forward. (* s1 = X[(i+14)&0x0f]; *)
autorewrite with sublist. rewrite Zland_15.

forward. (* s1 = sigma1(s1); *)
rewrite extract_from_b by auto; rewrite Int.and_mone; rewrite <- sigma_1_eq.

forward. (* T1 = X[i&0xf]; *)
autorewrite with sublist. rewrite Zland_15.
replace (nthi (Xarray b (Z.to_nat i)) (i mod 16))
  with (W (nthi b) (i - 16 + 0))
 by (replace (i mod 16) with ((i + 0) mod 16)
        by (rewrite Z.add_0_r; auto);
      rewrite extract_from_b; try omega; auto).

forward. (* t = X[(i+9)&0xf]; *)
autorewrite with sublist. rewrite Zland_15.
rewrite extract_from_b by (try assumption; try omega).

forward.  (* T1 += s0 + s1 + t; *)
pattern (i-16) at 1; rewrite <- (Z.add_0_r (i - 16)).
rewrite <- (W_unfold i b) by auto.

forward. (* X[i&0xf] = T1; *)
rewrite Zland_15.
rewrite Xarray_update by assumption.
unfold K_vector.
change CBLOCKz with 64%Z.
assert (LEN: Zlength K256 = 64%Z) by reflexivity.
forward.  (* Ki=K256[i]; *)
autorewrite with sublist.
rename b into bb.
assert (Hregs' := length_Round _ (nthi bb) (i-1) Hregs).
remember (Round regs (nthi bb) (i - 1)) as regs' eqn:H1.
(destruct regs' as [ | a [ | b [ | c [ | d [ | e [ | f [ | g [ | h [ | ]]]]]]]]];
  try now inversion Hregs'); [ clear Hregs' ].
change (nthi [a;b;c;d;e;f;g;h]) with (fun t => nth (Z.to_nat t) [a;b;c;d;e;f;g;h] Int.zero);
  cbv beta; simpl nth.
forward. (* T1 += h + Sigma1(e) + Ch(e,f,g) + Ki; *)
rewrite <- Sigma_1_eq, <- Ch_eq.
forward. 	(* T2 = Sigma0(a) + Maj(a,b,c); *)
rewrite <- Sigma_0_eq, <- Maj_eq.
repeat forward.
rewrite Z.add_simpl_r.
rewrite Z2Nat.inj_add by omega.
entailer!. 2: apply derives_refl.
clear - H H0 H1.
rewrite Round_equation.
forget (W (nthi bb) i) as Wbbi.
rewrite if_false by omega.
rewrite <- H1; clear H1.
unfold rnd_function, nthi; simpl.
repeat split; try reflexivity.
 +
  f_equal.
  rewrite <- Int.add_assoc; symmetry; rewrite <- Int.add_assoc.
  f_equal. f_equal.
  rewrite Int.add_commut. rewrite !Int.add_assoc. reflexivity.
 +
  f_equal. f_equal. rewrite Int.add_commut. f_equal.
*
 entailer!.
Qed.