Require Import Coq.ZArith.ZArith Coq.ZArith.BinIntDef.
Require Import Coq.QArith.QArith_base.
Require Import Coq.Lists.List. Import ListNotations.
Require Import Crypto.Arithmetic.CoreUnfolder.
Require Import Crypto.Arithmetic.Core. Import B.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Crypto.Specific.Framework.CurveParameters.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.LetIn Crypto.Util.ZUtil.
Require Import Crypto.Arithmetic.Karatsuba.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Crypto.Util.Tuple.
Require Import Crypto.Util.IdfunWithAlt.
Require Import Crypto.Util.Tactics.VM.
Require Import Crypto.Util.QUtil.
Require Import Crypto.Util.ZUtil.ModInv.

Require Import Crypto.Specific.Framework.ArithmeticSynthesis.SquareFromMul.
Require Import Crypto.Specific.Framework.ArithmeticSynthesis.Base.
Require Import Crypto.Specific.Framework.ArithmeticSynthesis.HelperTactics.
Require Import Crypto.Util.Tactics.PoseTermWithName.
Require Import Crypto.Util.Tactics.CacheTerm.

Local Open Scope Z_scope.
Local Infix "^" := Tuple.tuple : type_scope.

(** XXX TODO(REDACTED) FIXME: Should we sanity-check that we have 2^2k - 2^k - 1 / the right form of prime? *)
Ltac internal_pose_sqrt_s s sqrt_s :=
  let v := (eval vm_compute in (Z.log2 s / 2)) in
  cache_term (2^v) sqrt_s.

Section gen.
  Context (m : positive)
          (base : Q)
          (sz : nat)
          (s : Z)
          (c : list limb)
          (half_sz : nat)
          (sqrt_s : Z)
          (base_pos : (1 <= base)%Q)
          (sz_nonzero : sz <> 0%nat)
          (half_sz_nonzero : half_sz <> 0%nat)
          (s_nonzero : s <> 0%Z)
          (m_correct : Z.pos m = s - Associational.eval c)
          (sqrt_s_nonzero : sqrt_s <> 0)
          (sqrt_s_mod_m : sqrt_s ^ 2 mod Z.pos m = (sqrt_s + 1) mod Z.pos m).

  Local Notation wt := (wt_gen base).
  Local Notation wt_divides' := (wt_gen_divides' base base_pos).
  Local Notation wt_nonzero := (wt_gen_nonzero base base_pos).

  Definition goldilocks_mul_sig'
    : { mul : (Z^sz -> Z^sz -> Z^sz)%type
      | forall a b : Z^sz,
          mul a b = goldilocks_mul_cps (n:=half_sz) (n2:=sz) wt sqrt_s a b (fun ab => Positional.reduce_cps (n:=sz) wt s c ab id) }.
  Proof.
    eexists; cbv beta zeta; intros.
    cbv [goldilocks_mul_cps].
    autorewrite with pattern_runtime.
    reflexivity.
  Defined.

  Definition mul_sig'
    : { mul : (Z^sz -> Z^sz -> Z^sz)%type
      | forall a b : Z^sz,
          let eval := Positional.Fdecode (m := m) wt in
          Positional.Fdecode (m := m) wt (mul a b) = (eval a * eval b)%F }.
  Proof.
    eexists; cbv beta zeta; intros a b.
    pose proof wt_nonzero.
    pose proof (wt_gen0_1 base).
    let x := constr:(
               goldilocks_mul_cps (n:=half_sz) (n2:=sz) wt sqrt_s a b (fun ab => Positional.reduce_cps (n:=sz) wt s c ab id)) in
    presolve_op_F constr:(wt) x;
      [ cbv [goldilocks_mul_cps];
        autorewrite with pattern_runtime;
        reflexivity
      | ].
    reflexivity.
  Defined.
End gen.

Ltac pose_half_sz_nonzero half_sz half_sz_nonzero :=
  cache_proof_with_type_by
    (half_sz <> 0%nat)
    ltac:(cbv; congruence)
           half_sz_nonzero.

Ltac pose_mul_sig wt m base sz s c half_sz mul_sig :=
  let sqrt_s := fresh "sqrt_s" in
  let sqrt_s := internal_pose_sqrt_s s sqrt_s in
  cache_sig_with_type_by_existing_sig_helper
    ltac:(fun _ => cbv [mul_sig'])
           { mul : (Z^sz -> Z^sz -> Z^sz)%type
           | forall a b : Z^sz,
               let eval := Positional.Fdecode (m := m) wt in
               Positional.Fdecode (m := m) wt (mul a b) = (eval a * eval b)%F }
           (mul_sig' m base sz s c half_sz sqrt_s)
           mul_sig.

Ltac pose_square_sig sz m wt mul_sig square_sig :=
  SquareFromMul.pose_square_sig sz m wt mul_sig square_sig.


Require Import FP.Core.

Class Galois (A B:qtype) :=
  { galoisβ : dom (A ⇒ B)
  ; galoisα : dom (B ⇒ A)
  ; galois_idL : (galoisβ ⊙ galoisα) ⊑ id
  ; galois_idR : id ⊑ (galoisα ⊙ galoisβ)
  }.

Instance : forall A B `{! Galois A B }, Galois (A ⇒ A) (B ⇒ B) :=
  { galoisβ := λ f → galoisβ ⊙ f ⊙ galoisα
  ; galoisα := λ g → galoisα ⊙ g ⊙ galoisβ
  }. admit. admit.
Defined.

Class CGalois (A B:qtype) :=
  { cgalois : dom A -> dom B -> Prop
    (*       b'
           /R  \⊑
          a'    b
           \⊑  /R
             a
    *)
  ; cgalois_upper : forall (a a':dom A) (b:dom B),
      cgalois a b -> a' ⊑ a -> cgalois a' b
  ; cgalois_lower : forall (a:dom A) (b b':dom B),
      cgalois a b -> b ⊑ b' -> cgalois a b'
  }.

Class CGaloisComplete A B `{! CGalois A B } :=
  { cgalois_completeβ : dom (A ⇒ B)
  ; cgalois_completeα : dom (B ⇒ A)
  ; cgalois_completeβ₁ : forall a, cgalois a (cgalois_completeβ ∙ a)
  ; cgalois_completeβ₂ : forall a b, cgalois a b -> a ⊑ cgalois_completeα ∙ b
  ; cgalois_completeα₁ : forall b, cgalois (cgalois_completeα ∙ b) b
  ; cgalois_completeα₂ : forall a b, cgalois a b -> cgalois_completeβ ∙ a ⊑ b
  }.

Instance : forall A B `{! CGalois A B }, CGalois (A ⇒ A) (B ⇒ B) :=
  { cgalois := fun af bf =>
      forall a b, cgalois a b -> cgalois (af ∙ a) (bf ∙ b)
  }.
Proof.
  - intros.
    simpl ; simpl in H ; intros.
    apply (cgalois_upper (a ∙ a0) (a' ∙ a0) (b ∙ b0)) ; qproper_elim ; qproper.
    apply H ; auto.
  - intros.
    simpl ; simpl in H ; intros.
    apply (cgalois_lower (a ∙ a0) (b ∙ b0) (b' ∙ b0)) ; qproper_elim ; qproper.
    apply H ; auto.
Defined.

Section Correspondance.
  Context {A B} `{! CGalois A B ,! CGaloisComplete A B }.

  Local Instance : Galois A B :=
    { galoisβ := cgalois_completeβ
    ; galoisα := cgalois_completeα
    }.
  Proof.
    - apply qmonotonic_intro ; unfold "⇉" ; intros.
      change (cgalois_completeβ ∙ (cgalois_completeα ∙ x) ⊑ y).
      Transitivity (cgalois_completeβ ∙ (cgalois_completeα ∙ y)) ; [qproper_elim ; qproper|].
      clear H.
      apply cgalois_completeα₂.
      apply cgalois_completeα₁.
    - apply qmonotonic_intro ; unfold "⇉" ; intros.
      change (x ⊑ cgalois_completeα ∙ (cgalois_completeβ ∙ y)).
      Transitivity (cgalois_completeα ∙ (cgalois_completeβ ∙ x)) ; [|qproper_elim ; qproper].
      clear H.
      apply cgalois_completeβ₂.
      apply cgalois_completeβ₁.
  Defined.
End Correspondance.


Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.ArrowCategory.

Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.Auxiliary.CategoryTheory.

(** * Arrow categories *)
Section ArrowCategory.

Definition arrow_category_ids {C : category}
           (abf cdg : arrow_category C)
  : UU
  := ∑ (hk : (pr1 (pr1 abf) = pr1 (pr1 cdg))
               × (dirprod_pr2 (pr1 abf) = dirprod_pr2 (pr1 cdg))),
    pr2 abf ;; idtoiso (dirprod_pr2 hk) = idtoiso (pr1 hk) ;; pr2 cdg.

Lemma arrow_category_id_to_ids {C : category}
           {abf cdg : arrow_category C}
  : (abf = cdg) ≃ arrow_category_ids abf cdg.
Proof.
  eapply weqcomp. { apply total2_paths_equiv. }
  use (weqtotal2 pathsdirprodweq).
  intros e.
  destruct abf as [ab f], cdg as [cd g].
  set (e' := e : ab = cd). clearbody e'; clear e.
  destruct e'. cbn.
  eapply weqcomp. { eapply weqpathscomp0l. apply id_right. }
  apply weqpathscomp0r. apply pathsinv0, id_left.
Defined.

Definition arrow_category_is_iso {C : category}
           {abf cdg : arrow_category C}
           (a_to_c : C ⟦ pr1 (pr1 abf), pr1 (pr1 cdg) ⟧)
           (b_to_d : C ⟦ dirprod_pr2 (pr1 abf), dirprod_pr2 (pr1 cdg) ⟧)
  : UU
  := is_z_isomorphism b_to_d ×
     is_z_isomorphism a_to_c ×
     (pr2 abf ;; b_to_d = a_to_c ;; pr2 cdg).

Lemma isaprop_arrow_category_is_iso {C : category}
           {abf cdg : arrow_category C}
           (a_to_c : C ⟦ pr1 (pr1 abf), pr1 (pr1 cdg) ⟧)
           (b_to_d : C ⟦ dirprod_pr2 (pr1 abf), dirprod_pr2 (pr1 cdg) ⟧)
  : isaprop (arrow_category_is_iso a_to_c b_to_d).
Proof.
  use isapropdirprod.
  - apply isaprop_is_z_isomorphism.
  - use isapropdirprod.
    + apply isaprop_is_z_isomorphism.
    + apply homset_property.
Defined.

Definition arrow_category_is_iso_to_is_iso {C : category}
           {abf cdg : arrow_category C}
           (a_to_c : C ⟦ pr1 (pr1 abf), pr1 (pr1 cdg) ⟧)
           (b_to_d : C ⟦ dirprod_pr2 (pr1 abf), dirprod_pr2 (pr1 cdg) ⟧)
  : arrow_category_is_iso a_to_c b_to_d
    → ∑ (p : pr2 abf ;; b_to_d = a_to_c ;; pr2 cdg)
    , is_z_isomorphism (((a_to_c,, b_to_d),,p) : arrow_category C ⟦ abf, cdg ⟧).
Proof.
  intros h.
  set (is_iso_a_to_c := pr1 (dirprod_pr2 h)).
  set (is_iso_b_to_d := pr1 h).
  set (iso_a_to_c := (a_to_c,,is_iso_a_to_c)).
  set (iso_b_to_d := (b_to_d,,is_iso_b_to_d)).
  set (comm_square := dirprod_pr2 (dirprod_pr2 h)).
  use tpair.
  - apply comm_square.
  - unfold is_z_isomorphism.
    use tpair.
    + use tpair.
      * use make_dirprod.
        -- apply (inv_from_z_iso iso_a_to_c).
        -- apply (inv_from_z_iso iso_b_to_d).
      * simpl.
        apply pathsinv0.
        etrans. apply pathsinv0, id_right.
        etrans. apply maponpaths, pathsinv0, (z_iso_inv_after_z_iso iso_b_to_d).
        etrans. apply assoc'.
        etrans. apply maponpaths, assoc.
        etrans. apply maponpaths, maponpaths_2, comm_square.
        etrans. apply assoc.
        etrans. apply maponpaths_2, assoc.
        etrans. apply maponpaths_2, maponpaths_2, z_iso_after_z_iso_inv.
        etrans. apply maponpaths_2, id_left.
        apply idpath.
    + use make_dirprod.
      * use total2_paths_f.
        -- use dirprod_paths.
           ++ apply (z_iso_inv_after_z_iso iso_a_to_c).
           ++ apply (z_iso_inv_after_z_iso iso_b_to_d).
        -- apply homset_property.
      * use total2_paths_f.
        -- use dirprod_paths.
           ++ apply (z_iso_after_z_iso_inv iso_a_to_c).
           ++ apply (z_iso_after_z_iso_inv iso_b_to_d).
        -- apply homset_property.
Defined.

Definition is_iso_to_arrow_category_is_iso {C : category}
           {abf cdg : arrow_category C}
           (a_to_c : C ⟦ pr1 (pr1 abf), pr1 (pr1 cdg) ⟧)
           (b_to_d : C ⟦ dirprod_pr2 (pr1 abf), dirprod_pr2 (pr1 cdg) ⟧)
  : (∑ (p : pr2 abf ;; b_to_d = a_to_c ;; pr2 cdg)
    , is_z_isomorphism (((a_to_c,, b_to_d),,p) : arrow_category C ⟦ abf, cdg ⟧))
    → arrow_category_is_iso a_to_c b_to_d.
Proof.
  intros hp.
  set (abf_to_cdg := ((a_to_c,, b_to_d),,pr1 hp) : arrow_category C ⟦ _ , _ ⟧).
  set (h := pr2 hp : is_z_isomorphism abf_to_cdg).
  set (c_to_a := pr1 (pr1 (inv_from_z_iso (abf_to_cdg,,h)))).
  set (d_to_b := dirprod_pr2 (pr1 (inv_from_z_iso (abf_to_cdg,,h)))).

  use make_dirprod.
  - use tpair. { apply d_to_b. }
    use make_dirprod.
    * apply (maponpaths (λ k, dirprod_pr2 (pr1 k)) (z_iso_inv_after_z_iso (_,,h))).
    * apply (maponpaths (λ k, dirprod_pr2 (pr1 k)) (z_iso_after_z_iso_inv (_,,h))).
  - use make_dirprod.
    + use tpair. { apply c_to_a. }
      use make_dirprod.
      * apply (maponpaths (λ k, pr1 (pr1 k)) (z_iso_inv_after_z_iso (_,,h))).
      * apply (maponpaths (λ k, pr1 (pr1 k)) (z_iso_after_z_iso_inv (_,,h))).
    + apply (pr2 abf_to_cdg).
Defined.

Definition arrow_category_weq_is_iso {C : category}
           {abf cdg : arrow_category C}
           (a_to_c : C ⟦ pr1 (pr1 abf), pr1 (pr1 cdg) ⟧)
           (b_to_d : C ⟦ dirprod_pr2 (pr1 abf), dirprod_pr2 (pr1 cdg) ⟧)
  : arrow_category_is_iso a_to_c b_to_d
                          ≃
    ∑ (p : pr2 abf ;; b_to_d = a_to_c ;; pr2 cdg)
    , is_z_isomorphism (((a_to_c,, b_to_d),,p) : arrow_category C ⟦ abf, cdg ⟧).
Proof.
  use weq_iso.
  - apply arrow_category_is_iso_to_is_iso.
  - apply is_iso_to_arrow_category_is_iso.
  - intros h. apply isaprop_arrow_category_is_iso.
  - intros h.
    use total2_paths_f.
    + apply homset_property.
    + apply isaprop_is_z_isomorphism.
Defined.

Definition arrow_category_id_weq_iso {C : category}
           (C_univ : is_univalent C)
           (abf cdg : arrow_category C)
  : (abf = cdg) ≃ z_iso abf cdg.
Proof.
  eapply weqcomp.
  apply arrow_category_id_to_ids.

  set (a := pr1 (pr1 abf)).
  set (b := dirprod_pr2 (pr1 abf)).
  set (f := pr2 abf).
  set (c := pr1 (pr1 cdg)).
  set (d := dirprod_pr2 (pr1 cdg)).
  set (g := pr2 cdg).

  assert (weq1 :
  (∑ hk : a = c × b = d,
    pr2 abf;; idtoiso (dirprod_pr2 hk) = idtoiso (pr1 hk) ;; pr2 cdg)
    ≃
  (∑ hk : z_iso a c × z_iso b d,
   pr2 abf;; dirprod_pr2 hk = pr1 hk ;; pr2 cdg)).
  eapply weqcomp. apply weqtotal2asstor.
  apply invweq.
  eapply weqcomp. apply weqtotal2asstor.
  apply invweq.
  use PartA.weqtotal2.
  - apply (make_weq _ (C_univ a c)).
  - intros id_ac.
    use PartA.weqtotal2.
    + apply (make_weq _ (C_univ b d)).
    + intros id_bd. apply idweq.

  - eapply weqcomp. apply weq1.
    eapply weqcomp. apply weqtotal2asstor.
    eapply weqcomp. apply weqtotal2asstor.
    apply invweq.
    eapply weqcomp. apply weqtotal2asstor.
    eapply weqcomp. apply weqtotal2asstor.
    use PartA.weqtotal2.
    + apply idweq.
    + intros a_to_c.
      apply invweq.
      eapply weqcomp. apply WeakEquivalences.weqtotal2comm.
      eapply weqcomp. apply weqtotal2asstor.
      use PartA.weqtotal2.
      * apply idweq.
      * intros b_to_d. simpl.
        apply arrow_category_weq_is_iso.
Defined.

Definition arrow_category_mor_eq {C : category}
           {abf cdg : arrow_category C}
           (f g : arrow_category C ⟦ abf, cdg ⟧)
  : pr1 (pr1 f) = pr1 (pr1 g)
    → dirprod_pr2 (pr1 f) = dirprod_pr2 (pr1 g)
    → f = g.
Proof.
  intros p1 p2.
  use total2_paths_f.
  - use dirprod_paths.
    + apply p1.
    + apply p2.
  - apply homset_property.
Defined.

Definition arrow_category_is_univalent {C : category}
           (C_univ : is_univalent C)
  : is_univalent (arrow_category C).
Proof.
  intros abf cdg.
  use isweqhomot.
  + apply arrow_category_id_weq_iso.
    apply C_univ.
  + intros p. induction p.
      apply z_iso_eq.
    apply arrow_category_mor_eq.
    * apply idpath.
      * apply idpath.
  + apply (pr2 (arrow_category_id_weq_iso C_univ _ _)).
Defined.

End ArrowCategory.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

Require Import Undecidability.Synthetic.Undecidability.
Require Import Undecidability.Synthetic.ReducibilityFacts.

Require Import Undecidability.TM.TM.
From Undecidability.MinskyMachines Require Import MM BSM_MM.
From Undecidability Require
  TM.Reductions.HaltTM_1_to_SBTM_HALT StackMachines.Reductions.SBTM_HALT_to_HaltBSM.

Theorem HaltTM_to_MM_HALTS_ON_ZERO : HaltTM 1 ⪯ MM_HALTS_ON_ZERO.
Proof.
  eapply reduces_transitive. { exact HaltTM_1_to_SBTM_HALT.reduction. }
  eapply reduces_transitive. { exact SBTM_HALT_to_HaltBSM.reduction. }
  exact BSM_MM_HALTS_ON_ZERO.
Qed.

Theorem HaltTM_to_MM_HALTING : HaltTM 1 ⪯ MM_HALTING.
Proof.
  eapply reduces_transitive. { exact HaltTM_1_to_SBTM_HALT.reduction. }
  eapply reduces_transitive. { exact SBTM_HALT_to_HaltBSM.reduction. }
  exact BSM_MM_HALTING.
Qed.


(** Some Neo-davidsonian Semantics*)
Require Import Bvector.
Require Import Coq.Lists.List.
Require Import Omega.
Load LibTactics.
Ltac AUTO:= cbv delta;intuition;try repeat congruence;  jauto;intuition.
Parameter Event Ind LOcation Instrument:Set.
Parameter Agent
          Theme: Ind->Event->Prop.
Parameter Caesar Brutus:Ind.
Parameter IN: LOcation->Event->Prop.
Parameter WITH: Instrument->Event->Prop.  Definition In:= fun
x:LOcation=>fun E: Event->Prop=> fun e1:Event=> exists e:Event, E e1/\
IN x e1.  Definition With:= fun x:Instrument=>fun E: Event->Prop=> fun
                                                  e1:Event=> exists e:Event, E e1/\ WITH x e1.
Parameter stab: Ind->Ind->Event->Prop.
Parameter e1:Event.
Definition stabs:= fun
x:Ind=> fun y:Ind=>fun e1:Event=> exists e:Event, stab x y e /\
Theme(x)(e)/\Agent(y)(e)/\ e=e1.  Parameter a_knife: Instrument.
Parameter Rome Verona Athens: LOcation.  Theorem BRUTUS: (stabs Caesar
Brutus e1)-> Agent(Brutus)(e1). (**AUTO automates the proof*)  cbv. intro.  destruct H. destruct
H. destruct H0. destruct H1. firstorder. congruence. Qed.  Theorem
BRUTUS1:(In Rome) ((With a_knife) (stabs Caesar Brutus)) e1-> WITH
a_knife e1. AUTO. Qed.  Theorem BRUTUS2:(In Rome) ((With a_knife)
(stabs Caesar Brutus)) e1-> ((With a_knife) (stabs Caesar Brutus))
                              e1. AUTO. Qed.
Theorem BRUTUS3:(In Rome) ((With a_knife) (stabs
                                             Caesar Brutus)) e1-> ((In Rome) (stabs Caesar Brutus)) e1. AUTO. Qed.

Theorem BRUTUS4:(In Rome) ((With a_knife) (stabs Caesar Brutus)) e1->
((stabs Caesar Brutus)) e1. AUTO. Qed.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2018 Sylvie Boldo
#<br />#
Copyright (C) 2010-2018 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Helper function for computing the rounded value of a real number. *)

Require Import Core Digits Float_prop Bracket.

Section Fcalc_round.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Section Fcalc_round_fexp.

Variable fexp : Z -> Z.
Context { valid_exp : Valid_exp fexp }.
Notation format := (generic_format beta fexp).

Theorem cexp_inbetween_float :
  forall x m e l,
  (0 < x)%R ->
  inbetween_float beta m e x l ->
  (e <= cexp beta fexp x \/ e <= fexp (Zdigits beta m + e))%Z ->
  cexp beta fexp x = fexp (Zdigits beta m + e).
Proof.
intros x m e l Px Bx He.
unfold cexp.
apply inbetween_float_bounds in Bx.
assert (0 <= m)%Z as Hm.
{ apply Zlt_succ_le.
  eapply gt_0_F2R.
  apply Rlt_trans with (1 := Px).
  apply Bx. }
destruct (Zle_lt_or_eq _ _ Hm) as [Hm'|<-].
  now erewrite <- mag_F2R_bounds_Zdigits with (1 := Hm').
clear Hm.
assert (mag beta x <= e)%Z as Hx.
{ apply mag_le_bpow.
  now apply Rgt_not_eq.
  rewrite Rabs_pos_eq.
  now rewrite <- F2R_bpow.
  now apply Rlt_le. }
simpl in He |- *.
clear Bx.
destruct He as [He|He].
- apply eq_sym, valid_exp with (2 := He).
  now apply Zle_trans with e.
- apply valid_exp with (1 := He).
  now apply Zle_trans with e.
Qed.

Theorem cexp_inbetween_float_loc_Exact :
  forall x m e l,
  (0 <= x)%R ->
  inbetween_float beta m e x l ->
  (e <= cexp beta fexp x \/ l = loc_Exact <->
   e <= fexp (Zdigits beta m + e) \/ l = loc_Exact)%Z.
Proof.
intros x m e l Px Bx.
destruct Px as [Px|Px].
- split ; (intros [H|H] ; [left|now right]).
  rewrite <- cexp_inbetween_float with (1 := Px) (2 := Bx).
  exact H.
  now left.
  rewrite cexp_inbetween_float with (1 := Px) (2 := Bx).
  exact H.
  now right.
- assert (H := Bx).
  destruct Bx as [|c Bx _].
  now split ; right.
  rewrite <- Px in Bx.
  destruct Bx as [Bx1 Bx2].
  apply lt_0_F2R in Bx1.
  apply gt_0_F2R in Bx2.
  omega.
Qed.

(** Relates location and rounding. *)

Theorem inbetween_float_round :
  forall rnd choice,
  ( forall x m l, inbetween_int m x l -> rnd x = choice m l ) ->
  forall x m l,
  let e := cexp beta fexp x in
  inbetween_float beta m e x l ->
  round beta fexp rnd x = F2R (Float beta (choice m l) e).
Proof.
intros rnd choice Hc x m l e Hl.
unfold round, F2R. simpl.
apply (f_equal (fun m => (IZR m * bpow e)%R)).
apply Hc.
apply inbetween_mult_reg with (bpow e).
apply bpow_gt_0.
now rewrite scaled_mantissa_mult_bpow.
Qed.

Definition cond_incr (b : bool) m := if b then (m + 1)%Z else m.

Theorem inbetween_float_round_sign :
  forall rnd choice,
  ( forall x m l, inbetween_int m (Rabs x) l ->
    rnd x = cond_Zopp (Rlt_bool x 0) (choice (Rlt_bool x 0) m l) ) ->
  forall x m l,
  let e := cexp beta fexp x in
  inbetween_float beta m e (Rabs x) l ->
  round beta fexp rnd x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) (choice (Rlt_bool x 0) m l)) e).
Proof.
intros rnd choice Hc x m l e Hx.
apply (f_equal (fun m => (IZR m * bpow e)%R)).
simpl.
replace (Rlt_bool x 0) with (Rlt_bool (scaled_mantissa beta fexp x) 0).
(* *)
apply Hc.
apply inbetween_mult_reg with (bpow e).
apply bpow_gt_0.
rewrite <- (Rabs_right (bpow e)) at 3.
rewrite <- Rabs_mult.
now rewrite scaled_mantissa_mult_bpow.
apply Rle_ge.
apply bpow_ge_0.
(* *)
destruct (Rlt_bool_spec x 0) as [Zx|Zx] ; simpl.
apply Rlt_bool_true.
rewrite <- (Rmult_0_l (bpow (-e))).
apply Rmult_lt_compat_r with (2 := Zx).
apply bpow_gt_0.
apply Rlt_bool_false.
apply Rmult_le_pos with (1 := Zx).
apply bpow_ge_0.
Qed.

(** Relates location and rounding down. *)

Theorem inbetween_int_DN :
  forall x m l,
  inbetween_int m x l ->
  Zfloor x = m.
Proof.
intros x m l Hl.
refine (Zfloor_imp m _ _).
apply inbetween_bounds with (2 := Hl).
apply IZR_lt.
apply Zlt_succ.
Qed.

Theorem inbetween_float_DN :
  forall x m l,
  let e := cexp beta fexp x in
  inbetween_float beta m e x l ->
  round beta fexp Zfloor x = F2R (Float beta m e).
Proof.
apply inbetween_float_round with (choice := fun m l => m).
exact inbetween_int_DN.
Qed.

Definition round_sign_DN s l :=
  match l with
  | loc_Exact => false
  | _ => s
  end.

Theorem inbetween_int_DN_sign :
  forall x m l,
  inbetween_int m (Rabs x) l ->
  Zfloor x = cond_Zopp (Rlt_bool x 0) (cond_incr (round_sign_DN (Rlt_bool x 0) l) m).
Proof.
intros x m l Hl.
unfold Rabs in Hl.
destruct (Rcase_abs x) as [Zx|Zx] .
(* *)
rewrite Rlt_bool_true with (1 := Zx).
inversion_clear Hl ; simpl.
rewrite <- (Ropp_involutive x).
rewrite H, <- opp_IZR.
apply Zfloor_IZR.
apply Zfloor_imp.
split.
apply Rlt_le.
rewrite opp_IZR.
apply Ropp_lt_cancel.
now rewrite Ropp_involutive.
ring_simplify (- (m + 1) + 1)%Z.
rewrite opp_IZR.
apply Ropp_lt_cancel.
now rewrite Ropp_involutive.
(* *)
rewrite Rlt_bool_false.
inversion_clear Hl ; simpl.
rewrite H.
apply Zfloor_IZR.
apply Zfloor_imp.
split.
now apply Rlt_le.
apply H.
now apply Rge_le.
Qed.

Theorem inbetween_float_DN_sign :
  forall x m l,
  let e := cexp beta fexp x in
  inbetween_float beta m e (Rabs x) l ->
  round beta fexp Zfloor x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) (cond_incr (round_sign_DN (Rlt_bool x 0) l) m)) e).
Proof.
apply inbetween_float_round_sign with (choice := fun s m l => cond_incr (round_sign_DN s l) m).
exact inbetween_int_DN_sign.
Qed.

(** Relates location and rounding up. *)

Definition round_UP l :=
  match l with
  | loc_Exact => false
  | _ => true
  end.

Theorem inbetween_int_UP :
  forall x m l,
  inbetween_int m x l ->
  Zceil x = cond_incr (round_UP l) m.
Proof.
intros x m l Hl.
assert (Hl': l = loc_Exact \/ (l <> loc_Exact /\ round_UP l = true)).
case l ; try (now left) ; now right ; split.
destruct Hl' as [Hl'|(Hl1, Hl2)].
(* Exact *)
rewrite Hl'.
destruct Hl ; try easy.
rewrite H.
exact (Zceil_IZR _).
(* not Exact *)
rewrite Hl2.
simpl.
apply Zceil_imp.
ring_simplify (m + 1 - 1)%Z.
refine (let H := _ in conj (proj1 H) (Rlt_le _ _ (proj2 H))).
apply inbetween_bounds_not_Eq with (2 := Hl1) (1 := Hl).
Qed.

Theorem inbetween_float_UP :
  forall x m l,
  let e := cexp beta fexp x in
  inbetween_float beta m e x l ->
  round beta fexp Zceil x = F2R (Float beta (cond_incr (round_UP l) m) e).
Proof.
apply inbetween_float_round with (choice := fun m l => cond_incr (round_UP l) m).
exact inbetween_int_UP.
Qed.

Definition round_sign_UP s l :=
  match l with
  | loc_Exact => false
  | _ => negb s
  end.

Theorem inbetween_int_UP_sign :
  forall x m l,
  inbetween_int m (Rabs x) l ->
  Zceil x = cond_Zopp (Rlt_bool x 0) (cond_incr (round_sign_UP (Rlt_bool x 0) l) m).
Proof.
intros x m l Hl.
unfold Rabs in Hl.
destruct (Rcase_abs x) as [Zx|Zx] .
(* *)
rewrite Rlt_bool_true with (1 := Zx).
simpl.
unfold Zceil.
apply f_equal.
inversion_clear Hl ; simpl.
rewrite H.
apply Zfloor_IZR.
apply Zfloor_imp.
split.
now apply Rlt_le.
apply H.
(* *)
rewrite Rlt_bool_false.
simpl.
inversion_clear Hl ; simpl.
rewrite H.
apply Zceil_IZR.
apply Zceil_imp.
split.
change (m + 1 - 1)%Z with (Zpred (Zsucc m)).
now rewrite <- Zpred_succ.
now apply Rlt_le.
now apply Rge_le.
Qed.

Theorem inbetween_float_UP_sign :
  forall x m l,
  let e := cexp beta fexp x in
  inbetween_float beta m e (Rabs x) l ->
  round beta fexp Zceil x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) (cond_incr (round_sign_UP (Rlt_bool x 0) l) m)) e).
Proof.
apply inbetween_float_round_sign with (choice := fun s m l => cond_incr (round_sign_UP s l) m).
exact inbetween_int_UP_sign.
Qed.

(** Relates location and rounding toward zero. *)

Definition round_ZR (s : bool) l :=
  match l with
  | loc_Exact => false
  | _ => s
  end.

Theorem inbetween_int_ZR :
  forall x m l,
  inbetween_int m x l ->
  Ztrunc x = cond_incr (round_ZR (Zlt_bool m 0) l) m.
Proof with auto with typeclass_instances.
intros x m l Hl.
inversion_clear Hl as [Hx|l' Hx Hl'].
(* Exact *)
rewrite Hx.
rewrite Zrnd_IZR...
(* not Exact *)
unfold Ztrunc.
assert (Hm: Zfloor x = m).
apply Zfloor_imp.
exact (conj (Rlt_le _ _ (proj1 Hx)) (proj2 Hx)).
rewrite Zceil_floor_neq.
rewrite Hm.
unfold cond_incr.
simpl.
case Rlt_bool_spec ; intros Hx' ;
  case Zlt_bool_spec ; intros Hm' ; try apply refl_equal.
elim Rlt_not_le with (1 := Hx').
apply Rlt_le.
apply Rle_lt_trans with (2 := proj1 Hx).
now apply IZR_le.
elim Rle_not_lt with (1 := Hx').
apply Rlt_le_trans with (1 := proj2 Hx).
apply IZR_le.
now apply Zlt_le_succ.
rewrite Hm.
now apply Rlt_not_eq.
Qed.

Theorem inbetween_float_ZR :
  forall x m l,
  let e := cexp beta fexp x in
  inbetween_float beta m e x l ->
  round beta fexp Ztrunc x = F2R (Float beta (cond_incr (round_ZR (Zlt_bool m 0) l) m) e).
Proof.
apply inbetween_float_round with (choice := fun m l => cond_incr (round_ZR (Zlt_bool m 0) l) m).
exact inbetween_int_ZR.
Qed.

Theorem inbetween_int_ZR_sign :
  forall x m l,
  inbetween_int m (Rabs x) l ->
  Ztrunc x = cond_Zopp (Rlt_bool x 0) m.
Proof.
intros x m l Hl.
simpl.
unfold Ztrunc.
destruct (Rlt_le_dec x 0) as [Zx|Zx].
(* *)
rewrite Rlt_bool_true with (1 := Zx).
simpl.
unfold Zceil.
apply f_equal.
apply Zfloor_imp.
rewrite <- Rabs_left with (1 := Zx).
apply inbetween_bounds with (2 := Hl).
apply IZR_lt.
apply Zlt_succ.
(* *)
rewrite Rlt_bool_false with (1 := Zx).
simpl.
apply Zfloor_imp.
rewrite <- Rabs_pos_eq with (1 := Zx).
apply inbetween_bounds with (2 := Hl).
apply IZR_lt.
apply Zlt_succ.
Qed.

Theorem inbetween_float_ZR_sign :
  forall x m l,
  let e := cexp beta fexp x in
  inbetween_float beta m e (Rabs x) l ->
  round beta fexp Ztrunc x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) m) e).
Proof.
apply inbetween_float_round_sign with (choice := fun s m l => m).
exact inbetween_int_ZR_sign.
Qed.

(** Relates location and rounding to nearest. *)

Definition round_N (p : bool) l :=
  match l with
  | loc_Exact => false
  | loc_Inexact Lt => false
  | loc_Inexact Eq => p
  | loc_Inexact Gt => true
  end.

Theorem inbetween_int_N :
  forall choice x m l,
  inbetween_int m x l ->
  Znearest choice x = cond_incr (round_N (choice m) l) m.
Proof with auto with typeclass_instances.
intros choice x m l Hl.
inversion_clear Hl as [Hx|l' Hx Hl'].
(* Exact *)
rewrite Hx.
rewrite Zrnd_IZR...
(* not Exact *)
unfold Znearest.
assert (Hm: Zfloor x = m).
apply Zfloor_imp.
exact (conj (Rlt_le _ _ (proj1 Hx)) (proj2 Hx)).
rewrite Zceil_floor_neq.
rewrite Hm.
replace (Rcompare (x - IZR m) (/2)) with l'.
now case l'.
rewrite <- Hl'.
rewrite plus_IZR.
rewrite <- (Rcompare_plus_r (- IZR m) x).
apply f_equal.
field.
rewrite Hm.
now apply Rlt_not_eq.
Qed.

Theorem inbetween_int_N_sign :
  forall choice x m l,
  inbetween_int m (Rabs x) l ->
  Znearest choice x = cond_Zopp (Rlt_bool x 0) (cond_incr (round_N (if Rlt_bool x 0 then negb (choice (-(m + 1))%Z) else choice m) l) m).
Proof with auto with typeclass_instances.
intros choice x m l Hl.
simpl.
unfold Rabs in Hl.
destruct (Rcase_abs x) as [Zx|Zx].
(* *)
rewrite Rlt_bool_true with (1 := Zx).
simpl.
rewrite <- (Ropp_involutive x).
rewrite Znearest_opp.
apply f_equal.
inversion_clear Hl as [Hx|l' Hx Hl'].
rewrite Hx.
apply Zrnd_IZR...
assert (Hm: Zfloor (-x) = m).
apply Zfloor_imp.
exact (conj (Rlt_le _ _ (proj1 Hx)) (proj2 Hx)).
unfold Znearest.
rewrite Zceil_floor_neq.
rewrite Hm.
replace (Rcompare (- x - IZR m) (/2)) with l'.
now case l'.
rewrite <- Hl'.
rewrite plus_IZR.
rewrite <- (Rcompare_plus_r (- IZR m) (-x)).
apply f_equal.
field.
rewrite Hm.
now apply Rlt_not_eq.
(* *)
generalize (Rge_le _ _ Zx).
clear Zx. intros Zx.
rewrite Rlt_bool_false with (1 := Zx).
simpl.
inversion_clear Hl as [Hx|l' Hx Hl'].
rewrite Hx.
apply Zrnd_IZR...
assert (Hm: Zfloor x = m).
apply Zfloor_imp.
exact (conj (Rlt_le _ _ (proj1 Hx)) (proj2 Hx)).
unfold Znearest.
rewrite Zceil_floor_neq.
rewrite Hm.
replace (Rcompare (x - IZR m) (/2)) with l'.
now case l'.
rewrite <- Hl'.
rewrite plus_IZR.
rewrite <- (Rcompare_plus_r (- IZR m) x).
apply f_equal.
field.
rewrite Hm.
now apply Rlt_not_eq.
Qed.

(** Relates location and rounding to nearest even. *)

Theorem inbetween_int_NE :
  forall x m l,
  inbetween_int m x l ->
  ZnearestE x = cond_incr (round_N (negb (Z.even m)) l) m.
Proof.
intros x m l Hl.
now apply inbetween_int_N with (choice := fun x => negb (Z.even x)).
Qed.

Theorem inbetween_float_NE :
  forall x m l,
  let e := cexp beta fexp x in
  inbetween_float beta m e x l ->
  round beta fexp ZnearestE x = F2R (Float beta (cond_incr (round_N (negb (Z.even m)) l) m) e).
Proof.
apply inbetween_float_round with (choice := fun m l => cond_incr (round_N (negb (Z.even m)) l) m).
exact inbetween_int_NE.
Qed.

Theorem inbetween_int_NE_sign :
  forall x m l,
  inbetween_int m (Rabs x) l ->
  ZnearestE x = cond_Zopp (Rlt_bool x 0) (cond_incr (round_N (negb (Z.even m)) l) m).
Proof.
intros x m l Hl.
erewrite inbetween_int_N_sign with (choice := fun x => negb (Z.even x)).
2: eexact Hl.
apply f_equal.
case Rlt_bool.
rewrite Z.even_opp, Z.even_add.
now case (Z.even m).
apply refl_equal.
Qed.

Theorem inbetween_float_NE_sign :
  forall x m l,
  let e := cexp beta fexp x in
  inbetween_float beta m e (Rabs x) l ->
  round beta fexp ZnearestE x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) (cond_incr (round_N (negb (Z.even m)) l) m)) e).
Proof.
apply inbetween_float_round_sign with (choice := fun s m l => cond_incr (round_N (negb (Z.even m)) l) m).
exact inbetween_int_NE_sign.
Qed.

(** Relates location and rounding to nearest away. *)

Theorem inbetween_int_NA :
  forall x m l,
  inbetween_int m x l ->
  ZnearestA x = cond_incr (round_N (Zle_bool 0 m) l) m.
Proof.
intros x m l Hl.
now apply inbetween_int_N with (choice := fun x => Zle_bool 0 x).
Qed.

Theorem inbetween_float_NA :
  forall x m l,
  let e := cexp beta fexp x in
  inbetween_float beta m e x l ->
  round beta fexp ZnearestA x = F2R (Float beta (cond_incr (round_N (Zle_bool 0 m) l) m) e).
Proof.
apply inbetween_float_round with (choice := fun m l => cond_incr (round_N (Zle_bool 0 m) l) m).
exact inbetween_int_NA.
Qed.

Theorem inbetween_int_NA_sign :
  forall x m l,
  inbetween_int m (Rabs x) l ->
  ZnearestA x = cond_Zopp (Rlt_bool x 0) (cond_incr (round_N true l) m).
Proof.
intros x m l Hl.
erewrite inbetween_int_N_sign with (choice := Zle_bool 0).
2: eexact Hl.
apply f_equal.
assert (Hm: (0 <= m)%Z).
apply Zlt_succ_le.
apply lt_IZR.
apply Rle_lt_trans with (Rabs x).
apply Rabs_pos.
refine (proj2 (inbetween_bounds _ _ _ _ _ Hl)).
apply IZR_lt.
apply Zlt_succ.
rewrite Zle_bool_true with (1 := Hm).
rewrite Zle_bool_false.
now case Rlt_bool.
omega.
Qed.

Definition truncate_aux t k :=
  let '(m, e, l) := t in
  let p := Zpower beta k in
  (Zdiv m p, (e + k)%Z, new_location p (Zmod m p) l).

Theorem truncate_aux_comp :
  forall t k1 k2,
  (0 < k1)%Z ->
  (0 < k2)%Z ->
  truncate_aux t (k1 + k2) = truncate_aux (truncate_aux t k1) k2.
Proof.
intros ((m,e),l) k1 k2 Hk1 Hk2.
unfold truncate_aux.
destruct (inbetween_float_ex beta m e l) as (x,Hx).
assert (B1 := inbetween_float_new_location _ _ _ _ _ _ Hk1 Hx).
assert (Hk3: (0 < k1 + k2)%Z).
change Z0 with (0 + 0)%Z.
now apply Zplus_lt_compat.
assert (B3 := inbetween_float_new_location _ _ _ _ _ _ Hk3 Hx).
assert (B2 := inbetween_float_new_location _ _ _ _ _ _ Hk2 B1).
rewrite Zplus_assoc in B3.
destruct (inbetween_float_unique _ _ _ _ _ _ _ B2 B3).
now rewrite H, H0, Zplus_assoc.
Qed.

(** Given a triple (mantissa, exponent, position), this function
    computes a triple with a canonic exponent, assuming the
    original triple had enough precision. *)

Definition truncate t :=
  let '(m, e, l) := t in
  let k := (fexp (Zdigits beta m + e) - e)%Z in
  if Zlt_bool 0 k then truncate_aux t k
  else t.

Theorem truncate_0 :
  forall e l,
  let '(m', e', l') := truncate (0, e, l)%Z in
  m' = Z0.
Proof.
intros e l.
unfold truncate.
case Zlt_bool.
simpl.
apply Zdiv_0_l.
apply refl_equal.
Qed.

Theorem generic_format_truncate :
  forall m e l,
  (0 <= m)%Z ->
  let '(m', e', l') := truncate (m, e, l) in
  format (F2R (Float beta m' e')).
Proof.
intros m e l Hm.
unfold truncate.
set (k := (fexp (Zdigits beta m + e) - e)%Z).
case Zlt_bool_spec ; intros Hk.
(* *)
unfold truncate_aux.
apply generic_format_F2R.
intros Hd.
unfold cexp.
rewrite mag_F2R_Zdigits with (1 := Hd).
rewrite Zdigits_div_Zpower with (1 := Hm).
replace (Zdigits beta m - k + (e + k))%Z with (Zdigits beta m + e)%Z by ring.
unfold k.
ring_simplify.
apply Zle_refl.
split.
now apply Zlt_le_weak.
apply Znot_gt_le.
contradict Hd.
apply Zdiv_small.
apply conj with (1 := Hm).
rewrite <- Zabs_eq with (1 := Hm).
apply Zpower_gt_Zdigits.
apply Zlt_le_weak.
now apply Zgt_lt.
(* *)
destruct (Zle_lt_or_eq _ _ Hm) as [Hm'|Hm'].
apply generic_format_F2R.
unfold cexp.
rewrite mag_F2R_Zdigits.
2: now apply Zgt_not_eq.
unfold k in Hk. clear -Hk.
omega.
rewrite <- Hm', F2R_0.
apply generic_format_0.
Qed.

Theorem truncate_correct_format :
  forall m e,
  m <> Z0 ->
  let x := F2R (Float beta m e) in
  generic_format beta fexp x ->
  (e <= fexp (Zdigits beta m + e))%Z ->
  let '(m', e', l') := truncate (m, e, loc_Exact) in
  x = F2R (Float beta m' e') /\ e' = cexp beta fexp x.
Proof.
intros m e Hm x Fx He.
assert (Hc: cexp beta fexp x = fexp (Zdigits beta m + e)).
unfold cexp, x.
now rewrite mag_F2R_Zdigits.
unfold truncate.
rewrite <- Hc.
set (k := (cexp beta fexp x - e)%Z).
case Zlt_bool_spec ; intros Hk.
(* *)
unfold truncate_aux.
rewrite Fx at 1.
assert (H: (e + k)%Z = cexp beta fexp x).
unfold k. ring.
refine (conj _ H).
rewrite <- H.
apply F2R_eq.
replace (scaled_mantissa beta fexp x) with (IZR (Zfloor (scaled_mantissa beta fexp x))).
rewrite Ztrunc_IZR.
unfold scaled_mantissa.
rewrite <- H.
unfold x, F2R. simpl.
rewrite Rmult_assoc, <- bpow_plus.
ring_simplify (e + - (e + k))%Z.
clear -Hm Hk.
destruct k as [|k|k] ; try easy.
simpl.
apply Zfloor_div.
intros H.
generalize (Zpower_pos_gt_0 beta k) (Zle_bool_imp_le _ _ (radix_prop beta)).
omega.
rewrite scaled_mantissa_generic with (1 := Fx).
now rewrite Zfloor_IZR.
(* *)
split.
apply refl_equal.
unfold k in Hk.
omega.
Qed.

Theorem truncate_correct_partial' :
  forall x m e l,
  (0 < x)%R ->
  inbetween_float beta m e x l ->
  (e <= cexp beta fexp x)%Z ->
  let '(m', e', l') := truncate (m, e, l) in
  inbetween_float beta m' e' x l' /\ e' = cexp beta fexp x.
Proof.
intros x m e l Hx H1 H2.
unfold truncate.
rewrite <- cexp_inbetween_float with (1 := Hx) (2 := H1) by now left.
generalize (Zlt_cases 0 (cexp beta fexp x - e)).
destruct Zlt_bool ; intros Hk.
- split.
  now apply inbetween_float_new_location.
  ring.
- apply (conj H1).
  omega.
Qed.

Theorem truncate_correct_partial :
  forall x m e l,
  (0 < x)%R ->
  inbetween_float beta m e x l ->
  (e <= fexp (Zdigits beta m + e))%Z ->
  let '(m', e', l') := truncate (m, e, l) in
  inbetween_float beta m' e' x l' /\ e' = cexp beta fexp x.
Proof.
intros x m e l Hx H1 H2.
apply truncate_correct_partial' with (1 := Hx) (2 := H1).
rewrite cexp_inbetween_float with (1 := Hx) (2 := H1).
exact H2.
now right.
Qed.

Theorem truncate_correct' :
  forall x m e l,
  (0 <= x)%R ->
  inbetween_float beta m e x l ->
  (e <= cexp beta fexp x)%Z \/ l = loc_Exact ->
  let '(m', e', l') := truncate (m, e, l) in
  inbetween_float beta m' e' x l' /\
  (e' = cexp beta fexp x \/ (l' = loc_Exact /\ format x)).
Proof.
intros x m e l [Hx|Hx] H1 H2.
- destruct (Zle_or_lt e (fexp (Zdigits beta m + e))) as [H3|H3].
  + generalize (truncate_correct_partial x m e l Hx H1 H3).
    destruct (truncate (m, e, l)) as [[m' e'] l'].
    intros [H4 H5].
    apply (conj H4).
    now left.
  + destruct H2 as [H2|H2].
      generalize (truncate_correct_partial' x m e l Hx H1 H2).
      destruct (truncate (m, e, l)) as [[m' e'] l'].
      intros [H4 H5].
      apply (conj H4).
      now left.
    rewrite H2 in H1 |- *.
    simpl.
    generalize (Zlt_cases 0 (fexp (Zdigits beta m + e) - e)).
    destruct Zlt_bool.
      intros H.
      apply False_ind.
      omega.
    intros _.
    apply (conj H1).
    right.
    repeat split.
    inversion_clear H1.
    rewrite H.
    apply generic_format_F2R.
    intros Zm.
    unfold cexp.
    rewrite mag_F2R_Zdigits with (1 := Zm).
    now apply Zlt_le_weak.
- assert (Hm: m = 0%Z).
  cut (m <= 0 < m + 1)%Z. omega.
  assert (F2R (Float beta m e) <= x < F2R (Float beta (m + 1) e))%R as Hx'.
    apply inbetween_float_bounds with (1 := H1).
    rewrite <- Hx in Hx'.
    split.
    apply le_0_F2R with (1 := proj1 Hx').
    apply gt_0_F2R with (1 := proj2 Hx').
  rewrite Hm, <- Hx in H1 |- *.
  clear -H1.
  destruct H1 as [_ | l' [H _] _].
  + assert (exists e', truncate (Z0, e, loc_Exact) = (Z0, e', loc_Exact)).
      unfold truncate, truncate_aux.
      case Zlt_bool.
        rewrite Zdiv_0_l, Zmod_0_l.
        eexists.
        apply f_equal.
        unfold new_location.
        now case Z.even.
      now eexists.
    destruct H as [e' H].
    rewrite H.
    split.
      constructor.
      apply eq_sym, F2R_0.
      right.
      repeat split.
      apply generic_format_0.
  + rewrite F2R_0 in H.
    elim Rlt_irrefl with (1 := H).
Qed.

Theorem truncate_correct :
  forall x m e l,
  (0 <= x)%R ->
  inbetween_float beta m e x l ->
  (e <= fexp (Zdigits beta m + e))%Z \/ l = loc_Exact ->
  let '(m', e', l') := truncate (m, e, l) in
  inbetween_float beta m' e' x l' /\
  (e' = cexp beta fexp x \/ (l' = loc_Exact /\ format x)).
Proof.
intros x m e l Hx H1 H2.
apply truncate_correct' with (1 := Hx) (2 := H1).
now apply cexp_inbetween_float_loc_Exact with (2 := H1).
Qed.

Section round_dir.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Variable choice : Z -> location -> Z.
Hypothesis inbetween_int_valid :
  forall x m l,
  inbetween_int m x l ->
  rnd x = choice m l.

Theorem round_any_correct :
  forall x m e l,
  inbetween_float beta m e x l ->
  (e = cexp beta fexp x \/ (l = loc_Exact /\ format x)) ->
  round beta fexp rnd x = F2R (Float beta (choice m l) e).
Proof with auto with typeclass_instances.
intros x m e l Hin [He|(Hl,Hf)].
rewrite He in Hin |- *.
apply inbetween_float_round with (2 := Hin).
exact inbetween_int_valid.
rewrite Hl in Hin.
inversion_clear Hin.
rewrite Hl.
replace (choice m loc_Exact) with m.
rewrite <- H.
apply round_generic...
rewrite <- (Zrnd_IZR rnd m) at 1.
apply inbetween_int_valid.
now constructor.
Qed.

(** Truncating a triple is sufficient to round a real number. *)

Theorem round_trunc_any_correct :
  forall x m e l,
  (0 <= x)%R ->
  inbetween_float beta m e x l ->
  (e <= fexp (Zdigits beta m + e))%Z \/ l = loc_Exact ->
  round beta fexp rnd x = let '(m', e', l') := truncate (m, e, l) in F2R (Float beta (choice m' l') e').
Proof.
intros x m e l Hx Hl He.
generalize (truncate_correct x m e l Hx Hl He).
destruct (truncate (m, e, l)) as ((m', e'), l').
intros (H1, H2).
now apply round_any_correct.
Qed.

Theorem round_trunc_any_correct' :
  forall x m e l,
  (0 <= x)%R ->
  inbetween_float beta m e x l ->
  (e <= cexp beta fexp x)%Z \/ l = loc_Exact ->
  round beta fexp rnd x = let '(m', e', l') := truncate (m, e, l) in F2R (Float beta (choice m' l') e').
Proof.
intros x m e l Hx Hl He.
generalize (truncate_correct' x m e l Hx Hl He).
destruct (truncate (m, e, l)) as [[m' e'] l'].
intros [H1 H2].
now apply round_any_correct.
Qed.

End round_dir.

Section round_dir_sign.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Variable choice : bool -> Z -> location -> Z.
Hypothesis inbetween_int_valid :
  forall x m l,
  inbetween_int m (Rabs x) l ->
  rnd x = cond_Zopp (Rlt_bool x 0) (choice (Rlt_bool x 0) m l).

Theorem round_sign_any_correct :
  forall x m e l,
  inbetween_float beta m e (Rabs x) l ->
  (e = cexp beta fexp x \/ (l = loc_Exact /\ format x)) ->
  round beta fexp rnd x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) (choice (Rlt_bool x 0) m l)) e).
Proof with auto with typeclass_instances.
intros x m e l Hin [He|(Hl,Hf)].
rewrite He in Hin |- *.
apply inbetween_float_round_sign with (2 := Hin).
exact inbetween_int_valid.
rewrite Hl in Hin.
inversion_clear Hin.
rewrite Hl.
replace (choice (Rlt_bool x 0) m loc_Exact) with m.
(* *)
unfold Rabs in H.
destruct (Rcase_abs x) as [Zx|Zx].
rewrite Rlt_bool_true with (1 := Zx).
simpl.
rewrite F2R_Zopp.
rewrite <- H, Ropp_involutive.
apply round_generic...
rewrite Rlt_bool_false.
simpl.
rewrite <- H.
now apply round_generic.
now apply Rge_le.
(* *)
destruct (Rlt_bool_spec x 0) as [Zx|Zx].
(* . *)
apply Zopp_inj.
change (- m = cond_Zopp true (choice true m loc_Exact))%Z.
rewrite <- (Zrnd_IZR rnd (-m)) at 1.
assert (IZR (-m) < 0)%R.
rewrite opp_IZR.
apply Ropp_lt_gt_0_contravar.
apply IZR_lt.
apply gt_0_F2R with beta e.
rewrite <- H.
apply Rabs_pos_lt.
now apply Rlt_not_eq.
rewrite <- Rlt_bool_true with (1 := H0).
apply inbetween_int_valid.
constructor.
rewrite Rabs_left with (1 := H0).
rewrite opp_IZR.
apply Ropp_involutive.
(* . *)
change (m = cond_Zopp false (choice false m loc_Exact))%Z.
rewrite <- (Zrnd_IZR rnd m) at 1.
assert (0 <= IZR m)%R.
apply IZR_le.
apply ge_0_F2R with beta e.
rewrite <- H.
apply Rabs_pos.
rewrite <- Rlt_bool_false with (1 := H0).
apply inbetween_int_valid.
constructor.
now apply Rabs_pos_eq.
Qed.

(** Truncating a triple is sufficient to round a real number. *)

Theorem round_trunc_sign_any_correct' :
  forall x m e l,
  inbetween_float beta m e (Rabs x) l ->
  (e <= cexp beta fexp x)%Z \/ l = loc_Exact ->
  round beta fexp rnd x = let '(m', e', l') := truncate (m, e, l) in F2R (Float beta (cond_Zopp (Rlt_bool x 0) (choice (Rlt_bool x 0) m' l')) e').
Proof.
intros x m e l Hl He.
rewrite <- cexp_abs in He.
generalize (truncate_correct' (Rabs x) m e l (Rabs_pos _) Hl He).
destruct (truncate (m, e, l)) as [[m' e'] l'].
intros [H1 H2].
apply round_sign_any_correct.
exact H1.
destruct H2 as [H2|[H2 H3]].
left.
now rewrite <- cexp_abs.
right.
apply (conj H2).
now apply generic_format_abs_inv.
Qed.

Theorem round_trunc_sign_any_correct :
  forall x m e l,
  inbetween_float beta m e (Rabs x) l ->
  (e <= fexp (Zdigits beta m + e))%Z \/ l = loc_Exact ->
  round beta fexp rnd x = let '(m', e', l') := truncate (m, e, l) in F2R (Float beta (cond_Zopp (Rlt_bool x 0) (choice (Rlt_bool x 0) m' l')) e').
Proof.
intros x m e l Hl He.
apply round_trunc_sign_any_correct' with (1 := Hl).
rewrite <- cexp_abs.
apply cexp_inbetween_float_loc_Exact with (2 := Hl) (3 := He).
apply Rabs_pos.
Qed.

End round_dir_sign.

(** * Instances of the theorems above, for the usual rounding modes. *)

Definition round_DN_correct :=
  round_any_correct _ (fun m _ => m) inbetween_int_DN.

Definition round_trunc_DN_correct :=
  round_trunc_any_correct _ (fun m _ => m) inbetween_int_DN.

Definition round_trunc_DN_correct' :=
  round_trunc_any_correct' _ (fun m _ => m) inbetween_int_DN.

Definition round_sign_DN_correct :=
  round_sign_any_correct _ (fun s m l => cond_incr (round_sign_DN s l) m) inbetween_int_DN_sign.

Definition round_trunc_sign_DN_correct :=
  round_trunc_sign_any_correct _ (fun s m l => cond_incr (round_sign_DN s l) m) inbetween_int_DN_sign.

Definition round_trunc_sign_DN_correct' :=
  round_trunc_sign_any_correct' _ (fun s m l => cond_incr (round_sign_DN s l) m) inbetween_int_DN_sign.

Definition round_UP_correct :=
  round_any_correct _ (fun m l => cond_incr (round_UP l) m) inbetween_int_UP.

Definition round_trunc_UP_correct :=
  round_trunc_any_correct _ (fun m l => cond_incr (round_UP l) m) inbetween_int_UP.

Definition round_trunc_UP_correct' :=
  round_trunc_any_correct' _ (fun m l => cond_incr (round_UP l) m) inbetween_int_UP.

Definition round_sign_UP_correct :=
  round_sign_any_correct _ (fun s m l => cond_incr (round_sign_UP s l) m) inbetween_int_UP_sign.

Definition round_trunc_sign_UP_correct :=
  round_trunc_sign_any_correct _ (fun s m l => cond_incr (round_sign_UP s l) m) inbetween_int_UP_sign.

Definition round_trunc_sign_UP_correct' :=
  round_trunc_sign_any_correct' _ (fun s m l => cond_incr (round_sign_UP s l) m) inbetween_int_UP_sign.

Definition round_ZR_correct :=
  round_any_correct _ (fun m l => cond_incr (round_ZR (Zlt_bool m 0) l) m) inbetween_int_ZR.

Definition round_trunc_ZR_correct :=
  round_trunc_any_correct _ (fun m l => cond_incr (round_ZR (Zlt_bool m 0) l) m) inbetween_int_ZR.

Definition round_trunc_ZR_correct' :=
  round_trunc_any_correct' _ (fun m l => cond_incr (round_ZR (Zlt_bool m 0) l) m) inbetween_int_ZR.

Definition round_sign_ZR_correct :=
  round_sign_any_correct _ (fun s m l => m) inbetween_int_ZR_sign.

Definition round_trunc_sign_ZR_correct :=
  round_trunc_sign_any_correct _ (fun s m l => m) inbetween_int_ZR_sign.

Definition round_trunc_sign_ZR_correct' :=
  round_trunc_sign_any_correct' _ (fun s m l => m) inbetween_int_ZR_sign.

Definition round_NE_correct :=
  round_any_correct _ (fun m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE.

Definition round_trunc_NE_correct :=
  round_trunc_any_correct _ (fun m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE.

Definition round_trunc_NE_correct' :=
  round_trunc_any_correct' _ (fun m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE.

Definition round_sign_NE_correct :=
  round_sign_any_correct _ (fun s m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE_sign.

Definition round_trunc_sign_NE_correct :=
  round_trunc_sign_any_correct _ (fun s m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE_sign.

Definition round_trunc_sign_NE_correct' :=
  round_trunc_sign_any_correct' _ (fun s m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE_sign.

Definition round_NA_correct :=
  round_any_correct _ (fun m l => cond_incr (round_N (Zle_bool 0 m) l) m) inbetween_int_NA.

Definition round_trunc_NA_correct :=
  round_trunc_any_correct _ (fun m l => cond_incr (round_N (Zle_bool 0 m) l) m) inbetween_int_NA.

Definition round_trunc_NA_correct' :=
  round_trunc_any_correct' _ (fun m l => cond_incr (round_N (Zle_bool 0 m) l) m) inbetween_int_NA.

Definition round_sign_NA_correct :=
  round_sign_any_correct _ (fun s m l => cond_incr (round_N true l) m) inbetween_int_NA_sign.

Definition round_trunc_sign_NA_correct :=
  round_trunc_sign_any_correct _ (fun s m l => cond_incr (round_N true l) m) inbetween_int_NA_sign.

Definition round_trunc_sign_NA_correct' :=
  round_trunc_sign_any_correct' _ (fun s m l => cond_incr (round_N true l) m) inbetween_int_NA_sign.

End Fcalc_round_fexp.

(** Specialization of truncate for FIX formats. *)

Variable emin : Z.

Definition truncate_FIX t :=
  let '(m, e, l) := t in
  let k := (emin - e)%Z in
  if Zlt_bool 0 k then
    let p := Zpower beta k in
    (Zdiv m p, (e + k)%Z, new_location p (Zmod m p) l)
  else t.

Theorem truncate_FIX_correct :
  forall x m e l,
  inbetween_float beta m e x l ->
  (e <= emin)%Z \/ l = loc_Exact ->
  let '(m', e', l') := truncate_FIX (m, e, l) in
  inbetween_float beta m' e' x l' /\
  (e' = cexp beta (FIX_exp emin) x \/ (l' = loc_Exact /\ generic_format beta (FIX_exp emin) x)).
Proof.
intros x m e l H1 H2.
unfold truncate_FIX.
set (k := (emin - e)%Z).
set (p := Zpower beta k).
unfold cexp, FIX_exp.
generalize (Zlt_cases 0 k).
case (Zlt_bool 0 k) ; intros Hk.
(* shift *)
split.
now apply inbetween_float_new_location.
clear H2.
left.
unfold k.
ring.
(* no shift *)
split.
exact H1.
unfold k in Hk.
destruct H2 as [H2|H2].
left.
omega.
right.
split.
exact H2.
rewrite H2 in H1.
inversion_clear H1.
rewrite H.
apply generic_format_F2R.
unfold cexp.
omega.
Qed.

End Fcalc_round.


Require Import MirrorCore.TypesI.
Require Import MirrorCore.Lambda.AppN.
Require Import MirrorCore.Lambda.Red.
Require Import MirrorCore.Lambda.RedAll.
Require Import MirrorCore.RTac.Simplify.

Require Import Charge.ModularFunc.BaseFunc.
Require Import Charge.ModularFunc.BaseType.
Require Import Charge.ModularFunc.ListFunc.
Require Import Charge.ModularFunc.ListType.
Require Import Charge.ModularFunc.SemiEqDecTyp.
Require Import Charge.ModularFunc.Denotation.

Require Import Charge.Tactics.Lists.ListTacs.
Require Import Charge.Tactics.Base.DenotationTacs.
Require Import Charge.Tactics.Base.MirrorCoreTacs.

Require Import ExtLib.Core.RelDec.

Section Map.
  Context {typ func : Type} {RType_typ : RType typ} {RSym_func : RSym func}.
  Context {BT : BaseType typ} {BTD : BaseTypeD BT}.
  Context {LT : ListType typ} {LTD : ListTypeD LT}.
  Context {BF : BaseFunc typ func} {LF: ListFunc typ func}.
  Context {Heq : RelDec (@eq typ)} {HC : RelDec_Correct Heq}.
  Context {Heqd : SemiEqDecTyp typ} {HeqdOk : SemiEqDecTypOk Heqd}.
  Context {Typ2_Fun : Typ2 RType_typ Fun}.
  Context {Typ0_Prop : Typ0 RType_typ Prop}.

  Context {BFOk : BaseFuncOk typ func} {LFOk : ListFuncOk typ func}.

  Context {RTypeOk_typ : RTypeOk}.
  Context {RSymOk_func : RSymOk RSym_func}.
  Context {Typ2Ok_Fun : Typ2Ok Typ2_Fun}.

  Fixpoint mapTac_aux (t u : typ) (f : expr typ func) (lst : expr typ func) :=
    match listS lst with
      | Some (pNil v) =>
        match type_cast t v with
          Some pf => mkNil u
          | _ => mkMap t u f lst
        end
      | _ =>
        match lst with
          | App (App g x) xs =>
            match listS g with
              | Some (pCons v) =>
                match type_cast t v with
                  | Some pf => mkCons u (beta (App f x)) (mapTac_aux t u f xs)
                  | None => mkMap t u f lst
                end
              | _ => mkMap t u f lst
            end
          | _ => mkMap t u f lst
       end
     end.

  Definition mapTac (e : expr typ func) (args : list (expr typ func)) : expr typ func :=
    match listS e with
      | Some (pMap t u) =>
        match args with
          | f :: lst :: nil =>
            match baseS lst with
              | Some (pConst v lst) =>
		  	    match type_cast v (tyList t) with
		  	      | Some pf =>
		  	        fold_right (mkCons u) (mkNil u)
                      (map (fun x => beta (App f (mkConst t x)))
                        (listD (eq_rect _ typD lst _ pf)))
		  	      | None => apps e args
		  	    end
		  	  | Some _ => apps e args
              | None => mapTac_aux t u f lst
            end
          | _ => apps e args
        end
      | _ => apps e args
    end.

  Definition MAP := SIMPLIFY (typ := typ) (fun _ _ _ _ => (beta_all (fun _ => mapTac))).

  Opaque beta.
  Opaque baseS.

  Lemma mapTac_auxOk tus tvs (t u : typ) (f lst : expr typ func) fD lstD
    (Hf : ExprDsimul.ExprDenote.exprD' tus tvs (typ2 t u) f = Some fD)
    (Hlst : ExprDsimul.ExprDenote.exprD' tus tvs (tyList t) lst = Some lstD) :
    ExprDsimul.ExprDenote.exprD' tus tvs (tyList u) (mapTac_aux t u f lst) = Some (fun us vs => tyArrD2 (mapD t u) (fD us vs) (lstD us vs)).
  Proof.
    Transparent listS.
    generalize dependent lstD.
    induction lst using expr_strong_ind; simpl; intros;
      try (erewrite mkMap_sound; try eassumption; reduce; reflexivity).
    + do 3 (destruct_exprs; try (erewrite mkMap_sound; try eassumption; do 2 rewrite exprT_App_tyArrD; reflexivity)).
      reduce. rewrite mkNil_sound. reflexivity.
    + do 4 (destruct_exprs; try (erewrite mkMap_sound; try eassumption; do 2 rewrite exprT_App_tyArrD; reflexivity)).
      reduce.
      erewrite mkCons_sound; [| reduce; reflexivity | apply H; [repeat constructor | eassumption]].
      reduce.
      reflexivity.
  Qed.

  Lemma mapTacOk : partial_reducer_ok mapTac.
  Proof.
    unfold partial_reducer_ok; intros.
    exists val; split; [|reflexivity].
    unfold mapTac.

    do 6 (destruct_exprs; try assumption).
	+ do 2 (destruct_exprs; try assumption). reduce.
	  remember (trmD t3 (listE eq_refl)) as l; clear Heql.
	  induction l; simpl.
	  * simpl; rewrite mkNil_sound. reflexivity.
	  * erewrite mkCons_sound; [| reduce; rewrite bf_typeof_const; rewrite mkConst_sound; reduce; reflexivity | eassumption].
	    reduce. reflexivity.
	+ reduce. erewrite mapTac_auxOk; try eassumption. reduce; reflexivity.
  Qed.

End Map.


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

Require Import ZArithRing.
Require Import Omega.
Require Export ZArith_base.
Open Local Scope Z_scope.

(**    !! This file is deprecated !!

    Please use rather Zsqrt_def.Zsqrt (or Zsqrtrem).
    Unlike here, proofs there are fully separated from functions.
    Some equivalence proofs between the old and the new versions
    can be found below. A Require Import ZArith provides by default
    the new versions.

*)

(**********************************************************************)
(** Definition and properties of square root on Z *)

(** The following tactic replaces all instances of (POS (xI ...)) by
    `2*(POS ...)+1`, but only when ... is not made only with xO, XI, or xH. *)
Ltac compute_POS :=
  match goal with
    |  |- context [(Zpos (xI ?X1))] =>
      match constr:X1 with
	| context [1%positive] => fail 1
	| _ => rewrite (BinInt.Zpos_xI X1)
      end
    |  |- context [(Zpos (xO ?X1))] =>
      match constr:X1 with
	| context [1%positive] => fail 1
	| _ => rewrite (BinInt.Zpos_xO X1)
      end
  end.

Inductive sqrt_data (n:Z) : Set :=
  c_sqrt : forall s r:Z, n = s * s + r -> 0 <= r <= 2 * s -> sqrt_data n.

Definition sqrtrempos : forall p:positive, sqrt_data (Zpos p).
  refine
    (fix sqrtrempos (p:positive) : sqrt_data (Zpos p) :=
      match p return sqrt_data (Zpos p) with
	| xH => c_sqrt 1 1 0 _ _
	| xO xH => c_sqrt 2 1 1 _ _
	| xI xH => c_sqrt 3 1 2 _ _
	| xO (xO p') =>
          match sqrtrempos p' with
            | c_sqrt s' r' Heq Hint =>
              match Z_le_gt_dec (4 * s' + 1) (4 * r') with
		| left Hle =>
                  c_sqrt (Zpos (xO (xO p'))) (2 * s' + 1)
                  (4 * r' - (4 * s' + 1)) _ _
		| right Hgt => c_sqrt (Zpos (xO (xO p'))) (2 * s') (4 * r') _ _
              end
          end
	| xO (xI p') =>
          match sqrtrempos p' with
            | c_sqrt s' r' Heq Hint =>
              match Z_le_gt_dec (4 * s' + 1) (4 * r' + 2) with
		| left Hle =>
                  c_sqrt (Zpos (xO (xI p'))) (2 * s' + 1)
                  (4 * r' + 2 - (4 * s' + 1)) _ _
		| right Hgt =>
                  c_sqrt (Zpos (xO (xI p'))) (2 * s') (4 * r' + 2) _ _
              end
          end
	| xI (xO p') =>
          match sqrtrempos p' with
            | c_sqrt s' r' Heq Hint =>
              match Z_le_gt_dec (4 * s' + 1) (4 * r' + 1) with
		| left Hle =>
                  c_sqrt (Zpos (xI (xO p'))) (2 * s' + 1)
                  (4 * r' + 1 - (4 * s' + 1)) _ _
		| right Hgt =>
                  c_sqrt (Zpos (xI (xO p'))) (2 * s') (4 * r' + 1) _ _
              end
          end
	| xI (xI p') =>
          match sqrtrempos p' with
            | c_sqrt s' r' Heq Hint =>
              match Z_le_gt_dec (4 * s' + 1) (4 * r' + 3) with
		| left Hle =>
                  c_sqrt (Zpos (xI (xI p'))) (2 * s' + 1)
                  (4 * r' + 3 - (4 * s' + 1)) _ _
            | right Hgt =>
                c_sqrt (Zpos (xI (xI p'))) (2 * s') (4 * r' + 3) _ _
            end
        end
    end); clear sqrtrempos; repeat compute_POS;
 try (try rewrite Heq; ring); try omega.
Defined.

(** Define with integer input, but with a strong (readable) specification. *)
Definition Zsqrt :
  forall x:Z,
    0 <= x ->
    {s : Z &  {r : Z | x = s * s + r /\ s * s <= x < (s + 1) * (s + 1)}}.
  refine
    (fun x =>
      match
	x
	return
        0 <= x ->
        {s : Z &  {r : Z | x = s * s + r /\ s * s <= x < (s + 1) * (s + 1)}}
	with
	| Zpos p =>
          fun h =>
            match sqrtrempos p with
              | c_sqrt s r Heq Hint =>
		existS
                (fun s:Z =>
                  {r : Z |
                    Zpos p = s * s + r /\ s * s <= Zpos p < (s + 1) * (s + 1)})
                s
                (exist
                  (fun r:Z =>
                    Zpos p = s * s + r /\
                    s * s <= Zpos p < (s + 1) * (s + 1)) r _)
            end
	| Zneg p =>
          fun h =>
            False_rec
            {s : Z &
              {r : Z |
		Zneg p = s * s + r /\ s * s <= Zneg p < (s + 1) * (s + 1)}}
            (h (refl_equal Datatypes.Gt))
	| Z0 =>
          fun h =>
            existS
            (fun s:Z =>
              {r : Z | 0 = s * s + r /\ s * s <= 0 < (s + 1) * (s + 1)}) 0
            (exist
               (fun r:Z => 0 = 0 * 0 + r /\ 0 * 0 <= 0 < (0 + 1) * (0 + 1)) 0
               _)
    end); try omega.
 split; [ omega | rewrite Heq; ring_simplify (s*s) ((s + 1) * (s + 1)); omega ].
Defined.

(** Define a function of type Z->Z that computes the integer square root,
    but only for positive numbers, and 0 for others. *)
Definition Zsqrt_plain (x:Z) : Z :=
  match x with
    | Zpos p =>
      match Zsqrt (Zpos p) (Zorder.Zle_0_pos p) with
	| existS s _ => s
      end
    | Zneg p => 0
    | Z0 => 0
  end.

(** A basic theorem about Zsqrt_plain *)

Theorem Zsqrt_interval :
  forall n:Z,
    0 <= n ->
    Zsqrt_plain n * Zsqrt_plain n <= n <
    (Zsqrt_plain n + 1) * (Zsqrt_plain n + 1).
Proof.
  intros x; case x.
  unfold Zsqrt_plain in |- *; omega.
  intros p; unfold Zsqrt_plain in |- *;
    case (Zsqrt (Zpos p) (Zorder.Zle_0_pos p)).
  intros s [r [Heq Hint]] Hle; assumption.
  intros p Hle; elim Hle; auto.
Qed.

(** Positivity *)

Theorem Zsqrt_plain_is_pos: forall n, 0 <= n ->  0 <= Zsqrt_plain n.
Proof.
  intros n m; case (Zsqrt_interval n); auto with zarith.
  intros H1 H2; case (Zle_or_lt 0 (Zsqrt_plain n)); auto.
  intros H3; contradict H2; auto; apply Zle_not_lt.
  apply Zle_trans with ( 2 := H1 ).
  replace ((Zsqrt_plain n + 1) * (Zsqrt_plain n + 1))
     with (Zsqrt_plain n * Zsqrt_plain n + (2 * Zsqrt_plain n + 1));
  auto with zarith.
  ring.
Qed.

(** Direct correctness on squares. *)

Theorem Zsqrt_square_id: forall a, 0 <= a ->  Zsqrt_plain (a * a) = a.
Proof.
  intros a H.
  generalize (Zsqrt_plain_is_pos (a * a)); auto with zarith; intros Haa.
  case (Zsqrt_interval (a * a)); auto with zarith.
  intros H1 H2.
  case (Zle_or_lt a (Zsqrt_plain (a * a))); intros H3; auto.
  case Zle_lt_or_eq with (1:=H3); auto; clear H3; intros H3.
  contradict H1; auto; apply Zlt_not_le; auto with zarith.
  apply Zle_lt_trans with (a * Zsqrt_plain (a * a)); auto with zarith.
  apply Zmult_lt_compat_r; auto with zarith.
  contradict H2; auto; apply Zle_not_lt; auto with zarith.
  apply Zmult_le_compat; auto with zarith.
Qed.

(** [Zsqrt_plain] is increasing *)

Theorem Zsqrt_le:
 forall p q, 0 <= p <= q  ->  Zsqrt_plain p <= Zsqrt_plain q.
Proof.
  intros p q [H1 H2]; case Zle_lt_or_eq with (1:=H2); clear H2; intros H2;
  [ | subst q; auto with zarith].
  case (Zle_or_lt (Zsqrt_plain p) (Zsqrt_plain q)); auto; intros H3.
  assert (Hp: (0 <= Zsqrt_plain q)).
   apply Zsqrt_plain_is_pos; auto with zarith.
  absurd (q <= p); auto with zarith.
  apply Zle_trans with ((Zsqrt_plain q + 1) * (Zsqrt_plain q + 1)).
  case (Zsqrt_interval q); auto with zarith.
  apply Zle_trans with (Zsqrt_plain p * Zsqrt_plain p); auto with zarith.
  apply Zmult_le_compat; auto with zarith.
  case (Zsqrt_interval p); auto with zarith.
Qed.

(** Equivalence between Zsqrt_plain and [Zsqrt_def.Zsqrt] *)

Lemma Zsqrt_equiv : forall n, Zsqrt_plain n = Zsqrt_def.Zsqrt n.
Proof.
 intros. destruct (Z_le_gt_dec 0 n).
 symmetry. apply Z.sqrt_unique; trivial.
 now apply Zsqrt_interval.
 now destruct n.
Qed.


Require Import List.
Require Import String.
Require Import Omega.
Require Import Cubes.axioms
        Cubes.sprop_utils
        Cubes.arith_lemmas
        Cubes.hott_lemmas
        Cubes.cubes
        Cubes.cubic_dec
        Cubes.cartesian
        Cubes.forcing_setup
        Cubes.interval
        Cubes.ax1.

Import MonadNotation.

(** Axiom 2 : distinct end points *)

Definition lowest_corner (p : nat) : cube p.
  intro. exact false.
Defined.

Run TemplateProgram (tImplementTC ax1'_TC "ax2_TC" "ax2" (I0 = I1 -> False)).
Next Obligation.
  specialize (H p id). inversion H.
  assert (I0ᵗ p = I1ᵗ p).
  change (I0ᵗ p) with ((fun (p1 : nat) (_ : p ~> p1) => I0ᵗ p1) p id). rewrite H1. reflexivity.
  assert (I_end_map p false = I_end_map p true).
  change (I_end_map p false) with ((I0ᵗ p).1s). rewrite H0. reflexivity.
  assert (false = true).
  change false with (I_end_map p false (lowest_corner p) (zero_finset 0)). rewrite H2. reflexivity.
  inversion H3.
Defined.


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 U V P D : Universe, ((wd_ U V /\ (wd_ A P /\ (wd_ V B /\ (wd_ U B /\ (wd_ A D /\ (wd_ A B /\ (col_ U V P /\ (col_ A U V /\ (col_ A P D /\ col_ A P B))))))))) -> col_ U V B)).
Proof.
  time tac.
Qed.

End FOFProblem.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  A couple of missing Nat lemmas.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import Coq.Init.Logic.

Require Export CpdtTactics.
Require Export Case.

(* Why are these not in the standard library ? *)
Lemma beq_nat_sym : forall (n m : nat),
                      beq_nat n m = beq_nat m n.
Proof.
  apply NPeano.Nat.eqb_sym.
Qed.
Hint Rewrite beq_nat_sym.

Lemma beq_nat_trans :
  forall n1 n2 n3,
    beq_nat n1 n2 = true ->
    beq_nat n2 n3 = true ->
    beq_nat n1 n3 = true.
Proof.
  induction n1; destruct n2;
  induction n3; simpl; auto. intros. inversion H.
  apply IHn1.
Qed.
Hint Resolve beq_nat_trans.


(* * FOL Reductions *)

From Undecidability.PCP Require Import PCP Util.PCP_facts.
From Undecidability.FOL Require Import Deduction.FragmentNDFacts Semantics.Tarski.FragmentFacts Semantics.Tarski.FragmentSoundness Syntax.Core Syntax.Facts.
From Undecidability.FOL Require Import FOL.
From Undecidability.Synthetic Require Import Definitions DecidabilityFacts EnumerabilityFacts ReducibilityFacts MoreReducibilityFacts.
Require Import Undecidability.PCP.Reductions.PCPb_iff_dPCPb.
From Undecidability Require Import Shared.ListAutomation.
Import ListAutomationNotations ListAutomationHints ListAutomationInstances.

(* ** Validity *)

Local Definition BSRS := list(card bool).
Local Notation "x / y" := (x, y).

Notation t_f b t := (func (s_f b) (Vector.cons _ t _ (Vector.nil _))).
Notation t_e := (func s_e (Vector.nil _)).
Notation Pr t t' := (@atom _ sig_pred _ _ sPr (Vector.cons _ t _ (Vector.cons _ t' _ (Vector.nil _)))).
Notation Q := (atom sQ (Vector.nil _)).

Notation i_f b i :=
  (@i_func _ _ _ _ (s_f b) (Vector.cons _ i _ (Vector.nil _))).

Notation i_Pr i i' :=
  (@i_atom _ _ _ _ sPr (Vector.cons _ i _ (Vector.cons _ i' _ (Vector.nil _)))).

Section validity.

  Context {ff : falsity_flag}.
  Variable R : BSRS.

  Fixpoint prep (x : string bool) (t : term) : term :=
    match x with
    | nil => t
    | b::x => t_f b (prep x t)
    end.

  Definition enc s := (prep s t_e).

  Lemma prep_app x y t :
    prep (x ++ y) t = prep x (prep y t).
  Proof.
    induction x; cbn; trivial. now rewrite <- IHx.
  Qed.

  Fixpoint iprep {domain} {I : interp domain} (x : list bool) (y : domain) :=
    match x with
    | nil => y
    | b::x => i_f b (iprep x y)
    end.

  Definition F1 := map (fun '(x,y) => Pr (enc x) (enc y)) R.
  Definition F2 := map (fun '(x, y) => ∀ ∀ Pr $1 $0 → Pr (prep x $1) (prep y $0)) R.
  Definition F3 := (∀ Pr $0 $0 → Q).

  Definition F : form := F1 ==> F2 ==> F3 → Q.

  Lemma iprep_eval domain (I : interp domain) rho x s :
    eval rho (prep x s) = iprep x (eval rho s).
  Proof.
    induction x; cbn; trivial. now rewrite <- IHx.
  Qed.

  Lemma iprep_app domain (I : interp domain) x y d :
    iprep (x ++ y) d = iprep x (iprep y d).
  Proof.
    induction x; cbn; trivial. now rewrite <- IHx.
  Qed.

  Global Instance IB : interp (string bool).
  Proof using R.
    split; intros [] v.
    - exact (b :: Vector.hd v).
    - exact nil.
    - exact (derivable R (Vector.hd v) (Vector.hd (Vector.tl v))).
    - exact (dPCPb R).
  Defined.

  Lemma IB_prep rho s t :
    eval rho (prep s t) = s ++ eval rho t.
  Proof.
    induction s; cbn; trivial.
    rewrite <- IHs. reflexivity.
  Qed.

  Lemma IB_enc rho s :
    eval rho (enc s) = s.
  Proof.
    unfold enc. rewrite IB_prep.
    cbn. apply app_nil_r.
  Qed.

  Lemma IB_drv rho t1 t2 :
    rho ⊨ (Pr t1 t2) <-> derivable R (eval rho t1) (eval rho t2).
  Proof.
    cbn. reflexivity.
  Qed.

  Lemma IB_F1 rho :
    rho ⊫ F1.
  Proof.
    unfold F1.
    intros ? ([x y] & <- & ?) % in_map_iff.
    cbn. econstructor. now rewrite !IB_enc.
  Qed.

  Lemma IB_F2 rho :
    rho ⊫ F2.
  Proof.
    unfold F2. intros ? ([x y] & <- & ?) % in_map_iff u v ?. cbn.
    rewrite !IB_prep. cbn in *. eauto using der_sing, der_cons.
  Qed.

  Lemma IB_F3 rho :
    rho ⊨ F3.
  Proof.
    cbn. unfold dPCPb, dPCP. eauto.
  Qed.

  Lemma IB_F rho :
    rho ⊨ F -> dPCPb R.
  Proof.
    intros H. unfold F in H. rewrite !impl_sat in H. eapply H.
    - eapply IB_F1.
    - eapply IB_F2.
    - apply IB_F3.
  Qed.

  Lemma drv_val domain (I : interp domain) rho u v :
    derivable R u v -> rho ⊨ (F1 ==> F2 ==> Pr (enc u) (enc v)).
  Proof.
    rewrite !impl_sat. intros. induction H.
    - eapply H0. eapply in_map_iff. exists (x/y). eauto.
    - eapply (H1 (∀ ∀ Pr $1 $0 → Pr (prep x $1) (prep y $0))) in IHderivable.
      + cbn in *. unfold enc in *. rewrite !iprep_eval in *. cbn in *.
        rewrite <- !iprep_app in IHderivable. eapply IHderivable.
      + eapply in_map_iff. exists (x/y). eauto.
  Qed.

  Theorem BPCP_valid :
    PCPb R <-> valid F.
  Proof.
    rewrite PCPb_iff_dPCPb. split.
    - intros [u H] D I rho.
      eapply (@drv_val _ I) in H. unfold F. cbn in *.
      rewrite !impl_sat in *. cbn in *.
      intros. eapply (H2 (eval rho (enc u))). eauto.
    - intros H. apply IB_F with (rho := fun _ => nil), H.
  Qed.

  (* ** Provability *)

  Definition ctx_S :=
    F3 :: rev F2 ++ rev F1.

  Lemma prep_subst sigma t x :
    subst_term sigma (prep x t) = prep x (subst_term sigma t).
  Proof.
    induction x; cbn; congruence.
  Qed.

  Lemma drv_prv (s : peirce) u v :
    derivable R u v -> ctx_S ⊢ Pr (enc u) (enc v).
  Proof.
    induction 1.
    - apply Ctx. right. eapply in_app_iff. right.
      rewrite <- in_rev. eapply in_map_iff. exists (x/y). eauto.
    - assert (ctx_S ⊢ ∀ ∀ Pr $1 $0 → Pr (prep x $1) (prep y $0)).
      + apply Ctx. right. eapply in_app_iff. left.
        rewrite <- in_rev. eapply in_map_iff. exists (x/y). eauto.
      + eapply AllE with (t := enc u) in H1; eauto.
        cbn in H1. rewrite !prep_subst in H1. cbn in H1.
        eapply AllE with (t := enc v) in H1; eauto. cbn in H1.
        unfold enc in H1. rewrite !prep_subst in H1. cbn in H1.
        unfold enc. rewrite !prep_app.
        eapply (IE H1). eassumption.
  Qed.

  Lemma BPCP_prv' (s : peirce) :
    dPCPb R -> [] ⊢ F.
  Proof.
    intros [u H].
    apply drv_prv with (s:=s) in H. unfold F.
    repeat eapply impl_prv. simpl_list. eapply II.
    assert (ctx_S ⊢ (∀ Pr $0 $0 → Q)).
    apply Ctx. now unfold ctx_S. eapply AllE with  (t := enc u) in H0.
    cbn in H0. now eapply (IE H0).
  Qed.

End validity.

Theorem BPCP_prv R :
  PCPb R <-> nil ⊢M (F R).
Proof.
  rewrite PCPb_iff_dPCPb. split.
  - apply BPCP_prv'.
  - intros H % soundness'. eapply PCPb_iff_dPCPb. now apply (@BPCP_valid falsity_off R).
Qed.

(* ** Satisfiability *)

Lemma valid_satis phi :
  valid phi -> ~ satis (¬ phi).
Proof.
  intros H1 (D & I & rho & H2).
  apply H2, (H1 D I rho).
Qed.

Theorem BPCP_satis R :
  ~ PCPb R <-> satis (¬ F R).
Proof.
  rewrite PCPb_iff_dPCPb. split.
  - intros H. exists (list bool), (IB R), (fun _ => nil).
    intros H'. cbn. apply H, (IB_F H').
  - rewrite <- PCPb_iff_dPCPb. intros H1 H2 % (BPCP_valid R (ff:=falsity_on)).
    apply (valid_satis H2), H1.
Qed.

(* ** Reduction theorems *)

Corollary valid_star_red :
  PCPb ⪯ FOL*_valid.
Proof.
  exists (fun R => F R). intros R. apply (BPCP_valid R).
Qed.

Theorem prv_red :
  PCPb ⪯ FOL*_prv_intu.
Proof.
  exists (fun R => F R). intros R. apply (BPCP_prv R).
Qed.

Corollary valid_red :
  PCPb ⪯ FOL_valid.
Proof.
  exists (fun R => F R). intros R. apply (BPCP_valid R).
Qed.

Theorem satis_red :
  complement PCPb ⪯ FOL_satis.
Proof.
  exists (fun R => ¬ F R). intros R. apply (BPCP_satis R).
Qed.

(* ** Corollaries *)

Lemma form_discrete {ff : falsity_flag} :
  discrete (form ff).
Proof.
  apply discrete_iff. constructor. apply dec_form.
  - intros ? ?. unfold dec. repeat decide equality.
  - intros ? ?. unfold dec. repeat decide equality.
  - intros [] []. now left.
  - intros [] []. now left.
Qed.

#[export] Hint Resolve stack_enum form_discrete : core.

Definition UA :=
  ~ enumerable (complement PCPb).

Corollary valid_undec :
  UA -> ~ decidable (@valid _ _ falsity_off).
Proof.
  intros H. now apply (not_decidable valid_star_red).
Qed.

Corollary valid_unenum :
  UA -> ~ enumerable (complement (@valid _ _ falsity_off)).
Proof.
  intros H. now apply (not_coenumerable valid_star_red).
Qed.

Corollary prv_undec :
  UA -> ~ decidable (@prv _ _ falsity_off intu nil).
Proof.
  intros H. now apply (not_decidable prv_red).
Qed.

Corollary prv_unenum :
  UA -> ~ enumerable (complement (@prv _ _ falsity_off intu nil)).
Proof.
  intros H. apply (not_coenumerable prv_red); trivial.
Qed.

Corollary satis_undec :
  UA -> ~ decidable (@satis _ _ falsity_on).
Proof.
  intros H1 H2 % (dec_red satis_red).
  now apply H1, dec_count_enum.
Qed.

Corollary satis_enum :
  UA -> ~ enumerable (@satis _ _ falsity_on).
Proof.
  intros H1 H2 % (enumerable_red satis_red); auto.
Qed.

(* ** Non-Standard Model *)

Module NonStan. Section Nonstan.

  Variable R : BSRS.
  Context {ff : falsity_flag}.

  Instance IB : interp (option (string bool)).
  Proof using R.
    split; intros [] v.
    - exact (match Vector.hd v with Some u => Some (b :: u) | None => None end).
    - exact (Some nil).
    - exact (match Vector.hd v, Vector.hd (Vector.tl v) with Some u, Some v => derivable R u v | _, _ => True end).
    - exact False.
  Defined.

  Lemma IB_eval_Some rho t u v :
    eval rho t = Some v -> eval rho (prep u t) = Some (u ++ v).
  Proof.
    intros H. induction u; cbn; trivial.
    unfold prep in IHu. fold prep in IHu. now rewrite IHu.
  Qed.

  Lemma IB_eval_None rho t u :
    eval rho t = None -> eval rho (prep u t) = None.
  Proof.
    intros H. induction u; cbn; trivial.
    unfold prep in IHu. fold prep in IHu. now rewrite IHu.
  Qed.

  Lemma IB_enc rho u :
    eval rho (enc u) = Some u.
  Proof.
    unfold enc. rewrite <- (app_nil_r u) at 2.
    now apply IB_eval_Some.
  Qed.

  Lemma IB_deriv rho u v :
    rho ⊨ (Pr (enc u) (enc v)) <-> derivable R u v.
  Proof.
    cbn. rewrite !IB_enc. reflexivity.
  Qed.

  Lemma IB_deriv' rho t1 t2 u v :
    eval rho t1 = Some u -> eval rho t2 = Some v ->
    rho ⊨ (Pr t1 t2) <-> derivable R u v.
  Proof.
    intros H1 H2. cbn. rewrite H1, H2. reflexivity.
  Qed.

  Lemma IB_F1 rho :
    rho ⊫ F1 R.
  Proof.
    unfold F1.
    intros ? ([x y] & <- & ?) % in_map_iff.
    cbn. rewrite !IB_enc. now constructor.
  Qed.

  Lemma IB_F2 rho :
    rho ⊫ F2 R.
  Proof.
    unfold F2. intros ? ([x y] & <- & ?) % in_map_iff [u|] [v|] ?; cbn in *.
    - erewrite !IB_eval_Some; cbn; auto. now constructor 2.
    - erewrite IB_eval_Some, IB_eval_None; cbn; auto.
    - erewrite IB_eval_None; cbn; auto.
    - erewrite !IB_eval_None; cbn; auto.
  Qed.

  Lemma IB_F rho :
    rho ⊨ F R.
  Proof.
    unfold F. rewrite !impl_sat. intros _ _ H.
    apply (H None). cbn. auto.
  Qed.

  Lemma IB_nonstandard rho :
    rho ⊨ ¬ ∀ ¬ Pr $0 $0.
  Proof.
    intros H. apply (H None). cbn. auto.
  Qed.

End Nonstan. End NonStan.


(*
  Autor(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

(*
  Reduction from:
    Uniform Two-inequality Semi-unification (RU2SemiU)
  to:
    Semi-unification (SemiU)
*)

Require Import List.
Import ListNotations.

Require Import Undecidability.SemiUnification.SemiU.

Require Import ssreflect ssrfun ssrbool.

Require Import Undecidability.Synthetic.Definitions.

(* many-one reduction from right-uniform two-inequality semi-unification to semi-unification *)
Theorem reduction : RU2SemiU ⪯ SemiU.
Proof.
  exists (fun '(s0, s1, t) => [(s0, t); (s1, t)]).
  move=> [[s0 s1] t]. constructor.
  - move=> [φ] [ψ0] [ψ1] [Hψ0 Hψ1]. exists φ.
    apply /Forall_forall.
    by constructor; [by exists ψ0 | constructor; [by exists ψ1|]].
  - move=> [φ].
    move=> /Forall_forall /Forall_cons_iff [[ψ0 Hψ0]] /Forall_cons_iff [[ψ1 Hψ1]] _.
    by exists φ, ψ0, ψ1.
Qed.