Require Import Tactics.
Require Import Axioms.
Require Import Sigma.
Require Import Equality.
Require Import Ordinal.
Require Import Relation.
Require Import Ofe.
Require Import Syntax.
Require Import SimpSub.
Require Import Hygiene.
Require Import Uniform.
Require Import Urelsp.
Require Import Intensional.
Require Import Dynamic.
Require Import Equivalence.
Require Import Equivalences.
Require Import Candidate.
Require Import Model.
Require Import Ceiling.
Require Import Truncate.
Require Import Standard.
Require Import MapTerm.
Require Import Extend.
Require Import System.
Require Import Page.
Require Import PageCode.
Require Import Defined.

Definition kext (w : ordinal) (K : qkind) : wterm w
  :=
  match lt_ord_dec (level K) w with
  | left h =>
      ext (objin (objsome (expair K (space_inhabitant _)) h))

  | right _ =>
      arb
  end.

Definition uext (w : ordinal) {l} (A : wurel l) : wterm w
  :=
  match lt_ord_dec l w with
  | left h =>
      ext (objin (objsome (expair (qtype l) (iubase A)) h))

  | right _ => arb
  end.

Fixpoint tosp (w : ordinal) (pg : page) (K : qkind) {struct K} : wterm w :=
  match K with
  | qone =>
      lam cunit

  | qtype l =>
      lam (cty (var 0))

  | qarrow K1 K2 =>
      lam (clam (kext w K1)
             (app (tosp w pg K2)
                (app (var 1) (app (fromsp w pg K1) (var 0)))))

  | qtarrow l A K2 =>
      lam (ctlam (uext w A)
             (app (tosp w pg K2) (app (var 1) (var 0)))
             (kext w K2))

  | qprod K1 K2 =>
      lam (cpair (app (tosp w pg K1) (ppi1 (var 0))) (app (tosp w pg K2) (ppi2 (var 0))))

  | qfut K1 =>
      lam (cnext (app (tosp w pg K1) (prev (var 0))))
  end

with fromsp (w : ordinal) (pg : page) (K : qkind) {struct K} : wterm w :=
  match K with
  | qone =>
      lam triv

  | qtype l =>
      (* Should have cin pg = l, don't need to check it. *)
      lam (con (pagelit pg) (var 0))

  | qarrow K1 K2 =>
      lam (lam (app (fromsp w pg K2)
                  (capp (var 1) (app (tosp w pg K1) (var 0)))))

  | qtarrow l A K2 =>
      lam (lam (app (fromsp w pg K2)
                  (ctapp (var 1) (var 0))))

  | qprod K1 K2 =>
      lam (ppair (app (fromsp w pg K1) (cpi1 (var 0))) (app (fromsp w pg K2) (cpi2 (var 0))))

  | qfut K1 =>
      lam (next (app (fromsp w pg K1) (cprev (var 0))))
  end.

Lemma kext_hygiene :
  forall w K,
    hygiene clo (kext w K).
Proof.
intros w K.
unfold kext.
set (X := lt_ord_dec (level K) w).
destruct X; apply hygiene_auto; cbn; auto.
Qed.

Lemma uext_hygiene :
  forall w l A,
    hygiene clo (@uext w l A).
Proof.
intros w l A.
unfold uext.
set (X := lt_ord_dec l w).
destruct X; apply hygiene_auto; cbn; auto.
Qed.

Local Ltac prove_hygiene :=
  repeat (first [ apply hygiene_shift_permit
                | apply hygiene_sumbool
                | apply hygiene_auto; cbn [row_rect nat_rect]; repeat2 split; auto
                ]);
  eauto using hygiene_weaken, clo_min, hygiene_shift', hygiene_subst1, kext_hygiene, uext_hygiene, pagelit_closed;
  try (apply hygiene_var; cbn; auto; done).

Lemma tosp_fromsp_hygiene :
  forall w pg K,
    hygiene clo (tosp w pg K)
    /\ hygiene clo (fromsp w pg K).
Proof.
intros w pg K.
induct K; intros; destruct_everywhere; cbn; split;
prove_hygiene.
Qed.

Lemma tosp_hygiene :
  forall w pg K, hygiene clo (tosp w pg K).
Proof.
intros w pg K.
exact (tosp_fromsp_hygiene w pg K andel).
Qed.

Lemma fromsp_hygiene :
  forall w pg K, hygiene clo (fromsp w pg K).
Proof.
intros w pg K.
exact (tosp_fromsp_hygiene w pg K ander).
Qed.

Lemma subst_kext :
  forall w s K, subst s (kext w K) = kext w K.
Proof.
intros.
unfold kext.
set (X := lt_ord_dec (level K) w).
destruct X; auto.
Qed.

Lemma subst_uext :
  forall w s l A, subst s (@uext w l A) = uext w A.
Proof.
intros.
unfold uext.
set (X := lt_ord_dec l w).
destruct X; auto.
Qed.

Lemma subst_tosp :
  forall w s pg K, subst s (tosp w pg K) = tosp w pg K.
Proof.
intros w s pg K.
apply subst_into_closed.
apply tosp_hygiene.
Qed.

Lemma subst_fromsp :
  forall w s pg K, subst s (fromsp w pg K) = fromsp w pg K.
Proof.
intros w s pg K.
apply subst_into_closed.
apply fromsp_hygiene.
Qed.

Hint Rewrite subst_kext subst_uext subst_tosp subst_fromsp : subst.

Lemma extend_kext :
  forall v w K,
    level K << v
    -> level K << w
    -> map_term (extend v w) (kext v K) = kext w K.
Proof.
intros v w K h h'.
unfold kext.
rewrite -> (lt_ord_dec_is _ _ h).
rewrite -> (lt_ord_dec_is _ _ h').
simpmap.
rewrite -> (extend_some v w (expair K (space_inhabitant K)) h h').
reflexivity.
Qed.

Lemma extend_uext :
  forall v w u (A : wurel u),
    u << v
    -> u << w
    -> map_term (extend v w) (uext v A) = uext w A.
Proof.
intros v w u A h h'.
unfold uext.
rewrite -> (lt_ord_dec_is _ _ h).
rewrite -> (lt_ord_dec_is _ _ h').
simpmap.
rewrite -> (extend_some v w (expair (qtype u) (iubase A)) h h').
reflexivity.
Qed.

Lemma extend_tosp_fromsp :
  forall v w pg K,
    (level K << v -> level K << w -> map_term (extend v w) (tosp v pg K) = tosp w pg K)
    /\ (level K << v -> level K << w -> map_term (extend v w) (fromsp v pg K) = fromsp w pg K).
Proof.
intros v w pg K.
induct K; split; cbn [fromsp tosp]; destruct_everywhere; try (simpmap; reflexivity); revert_all.

(* arrow tosp *)
{
intros v w pg K _ IH1 L IH2 _ Hlevv Hlevw.
cbn in Hlevv, Hlevw.
so (max_ord_lub_strict_l _#3 Hlevv) as HlevKv.
so (max_ord_lub_strict_r _#3 Hlevv) as HlevLv.
so (max_ord_lub_strict_l _#3 Hlevw) as HlevKw.
so (max_ord_lub_strict_r _#3 Hlevw) as HlevLw.
simpmap.
f_equal.
f_equal.
  {
  apply extend_kext; auto.
  }
f_equal; auto.
f_equal.
f_equal; auto.
}

(* arrow fromsp *)
{
intros v w pg K IH1 _ L _ IH2 Hlevv Hlevw.
cbn in Hlevv, Hlevw.
so (max_ord_lub_strict_l _#3 Hlevv) as HlevKv.
so (max_ord_lub_strict_r _#3 Hlevv) as HlevLv.
so (max_ord_lub_strict_l _#3 Hlevw) as HlevKw.
so (max_ord_lub_strict_r _#3 Hlevw) as HlevLw.
simpmap.
f_equal.
f_equal.
f_equal; auto.
f_equal.
f_equal; auto.
}

(* tarrow tosp *)
{
intros v w pg u A K IH1 IH2 Hlevv Hlevw.
cbn in Hlevv, Hlevw.
so (max_ord_lub_strict_l _#3 Hlevv) as Huv.
so (max_ord_lub_strict_r _#3 Hlevv) as HlevKv.
so (max_ord_lub_strict_l _#3 Hlevw) as Huw.
so (max_ord_lub_strict_r _#3 Hlevw) as HlevKw.
simpmap.
f_equal.
f_equal; auto using extend_uext, extend_kext.
f_equal; auto.
}

(* tarrow fromsp *)
{
intros v w pg u A K IH1 IH2 Hlevv Hlevw.
cbn in Hlevv, Hlevw.
so (max_ord_lub_strict_l _#3 Hlevv) as Huv.
so (max_ord_lub_strict_r _#3 Hlevv) as HlevKv.
so (max_ord_lub_strict_l _#3 Hlevw) as Huw.
so (max_ord_lub_strict_r _#3 Hlevw) as HlevKw.
simpmap.
f_equal.
f_equal.
f_equal; auto.
}

(* prod tosp *)
{
intros v w pg K IH1 _ L IH2 _ Hlevv Hlevw.
cbn in Hlevv, Hlevw.
so (max_ord_lub_strict_l _#3 Hlevv) as HlevKv.
so (max_ord_lub_strict_r _#3 Hlevv) as HlevLv.
so (max_ord_lub_strict_l _#3 Hlevw) as HlevKw.
so (max_ord_lub_strict_r _#3 Hlevw) as HlevLw.
simpmap.
f_equal.
rewrite -> IH1; auto.
rewrite -> IH2; auto.
}

(* prod fromsp *)
{
intros v w pg K _ IH1 L _ IH2 Hlevv Hlevw.
cbn in Hlevv, Hlevw.
so (max_ord_lub_strict_l _#3 Hlevv) as HlevKv.
so (max_ord_lub_strict_r _#3 Hlevv) as HlevLv.
so (max_ord_lub_strict_l _#3 Hlevw) as HlevKw.
so (max_ord_lub_strict_r _#3 Hlevw) as HlevLw.
simpmap.
f_equal.
rewrite -> IH1; auto.
rewrite -> IH2; auto.
}

(* fut tosp *)
{
intros v w pg K IH1 IH2 Hlevv Hlevw.
cbn in Hlevv, Hlevw.
simpmap.
f_equal.
f_equal.
f_equal; auto.
}

(* fut fromsp *)
{
intros v w pg K IH1 IH2 Hlevv Hlevw.
cbn in Hlevv, Hlevw.
simpmap.
f_equal.
f_equal.
f_equal; auto.
}
Qed.

Lemma extend_tosp :
  forall v w pg K,
    level K << v
    -> level K << w
    -> map_term (extend v w) (tosp v pg K) = tosp w pg K.
Proof.
intros v w pg K Hv Hw.
exact (extend_tosp_fromsp v w pg K andel Hv Hw).
Qed.

Lemma extend_fromsp :
  forall v w pg K,
    level K << v
    -> level K << w
    -> map_term (extend v w) (fromsp v pg K) = fromsp w pg K.
Proof.
intros v w pg K Hv Hw.
exact (extend_tosp_fromsp v w pg K ander Hv Hw).
Qed.


(*! Branchless utf-8 decoder, from https://github.com/skeeto/branchless-utf8 !*)
Require Import
        Rupicola.Lib.Api
        Rupicola.Lib.Arrays
        Rupicola.Lib.InlineTables
        Rupicola.Lib.WordNotations
        Rupicola.Examples.Utf8.Utils.

Definition masks :=
  Eval cbv in List.map byte.of_Z [0x00; 0x7f; 0x1f; 0x0f; 0x07].
Definition mins :=
  Eval cbv in List.map byte.of_Z [4194304; 0; 128; 2048; 65536].
Definition shiftc :=
  Eval cbv in List.map byte.of_Z [0; 18; 12; 6; 0].
Definition shifte :=
  Eval cbv in List.map byte.of_Z [0; 6; 4; 2; 0].

Notation f x := (@F 5 x).
Definition lengths : list (Fin.t 5) :=
  Eval cbv in
    [f 1; f 1; f 1; f 1; f 1; f 1; f 1; f 1; f 1; f 1; f 1; f 1; f 1; f 1; f 1; f 1;
     f 0; f 0; f 0; f 0; f 0; f 0; f 0; f 0; f 2; f 2; f 2; f 2; f 3; f 3; f 4; f 0].

Definition utf8_decode (ptr: word) (bs: list byte) : word * word * word :=
  let/n b0 := ListArray.get bs 0 in
  let/n len := InlineTable.get lengths (b0 >>w 3) in

  let/n ptr := ptr +w len +w (len ==w 0) in

  let/n mask := InlineTable.get masks len in
  let/n c := (b0 &w mask) <<w 18 in
  let/n b1 := ListArray.get bs 1 in
  let/n c := c |w (b1 &w 0x3f) <<w 12 in
  let/n b2 := ListArray.get bs 2 in
  let/n c := c |w (b2 &w 0x3f) <<w 6 in
  let/n b3 := ListArray.get bs 3 in
  let/n c := c |w (b3 &w 0x3f) <<w 0 in

  let/n shiftc := InlineTable.get shiftc len in
  let/n c := c >>w shiftc in

  let/n min := InlineTable.get mins len in
  let/n e := (c <w min) <<w 6 in
  let/n e := e |w ((c >>w 11) ==w 0x1b) <<w 7 in
  let/n e := e |w (0x10FFFF <w c) <<w 8 in
  let/n e := e |w (b1 &w 0xc0) >>w 2 in
  let/n e := e |w (b2 &w 0xc0) >>w 4 in
  let/n e := e |w (b3       ) >>w 6 in
  let/n e := e ^w 0x2a in

  let/n shifte := InlineTable.get shifte len in
  let/n e := e >>w shifte in

  (c, e, ptr).

Instance spec_of_utf8_decode : spec_of "utf8_decode" :=
  fnspec! "utf8_decode" data_ptr / (data : list byte) R ~> c e ptr,
    { requires tr mem :=
        Z.of_nat (length data) >= 4 /\
        (listarray_value AccessByte data_ptr data * R)%sep mem;
      ensures tr' mem' :=
        tr' = tr /\
        (c, e, ptr) = utf8_decode data_ptr data /\
        (listarray_value AccessByte data_ptr data * R)%sep mem' }.

Import UnsizedListArrayCompiler.

Hint Rewrite @word_of_byte_of_fin : compiler_side_conditions.
#[local] Hint Resolve Fin_to_nat_lt : compiler_side_conditions.
#[local] Hint Extern 1 => simple apply word_of_byte_sru_lt : compiler_side_conditions.
#[local] Hint Extern 10 => cbn; lia : compiler_side_conditions.

Derive utf8_decode_br2fn SuchThat
       (defn! "utf8_decode" ("data") ~> "c", "e", "ptr"
         { utf8_decode_br2fn },
         implements utf8_decode)
       As utf8_decode_br2fn_ok.
Proof.
  Time compile.
Time Qed.

Definition utf8_decode_cbytes := Eval vm_compute in
  list_byte_of_string (ToCString.c_module
    [("dummy_main_to_make_impl_get_inlined", ([], [], cmd.skip));
     utf8_decode_br2fn]).


From LogRel.AutoSubst Require Import core unscoped Ast Extra.
From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening GenericTyping LogicalRelation DeclarativeTyping DeclarativeInstance Validity.
From LogRel.LogicalRelation Require Import Induction Irrelevance Escape Reflexivity Weakening Neutral Transitivity Reduction Application Universe SimpleArr.
From LogRel.Substitution Require Import Irrelevance Properties Conversion SingleSubst Reflexivity.
From LogRel.Substitution.Introductions Require Import Universe Pi SimpleArr Var.

Set Universe Polymorphism.

Section Nat.
Context `{GenericTypingProperties}.

Set Printing Primitive Projection Parameters.

Lemma natRed {Γ l} : [|- Γ] -> [Γ ||-<l> tNat].
Proof.
  intros; eapply LRNat_; constructor; eapply redtywf_refl; gen_typing.
Defined.

Lemma natValid {Γ l} (VΓ : [||-v Γ]) : [Γ ||-v<l> tNat | VΓ].
Proof.
  unshelve econstructor; intros.
  + now eapply natRed.
  + cbn; constructor; eapply redtywf_refl; gen_typing.
Defined.

Lemma natconvValid {Γ l} (VΓ : [||-v Γ]) (VNat : [Γ ||-v<l> tNat | VΓ]) :
  [Γ ||-v<l> tNat ≅ tNat | VΓ | VNat].
Proof.
  constructor; intros.
  enough [Δ ||-<l> tNat ≅ tNat | natRed wfΔ] by irrelevance.
  constructor; cbn; eapply redtywf_refl; gen_typing.
Qed.

Lemma redUOne {Γ} : [|- Γ] -> [Γ ||-U<one> U].
Proof.
  intros ; econstructor; [easy| gen_typing|eapply redtywf_refl; gen_typing].
Defined.

Lemma natTermRed {Δ} (wfΔ : [|-Δ]) : [Δ ||-<one> tNat : U | LRU_ (redUOne wfΔ)].
Proof.
  econstructor.
  + eapply redtmwf_refl; gen_typing.
  + constructor.
  + now apply tm_nf_nat.
  + gen_typing.
  + now eapply (natRed (l:= zero)).
Defined.

Lemma natTermValid {Γ} (VΓ : [||-v Γ]):  [Γ ||-v<one> tNat : U | VΓ | UValid VΓ].
Proof.
  constructor; intros.
  - eapply natTermRed.
  - eexists (natTermRed wfΔ) (natTermRed wfΔ) (natRed wfΔ); cbn.
    + gen_typing.
    + now eapply (natRed (l:=zero)).
    + constructor; eapply redtywf_refl; gen_typing.
Qed.

Lemma zeroRed {Γ l} {NN : [Γ ||-Nat tNat]} (wfΓ : [|- Γ]): [Γ ||-<l> tZero : _ | LRNat_ l NN].
Proof.
  exists tZero.
  1,2: gen_typing.
  constructor.
Defined.

Lemma zeroRedEq {Γ l} {NN : [Γ ||-Nat tNat]} (wfΓ : [|- Γ]): [Γ ||-<l> tZero ≅ tZero : _ | LRNat_ l NN].
Proof.
  exists tZero tZero.
  1-3: gen_typing.
  constructor.
Defined.

Lemma zeroValid {Γ l} (VΓ : [||-v Γ]):
  [Γ ||-v<l> tZero : tNat | VΓ | natValid VΓ].
Proof.
  constructor; intros; cbn; [unshelve eapply zeroRed| unshelve eapply zeroRedEq]; tea.
Qed.

Lemma succRed {Γ l n} {NN : [Γ ||-Nat tNat]} :
  [Γ ||-<l> n : _ | LRNat_ l NN] ->
  [Γ ||-<l> tSucc n : _ | LRNat_ l NN].
Proof.
  intros Rn; exists (tSucc n).
  + eapply redtmwf_refl; eapply ty_succ; now escape.
  + eapply convtm_succ; eapply escapeEqTerm; now eapply LREqTermRefl_.
  + now constructor.
Defined.

Lemma succRedEq {Γ l n n'} {NN : [Γ ||-Nat tNat]} :
  [Γ ||-<l> n : _ | LRNat_ l NN] ->
  [Γ ||-<l> n' : _ | LRNat_ l NN] ->
  [Γ ||-<l> n ≅ n' : _ | LRNat_ l NN] ->
  [Γ ||-<l> tSucc n ≅ tSucc n' : _ | LRNat_ l NN].
Proof.
  intros ???; escape; exists (tSucc n) (tSucc n').
  1,2: eapply redtmwf_refl; now eapply ty_succ.
  + now eapply convtm_succ.
  + now constructor.
Defined.

Lemma succRedInv {Γ l n} {NN : [Γ ||-Nat tNat]} :
  [Γ ||-<l> tSucc n : _ | LRNat_ l NN] ->
  [Γ ||-<l> n : _ | LRNat_ l NN].
Proof.
  intros RSn; inversion RSn; subst.
  unshelve epose proof (redtmwf_whnf red _). 1: constructor.
  subst. inversion prop; subst; tea.
  match goal with H : [ _ ||-NeNf _ : _] |- _ => destruct H; apply tm_ne_whne in ne; inv_whne end.
Qed.

Lemma succValid {Γ l n} (VΓ : [||-v Γ])
  (Vn : [Γ ||-v<l> n : tNat | VΓ | natValid VΓ]) :
  [Γ ||-v<l> tSucc n : tNat | VΓ | natValid VΓ].
Proof.
  constructor; intros; cbn.
  - instValid Vσ ; now unshelve eapply succRed.
  - instAllValid Vσ Vσ' Vσσ'; now unshelve eapply succRedEq.
Qed.

Lemma succcongValid {Γ l n n'} (VΓ : [||-v Γ])
  (Vn : [Γ ||-v<l> n : tNat | VΓ | natValid VΓ])
  (Vn' : [Γ ||-v<l> n' : tNat | VΓ | natValid VΓ])
  (Veqn : [Γ ||-v<l> n ≅ n' : tNat | VΓ | natValid VΓ]) :
  [Γ ||-v<l> tSucc n ≅ tSucc n' : tNat | VΓ | natValid VΓ].
Proof.
  constructor; intros; cbn; instValid Vσ; now unshelve eapply succRedEq.
Qed.

Lemma red_natElimSubst {Γ l P hz hs n n'} :
  [|- Γ] ->
  [Γ ,, tNat |- P] ->
  [Γ |- hz : P[tZero..]] ->
  [Γ |- hs : elimSuccHypTy P] ->
  [Γ |- n :⇒*: n' : tNat ] ->
  forall (RN : [Γ ||-<l> tNat]),
  [Γ ||-<l> n' : tNat | RN] ->
  (forall t t',
    [Γ ||-<l> t : tNat | RN] ->
    [Γ ||-<l> t' : tNat | RN] ->
    [Γ ||-<l> t ≅ t' : tNat | RN] ->
    [Γ |- P[t..] ≅ P[t'..]]) ->
  [Γ |- tNatElim P hz hs n :⇒*: tNatElim P hz hs n' : P[n..]].
Proof.
  intros hΓ hp hhz hhs red rN rn' congP.
  generalize (tmr_wf_red _ _ _ _ red).
  escape.
  assert ([rN | Γ ||- n : tNat]).
  { now eapply redwfSubstTerm. }
  assert ([ Γ |- P[n..] ≅ P[n'..]]).
  { apply congP; [assumption|assumption|].
    now eapply redwfSubstTerm. }
  intros.
  econstructor.
  - eapply ty_conv; [|now symmetry].
    escape; apply ty_natElim; tea.
  - apply redtm_natelim; tea.
    + now eapply redtm_ty_src.
    + intros u Hu.
      assert ([Γ |-[ ta ] u :⇒*: n' : tNat]).
      { now constructor. }
      apply congP; [eassumption| |].
      * eapply redwfSubstTerm; [exact rn'|assumption].
      * now eapply LRTmEqSym, redwfSubstTerm.
Qed.

Lemma arr_subst_eq {A B σ} : (arr A B)[σ] = arr A[σ] B[σ].
Proof. now bsimpl. Qed.

Lemma shift_up_eq {t σ} : t⟨↑⟩[up_term_term σ] = t[σ]⟨↑⟩.
Proof. now bsimpl. Qed.

Lemma up_single_subst {t σ u} : t[up_term_term σ][u..] = t[u .:  σ].
Proof.  now bsimpl. Qed.

Lemma up_liftSubst_eq {σ t u} : t[up_term_term σ][u]⇑ = t[u .: ↑ >> up_term_term σ].
Proof.
  bsimpl. eapply ext_term; intros [|n]; cbn.
  1: reflexivity.
  unfold funcomp; now rewrite  rinstInst'_term.
Qed.

Lemma elimSuccHypTy_subst {P} σ :
  elimSuccHypTy P[up_term_term σ] = (elimSuccHypTy P)[σ].
Proof.
  unfold elimSuccHypTy.
  cbn. rewrite shift_up_eq.
  rewrite liftSubstComm. cbn.
  now rewrite up_liftSubst_eq.
Qed.

Lemma liftSubst_singleSubst_eq {t u v: term} : t[u]⇑[v..] = t[u[v..]..].
Proof. now bsimpl. Qed.

Definition natElim {Γ A} (P hz hs : term) {n} {NA : [Γ ||-Nat A]} (p : NatProp NA n) : term.
Proof.
  destruct p.
  - exact hz.
  - exact (tApp (tApp hs n) (tNatElim P hz hs n)).
  - exact (tNatElim P hz hs ne).
Defined.

Section NatElimRed.
  Context {Γ l P hs hz}
    (wfΓ : [|- Γ])
    (NN : [Γ ||-Nat tNat])
    (RN := LRNat_ _ NN)
    (RP : [Γ,, tNat ||-<l> P])
    (RPpt : forall n, [Γ ||-<l> n : _ | RN] -> [Γ ||-<l> P[n..]])
    (RPext : forall n n' (Rn : [Γ ||-<l> n : _ | RN]),
      [Γ ||-<l> n' : _ | RN] ->
      [Γ ||-<l> n ≅ n' : _ | RN] ->
      [Γ ||-<l> P[n..] ≅ P[n'..] | RPpt _ Rn])
    (RPz := RPpt _ (zeroRed wfΓ))
    (Rhz : [Γ ||-<l> hz : P[tZero..] | RPz])
    (RPs : [Γ ||-<l> elimSuccHypTy P])
    (Rhs : [Γ ||-<l> hs : _ | RPs]).

  Definition natRedElimStmt :=
    (forall n (Rn : [Γ ||-<l> n : _ | RN]),
      [Γ ||-<l> tNatElim P hz hs n : _ | RPpt _ Rn ] ×
      [Γ ||-<l> tNatElim P hz hs n ≅ tNatElim P hz hs (NatRedTm.nf Rn) : _ | RPpt _ Rn]) ×
    (forall n (Nn : NatProp NN n) (Rn : [Γ ||-<l> n : _ | RN]),
      [Γ ||-<l> tNatElim P hz hs n : _ | RPpt _ Rn ] ×
      [Γ ||-<l> tNatElim P hz hs n ≅ natElim P hz hs Nn : _ | RPpt _ Rn]).

  Lemma natElimRedAux : natRedElimStmt.
  Proof.
    escape.
    apply NatRedInduction.
    - intros ? nf red ? nfprop ih.
      assert [Γ ||-<l> nf : _ | RN]. 1:{
        econstructor; tea.
        eapply redtmwf_refl; gen_typing.
      }
      eapply redwfSubstTerm.
      + eapply LRTmRedConv.
        2: unshelve eapply ih; tea.
        eapply RPext.
        2: eapply LRTmEqSym.
        1,2: eapply redwfSubstTerm; tea.
      + eapply red_natElimSubst; tea.
        intros; eapply escapeEq; now eapply RPext.
    - intros.
      eapply redSubstTermOneStep.
      1: eapply osredtm_natElimZero; tea.
      irrelevance.
    - intros n Rn ih RSucc; change [Γ ||-<l> n : tNat | RN] in Rn.
      eapply redSubstTermOneStep.
      1: eapply osredtm_natElimSucc; tea.
      1: now escape.
      eapply simple_appTerm.
      2: eapply ih.
      irrelevance0.
      2: unshelve eapply (appTerm RPs Rhs Rn).
      now bsimpl.
    - intros ? [] ?.
      apply reflect.
      + apply completeness.
      + eapply tm_ne_natelim; now first [eassumption|eapply reifyType|eapply reifyTerm].
      + eapply tm_ne_natelim; now first [eassumption|eapply reifyType|eapply reifyTerm].
      + now eapply ty_natElim.
      + now eapply ty_natElim.
      + eapply convneu_natElim; tea.
        { eapply escapeEq, LRTyEqRefl_. }
        { eapply escapeEqTerm; now eapply LREqTermRefl_. }
        { eapply escapeEqTerm; now eapply LREqTermRefl_. }
    Unshelve.
    * tea.
    * eapply ArrRedTy; now eapply RPpt.
    * rewrite arr_subst_eq. eapply ArrRedTy.
      2: rewrite liftSubst_singleSubst_eq; cbn.
      all: now eapply RPpt.
    * exact l.
    * assumption.
  Qed.

  Lemma natElimRed : forall n (Rn : [Γ ||-<l> n : _ | RN]), [Γ ||-<l> tNatElim P hz hs n : _ | RPpt _ Rn ].
  Proof. intros. apply (fst natElimRedAux). Qed.
End NatElimRed.

Section NatElimRedEq.
  Context {Γ l P Q hs hs' hz hz'}
    (wfΓ : [|- Γ])
    (NN : [Γ ||-Nat tNat])
    (RN := LRNat_ _ NN)
    (RP : [Γ,, tNat ||-<l> P])
    (RQ : [Γ,, tNat ||-<l> Q])
    (eqPQ : [Γ,, tNat |- P ≅ Q])
    (RPpt : forall n, [Γ ||-<l> n : _ | RN] -> [Γ ||-<l> P[n..]])
    (RQpt : forall n, [Γ ||-<l> n : _ | RN] -> [Γ ||-<l> Q[n..]])
    (RPQext : forall n n' (Rn : [Γ ||-<l> n : _ | RN]),
      [Γ ||-<l> n' : _ | RN] ->
      [Γ ||-<l> n ≅ n' : _ | RN] ->
      [Γ ||-<l> P[n..] ≅ Q[n'..] | RPpt _ Rn])
    (RPz := RPpt _ (zeroRed wfΓ))
    (RQz := RQpt _ (zeroRed wfΓ))
    (Rhz : [Γ ||-<l> hz : P[tZero..] | RPz])
    (RQhz : [Γ ||-<l> hz' : Q[tZero..] | RQz])
    (RPQhz : [Γ ||-<l> hz ≅ hz' : _ | RPz])
    (RPs : [Γ ||-<l> elimSuccHypTy P])
    (RQs : [Γ ||-<l> elimSuccHypTy Q])
    (Rhs : [Γ ||-<l> hs : _ | RPs])
    (RQhs : [Γ ||-<l> hs' : _ | RQs])
    (RPQhs : [Γ ||-<l> hs ≅ hs' : _ | RPs ])
    .

  Lemma RPext : forall n n' (Rn : [Γ ||-<l> n : _ | RN]),
      [Γ ||-<l> n' : _ | RN] ->
      [Γ ||-<l> n ≅ n' : _ | RN] ->
      [Γ ||-<l> P[n..] ≅ P[n'..] | RPpt _ Rn].
  Proof.
    intros. eapply transEq; [| eapply LRTyEqSym ]; eapply RPQext; cycle 1; tea.
    now eapply LREqTermRefl_.
    Unshelve. 3,4: eauto. tea.
  Qed.

  Lemma natElimRedAuxLeft : @natRedElimStmt _ _ P hs hz NN RPpt.
  Proof.
    eapply natElimRedAux; tea.
    + eapply RPext.
  Qed.

  Lemma natElimRedAuxRight : @natRedElimStmt _ _ Q hs' hz' NN RQpt.
  Proof.
    eapply natElimRedAux; tea.
    + intros. eapply transEq; [eapply LRTyEqSym |]; eapply RPQext; cycle 1; tea.
      now eapply LREqTermRefl_.
    Unshelve. 2: eauto. all:tea.
  Qed.

  Lemma natElimRedEqAux :
    (forall n n' (Rnn' : [Γ ||-<l> n ≅ n' : _ | RN]) (Rn : [Γ ||-<l> n : _ | RN]) (Rn' : [Γ ||-<l> n' : _ | RN]),
      [Γ ||-<l> tNatElim P hz hs n ≅ tNatElim Q hz' hs' n' : _ | RPpt _ Rn ]) ×
    (forall n n' (Rnn' : NatPropEq NN n n') (Rn : [Γ ||-<l> n : _ | RN]) (Rn' : [Γ ||-<l> n' : _ | RN]),
      [Γ ||-<l> tNatElim P hz hs n ≅ tNatElim Q hz' hs' n' : _ | RPpt _ Rn ]).
  Proof.
    apply NatRedEqInduction.
    - intros ?? nfL nfR redL redR ? prop ih RL RR; destruct (NatPropEq_whnf prop).
      assert [Γ ||-<l> nfL : _ | RN] by (eapply redTmFwd; cycle 1; tea).
      assert [Γ ||-<l> nfR : _ | RN] by (eapply redTmFwd; cycle 1; tea).
      eapply LREqTermHelper.
      * eapply (fst natElimRedAuxLeft).
      * eapply (fst natElimRedAuxRight).
      * eapply RPQext. 1: tea.
        now econstructor.
      * eapply LRTmEqRedConv.
        + eapply RPext; tea.
          eapply LRTmEqSym; eapply redwfSubstTerm; cycle 1; tea.
        + unshelve erewrite (redtmwf_det _ _ _ _ _ _ _ _ (NatRedTm.red RL) redL); tea.
          1: dependent inversion RL; subst; cbn; now eapply NatProp_whnf.
          unshelve erewrite (redtmwf_det _ _ _ _ _ _ _ _ (NatRedTm.red RR) redR); tea.
          1: dependent inversion RR; subst; cbn; now eapply NatProp_whnf.
          now eapply ih.
        Unshelve. tea.
    - intros. eapply LREqTermHelper.
      * unshelve eapply (snd natElimRedAuxLeft); constructor.
      * unshelve eapply (snd natElimRedAuxRight); tea; constructor.
      * eapply RPQext; [unshelve eapply zeroRed| unshelve eapply zeroRedEq]; tea.
      * cbn; irrelevance.
    - intros ??? ih Rn Rn'. pose proof (succRedInv Rn); pose proof (succRedInv Rn').
      eapply LREqTermHelper.
      * unshelve eapply (snd natElimRedAuxLeft); now constructor.
      * unshelve eapply (snd natElimRedAuxRight); tea; now constructor.
      * eapply RPQext; [unshelve eapply succRed| unshelve eapply succRedEq]; tea.
      * cbn.
        eapply simple_appcongTerm.
        4: now eapply ih.
        + irrelevance0. 2: eapply appcongTerm; tea.
          now bsimpl.
        + eapply (fst natElimRedAuxLeft).
        + eapply LRTmRedConv. 2: eapply (fst natElimRedAuxRight).
          eapply LRTyEqSym; now eapply RPQext.
        Unshelve. 2,4,5: tea.
        1: eapply ArrRedTy; now eapply RPpt.
        rewrite arr_subst_eq. eapply ArrRedTy.
        2: rewrite liftSubst_singleSubst_eq; cbn.
        all: now eapply RPpt.
    - intros ?? neueq ??. escape. inversion neueq.
      assert [Γ |- P[ne..] ≅ Q[ne'..]]. 1:{
        eapply escapeEq. eapply RPQext; tea.
        econstructor.
        1,2: now eapply redtmwf_refl.
        2: now constructor.
        gen_typing.
      }
      eapply neuTermEq.
      + eapply tm_ne_natelim; now first [eassumption|eapply reifyType|eapply reifyTerm].
      + eapply tm_ne_conv; [|now eapply escape|symmetry; eassumption].
        eapply tm_ne_natelim; now first [eassumption|eapply reifyType|eapply reifyTerm].
      + eapply ty_natElim; tea.
      + eapply ty_conv.
        1: eapply ty_natElim; tea.
        now symmetry.
      + eapply convneu_natElim ; tea.
      Unshelve. tea.
  Qed.

  Lemma natElimRedEq :
    (forall n n' (Rnn' : [Γ ||-<l> n ≅ n' : _ | RN]) (Rn : [Γ ||-<l> n : _ | RN]) (Rn' : [Γ ||-<l> n' : _ | RN]),
      [Γ ||-<l> tNatElim P hz hs n ≅ tNatElim Q hz' hs' n' : _ | RPpt _ Rn ]).
  Proof. apply natElimRedEqAux. Qed.
End NatElimRedEq.

Section NatElimValid.
  Context {Γ l P}
    (VΓ : [||-v Γ])
    (VN := natValid (l:=l) VΓ)
    (VΓN := validSnoc VΓ VN)
    (VP : [Γ ,, tNat ||-v<l> P | VΓN]).

  Lemma elimSuccHypTyValid :
    [Γ ||-v<l> elimSuccHypTy P | VΓ].
  Proof.
    unfold elimSuccHypTy.
    unshelve eapply PiValid.
    1: exact VN.
    eapply simpleArrValid; tea.
    eapply substLiftS; tea.
    eapply irrelevanceTm.
    eapply succValid.
    eapply irrelevanceTm.
    change tNat with tNat⟨@wk1 Γ tNat⟩ at 2.
    eapply var0Valid.
    Unshelve. all: tea.
  Qed.

  Context {hz hs}
    (VPz := substS VP (zeroValid VΓ))
    (Vhz : [Γ ||-v<l> hz : P[tZero..] | VΓ | VPz])
    (Vhs : [Γ ||-v<l> hs : _ | VΓ | elimSuccHypTyValid]).

  Lemma natElimValid {n}
    (Vn : [Γ ||-v<l> n : tNat | VΓ | VN])
    (VPn := substS VP Vn)
    : [Γ ||-v<l> tNatElim P hz hs n : _ | VΓ | VPn].
  Proof.
    constructor; intros.
    - instValid Vσ; cbn.
      irrelevance0.  1: now rewrite singleSubstComm'.
      epose proof (Vuσ := liftSubstS' VN Vσ).
      instValid Vuσ; escape.
      unshelve eapply natElimRed; tea.
      + intros m Rm.
        rewrite up_single_subst.
        unshelve eapply validTy; cycle 1; tea.
        unshelve econstructor; [now bsimpl| now cbn].
      + rewrite elimSuccHypTy_subst. eapply validTy; tea; eapply elimSuccHypTyValid.
      + intros m m' Rm Rm' Rmm'; cbn.
        irrelevance0. 1: now rewrite up_single_subst.
        rewrite up_single_subst.
        unshelve eapply validTyExt; cycle 1 ; tea.
        1,2: unshelve econstructor; [now bsimpl| now cbn].
        unshelve econstructor; [|now cbn].
        bsimpl; cbn; eapply reflSubst.
      + irrelevance.
      + irrelevance. now rewrite elimSuccHypTy_subst.
    - instAllValid Vσ Vσ' Vσσ'.
      irrelevance0.  1: now rewrite singleSubstComm'.
      pose (Vuσ := liftSubstS' VN Vσ).
      pose proof (Vuσ' := liftSubstS' VN Vσ').
      pose proof (Vuσrea :=  liftSubstSrealign' VN Vσσ' Vσ').
      pose proof (Vuσσ' := liftSubstSEq' VN Vσσ').
      instValid Vuσ'; instAllValid Vuσ Vuσrea Vuσσ'; escape.
      unshelve eapply natElimRedEq; tea; fold subst_term.
      6-11: irrelevance; now rewrite elimSuccHypTy_subst.
      3,4: rewrite elimSuccHypTy_subst; eapply validTy; tea; eapply elimSuccHypTyValid.
      + intros m Rm.
        rewrite up_single_subst.
        unshelve eapply validTy; cycle 1; tea.
        unshelve econstructor; [now bsimpl| now cbn].
      + intros m Rm.
        rewrite up_single_subst.
        unshelve eapply validTy; cycle 1; tea.
        unshelve econstructor; [now bsimpl| now cbn].
      + intros m m' Rm Rm' Rmm'; cbn.
        irrelevance0. 1: now rewrite up_single_subst.
        rewrite up_single_subst.
        unshelve eapply validTyExt; cycle 1 ; tea.
        1,2: unshelve econstructor; [now bsimpl| now cbn].
        unshelve econstructor; [|now cbn].
        now bsimpl.
  Qed.

  Lemma natElimZeroValid  :
    [Γ ||-v<l> tNatElim P hz hs tZero ≅ hz : _ | VΓ | VPz].
  Proof.
    constructor; intros.
    epose proof (Vuσ := liftSubstS' VN Vσ).
    instValid Vσ; instValid Vuσ; escape.
    irrelevance0.  1: now rewrite singleSubstComm'.
    unshelve eapply (snd (natElimRedAux _ _ _ _ _ _ _ _) _ NatRedTm.zeroR); tea; fold subst_term.
    7: eapply zeroValid.
    + intros m Rm.
      rewrite up_single_subst.
      unshelve eapply validTy; cycle 1; tea.
      unshelve econstructor; [now bsimpl| now cbn].
    + intros m m' Rm Rm' Rmm'; cbn.
      irrelevance0. 1: now rewrite up_single_subst.
      rewrite up_single_subst.
      unshelve eapply validTyExt; cycle 1 ; tea.
      1,2: unshelve econstructor; [now bsimpl| now cbn].
      unshelve econstructor; [|now cbn].
      bsimpl; cbn; eapply reflSubst.
    + irrelevance.
    + rewrite elimSuccHypTy_subst. eapply validTy; tea; eapply elimSuccHypTyValid.
    + irrelevance. now rewrite elimSuccHypTy_subst.
    Unshelve. 4: tea.
  Qed.

  Lemma natElimSuccValid {n}
    (Vn : [Γ ||-v<l> n : tNat | VΓ | VN])
    (VPSn := substS VP (succValid _ Vn)) :
    [Γ ||-v<l> tNatElim P hz hs (tSucc n) ≅ tApp (tApp hs n) (tNatElim P hz hs n) : _ | VΓ | VPSn].
  Proof.
    constructor; intros.
    epose proof (Vuσ := liftSubstS' VN Vσ).
    instValid Vσ; instValid Vuσ; escape.
    irrelevance0.  1: now rewrite singleSubstComm'.
    pose (NSn := NatRedTm.succR RVn).
    unshelve eapply (snd (natElimRedAux _ _ _ _ _ _ _ _) _ NSn); tea; fold subst_term.
    + intros m Rm.
      rewrite up_single_subst.
      unshelve eapply validTy; cycle 1; tea.
      unshelve econstructor; [now bsimpl| now cbn].
    + intros m m' Rm Rm' Rmm'; cbn.
      irrelevance0. 1: now rewrite up_single_subst.
      rewrite up_single_subst.
      unshelve eapply validTyExt; cycle 1 ; tea.
      1,2: unshelve econstructor; [now bsimpl| now cbn].
      unshelve econstructor; [|now cbn].
      bsimpl; cbn; eapply reflSubst.
    + irrelevance.
    + rewrite elimSuccHypTy_subst. eapply validTy; tea; eapply elimSuccHypTyValid.
    + irrelevance. now rewrite elimSuccHypTy_subst.
    + now eapply succRed.
  Qed.

End NatElimValid.

Lemma natElimCongValid {Γ l P Q hz hz' hs hs' n n'}
    (VΓ : [||-v Γ])
    (VN := natValid (l:=l) VΓ)
    (VΓN := validSnoc VΓ VN)
    (VP : [Γ ,, tNat ||-v<l> P | VΓN])
    (VQ : [Γ ,, tNat ||-v<l> Q | VΓN])
    (VPQ : [Γ ,, tNat ||-v<l> P ≅ Q | VΓN | VP])
    (VPz := substS VP (zeroValid VΓ))
    (VQz := substS VQ (zeroValid VΓ))
    (Vhz : [Γ ||-v<l> hz : P[tZero..] | VΓ | VPz])
    (Vhz' : [Γ ||-v<l> hz' : Q[tZero..] | VΓ | VQz])
    (Vheqz : [Γ ||-v<l> hz ≅ hz' : P[tZero..] | VΓ | VPz])
    (VPs := elimSuccHypTyValid VΓ VP)
    (VQs := elimSuccHypTyValid VΓ VQ)
    (Vhs : [Γ ||-v<l> hs : _ | VΓ | VPs])
    (Vhs' : [Γ ||-v<l> hs' : _ | VΓ | VQs])
    (Vheqs : [Γ ||-v<l> hs ≅ hs' : _ | VΓ | VPs])
    (Vn : [Γ ||-v<l> n : _ | VΓ | VN])
    (Vn' : [Γ ||-v<l> n' : _ | VΓ | VN])
    (Veqn : [Γ ||-v<l> n ≅ n' : _ | VΓ | VN])
    (VPn := substS VP Vn) :
    [Γ ||-v<l> tNatElim P hz hs n ≅ tNatElim Q hz' hs' n' : _ | VΓ | VPn].
Proof.
  constructor; intros.
  pose (Vuσ := liftSubstS' VN Vσ).
  instValid Vσ; instValid Vuσ; escape.
  irrelevance0.  1: now rewrite singleSubstComm'.
  unshelve eapply natElimRedEq; tea; fold subst_term.
  6-11: irrelevance; now rewrite elimSuccHypTy_subst.
  3,4: rewrite elimSuccHypTy_subst; eapply validTy; tea; eapply elimSuccHypTyValid.
  + intros m Rm.
    rewrite up_single_subst.
    unshelve eapply validTy; cycle 1; tea.
    unshelve econstructor; [now bsimpl| now cbn].
  + intros m Rm.
    rewrite up_single_subst.
    unshelve eapply validTy; cycle 1; tea.
    unshelve econstructor; [now bsimpl| now cbn].
  + intros m m' Rm Rm' Rmm'; cbn.
    irrelevance0. 1: now rewrite up_single_subst.
    rewrite up_single_subst.
    eapply transEq; cycle 1.
    - unshelve eapply validTyEq.
      7: tea. 1: tea.
      unshelve econstructor; [now bsimpl| now cbn].
    - unshelve eapply validTyExt; cycle 1 ; tea.
    1,2: unshelve econstructor; [now bsimpl| now cbn].
    unshelve econstructor; [|now cbn].
    bsimpl. eapply reflSubst.
    Unshelve. 1: tea.
    eapply validTy; tea.
    unshelve econstructor; [| now cbn]; now bsimpl.
Qed.

Lemma elimSuccHypTyCongValid {Γ l P P'}
    (VΓ : [||-v Γ])
    (VN := natValid (l:=l) VΓ)
    (VΓN := validSnoc VΓ VN)
    (VP : [Γ ,, tNat ||-v<l> P | VΓN])
    (VP' : [Γ ,, tNat ||-v<l> P' | VΓN])
    (VeqP : [Γ ,, tNat ||-v<l> P ≅ P' | VΓN | VP]) :
    [Γ ||-v<l> elimSuccHypTy P ≅ elimSuccHypTy P' | VΓ | elimSuccHypTyValid VΓ VP].
  Proof.
    unfold elimSuccHypTy.
    eapply irrelevanceEq.
    assert [Γ,, tNat ||-v< l > P'[tSucc (tRel 0)]⇑ | validSnoc VΓ VN]. 1:{
      eapply substLiftS; tea.
      eapply irrelevanceTm.
      eapply succValid.
      eapply irrelevanceTm.
      change tNat with tNat⟨@wk1 Γ tNat⟩ at 2.
      eapply var0Valid.
    }
    eapply PiCong.
    - eapply simpleArrValid; tea.
    - eapply reflValidTy.
    - eapply simpleArrCongValid; tea.
      eapply substLiftSEq; tea.
    Unshelve. all: tea.
    unshelve eapply irrelevanceTm; tea.
    2: eapply succValid.
    unshelve eapply irrelevanceTm'.
    5: unshelve eapply var0Valid; tea.
    now bsimpl.
  Qed.

End Nat.


From Hammer Require Import Hammer.

Require Import Reals.
Require Import Psatz.
From compcert Require Import Core.
From compcert Require Import Operations.

Definition Zrnd_odd x :=  match Req_EM_T x (IZR (Zfloor x))  with
| left _   => Zfloor x
| right _  => match (Z.even (Zfloor x)) with
| true => Zceil x
| false => Zfloor x
end
end.

Global Instance valid_rnd_odd : Valid_rnd Zrnd_odd.
Proof. hammer_hook "Round_odd" "Round_odd.valid_rnd_odd".
split.

intros x y Hxy.
assert (Zfloor x <= Zrnd_odd y)%Z.

apply Z.le_trans with (Zfloor y).
now apply Zfloor_le.
unfold Zrnd_odd; destruct (Req_EM_T  y (IZR (Zfloor y))).
now apply Z.le_refl.
case (Z.even (Zfloor y)).
apply le_IZR.
apply Rle_trans with y.
apply Zfloor_lb.
apply Zceil_ub.
now apply Z.le_refl.
unfold Zrnd_odd at 1.

destruct (Req_EM_T  x (IZR (Zfloor x))) as [Hx|Hx].

apply H.

case_eq (Z.even (Zfloor x)); intros Hx2.
2: apply H.
unfold Zrnd_odd; destruct (Req_EM_T  y (IZR (Zfloor y))) as [Hy|Hy].
apply Zceil_glb.
now rewrite <- Hy.
case_eq (Z.even (Zfloor y)); intros Hy2.
now apply Zceil_le.
apply Zceil_glb.
assert (H0:(Zfloor x <= Zfloor y)%Z) by now apply Zfloor_le.
case (Zle_lt_or_eq _ _  H0); intros H1.
apply Rle_trans with (1:=Zceil_ub _).
rewrite Zceil_floor_neq.
apply IZR_le; omega.
now apply sym_not_eq.
contradict Hy2.
rewrite <- H1, Hx2; discriminate.

intros n; unfold Zrnd_odd.
rewrite Zfloor_IZR, Zceil_IZR.
destruct (Req_EM_T  (IZR n) (IZR n)); trivial.
case (Z.even n); trivial.
Qed.

Lemma Zrnd_odd_Zodd: forall x, x <> (IZR (Zfloor x)) ->
(Z.even (Zrnd_odd x)) = false.
Proof. hammer_hook "Round_odd" "Round_odd.Zrnd_odd_Zodd".
intros x Hx; unfold Zrnd_odd.
destruct (Req_EM_T  x (IZR (Zfloor x))) as [H|H].
now contradict H.
case_eq (Z.even (Zfloor x)).

intros H'.
rewrite Zceil_floor_neq.
rewrite Z.even_add, H'.
reflexivity.
now apply sym_not_eq.
trivial.
Qed.

Lemma Zfloor_plus: forall (n:Z) y,
(Zfloor (IZR n+y) = n + Zfloor y)%Z.
Proof. hammer_hook "Round_odd" "Round_odd.Zfloor_plus".
intros n y; unfold Zfloor.
unfold Zminus; rewrite Zplus_assoc; f_equal.
apply sym_eq, tech_up.
rewrite plus_IZR.
apply Rplus_lt_compat_l.
apply archimed.
rewrite plus_IZR, Rplus_assoc.
apply Rplus_le_compat_l.
apply Rplus_le_reg_r with (-y)%R.
ring_simplify (y+1+-y)%R.
apply archimed.
Qed.

Lemma Zceil_plus: forall (n:Z) y,
(Zceil (IZR n+y) = n + Zceil y)%Z.
Proof. hammer_hook "Round_odd" "Round_odd.Zceil_plus".
intros n y; unfold Zceil.
rewrite Ropp_plus_distr, <- Ropp_Ropp_IZR.
rewrite Zfloor_plus.
ring.
Qed.

Lemma Zeven_abs: forall z, Z.even (Z.abs z) = Z.even z.
Proof. hammer_hook "Round_odd" "Round_odd.Zeven_abs".
intros z; case (Zle_or_lt z 0); intros H1.
rewrite Z.abs_neq; try assumption.
apply Z.even_opp.
rewrite Z.abs_eq; auto with zarith.
Qed.

Lemma Zrnd_odd_plus: forall x y, (x = IZR (Zfloor x)) ->
Z.even (Zfloor x) = true ->
(IZR (Zrnd_odd (x+y)) = x+IZR (Zrnd_odd y))%R.
Proof. hammer_hook "Round_odd" "Round_odd.Zrnd_odd_plus".
intros x y Hx H.
unfold Zrnd_odd; rewrite Hx, Zfloor_plus.
case (Req_EM_T y (IZR (Zfloor y))); intros Hy.
rewrite Hy; repeat rewrite <- plus_IZR.
repeat rewrite Zfloor_IZR.
case (Req_EM_T _ _); intros K; easy.
case (Req_EM_T _ _); intros K.
contradict Hy.
apply Rplus_eq_reg_l with (IZR (Zfloor x)).
now rewrite K, plus_IZR.
rewrite Z.even_add, H; simpl.
case (Z.even (Zfloor y)).
now rewrite Zceil_plus, plus_IZR.
now rewrite plus_IZR.
Qed.

Section Fcore_rnd_odd.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.

Context { valid_exp : Valid_exp fexp }.
Context { exists_NE_ : Exists_NE beta fexp }.

Notation format := (generic_format beta fexp).
Notation canonical := (canonical beta fexp).
Notation cexp := (cexp beta fexp).

Definition Rnd_odd_pt (x f : R) :=
format f /\ ((f = x)%R \/
((Rnd_DN_pt format x f \/ Rnd_UP_pt format x f) /\
exists g : float beta, f = F2R g /\ canonical g /\ Z.even (Fnum g) = false)).

Definition Rnd_odd (rnd : R -> R) :=
forall x : R, Rnd_odd_pt x (rnd x).

Theorem Rnd_odd_pt_opp_inv :   forall x f : R,
Rnd_odd_pt (-x) (-f) -> Rnd_odd_pt x f.
Proof with auto with typeclass_instances. hammer_hook "Round_odd" "Round_odd.Rnd_odd_pt_opp_inv".
intros x f (H1,H2).
split.
replace f with (-(-f))%R by ring.
now apply generic_format_opp.
destruct H2.
left.
replace f with (-(-f))%R by ring.
rewrite H; ring.
right.
destruct H as (H2,(g,(Hg1,(Hg2,Hg3)))).
split.
destruct H2.
right.
replace f with (-(-f))%R by ring.
replace x with (-(-x))%R by ring.
apply Rnd_UP_pt_opp...
apply generic_format_opp.
left.
replace f with (-(-f))%R by ring.
replace x with (-(-x))%R by ring.
apply Rnd_DN_pt_opp...
apply generic_format_opp.
exists (Float beta (-Fnum g) (Fexp g)).
split.
rewrite F2R_Zopp.
replace f with (-(-f))%R by ring.
rewrite Hg1; reflexivity.
split.
now apply canonical_opp.
simpl.
now rewrite Z.even_opp.
Qed.

Theorem round_odd_opp :
forall x,
round beta fexp Zrnd_odd (-x) = (- round beta fexp Zrnd_odd x)%R.
Proof. hammer_hook "Round_odd" "Round_odd.round_odd_opp".
intros x; unfold round.
rewrite <- F2R_Zopp.
unfold F2R; simpl.
apply f_equal2; apply f_equal.
rewrite scaled_mantissa_opp.
generalize (scaled_mantissa beta fexp x); intros r.
unfold Zrnd_odd.
case (Req_EM_T (- r) (IZR (Zfloor (- r)))).
case (Req_EM_T r (IZR (Zfloor r))).
intros Y1 Y2.
apply eq_IZR.
now rewrite opp_IZR, <- Y1, <-Y2.
intros Y1 Y2.
absurd (r=IZR (Zfloor r)); trivial.
pattern r at 2; replace r with (-(-r))%R by ring.
rewrite Y2, <- opp_IZR.
rewrite Zfloor_IZR.
rewrite opp_IZR, <- Y2.
ring.
case (Req_EM_T r (IZR (Zfloor r))).
intros Y1 Y2.
absurd (-r=IZR (Zfloor (-r)))%R; trivial.
pattern r at 2; rewrite Y1.
rewrite <- opp_IZR, Zfloor_IZR.
now rewrite opp_IZR, <- Y1.
intros Y1 Y2.
unfold Zceil; rewrite Ropp_involutive.
replace  (Z.even (Zfloor (- r))) with (negb (Z.even (Zfloor r))).
case (Z.even (Zfloor r));  simpl; ring.
apply trans_eq with (Z.even (Zceil r)).
rewrite Zceil_floor_neq.
rewrite Z.even_add.
destruct (Z.even (Zfloor r)); reflexivity.
now apply sym_not_eq.
rewrite <- (Z.even_opp (Zfloor (- r))).
reflexivity.
apply cexp_opp.
Qed.

Theorem round_odd_pt :
forall x,
Rnd_odd_pt x (round beta fexp Zrnd_odd x).
Proof with auto with typeclass_instances. hammer_hook "Round_odd" "Round_odd.round_odd_pt".
cut (forall x : R, (0 < x)%R -> Rnd_odd_pt x (round beta fexp Zrnd_odd x)).
intros H x; case (Rle_or_lt 0 x).
intros H1; destruct H1.
now apply H.
rewrite <- H0.
rewrite round_0...
split.
apply generic_format_0.
now left.
intros Hx; apply Rnd_odd_pt_opp_inv.
rewrite <- round_odd_opp.
apply H.
auto with real.

intros x Hxp.
generalize (generic_format_round beta fexp Zrnd_odd x).
set (o:=round beta fexp Zrnd_odd x).
intros Ho.
split.
assumption.

case (Req_dec o x); intros Hx.
now left.
right.
assert (o=round beta fexp Zfloor x \/ o=round beta fexp Zceil x).
unfold o, round, F2R;simpl.
case (Zrnd_DN_or_UP Zrnd_odd  (scaled_mantissa beta fexp x))...
intros H; rewrite H; now left.
intros H; rewrite H; now right.
split.
destruct H; rewrite H.
left; apply round_DN_pt...
right; apply round_UP_pt...

unfold o, Zrnd_odd, round.
case (Req_EM_T (scaled_mantissa beta fexp x)
(IZR (Zfloor (scaled_mantissa beta fexp x)))).
intros T.
absurd (o=x); trivial.
apply round_generic...
unfold generic_format, F2R; simpl.
rewrite <- (scaled_mantissa_mult_bpow beta fexp) at 1.
apply f_equal2; trivial; rewrite T at 1.
apply f_equal, sym_eq, Ztrunc_floor.
apply Rmult_le_pos.
now left.
apply bpow_ge_0.
intros L.
case_eq (Z.even (Zfloor (scaled_mantissa beta fexp x))).

generalize (generic_format_round beta fexp Zceil x).
unfold generic_format.
set (f:=round beta fexp Zceil x).
set (ef := cexp f).
set (mf := Ztrunc (scaled_mantissa beta fexp f)).
exists (Float beta mf ef).
unfold canonical.
rewrite <- H0.
repeat split; try assumption.
apply trans_eq with (negb (Z.even (Zfloor (scaled_mantissa beta fexp x)))).
2: rewrite H1; reflexivity.
apply trans_eq with (negb (Z.even (Fnum
(Float beta  (Zfloor (scaled_mantissa beta fexp x)) (cexp x))))).
2: reflexivity.
case (Rle_lt_or_eq_dec 0 (round beta fexp Zfloor x)).
rewrite <- round_0 with beta fexp Zfloor...
apply round_le...
now left.
intros Y.
generalize (DN_UP_parity_generic beta fexp)...
unfold DN_UP_parity_prop.
intros T; apply T with x; clear T.
unfold generic_format.
rewrite <- (scaled_mantissa_mult_bpow beta fexp x) at 1.
unfold F2R; simpl.
apply Rmult_neq_compat_r.
apply Rgt_not_eq, bpow_gt_0.
rewrite Ztrunc_floor.
assumption.
apply Rmult_le_pos.
now left.
apply bpow_ge_0.
unfold canonical.
simpl.
apply sym_eq, cexp_DN...
unfold canonical.
rewrite <- H0; reflexivity.
reflexivity.
apply trans_eq with (round beta fexp Ztrunc (round beta fexp Zceil x)).
reflexivity.
apply round_generic...
intros Y.
replace  (Fnum {| Fnum := Zfloor (scaled_mantissa beta fexp x); Fexp := cexp x |})
with (Fnum (Float beta 0 (fexp (mag beta 0)))).
generalize (DN_UP_parity_generic beta fexp)...
unfold DN_UP_parity_prop.
intros T; apply T with x; clear T.
unfold generic_format.
rewrite <- (scaled_mantissa_mult_bpow beta fexp x) at 1.
unfold F2R; simpl.
apply Rmult_neq_compat_r.
apply Rgt_not_eq, bpow_gt_0.
rewrite Ztrunc_floor.
assumption.
apply Rmult_le_pos.
now left.
apply bpow_ge_0.
apply canonical_0.
unfold canonical.
rewrite <- H0; reflexivity.
rewrite <- Y; unfold F2R; simpl; ring.
apply trans_eq with (round beta fexp Ztrunc (round beta fexp Zceil x)).
reflexivity.
apply round_generic...
simpl.
apply eq_IZR, Rmult_eq_reg_r with (bpow (cexp x)).
unfold round, F2R in Y; simpl in Y; rewrite <- Y.
simpl; ring.
apply Rgt_not_eq, bpow_gt_0.

intros Y.
case (Rle_lt_or_eq_dec 0 (round beta fexp Zfloor x)).
rewrite <- round_0 with beta fexp Zfloor...
apply round_le...
now left.
intros Hrx.
set (ef := cexp x).
set (mf := Zfloor (scaled_mantissa beta fexp x)).
exists (Float beta mf ef).
unfold canonical.
repeat split; try assumption.
simpl.
apply trans_eq with (cexp (round beta fexp Zfloor x )).
apply sym_eq, cexp_DN...
reflexivity.
intros Hrx; contradict Y.
replace (Zfloor (scaled_mantissa beta fexp x)) with 0%Z.
simpl; discriminate.
apply eq_IZR, Rmult_eq_reg_r with (bpow (cexp x)).
unfold round, F2R in Hrx; simpl in Hrx; rewrite <- Hrx.
simpl; ring.
apply Rgt_not_eq, bpow_gt_0.
Qed.

Theorem Rnd_odd_pt_unique :
forall x f1 f2 : R,
Rnd_odd_pt x f1 -> Rnd_odd_pt x f2 ->
f1 = f2.
Proof. hammer_hook "Round_odd" "Round_odd.Rnd_odd_pt_unique".
intros x f1 f2 (Ff1,H1) (Ff2,H2).

case (generic_format_EM beta fexp x); intros L.
apply trans_eq with x.
case H1; try easy.
intros (J,_); case J; intros J'.
apply Rnd_DN_pt_idempotent with format; assumption.
apply Rnd_UP_pt_idempotent with format; assumption.
case H2; try easy.
intros (J,_); case J; intros J'; apply sym_eq.
apply Rnd_DN_pt_idempotent with format; assumption.
apply Rnd_UP_pt_idempotent with format; assumption.

destruct H1 as [H1|(H1,H1')].
contradict L; now rewrite <- H1.
destruct H2 as [H2|(H2,H2')].
contradict L; now rewrite <- H2.
destruct H1 as [H1|H1]; destruct H2 as [H2|H2].
apply Rnd_DN_pt_unique with format x; assumption.
destruct H1' as (ff,(K1,(K2,K3))).
destruct H2' as (gg,(L1,(L2,L3))).
absurd (true = false); try discriminate.
rewrite <- L3.
apply trans_eq with (negb (Z.even (Fnum ff))).
rewrite K3; easy.
apply sym_eq.
generalize (DN_UP_parity_generic beta fexp).
unfold DN_UP_parity_prop; intros T; apply (T x); clear T; try assumption...
rewrite <- K1; apply Rnd_DN_pt_unique with (generic_format beta fexp) x; try easy...
now apply round_DN_pt...
rewrite <- L1; apply Rnd_UP_pt_unique with (generic_format beta fexp) x; try easy...
now apply round_UP_pt...

destruct H1' as (ff,(K1,(K2,K3))).
destruct H2' as (gg,(L1,(L2,L3))).
absurd (true = false); try discriminate.
rewrite <- K3.
apply trans_eq with (negb (Z.even (Fnum gg))).
rewrite L3; easy.
apply sym_eq.
generalize (DN_UP_parity_generic beta fexp).
unfold DN_UP_parity_prop; intros T; apply (T x); clear T; try assumption...
rewrite <- L1; apply Rnd_DN_pt_unique with (generic_format beta fexp) x; try easy...
now apply round_DN_pt...
rewrite <- K1; apply Rnd_UP_pt_unique with (generic_format beta fexp) x; try easy...
now apply round_UP_pt...
apply Rnd_UP_pt_unique with format x; assumption.
Qed.

Theorem Rnd_odd_pt_monotone :
round_pred_monotone (Rnd_odd_pt).
Proof with auto with typeclass_instances. hammer_hook "Round_odd" "Round_odd.Rnd_odd_pt_monotone".
intros x y f g H1 H2 Hxy.
apply Rle_trans with (round beta fexp Zrnd_odd x).
right; apply Rnd_odd_pt_unique with x; try assumption.
apply round_odd_pt.
apply Rle_trans with (round beta fexp Zrnd_odd y).
apply round_le...
right; apply Rnd_odd_pt_unique with y; try assumption.
apply round_odd_pt.
Qed.

End Fcore_rnd_odd.

Section Odd_prop_aux.

Variable beta : radix.
Hypothesis Even_beta: Z.even (radix_val beta)=true.

Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.
Variable fexpe : Z -> Z.

Context { valid_exp : Valid_exp fexp }.
Context { exists_NE_ : Exists_NE beta fexp }.
Context { valid_expe : Valid_exp fexpe }.
Context { exists_NE_e : Exists_NE beta fexpe }.

Hypothesis fexpe_fexp: forall e, (fexpe e <= fexp e -2)%Z.

Lemma generic_format_fexpe_fexp: forall x,
generic_format beta fexp x ->  generic_format beta fexpe x.
Proof. hammer_hook "Round_odd" "Round_odd.generic_format_fexpe_fexp".
intros x Hx.
apply generic_inclusion_mag with fexp; trivial; intros Hx2.
generalize (fexpe_fexp (mag beta x)).
omega.
Qed.

Lemma exists_even_fexp_lt: forall (c:Z->Z), forall (x:R),
(exists f:float beta, F2R f = x /\ (c (mag beta x) < Fexp f)%Z) ->
exists f:float beta, F2R f =x /\ canonical beta c f /\ Z.even (Fnum f) = true.
Proof with auto with typeclass_instances. hammer_hook "Round_odd" "Round_odd.exists_even_fexp_lt".
intros c x (g,(Hg1,Hg2)).
exists (Float beta
(Fnum g*Z.pow (radix_val beta) (Fexp g - c (mag beta x)))
(c (mag beta x))).
assert (F2R (Float beta
(Fnum g*Z.pow (radix_val beta) (Fexp g - c (mag beta x)))
(c (mag beta x))) = x).
unfold F2R; simpl.
rewrite mult_IZR, IZR_Zpower.
rewrite Rmult_assoc, <- bpow_plus.
rewrite <- Hg1; unfold F2R.
apply f_equal, f_equal.
ring.
omega.
split; trivial.
split.
unfold canonical, cexp.
now rewrite H.
simpl.
rewrite Z.even_mul.
rewrite Z.even_pow.
rewrite Even_beta.
apply Bool.orb_true_intro.
now right.
omega.
Qed.

Variable choice:Z->bool.
Variable x:R.

Variable d u: float beta.
Hypothesis Hd: Rnd_DN_pt (generic_format beta fexp) x (F2R d).
Hypothesis Cd: canonical beta fexp d.
Hypothesis Hu: Rnd_UP_pt (generic_format beta fexp) x (F2R u).
Hypothesis Cu: canonical beta fexp u.

Hypothesis xPos: (0 < x)%R.

Let m:= ((F2R d+F2R u)/2)%R.

Lemma d_eq: F2R d= round beta fexp Zfloor x.
Proof with auto with typeclass_instances. hammer_hook "Round_odd" "Round_odd.d_eq".
apply Rnd_DN_pt_unique with (generic_format beta fexp) x...
apply round_DN_pt...
Qed.

Lemma u_eq: F2R u= round beta fexp Zceil x.
Proof with auto with typeclass_instances. hammer_hook "Round_odd" "Round_odd.u_eq".
apply Rnd_UP_pt_unique with (generic_format beta fexp) x...
apply round_UP_pt...
Qed.

Lemma d_ge_0: (0 <= F2R d)%R.
Proof with auto with typeclass_instances. hammer_hook "Round_odd" "Round_odd.d_ge_0".
rewrite d_eq; apply round_ge_generic...
apply generic_format_0.
now left.
Qed.

Lemma mag_d:  (0< F2R d)%R ->
(mag beta (F2R d) = mag beta x :>Z).
Proof with auto with typeclass_instances. hammer_hook "Round_odd" "Round_odd.mag_d".
intros Y.
rewrite d_eq; apply mag_DN...
now rewrite <- d_eq.
Qed.

Lemma Fexp_d: (0 < F2R d)%R -> Fexp d =fexp (mag beta x).
Proof with auto with typeclass_instances. hammer_hook "Round_odd" "Round_odd.Fexp_d".
intros Y.
now rewrite Cd, <- mag_d.
Qed.

Lemma format_bpow_x: (0 < F2R d)%R
-> generic_format beta fexp  (bpow (mag beta x)).
Proof with auto with typeclass_instances. hammer_hook "Round_odd" "Round_odd.format_bpow_x".
intros Y.
apply generic_format_bpow.
apply valid_exp.
rewrite <- Fexp_d; trivial.
apply Z.lt_le_trans with  (mag beta (F2R d))%Z.
rewrite Cd; apply mag_generic_gt...
now apply Rgt_not_eq.
apply Hd.
apply mag_le; trivial.
apply Hd.
Qed.

Lemma format_bpow_d: (0 < F2R d)%R ->
generic_format beta fexp (bpow (mag beta (F2R d))).
Proof with auto with typeclass_instances. hammer_hook "Round_odd" "Round_odd.format_bpow_d".
intros Y; apply generic_format_bpow.
apply valid_exp.
apply mag_generic_gt...
now apply Rgt_not_eq.
now apply generic_format_canonical.
Qed.

Lemma d_le_m: (F2R d <= m)%R.
Proof. hammer_hook "Round_odd" "Round_odd.d_le_m".
assert (F2R d <= F2R u)%R.
apply Rle_trans with x.
apply Hd.
apply Hu.
unfold m.
lra.
Qed.

Lemma m_le_u: (m <= F2R u)%R.
Proof. hammer_hook "Round_odd" "Round_odd.m_le_u".
assert (F2R d <= F2R u)%R.
apply Rle_trans with x.
apply Hd.
apply Hu.
unfold m.
lra.
Qed.

Lemma mag_m: (0 < F2R d)%R -> (mag beta m =mag beta (F2R d) :>Z).
Proof with auto with typeclass_instances. hammer_hook "Round_odd" "Round_odd.mag_m".
intros dPos; apply mag_unique_pos.
split.
apply Rle_trans with (F2R d).
destruct (mag beta (F2R d)) as (e,He).
simpl.
rewrite Rabs_right in He.
apply He.
now apply Rgt_not_eq.
apply Rle_ge; now left.
apply d_le_m.
case m_le_u; intros H.
apply Rlt_le_trans with (1:=H).
rewrite u_eq.
apply round_le_generic...
apply generic_format_bpow.
apply valid_exp.
apply mag_generic_gt...
now apply Rgt_not_eq.
now apply generic_format_canonical.
case (Rle_or_lt x (bpow (mag beta (F2R d)))); trivial; intros Z.
absurd ((bpow (mag beta (F2R d)) <= (F2R d)))%R.
apply Rlt_not_le.
destruct  (mag beta (F2R d)) as (e,He).
simpl in *; rewrite Rabs_right in He.
apply He.
now apply Rgt_not_eq.
apply Rle_ge; now left.
apply Rle_trans with (round beta fexp Zfloor x).
2: right; apply sym_eq, d_eq.
apply round_ge_generic...
apply generic_format_bpow.
apply valid_exp.
apply mag_generic_gt...
now apply Rgt_not_eq.
now apply generic_format_canonical.
now left.
replace m with (F2R d).
destruct (mag beta (F2R d)) as (e,He).
simpl in *; rewrite Rabs_right in He.
apply He.
now apply Rgt_not_eq.
apply Rle_ge; now left.
unfold m in H |- *.
lra.
Qed.

Lemma mag_m_0: (0 = F2R d)%R
-> (mag beta m =mag beta (F2R u)-1:>Z)%Z.
Proof with auto with typeclass_instances. hammer_hook "Round_odd" "Round_odd.mag_m_0".
intros Y.
apply mag_unique_pos.
unfold m; rewrite <- Y, Rplus_0_l.
rewrite u_eq.
destruct (mag beta x) as (e,He).
rewrite Rabs_pos_eq in He by now apply Rlt_le.
rewrite round_UP_small_pos with (ex:=e).
rewrite mag_bpow.
ring_simplify (fexp e + 1 - 1)%Z.
split.
unfold Zminus; rewrite bpow_plus.
unfold Rdiv; apply Rmult_le_compat_l.
apply bpow_ge_0.
simpl; unfold Z.pow_pos; simpl.
rewrite Zmult_1_r; apply Rinv_le.
exact Rlt_0_2.
apply IZR_le.
specialize (radix_gt_1 beta).
omega.
apply Rlt_le_trans with (bpow (fexp e)*1)%R.
2: right; ring.
unfold Rdiv; apply Rmult_lt_compat_l.
apply bpow_gt_0.
lra.
now apply He, Rgt_not_eq.
apply exp_small_round_0_pos with beta (Zfloor) x...
now apply He, Rgt_not_eq.
now rewrite <- d_eq, Y.
Qed.

Lemma u'_eq:  (0 < F2R d)%R -> exists f:float beta, F2R f = F2R u /\ (Fexp f = Fexp d)%Z.
Proof with auto with typeclass_instances. hammer_hook "Round_odd" "Round_odd.u'_eq".
intros Y.
rewrite u_eq; unfold round.
eexists; repeat split.
simpl; now rewrite Fexp_d.
Qed.

Lemma m_eq :
(0 < F2R d)%R ->
exists f:float beta,
F2R f = m /\ (Fexp f = fexp (mag beta x) - 1)%Z.
Proof with auto with typeclass_instances. hammer_hook "Round_odd" "Round_odd.m_eq".
intros Y.
specialize (Zeven_ex (radix_val beta)); rewrite Even_beta.
intros (b, Hb); rewrite Zplus_0_r in Hb.
destruct u'_eq as (u', (Hu'1,Hu'2)); trivial.
exists (Fmult (Float beta b (-1)) (Fplus d u'))%R.
split.
rewrite F2R_mult, F2R_plus, Hu'1.
unfold m; rewrite Rmult_comm.
unfold Rdiv; apply f_equal.
unfold F2R; simpl; unfold Z.pow_pos; simpl.
rewrite Zmult_1_r, Hb, mult_IZR.
simpl; field.
apply Rgt_not_eq, Rmult_lt_reg_l with (1 := Rlt_0_2).
rewrite Rmult_0_r, <- (mult_IZR 2), <-Hb.
apply radix_pos.
apply trans_eq with (-1+Fexp (Fplus d u'))%Z.
unfold Fmult.
destruct  (Fplus d u'); reflexivity.
rewrite Zplus_comm; unfold Zminus; apply f_equal2.
2: reflexivity.
rewrite Fexp_Fplus.
rewrite Z.min_l.
now rewrite Fexp_d.
rewrite Hu'2; omega.
Qed.

Lemma m_eq_0: (0 = F2R d)%R ->  exists f:float beta,
F2R f = m /\ (Fexp f = fexp (mag beta (F2R u)) -1)%Z.
Proof with auto with typeclass_instances. hammer_hook "Round_odd" "Round_odd.m_eq_0".
intros Y.
specialize (Zeven_ex (radix_val beta)); rewrite Even_beta.
intros (b, Hb); rewrite Zplus_0_r in Hb.
exists (Fmult (Float beta b (-1)) u)%R.
split.
rewrite F2R_mult; unfold m; rewrite <- Y, Rplus_0_l.
rewrite Rmult_comm.
unfold Rdiv; apply f_equal.
unfold F2R; simpl; unfold Z.pow_pos; simpl.
rewrite Zmult_1_r, Hb, mult_IZR.
simpl; field.
apply Rgt_not_eq, Rmult_lt_reg_l with (1 := Rlt_0_2).
rewrite Rmult_0_r, <- (mult_IZR 2), <-Hb.
apply radix_pos.
apply trans_eq with (-1+Fexp u)%Z.
unfold Fmult.
destruct u; reflexivity.
rewrite Zplus_comm, Cu; unfold Zminus; now apply f_equal2.
Qed.

Lemma fexp_m_eq_0:  (0 = F2R d)%R ->
(fexp (mag beta (F2R u)-1) < fexp (mag beta (F2R u))+1)%Z.
Proof with auto with typeclass_instances. hammer_hook "Round_odd" "Round_odd.fexp_m_eq_0".
intros Y.
assert ((fexp (mag beta (F2R u) - 1) <= fexp (mag beta (F2R u))))%Z.
2: omega.
destruct (mag beta x) as (e,He).
rewrite Rabs_right in He.
2: now left.
assert (e <= fexp e)%Z.
apply exp_small_round_0_pos with beta (Zfloor) x...
now apply He, Rgt_not_eq.
now rewrite <- d_eq, Y.
rewrite u_eq, round_UP_small_pos with (ex:=e); trivial.
2: now apply He, Rgt_not_eq.
rewrite mag_bpow.
ring_simplify (fexp e + 1 - 1)%Z.
replace (fexp (fexp e)) with (fexp e).
case exists_NE_; intros V.
contradict V; rewrite Even_beta; discriminate.
rewrite (proj2 (V e)); omega.
apply sym_eq, valid_exp; omega.
Qed.

Lemma Fm:  generic_format beta fexpe m.
Proof. hammer_hook "Round_odd" "Round_odd.Fm".
case (d_ge_0); intros Y.

destruct m_eq as (g,(Hg1,Hg2)); trivial.
apply generic_format_F2R' with g.
now apply sym_eq.
intros H; unfold cexp; rewrite Hg2.
rewrite mag_m; trivial.
rewrite <- Fexp_d; trivial.
rewrite Cd.
unfold cexp.
generalize (fexpe_fexp (mag beta (F2R d))).
omega.

destruct m_eq_0 as (g,(Hg1,Hg2)); trivial.
apply generic_format_F2R' with g.
assumption.
intros H; unfold cexp; rewrite Hg2.
rewrite mag_m_0; try assumption.
apply Z.le_trans with (1:=fexpe_fexp _).
generalize (fexp_m_eq_0 Y).
omega.
Qed.

Lemma Zm:
exists g : float beta, F2R g = m /\ canonical beta fexpe g /\ Z.even (Fnum g) = true.
Proof with auto with typeclass_instances. hammer_hook "Round_odd" "Round_odd.Zm".
case (d_ge_0); intros Y.

destruct m_eq as (g,(Hg1,Hg2)); trivial.
apply exists_even_fexp_lt.
exists g; split; trivial.
rewrite Hg2.
rewrite mag_m; trivial.
rewrite <- Fexp_d; trivial.
rewrite Cd.
unfold cexp.
generalize (fexpe_fexp  (mag beta (F2R d))).
omega.

destruct m_eq_0 as (g,(Hg1,Hg2)); trivial.
apply exists_even_fexp_lt.
exists g; split; trivial.
rewrite Hg2.
rewrite mag_m_0; trivial.
apply Z.le_lt_trans with (1:=fexpe_fexp _).
generalize (fexp_m_eq_0 Y).
omega.
Qed.

Lemma DN_odd_d_aux :
forall z, (F2R d <= z < F2R u)%R ->
Rnd_DN_pt (generic_format beta fexp) z (F2R d).
Proof with auto with typeclass_instances. hammer_hook "Round_odd" "Round_odd.DN_odd_d_aux".
intros z Hz1.
replace (F2R d) with (round beta fexp Zfloor z).
apply round_DN_pt...
case (Rnd_DN_UP_pt_split _ _ _ _ Hd Hu (round beta fexp Zfloor z)).
apply generic_format_round...
intros Y; apply Rle_antisym; trivial.
apply round_DN_pt...
apply Hd.
apply Hz1.
intros Y ; elim (Rlt_irrefl z).
apply Rlt_le_trans with (1:=proj2 Hz1), Rle_trans with (1:=Y).
apply round_DN_pt...
Qed.

Lemma UP_odd_d_aux :
forall z, (F2R d < z <= F2R u)%R ->
Rnd_UP_pt (generic_format beta fexp) z (F2R u).
Proof with auto with typeclass_instances. hammer_hook "Round_odd" "Round_odd.UP_odd_d_aux".
intros z Hz1.
replace (F2R u) with (round beta fexp Zceil z).
apply round_UP_pt...
case (Rnd_DN_UP_pt_split _ _ _ _ Hd Hu (round beta fexp Zceil z)).
apply generic_format_round...
intros Y ; elim (Rlt_irrefl z).
apply Rle_lt_trans with (2:=proj1 Hz1), Rle_trans with (2:=Y).
apply round_UP_pt...
intros Y; apply Rle_antisym; trivial.
apply round_UP_pt...
apply Hu.
apply Hz1.
Qed.

Lemma round_N_odd_pos :
round beta fexp (Znearest choice) (round beta fexpe Zrnd_odd x) =
round beta fexp (Znearest choice) x.
Proof with auto with typeclass_instances. hammer_hook "Round_odd" "Round_odd.round_N_odd_pos".
set (o:=round beta fexpe Zrnd_odd x).
case (generic_format_EM beta fexp x); intros Hx.
replace o with x; trivial.
unfold o; apply sym_eq, round_generic...
now apply generic_format_fexpe_fexp.
assert (K1:(F2R d <= o)%R).
apply round_ge_generic...
apply generic_format_fexpe_fexp, Hd.
apply Hd.
assert (K2:(o <= F2R u)%R).
apply round_le_generic...
apply generic_format_fexpe_fexp, Hu.
apply Hu.
assert (P:(x <> m -> o=m -> (forall P:Prop, P))).
intros Y1 Y2.
assert (H:(Rnd_odd_pt beta fexpe x o)).
apply round_odd_pt...
destruct H as (_,H); destruct H.
absurd (x=m)%R; try trivial.
now rewrite <- Y2, H.
destruct H as (_,(k,(Hk1,(Hk2,Hk3)))).
destruct Zm as (k',(Hk'1,(Hk'2,Hk'3))).
absurd (true=false).
discriminate.
rewrite <- Hk3, <- Hk'3.
apply f_equal, f_equal.
apply canonical_unique with fexpe...
now rewrite Hk'1, <- Y2.
assert (generic_format beta fexp o -> (forall P:Prop, P)).
intros Y.
assert (H:(Rnd_odd_pt beta fexpe x o)).
apply round_odd_pt...
destruct H as (_,H); destruct H.
absurd (generic_format beta fexp x); trivial.
now rewrite <- H.
destruct H as (_,(k,(Hk1,(Hk2,Hk3)))).
destruct (exists_even_fexp_lt fexpe o) as (k',(Hk'1,(Hk'2,Hk'3))).
eexists; split.
apply sym_eq, Y.
simpl; unfold cexp.
apply Z.le_lt_trans with (1:=fexpe_fexp _).
omega.
absurd (true=false).
discriminate.
rewrite <- Hk3, <- Hk'3.
apply f_equal, f_equal.
apply canonical_unique with fexpe...
now rewrite Hk'1, <- Hk1.
case K1; clear K1; intros K1.
2: apply H; rewrite <- K1; apply Hd.
case K2; clear K2; intros K2.
2: apply H; rewrite K2; apply Hu.
case (Rle_or_lt  x m); intros Y;[destruct Y|idtac].

apply trans_eq with (F2R d).
apply round_N_eq_DN_pt with (F2R u)...
apply DN_odd_d_aux; split; try left; assumption.
apply UP_odd_d_aux; split; try left; assumption.
assert (o <= (F2R d + F2R u) / 2)%R.
apply round_le_generic...
apply Fm.
now left.
destruct H1; trivial.
apply P.
now apply Rlt_not_eq.
trivial.
apply sym_eq, round_N_eq_DN_pt with (F2R u)...

replace o with x.
reflexivity.
apply sym_eq, round_generic...
rewrite H0; apply Fm.

apply trans_eq with (F2R u).
apply round_N_eq_UP_pt with (F2R d)...
apply DN_odd_d_aux; split; try left; assumption.
apply UP_odd_d_aux; split; try left; assumption.
assert ((F2R d + F2R u) / 2 <= o)%R.
apply round_ge_generic...
apply Fm.
now left.
destruct H0; trivial.
apply P.
now apply Rgt_not_eq.
rewrite <- H0; trivial.
apply sym_eq, round_N_eq_UP_pt with (F2R d)...
Qed.

End Odd_prop_aux.

Section Odd_prop.

Variable beta : radix.
Hypothesis Even_beta: Z.even (radix_val beta)=true.

Variable fexp : Z -> Z.
Variable fexpe : Z -> Z.
Variable choice:Z->bool.

Context { valid_exp : Valid_exp fexp }.
Context { exists_NE_ : Exists_NE beta fexp }.
Context { valid_expe : Valid_exp fexpe }.
Context { exists_NE_e : Exists_NE beta fexpe }.

Hypothesis fexpe_fexp: forall e, (fexpe e <= fexp e -2)%Z.

Theorem round_N_odd :
forall x,
round beta fexp (Znearest choice) (round beta fexpe Zrnd_odd x) =
round beta fexp (Znearest choice) x.
Proof with auto with typeclass_instances. hammer_hook "Round_odd" "Round_odd.round_N_odd".
intros x.
case (total_order_T x 0); intros H; [case H; clear H; intros H | idtac].
rewrite <- (Ropp_involutive x).
rewrite round_odd_opp.
rewrite 2!round_N_opp.
apply f_equal.
destruct (canonical_generic_format beta fexp (round beta fexp Zfloor (-x))) as (d,(Hd1,Hd2)).
apply generic_format_round...
destruct (canonical_generic_format beta fexp (round beta fexp Zceil (-x))) as (u,(Hu1,Hu2)).
apply generic_format_round...
apply round_N_odd_pos with d u...
rewrite <- Hd1; apply round_DN_pt...
rewrite <- Hu1; apply round_UP_pt...
auto with real.

rewrite H; repeat rewrite round_0...

destruct (canonical_generic_format beta fexp (round beta fexp Zfloor x)) as (d,(Hd1,Hd2)).
apply generic_format_round...
destruct (canonical_generic_format beta fexp (round beta fexp Zceil x)) as (u,(Hu1,Hu2)).
apply generic_format_round...
apply round_N_odd_pos with d u...
rewrite <- Hd1; apply round_DN_pt...
rewrite <- Hu1; apply round_UP_pt...
Qed.

End Odd_prop.

Section Odd_propbis.

Variable beta : radix.
Hypothesis Even_beta: Z.even (radix_val beta)=true.

Variable emin prec:Z.
Variable choice:Z->bool.

Hypothesis prec_gt_1: (1 < prec)%Z.

Notation format := (generic_format beta (FLT_exp emin prec)).
Notation round_flt :=(round beta (FLT_exp emin prec) (Znearest choice)).
Notation cexp_flt := (cexp beta (FLT_exp emin prec)).
Notation fexpe k := (FLT_exp (emin-k) (prec+k)).

Lemma Zrnd_odd_plus': forall x y,
(exists n:Z, exists e:Z, (x = IZR n*bpow beta e)%R /\ (1 <= e)%Z) ->
(IZR (Zrnd_odd (x+y)) = x+IZR (Zrnd_odd y))%R.
Proof. hammer_hook "Round_odd" "Round_odd.Zrnd_odd_plus'".
intros x y (n,(e,(H1,H2))).
apply Zrnd_odd_plus.
rewrite H1.
rewrite <- IZR_Zpower.
2: auto with zarith.
now rewrite <- mult_IZR, Zfloor_IZR.
rewrite H1, <- IZR_Zpower.
2: auto with zarith.
rewrite <- mult_IZR, Zfloor_IZR.
rewrite Z.even_mul.
rewrite Z.even_pow.
2: auto with zarith.
rewrite Even_beta.
apply Bool.orb_true_iff; now right.
Qed.

Theorem mag_round_odd: forall (x:R),
(emin < mag beta x)%Z ->
(mag_val beta _ (mag beta (round beta (FLT_exp emin prec) Zrnd_odd x))
= mag_val beta x (mag beta x))%Z.
Proof with auto with typeclass_instances. hammer_hook "Round_odd" "Round_odd.mag_round_odd".
intros x.
assert (T:Prec_gt_0 prec).
unfold Prec_gt_0; auto with zarith.
case (Req_dec x 0); intros Zx.
intros _; rewrite Zx, round_0...
destruct (mag beta x) as (e,He); simpl; intros H.
apply mag_unique; split.
apply abs_round_ge_generic...
apply FLT_format_bpow...
auto with zarith.
now apply He.
assert (V:
(Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) <= bpow beta e)%R).
apply abs_round_le_generic...
apply FLT_format_bpow...
auto with zarith.
left; now apply He.
case V; try easy; intros K.
assert (H0:Rnd_odd_pt beta (FLT_exp emin prec) x (round beta (FLT_exp emin prec) Zrnd_odd x)).
apply round_odd_pt...
destruct H0 as (_,HH); destruct HH as [H0|(H0,(g,(Hg1,(Hg2,Hg3))))].
absurd (Rabs x < bpow beta e)%R.
apply Rle_not_lt; right.
now rewrite <- H0,K.
now apply He.
pose (gg:=Float beta (Zpower beta (e-FLT_exp emin prec (e+1))) (FLT_exp emin prec (e+1))).
assert (Y1: F2R gg = bpow beta e).
unfold F2R; simpl.
rewrite IZR_Zpower.
rewrite <- bpow_plus.
f_equal; ring.
assert (FLT_exp emin prec (e+1) <= e)%Z; [idtac|auto with zarith].
unfold FLT_exp.
apply Z.max_case_strong; auto with zarith.
assert (Y2: canonical beta (FLT_exp emin prec) gg).
unfold canonical; rewrite Y1; unfold gg; simpl.
unfold cexp; now rewrite mag_bpow.
assert (Y3: Fnum gg = Z.abs (Fnum g)).
apply trans_eq with (Fnum (Fabs g)).
2: destruct g; unfold Fabs; now simpl.
f_equal.
apply canonical_unique with (FLT_exp emin prec); try assumption.
destruct g; unfold Fabs; apply canonical_abs; easy.
now rewrite Y1, F2R_abs, <- Hg1,K.
assert (Y4: Z.even (Fnum gg) = true).
unfold gg; simpl.
rewrite Z.even_pow; try assumption.
assert (FLT_exp emin prec (e+1) < e)%Z; [idtac|auto with zarith].
unfold FLT_exp.
apply Z.max_case_strong; auto with zarith.
absurd (true = false).
discriminate.
rewrite <- Hg3.
rewrite <- Zeven_abs.
now rewrite <- Y3.
Qed.

Theorem fexp_round_odd: forall (x:R),
(cexp_flt (round beta (FLT_exp emin prec) Zrnd_odd x)
= cexp_flt x)%Z.
Proof with auto with typeclass_instances. hammer_hook "Round_odd" "Round_odd.fexp_round_odd".
intros x.
assert (G0:Valid_exp (FLT_exp emin prec)).
apply FLT_exp_valid; unfold Prec_gt_0; auto with zarith.
case (Req_dec x 0); intros Zx.
rewrite Zx, round_0...
case (Zle_or_lt (mag beta x) emin).
unfold cexp; destruct (mag beta x) as (e,He); simpl.
intros H; unfold FLT_exp at 4.
rewrite Z.max_r.
2: auto with zarith.
apply Z.max_r.
assert (G: Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) = bpow beta emin).
assert (G1: (Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) <= bpow beta emin)%R).
apply abs_round_le_generic...
apply generic_format_bpow'...
unfold FLT_exp; rewrite Z.max_r; auto with zarith.
left; apply Rlt_le_trans with (bpow beta e).
now apply He.
now apply bpow_le.
assert (G2: (0 <= Rabs (round beta (FLT_exp emin prec) Zrnd_odd x))%R).
apply Rabs_pos.
assert (G3: (Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) <> 0)%R).
assert (H0:Rnd_odd_pt beta (FLT_exp emin prec) x
(round beta (FLT_exp emin prec) Zrnd_odd x)).
apply round_odd_pt...
destruct H0 as (_,H0); destruct H0 as [H0|(_,(g,(Hg1,(Hg2,Hg3))))].
apply Rgt_not_eq; rewrite H0.
apply Rlt_le_trans with (bpow beta (e-1)).
apply bpow_gt_0.
now apply He.
rewrite Hg1; intros K.
contradict Hg3.
replace (Fnum g) with 0%Z.
easy.
case (Z.eq_dec (Fnum g) Z0); intros W; try easy.
contradict K.
apply Rabs_no_R0.
now apply F2R_neq_0.
apply Rle_antisym; try assumption.
apply Rle_trans with (succ beta (FLT_exp emin prec) 0).
right; rewrite succ_0.
rewrite ulp_FLT_small; try easy.
unfold Prec_gt_0; auto with zarith.
rewrite Rabs_R0; apply bpow_gt_0.
apply succ_le_lt...
apply generic_format_0.
apply generic_format_abs; apply generic_format_round...
case G2; [easy|intros; now contradict G3].
rewrite <- mag_abs.
rewrite G, mag_bpow; auto with zarith.
intros H; unfold cexp.
now rewrite mag_round_odd.
Qed.

End Odd_propbis.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D Aprime Bprime Cprime Dprime X Y : Universe, ((wd_ X A /\ (wd_ X Aprime /\ (wd_ X C /\ (wd_ X Cprime /\ (wd_ Y B /\ (wd_ Y Bprime /\ (wd_ Y D /\ (wd_ Y Dprime /\ (wd_ A B /\ (wd_ Aprime Bprime /\ (wd_ A C /\ (wd_ B D /\ (wd_ A Aprime /\ (wd_ X Y /\ (wd_ X B /\ (wd_ A Y /\ (wd_ B C /\ (wd_ Bprime Cprime /\ (wd_ A D /\ (wd_ Aprime Dprime /\ (col_ X A C /\ (col_ X A Aprime /\ (col_ X A Cprime /\ (col_ Y B D /\ (col_ Y B Bprime /\ col_ Y B Dprime))))))))))))))))))))))))) -> col_ Y Bprime Dprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From isla Require Import opsem.

Definition a18250 : isla_trace :=
  Smt (DeclareConst 46%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "R6" [] (RegVal_Base (Val_Symbolic 46%Z)) Mk_annot :t:
  Smt (DefineConst 49%Z (Manyop (Bvmanyarith Bvor) [Manyop (Bvmanyarith Bvand) [Val (Val_Symbolic 46%Z) Mk_annot; Val (Val_Bits (BV 64%N 0xffffffffffff0000%Z)) Mk_annot] Mk_annot; Val (Val_Bits (BV 64%N 0x100f%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "R6" [] (RegVal_Base (Val_Symbolic 49%Z)) Mk_annot :t:
  Smt (DeclareConst 50%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 50%Z)) Mk_annot :t:
  Smt (DefineConst 51%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 50%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 51%Z)) Mk_annot :t:
  tnil
.


(** 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 robots.car.ackermannSteering.
Require Import MCMisc.tactics.
Require Import CartIR.
Require Import fastReals.interface.
Require Import fastReals.misc.
Require Import geometry2D.
Require Import geometry2DProps.
Require Import car.errorBounds.
Require Import robots.car.ackermannSteeringProp.
Require Import MathClasses.orders.rings.
Require Import MathClasses.interfaces.orders.
Require Import robots.car.atomicMoves.
Require Import IRMisc.LegacyIRRing.
Hint Unfold One_instance_IR : IRMC.
Require Import robots.car.firstQuadrant.
Require Import CRMisc.numericalOpt.

  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.

Require Import CartIR2.

Require Import robots.car.exampleDimensions.
Require Import robots.car.wriggle.
Require Import robots.car.sidewaysMove.
Require Import MathClasses.implementations.bool.

(** In [sidewaysMove], we analyzed the space needed to execute
a sideways move, which is specified by 3 parameters.
To implement such a move, one has to invert that equation --
given the amount of available space, find a best
choice of those 3 parameters.
We fix one of those by deciding that while turning, the
steering wheel will be at its extremities -- this choice
may be optimal.

2 parameters remain : how much to drive while turning (d),
and how much to drive while moving straight (d').

The total X-space needed can be decomposed as a sum
of 2 terms, each of which is a function of d and d'.
The former, which is
the space needed to execute the [Wriggle] part of the sideways move,
is a horrendous quartic.

The latter function, which
is the X-space consumed by the straight move, and is easily
invertible w.r.t. d'. Hence we chose d' such that all the
remaining space (if any) is
taken up by the straight move.

So, the only remaining parameter is d. We systematically try several
samples and pick the best one that is safe.
Based on the how closely the samples are chosen for d, this approach
is both sound and approximately optimal.
*)

Definition mkQTurnMove (α:Qpos) (d:CR): DAtomicMove CR.
  exists {|am_distance := d ; am_tc := '`α|}.
  simpl. right. right.
  exists α. simpl.
  fold (CRopp).
  fold (CRplus).
  fold (@negate CR _).
  fold (@plus CR _).
  rewrite minus_0_r.
  reflexivity.
Defined.

Definition mkNegQTurnMove (α:Qpos) (d:CR): DAtomicMove CR.
  exists {|am_distance := d ; am_tc := -'`α|}.
  simpl. right. left.
  exists α. simpl.
  fold (CRopp).
  fold (CRplus).
  fold (@negate CR _).
  fold (@plus CR _).
  rewrite negate_involutive.
  rewrite plus_0_l.
  reflexivity.
Defined.

Definition mkQWriggle (α:Qpos) (d:CR) : list (DAtomicMove CR)
    :=  [mkQTurnMove α d; mkNegQTurnMove α (-d)].

Require Import robots.car.commutator.
Definition mkQSideways (α:Qpos) (d d':CR) : list (DAtomicMove CR)
    :=
conjugate [mkStraightMove d'] (mkQWriggle α d).

(*
Lemma DWriggleSame : forall (t:Qpos) (d:CR),
  List.map getAtomicMove (DWriggle t d) = Wriggle ('t) d.
Proof.
  intros. reflexivity.
Qed.

Lemma DSidewaysSame : forall (t:Qpos) (dw ds :CR),
  List.map getAtomicMove (DSideways t dw ds) = SidewaysMove ('t) dw ds.
Proof.
  intros. reflexivity.
Qed.
*)

Section InverseProblem.

Variable cd : CarDimensions Q.

Hypothesis ntriv : nonTrivialCarDim cd.

Variable  α : Q.
Hypothesis αPosQ : (0<α).

(** there is already a ring instance decrared for CR,
 using the legacy
 definition of ring. That may cause issues.
 Remove that ring, because that needs unfolding to ugly
legacy notations for the old [CRing].
Add the old ring declaration to a separate file, and
import it in old files.
 *)
Add Ring tempRingCR : (stdlib_ring_theory CR).

Let αPos : ((0:IR)[<]'α).
Proof using αPosQ.
  eapply less_wdl;[| apply inj_Q_Zero].
  apply inj_Q_less. apply αPosQ.
Qed.

Let tr :=  Qinv α.

Hint Resolve  αPos : sideways.
Let αNZ := ((pos_ap_zero _ _ αPos): 'α[#](0:IR)).

Let trComplicated : 'tr = f_rcpcl ('α) αNZ.
Proof using ntriv.
 apply QinvIRinv.
Qed.

(** 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 : ((width cd) <= tr)%Q.

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

(** extra space available t execute the sideways move *)
Variable Xs : Q.
Hypothesis Xsp : (0<Xs).

(** space needed for the wriggle move for a given θ. The parameter
[d] that we are after is just [θ/α] *)
Let extraSpaceX1W  (θ:CR) : CR :=
  compress (wriggle.extraSpaceX1 α cd θ).

(** Recap:
[extraSpaceX1W] is valid only for
when [(α * d)] is  between 0 and [leftCriticalAngle].
There is also an [extraSpaceX2] for the case when
[(α * d)] is between [leftCriticalAngle]
and [(polarTheta βPlusBack)/2], however that
range may be so small for most cars, that
it is not worth analysing that equation.
For mazda 3, the range was 2 degrees.
Beyond [(polarTheta βPlusBack)/2], the problem
becomes trivial, and can be solved in just 1 move.
*)

Let leftCriticalAngle : CR :=
  wriggle.leftCriticalAngleCR  α cd.

Definition extraSpaceX1WValid (θ:CR) : Prop :=
0 ≤ θ ≤ leftCriticalAngle
∧ 2 * θ ≤ (polarTheta βPlusBack).

Definition maxValidAngle : CR :=
  min (leftCriticalAngle) (½*(polarTheta βPlusBack)).

Require Import MCMisc.fields.
Require Import MCMisc.rings.

Lemma extraSpaceX1WValidIff (θ:CR) :
extraSpaceX1WValid θ
↔ 0 ≤ θ ≤ maxValidAngle.
Proof using.
  unfold extraSpaceX1WValid, maxValidAngle.
  rewrite halfLeShift.
  split; intro h;
   dands; try tauto.
- apply CRmin_glb; [apply h; fail| tauto].
- eapply transitivity;[|eapply CRmin_lb_l].
  apply h.
- eapply transitivity;[|eapply CRmin_lb_r].
  apply proj2 in h.
  exact h.
Qed.

(** the srict inequality in the
last clause is necessary, because we want
same space to be left for the straight move,
to ensure that
the upward shift is nonzero. *)
Definition dAdmissibleXwise (θ:CR) :=
extraSpaceX1WValid θ
∧ extraSpaceX1W θ < 'Xs.

(** we need to often compare reals. This can
 -only be done upto a finte (but arbitrary) accuracy.*)
Variable eps : Qpos.

Definition approxDecideXAdmiss (θ:CR) : bool :=
approxDecLtRQ eps (extraSpaceX1W θ) Xs.

Require Import MCMisc.rings.

Let trPos : 0 < tr.
Proof using αPosQ.
apply Qinv_lt_0_compat.
exact αPosQ.
Qed.

Lemma cosβPlusBackPos :
 0 < cos (polarTheta βPlusBack).
Proof using Xsp ntriv trComplicated turnCentreOut.
  apply pos_cos_CR.
  unfold nonTrivialCarDim in ntriv.
  split. eapply (proj1 (polarFirstQuad _ _)).
  apply polarFirstQuadStrict; simpl;  autounfold with QMC in *;
  simpl; try lra.
  Unshelve.
  split; simpl;  autounfold with QMC in *; try lra.
Qed.

Definition cosβPlusBackPosWitness : Qpos.
Proof using ntriv tr trPos Xsp.
  exists (lengthBack cd /(tr + width cd + lengthBack cd))%Q.
  unfold nonTrivialCarDim in ntriv.
  autounfold with QMC in *.
  apply Qlt_shift_div_l; lra.
Defined.

  (** hypotenuse  ≤ sum of the other sides of a right angled triangle*)
Lemma cosβPlusBackPosT_subproof:
(' cosβPlusBackPosWitness <= cos (polarTheta βPlusBack) - 0%mc)%CR.
Proof using Xsp ntriv trComplicated trPos turnCentreOut.
  fold (CRopp).
  fold (CRplus).
  fold (@negate CR _).
  fold (@plus CR _).
  rewrite minus_0_r.
  pose proof (Cart2Polar2CartID βPlusBack) as H.
  destruct H as [Hx _].
  simpl in Hx.
  simpl.
  unfold nonTrivialCarDim in ntriv.
  autounfold with QMC in ntriv, trPos.
  apply (@order_reflecting _ _ _ _  _ _ (mult ('(tr + width cd + lengthBack cd)))).
    apply OrderReflecting_instance_0. apply preserves_pos.
    unfold PropHolds. autounfold with QMC. lra.

  fold (cast Q CR).
  rewrite <- preserves_mult.
  assert (
  ((tr + width cd + lengthBack cd) * (lengthBack cd / (tr + width cd + lengthBack cd))%Q)
  == (lengthBack cd ))%Q as Heq by (field; lra).
  setoid_rewrite Heq. clear Heq.
  rewrite Hx. clear Hx.
  apply mult_le_compat;[apply Cart2PolarRadRange
    | apply lt_le, cosβPlusBackPos
    |
    |  reflexivity]; [].
  apply RingLeIfSqrLe.
- apply RingPosNnegCompatPlus;[| apply Cart2PolarRadRange].
  apply preserves_pos. autounfold with QMC in *. unfold PropHolds; lra.

- unfold sqr.
  rewrite <- preserves_mult.
  setoid_rewrite CRsqrt_sqr1Q1.
  apply (@order_preserving _ _ _ _ _ _ _ _ _ _ ).
  simpl.
  rewrite nat_pow.nat_pow_2.
  rewrite nat_pow.nat_pow_2.
  remember (tr + width cd).
  fold (sqr (y + lengthBack cd)).
  fold (sqr y).
  fold (sqr (lengthBack cd)).
  apply RingLeSqr1; autounfold with QMC in *; subst; lra.
Qed.

Lemma cosβPlusBackPosT :
 (0 < cos (polarTheta βPlusBack))%CR.
Proof using Xsp ntriv trComplicated trPos turnCentreOut.
  exists cosβPlusBackPosWitness.
  (** now we can invoke opaque lemmas.
  Even if everything in the the above [cosβPlusBackPos] opaque version
  was made transparent recursively, the witness may not be as simple/fast
  as the one above
   *)
  apply cosβPlusBackPosT_subproof.
Defined.

Lemma extraSpaceX1WValidCosPos :forall  (θ:CR),
extraSpaceX1WValid θ
→ 0 < cos (2 * θ).
Proof  using αPosQ ntriv Xsp.
  intros ? Hv.
  apply pos_cos_CR.
  unfold extraSpaceX1WValid in Hv.
  split;[apply RingLeProp3; tauto|].
  eapply le_lt_trans; [apply Hv|].
  unfold nonTrivialCarDim in ntriv.
  apply polarFirstQuadStrict; simpl;  autounfold with QMC in *;
  simpl; try lra.
Qed.

(** needed because we wish to divide by [cos (2 * θ)]
  To avoid carrying the proof positivity, a dummy max is used.
  [extraSpaceX1WValid θ] implies that the max is equal to its right argument.
Lemma extraSpaceX1WValidCosPos :forall  (θ:CR),
 (0 < max (cos (polarTheta βPlusBack)) (cos (2 * θ)))%CR.
Proof using Xsp ntriv trComplicated trPos turnCentreOut.
  intros ? .
  exists cosβPlusBackPosWitness.
  eapply transitivity;[apply cosβPlusBackPosT_subproof|].
  setoid_rewrite preserves_0.
  fold (CRopp).
  fold (CRplus).
  fold (@negate CR _).
  fold (@plus CR _).
  rewrite minus_0_r.
  rewrite minus_0_r.
  apply CRmax_ub_l.
Defined.
 *)

Section objective.

Variable θ:CR.

(** Now compute the quality (the amount of upward shift) for a
given parameter [d]. The remaining space, which must be positive for
admissible values, will be used up for the straight move.
This function will only be used for admissible
[d]s -- if that simplifies anything .

[d'] is the distance covered during the straight move
*)

Hypothesis valid : extraSpaceX1WValid θ.

Let  cos2θ_lb :Qpos.
destruct (CRlt_Qmid 0 (cos (polarTheta βPlusBack))
cosβPlusBackPosT).
exists x.
destruct p.
apply Qlt_from_CRlt in c.
assumption.
Defined.

Local Opaque CR.

Lemma  cos2θ_lbCorrect:
 '`cos2θ_lb ≤ (cos (2 * θ)).
Proof using valid.
  subst cos2θ_lb.
  destruct  (CRlt_Qmid 0 (cos (polarTheta βPlusBack))).
  simpl.
  apply snd in p.
  apply CR_lt_ltT in p.
  apply lt_le in p.
  eapply transitivity;[apply p|].
  unfold extraSpaceX1WValid in valid.
  apply CRcos_resp_leEq; try tauto;[|].
- apply RingLeProp3; tauto.
- apply Cart2PolarAngleRange.
Qed.

Let cos2θ_inv : CR.
  apply (CRinvT
          (max ('(`cos2θ_lb))  (cos (2 * θ)))).
  right.
  exists cos2θ_lb.
  fold (CRopp).
  fold (CRplus).
  fold (@negate CR _).
  fold (@plus CR _).
  setoid_rewrite preserves_0.
  rewrite minus_0_r.
  apply CRmax_ub_l.
Defined.

Require Import MCMisc.tactics.

(** the RHS is a formula of MathClasses.abstract_algebra.Field, so
that the general field lemmas can be used *)
Lemma  cos2θ_inv_simpl :
cos2θ_inv = (// (cos (2 * θ)) ↾ (or_intror (extraSpaceX1WValidCosPos _ valid))).
Proof using.
  unfold cos2θ_inv.
  rewrite CRinv_CRinvT.
  apply fields.recip_proper_alt.
  apply  CRle_max_r.
  apply cos2θ_lbCorrect.
Qed.

Definition spaceNeededFor1MoveSoln : CR :=
  rad ('(βPlusFront)) - '(lengthFront cd).

Definition dStraight  : CR := (compress cos2θ_inv) * ('Xs -  (extraSpaceX1W θ)).

Local Notation d' := dStraight.

Require Import MathClasses.theory.fields.

Definition dWriggle :CR := ('tr*θ).

Local Notation d := dWriggle.

Let sidewaysMove : list (DAtomicMove IR)
  := SidewaysAux ('α) αNZ ('d) ('(d')).

Definition sidewaysMoveQCR : list (DAtomicMove CR)
  := mkQSideways (α ↾ αPosQ) d d'.

Lemma  θcorrect : θ = 'α * d.
Proof using αPosQ Xsp cd turnCentreOut.
  unfold dWriggle.
  rewrite  (@simple_associativity _ _ mult _ _).
  rewrite <- preserves_mult.
  clear valid  cos2θ_lb cos2θ_inv sidewaysMove.
  subst tr.
  autounfold with QMC in *.
  field_simplify ((α * / α)%Q);[| lra].
  change ((1 / 1)%Q) with (@one Q _).
  rewrite preserves_1.
  fold (@mult CR _).
  rewrite mult_1_l.
  reflexivity.
Qed.

(** the above sideways move takes up all the available space in the X direction *)
Lemma sidweaysXSpaceExact :
   extraSpaceXSidewaysCase1  α cd d d' = 'Xs.
Proof using cos2θ_inv valid.
  unfold extraSpaceXSidewaysCase1.
  unfold d'.
  rewrite MultShuffle3r.
  rewrite compress_correct, cos2θ_inv_simpl.
  unfold cos, implCR.CosClassCR .
  setoid_rewrite <- (@simple_associativity _ _ mult _ 2 _ _) at 3.
  setoid_rewrite <- θcorrect at 2.
  rewrite reciperse_altL.
  unfold extraSpaceX1W.
  unfold extraSpaceX1.
  unfold cos, implCR.CosClassCR .
  rewrite compress_correct.
  setoid_rewrite <- θcorrect.
  ring.
Qed.

Definition upwardShift : CR := d' * (sin (2 * θ)).

Lemma upwardShiftEq1 :
let pf :=  (or_intror (extraSpaceX1WValidCosPos _ valid)) in
upwardShift =
(// (cos (2 * θ)) ↾ pf) * ('Xs -  (extraSpaceX1W θ)) * (sin (2 * θ)).

(* essentially, [upwardShift =  (tan (2 * θ)) * ('Xs -  (extraSpaceX1W θ))] .

tan is not defined for CR. Unlike sine and cosine, it has a limited domain, and thus
would have needed a dependent argument like the one on IR
*)
Proof using.
  simpl. unfold upwardShift, d'.
  rewrite compress_correct, cos2θ_inv_simpl.
  reflexivity.
Qed.

Lemma upwardShiftCorrect: forall init,
θ2D init =0
→
Y (pos2D (stateAfterAtomicMoves sidewaysMove init))
  =
Y (pos2D init) + 'upwardShift.
Proof using.
  intros ? h0.
  unfold sidewaysMove.
  rewrite SidewaysAuxState.
  unfold sidewaysDisp, upwardShift.
  simpl.
  rewrite h0.
  rewrite plus_0_l.
  setoid_rewrite <- (@simple_associativity _ _ mult _ 2 _ _).
  unfold sin, implCR.SinClassCR.
  rewrite  θcorrect.
  fold implCR.SinClassCR.
  autounfold with IRMC.
  unfold cast, Cast_instace_Q_IR, Cart_CR_IR, implCR.SinClassCR, Cart2Polar.
  autorewrite with CRtoIR.
  reflexivity.
Qed.

(* using product rule and:
http://www.math.com/tables/derivatives/more/trig.htm

 (d/dx) tan(x) : sec^2(x)

To lower bound the quality of the solution found by the optimizer,
we have to upper bound this derivative.
*)

Definition  upwardShiftDeriv :CR :=
let pf :=  (or_intror (extraSpaceX1WValidCosPos _ valid)) in
sqr (// (cos (2 * θ)) ↾ pf) * ('Xs -  (extraSpaceX1W θ))
- (// (cos (2 * θ)) ↾ pf) * (IRasCR (extraSpaceX1Deriv  α cd ('θ))).

(* this can ony be stated after this section is closed *)
Lemma upwardShiftDerivCorrect : 0=(0:CR).
Abort.

End objective.

Require Import CRMisc.numericalOpt.

Definition approxMaximizeUpwardShift : list CR -> option CR :=
  approxMaximize eps CR approxDecideXAdmiss upwardShift.

Require Import MathClasses.interfaces.functors.
Require Import MathClasses.interfaces.monads.
Require Import MathClasses.theory.monads.
Require Import MathClasses.implementations.option.

(* Move and use in approximateAngleAsDegrees.*)
Definition angleAsDegrees (a:CR) : CR :=
 (a*CRPiInv* ('180%positive)).

Let sap : CR -> Q :=  fun r => simpleApproximate r (100)%positive eps.
Definition sidewaysOptimalParamsAndShiftAux (l: list CR) : list CR :=
  match (approxMaximizeUpwardShift l) with
  | None  => [0;0;0;0;0]
  | Some θ =>
    let ds := dStraight θ in
    [(angleAsDegrees θ); upwardShift θ; ds; extraSpaceX1W θ; ds * cos (2*θ)]
  end.

Definition sidewaysOptimalParamsAndShiftQAux (l: list CR) : (list Q) :=
  List.map  sap (sidewaysOptimalParamsAndShiftAux l).

Definition optimalSidewaysMoveAux (l: list CR) : (CR * list (DAtomicMove CR)) :=
  match (approxMaximizeUpwardShift l) with
  | None => (0,[])
  | Some θ =>
    let straightXspace := (dStraight θ) * (cos (2*θ)) in
    let totalRightExtraSpace := (rightExtraSpaceW α cd θ) + straightXspace in
    (totalRightExtraSpace , sidewaysMoveQCR θ)
  end.

Example approxMaximizeUpwardShiftTest :
  approxMaximizeUpwardShift [] = None.
  reflexivity.
Qed.

Section sampling.
Variable δ: Qpos.

(** the goal here is to create a list of rationals
between 0 and [maxValidAngle] such that any point in that range
is at most δ away from some member of the list.

Thus, the optimal solution, whether real or rational, is also
at most δ away from a solution in the list that we considered
during the optimization. Because the objective function (upward shift)
is a continuous function with bounded derivative (say ≤ k), the suboptimality
is at most kδ + eps. Need to characterize k.
 *)

Require Import Qmisc.
Definition maxValidAngleApprox : Q :=
  lowerApprox (compress maxValidAngle) ((QposMake 1 2)*δ).

Definition equiSpacedSamples : list Q :=
  Qmisc.equiSpacedSamples  δ maxValidAngleApprox.

Let samples := (cbvApply (List.map (cast Q CR)) equiSpacedSamples).

Definition optimalSolution : option CR :=
  approxMaximizeUpwardShift samples.

Definition sidewaysOptimalParamsAndShiftQ : (list Q) :=
sidewaysOptimalParamsAndShiftQAux samples.

Definition optimalSidewaysMove : (CR * list (DAtomicMove CR)) :=
  optimalSidewaysMoveAux samples.

(* Move *)
Lemma preserves_extraSpaceX1DerivUB:
  '(extraSpaceX1DerivUB α cd) = ((extraSpaceX1DerivUB α cd):IR).
Proof using.
  unfold extraSpaceX1DerivUB.
  simpl.
  autounfold with IRMC.
  autorewrite with CRtoIR.
  reflexivity.
Qed.

(* Move *)
Lemma nonneg_extraSpaceX1DerivUB:
 (0:IR) ≤ extraSpaceX1DerivUB α cd.
Proof using.
  apply nonneg_plus_compat;
  [ apply RingLeProp3 | ];apply Cart2DRadNNegIR.
Qed.

Hypothesis δSmallEnough : '`δ ≤ maxValidAngle.

Lemma maxValidAngleApproxNonneg : 0 ≤ maxValidAngleApprox.
Proof using δSmallEnough.
  unfold maxValidAngleApprox.
  apply (order_reflecting (cast Q CR)).
  eapply transitivity;[| apply (proj1 (lowerApproxCorrect _ _))].
  rewrite compress_correct.
  apply flip_le_minus_l.
  rewrite negate_involutive.
  rewrite <- preserves_plus.
  eapply transitivity;[| apply δSmallEnough].
  apply order_preserving;[eauto 2 with typeclass_instances|].
  apply eq_le.
  simpl.
  autounfold with QMC.
  destruct δ; simpl.
  ring.
Qed.

Lemma  equiSpacedSamplesFstValue:
 {q :Q | List.head  equiSpacedSamples ≡ Some q
    /\ extraSpaceX1W ('q) ≤ (extraSpaceX1DerivUB α cd) * ('`δ) }.
Proof using δSmallEnough eps.
  destruct (equiSpacedSamplesFst2 δ maxValidAngleApprox) as [q Hd];
    [apply maxValidAngleApproxNonneg|].
  exists q. destruct Hd as [Hdl Hdr].
  setoid_rewrite Hdl.
  split;[reflexivity|].
  apply CR_leEq_as_IR.
  unfold extraSpaceX1W.
  rewrite compress_correct.
  rewrite preserves_extraSpaceX1.
  rewrite CR_mult_asIR.
  rewrite preserves_extraSpaceX1DerivUB.
  eapply transitivity;
    [apply extraSpaceX10UB|].
- unfold cast, Cast_instace_Q_IR, Cart_CR_IR, implCR.SinClassCR, Cart2Polar.
  autorewrite with CRtoIR.
  apply preserves_nonneg; tauto.

- fold Mult_instance_IR.
  fold (@mult IR _).
  pose proof nonneg_extraSpaceX1DerivUB.
  apply order_preserving; [eauto 2 with typeclass_instances |].
  unfold cast, Cast_instace_Q_IR, Cart_CR_IR, implCR.SinClassCR, Cart2Polar.
  autorewrite with CRtoIR.
  apply order_preserving; [eauto 2 with typeclass_instances |].
  apply Hdr.
Qed.

Lemma  equiSpacedSamplesFstAdmissible:
(extraSpaceX1DerivUB α cd) * ('`δ) + '(2*`eps) <  'Xs
→
{q :Q | List.head  equiSpacedSamples ≡ Some q
    /\ approxDecideXAdmiss ('q) ≡ true}.
Proof using δSmallEnough.
  intro H.
  destruct equiSpacedSamplesFstValue as [q Hd].
  exists q. repnd.
  rewrite Hdl.
  split;[reflexivity|].
  unfold approxDecideXAdmiss.
  apply approxDecLtRQApproxComplete.
  eapply le_lt_trans;[apply Hdr|].
  rewrite preserves_minus.
  apply flip_lt_minus_l.
  rewrite negate_involutive.
  assumption.
Qed.

Lemma optimalSolution_isSome :
(extraSpaceX1DerivUB α cd) * ('`δ) + '(2*`eps) <  'Xs
→
   ∃ (m : Q),
      In m equiSpacedSamples
      ∧ approxDecideXAdmiss ('m) ≡ true
      ∧ optimalSolution ≡ Some ('m).
Proof using δSmallEnough.
  intro Hyp.
  destruct (equiSpacedSamplesFstAdmissible Hyp) as [q Hd].
  repnd.
  eapply (approxMaximizeCorrect eps CR approxDecideXAdmiss
      upwardShift _ ((List.map (cast Q CR) equiSpacedSamples))) in Hdr;
  [| destruct equiSpacedSamples;inversion Hdl; subst; left; reflexivity].
  destruct Hdr as [mr Hs].
  repnd.
  apply in_map_iff in Hsl.
  destruct Hsl as [mq Hsl].
  exists mq.
  split;[tauto|].
  repnd.
  subst mr.
  tauto.
Qed.

End sampling.

End InverseProblem.

Section TestSetup.

Let cd : CarDimensions Q := '(carDim Mazda3Sedan2014sGT).

Let ntriv : nonTrivialCarDim cd.
  unfold nonTrivialCarDim. compute; dands; reflexivity.
Defined. (*Qed? *)

(** all turns will be executed at maximum curvature, which
corresponds to the minimum turn radius allowed by the car's geometry*)
Let α : Q.
  let t := eval compute in (Qinv (minTR Mazda3Sedan2014sGT)) in
  exact t.
Defined.

(*
Print α.
α := (1 # 150)%Q : Q]
*)

Let αPosQ : (0 < α).
compute. reflexivity.
Defined.

Definition mazdaMaxCurvTurnMove (dist:CR): DAtomicMove CR :=
  mkQTurnMove (α ↾ αPosQ) dist.

Let turnCentreOut : (width cd <= Qinv α)%Q.
compute. intros H; discriminate.
Defined.  (*Qed? *)

Let eps : Qpos.
  let t := eval compute in ((Qmake 1 100)) in
  exists t.
  compute. reflexivity.
Defined.

(** extra available space in the X direction.
set to one tenth of the length of the car
Let Xs : Q.
  let t := eval compute in ((Qmake 1 10) * (totalLength cd)) in
  exact t.
Defined.

(*
Print Xs.
(178 # 10)%Q

unit : inches
*)

Let Xsp : (0 < Xs).
compute. reflexivity.
Defined.  (*Qed? *)

Let tapproxMaximizeUpwardShift : list CR → option CR :=
  approxMaximizeUpwardShift cd ntriv α αPosQ turnCentreOut Xs Xsp eps.

Let test1 : option CR :=
(tapproxMaximizeUpwardShift [' (Qmake 1 100); ' (Qmake 1 200)]).
*)

Let approx : option CR -> option Q :=
  sfmap (fun r => approximate r eps).

(* unit : radians. pi radians = 180 degrees. 1 radian ~ 57 degrees *)
Definition δ :Qpos := QposMake 1 100.

Let  tr :Q := '(minTR Mazda3Sedan2014sGT).

Eval compute in tr.

Eval vm_compute in (R2ZApprox (rad ('(βPlusFront cd α)))  eps).
(*235*)
Eval vm_compute in (lengthFront cd).
(*142.
If there is sufficient space at the bottom and if there is more than
235-142 = 93 inches of space in the front, parallel parking can be done in 1 move
*)
Eval vm_compute in (R2ZApprox (spaceNeededFor1MoveSoln cd α)  eps).
(* 93 *)

Definition samples : list Q:=
equiSpacedSamples cd α δ.

Eval vm_compute in (samples).

Definition optimalSidewaysMoveShiftMazdaQp (Xspos : Qpos ): (list Q) :=
  let (Xs, Xsp) := Xspos in
  (sidewaysOptimalParamsAndShiftQ cd ntriv α αPosQ turnCentreOut Xs Xsp eps δ).

Definition optimalSidewaysMoveMazda (Xspos : Qpos ) : (CR * list (DAtomicMove CR)) :=
  let (Xs, Xsp) := Xspos in
  optimalSidewaysMove cd ntriv α αPosQ turnCentreOut Xs Xsp eps δ.

Definition optimalSidewaysMoveShiftMazdaQ (eps' δ': Qpos) (q : Q): (list Q) :=
let (Xs, Xsp) := Qpossec.QabsQpos q in
  (sidewaysOptimalParamsAndShiftQ cd ntriv α αPosQ turnCentreOut Xs Xsp eps' δ').

Let  tupwardShift (Xspos : Qpos ) : CR -> CR :=
  let (Xs, Xsp) := Xspos in
    upwardShift cd ntriv α αPosQ turnCentreOut Xs Xsp.

Example xxxx :
(optimalSidewaysMoveShiftMazdaQ (QposMake 17 1)) eps δ
≡ [(171 # 100)%Q; (56 # 100)%Q; (938 # 100)%Q; (764 # 100)%Q; (936 # 100)%Q].
(*vm_compute.
reflexivity. *)
Abort.

Definition xspaceSamples (np : positive ): list Q :=
let max :Q  := (approximate (spaceNeededFor1MoveSoln cd α) eps) in
let eqs : list Q := equiMidPoints np in
  List.map (mult max) eqs.

Definition plotl `(f: A->B) (l: list A) : (list (A * B)) :=
List.map (fun a => (a,f a)) l.

(*
Eval vm_compute in
  (List.map (fun q => approximateQ q (100)%positive)
     (xspaceSamples (100)%positive)).
*)
Definition plotOptimalSidewaysMoveShiftMazdaQ (eps' δ': Qpos) (np : positive) :=
  plotl (optimalSidewaysMoveShiftMazdaQ eps' δ') (xspaceSamples np).

(**
Ideas to make it fast:
(0.7s (eps=0.01 inch, 41 samples) afer extraction is fast enough for now)

1) Switch to AR.

Even though operations on AR are exact, AR is a completion of
AQ (approximate rationals), where there is no exact division.
This should not be a problem. In worst case, one can inject the AQs
into ARs and then do the exact division in AR.

Does CoRN.reals.fast.Compress, already provide some of the advantages
of AR in CR?

2) It suffices to only consider rational solutions. We are only after
approximate optimality. We can replace [sin] by [rational_sin] ...  e.t.c.
[sin] invokes [rational_sin].

*)

(*
Print boundAbove.
Print QboundAbove_uc.
Print QboundAbove_uc_prf.
SearchAbout boundAbove.
SearchAbout CR Q.
*)

End TestSetup.