(** * Completeness of [LJT] w.r.t. Kripke Semantics *)

Set Implicit Arguments.

Require Import decidable_In.
Require Import environments.
Require Import extralibrary.
Require Import sublist.
Require Import language_syntax.
Require Import variable_sets.
Require Import substitution.
Require Import fresh_csts.
Require Import relocation.
Require Import LJT_and_weakening.
Require Import kripke_semantics.
Require Import soundness.

(** The completeness of [LJT] w.r.t. Kripke semantics follows
   from the Universal Completeness.

   The universal Kripke model consists of contexts as worlds,
   the sub-context relation, and the provability for atomic
   sentences, and term as the constant domain. *)

(** ** The Universal Model *)

(** Monotonicity of forcing relation *)

Lemma weakening_atom : forall Ga Ga',
  sub_ctx Ga Ga' ->
  forall (P : predicate * (term nil)),
    Ga |- Atom P ->
    Ga' |- Atom P.
Proof.
  intros Ga Ga' h1 P h2; exact (weakening h1 h2).
Qed.

(** Reflexivity of sub-context relation. *)

Lemma sub_ctx_refl : forall (Ga : context), sub_ctx Ga Ga.
Proof.
  apply incl_refl.
Qed.

(** Transitivity of sub-context relation. *)

Lemma sub_ctx_trans : forall (Ga Ga0 Ga1 : context),
  sub_ctx Ga Ga0 -> sub_ctx Ga0 Ga1 -> sub_ctx Ga Ga1.
Proof.
  unfold sublist; intros Ga Ga0 Ga1 H H0 a H1.
  apply H0; apply H; exact H1.
Qed.

(** Universal model's domain is the set of well-formed terms. *)

Canonical Structure Universal := @Build_Kripke
  context
  (@sub_ctx (formula nil))
  sub_ctx_refl
  sub_ctx_trans
  (term nil)
  (@Cst nil)
  (@App nil)
  (fun Ga P => Ga |- Atom P)
  weakening_atom.

(** In the universal model, substitution plays the role of
   semantic interpretation. *)

Lemma psem_tsubst : forall m (t:term m) (eta:assoc (term nil)),
  psem Universal t eta = [[nil ! eta]] t.
Proof.
  induction t; simpl; intros; auto;
  [ case_Env
  | f_equal ]
  ; auto.
Qed.

(** ** Universal Completeness *)

Theorem univ_cpltness : forall m (A:formula m) (Ga:context) (eta:assoc (term nil)),
  Ga ||- A [eta] ->
  Ga |- [nil ! eta] A

with univ_cpltness_stoup : forall m (A:formula m) (Ga:context) (eta:assoc (term nil)),
    (forall C Ga', sub_ctx Ga Ga' -> Ga' ;; [nil ! eta] A |- C -> Ga' |- C) ->
    Ga ||- A [eta].
Proof.
  destruct A as [ [p t] | | ]; simpl; intros.

  rewrite <- psem_tsubst; assumption.

  apply ProofImplyR.
  apply univ_cpltness; auto.
  apply X; auto using incl_cons_2.
  apply univ_cpltness_stoup; intros; auto.
  apply ProofCont with (A:= [nil ! eta] A1); auto using in_eq.

  set (a:= new (oc_c (Forall x ([x :: nil ! eta]A) :: Ga))).
  apply ProofForallR with (a:=a); intros.
  apply new_fresh.
  rewrite substitution; apply univ_cpltness; auto using sub_ctx_refl.

  destruct A as [ [p t] | |]; simpl; intros.

  apply H; auto using sub_ctx_refl.
  rewrite psem_tsubst; auto using ProofAxiom.

  apply univ_cpltness_stoup; intros; auto.
  apply H; eauto using sub_ctx_trans.
  apply ProofImplyL; eauto using univ_cpltness, mono_force.

  apply univ_cpltness_stoup; intros; auto.
  apply H; eauto using sub_ctx_trans.
  apply ProofForallL with (u:=d).
  rewrite substitution; auto.
Qed.

(** ** Completeness for _closed_ formulae *)

(** Remark:

   - Because we don't consider parameters, every term/formula are closed. *)

Theorem univ_cpltness' : forall (A: formula nil)(Ga:context),
  Ga ||- A [nil] ->
  Ga |- A.
Proof.
  intros.
  rewrite freloc_id with (h:=sub_ov_fml A).
  rewrite <- formula_subst with (eta:=nil).
  apply univ_cpltness; auto.
Qed.

Theorem univ_cpltness_stoup' : forall (A:formula nil)(Ga:context),
  (forall C Ga', sub_ctx Ga Ga' -> Ga' ;; A |- C -> Ga' |- C) ->
  Ga ||- A [nil].
Proof.
  intros.
  rewrite freloc_id with (h:=sub_ov_fml A) in H.
  rewrite <- formula_subst with (eta:=nil) in H.
  apply univ_cpltness_stoup; auto.
Qed.

Lemma univ_cpltness_axiom : forall (Ga:context)(A:formula nil),
  A @ Ga ->
  Ga ||- A [nil].
Proof.
  induction Ga as [| B]; simpl; intros A H;
    [ elim H
      |  destruct (fml_dec A B); subst;
        [ apply univ_cpltness_stoup'; intros;
          eauto using ProofCont, in_eq
          | apply mono_force with Ga;
            [ change (sub_ctx Ga (B::Ga)); apply incl_cons_2
              | apply IHGa; auto; intuition; contradict n; auto
            ]
        ]
    ].
Qed.

Lemma universal_force_context : forall (Ga: worlds Universal) De,
  sub_ctx De Ga ->
  list_forall (fun B => Ga ||- B [nil]) De.
Proof.
  induction De as [|A]; intros; constructor;
    [ apply univ_cpltness_axiom; auto using in_eq
      | apply IHDe; eauto using incl_cons_1;
        intros; auto using in_cons
    ].
Qed.

Theorem completeness : forall Ga A,
  (forall K (w: worlds K),
    (list_forall (fun B => w ||- B [nil]) Ga) -> w ||- A [nil]) ->
  Ga |- A.
Proof.
  intros; apply univ_cpltness';
  apply X; apply universal_force_context with (Ga:=Ga)(De:=Ga); auto.
Qed.

(** ** Cut-admissibility *)

Definition cut_ad Ga A B :
  Ga ;; A |- B -> Ga |- A -> Ga |- B :=
  fun p1 p2 =>
    completeness B
    (fun K w H1 =>
      soundness_stoup p1 K w H1 (soundness p2 K w H1)).


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

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 2.1 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 GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Rbase Rpower.
Require Import Ranalysis.
Require Import Lra.

Require Import Rfunctions Rfunction_def Rextensionality.
Require Import MyRIneq MyR_dist.
Require Import Rtopology.

Require Import Ass_handling.
Require Import Rinterval Ranalysis_def Ranalysis_def_simpl.
Require Export Ranalysis_continuity Ranalysis_derivability Ranalysis_monotonicity.

Local Open Scope R_scope.

(** * Correcting stdlib's mistakes (generic derivable_* proofs) *)

Lemma derive_pt_id : forall x pr, derive_pt id x pr = 1.
Proof.
intros ; rewrite <- derive_pt_id with x ; apply pr_nu_var ; reflexivity.
Qed.

Lemma derive_pt_const : forall x v p, derive_pt (fct_cte v) x p = 0.
Proof.
intros x v p ; transitivity (derive_pt (fct_cte v) x (derivable_pt_const v x)).
 apply derive_pt_ext ; reflexivity.
 apply derive_pt_const.
Qed.

Lemma derive_pt_minus : forall f g x prf prg pr,
  derive_pt (f - g)%F x pr = derive_pt f x prf - derive_pt g x prg.
Proof.
intros f g x prf prg pr ; erewrite pr_nu_var with
 (pr2 := derivable_pt_minus _ _ x prf prg) ;
 [apply derive_pt_minus | reflexivity].
Qed.

Lemma derive_pt_comp : forall f g x prf prg pr,
  derive_pt (comp g f)%F x pr = derive_pt f x prf * derive_pt g (f x) prg.
Proof.
intros f g x prf prg pr ; erewrite pr_nu_var
 with (pr2 := derivable_pt_comp _ _ x prf prg) ;
 [ rewrite Rmult_comm ; apply derive_pt_comp | reflexivity ].
Qed.

(** * Usual functions *)

Lemma derivable_pt_lim_in_id : forall D x, derivable_pt_lim_in D id x 1.
Proof.
intros ; apply derivable_pt_lim_derivable_pt_lim_in,
 derivable_pt_lim_id.
Qed.

(** * Relating variations to the value of the derivative *)

Lemma derive_open_interval_pos_strictly_increasing_open_interval :
  forall f lb ub (pr : derivable_open_interval lb ub f),
  (forall x, open_interval lb ub x -> 0 < derive_open_interval lb ub f pr x) ->
  strictly_increasing_open_interval lb ub f.
Proof.
intros f lb ub pr Df_pos x y x_in y_in Hxy.
 assert (pr1 : forall c : R, open_interval x y c -> derivable_pt f c).
  intros ; eapply derivable_open_interval_pt ; [eapply pr |].
   eapply open_interval_restriction ; try eassumption ;
   apply open_interval_interval ; eassumption.
 assert (pr2 : forall c : R, open_interval x y c -> derivable_pt id c).
  intros ; apply derivable_id.
 destruct (MVT f id x y pr1 pr2 Hxy) as [c [c_in Hc]].
  intros ; eapply derivable_continuous_pt, derivable_open_interval_pt ;
   [eapply pr | apply interval_open_restriction with x y ; assumption].
  intros ; reg.
  unfold id in Hc ; fold id in Hc ; replace (derive_pt id c (pr2 c c_in)) with 1 in Hc ;
   [rewrite Rmult_1_r in Hc |].
  apply Rminus_gt ; rewrite <- Hc ; apply Rmult_lt_0_compat ; [lra |].
   erewrite <- derive_open_interval_derive_pt ; [eapply Df_pos |] ;
    eapply open_interval_restriction ;
    try (eapply open_interval_interval || apply c_in) ; eassumption.
  symmetry ; apply derive_pt_id.
Qed.

Lemma reciprocal_opp_compat_interval : forall f g lb ub,
  reciprocal_interval lb ub f g ->
  reciprocal_interval lb ub (fun x =>f(-x)) (-g)%F.
Proof.
intros f g lb ub f_recip_g x x_in_I.
 unfold comp, opp_fct ; simpl ; rewrite Ropp_involutive ;
 apply f_recip_g ; assumption.
Qed.

Lemma reciprocal_opp_compat_interval2 : forall f g lb ub,
  reciprocal_interval lb ub f g ->
  reciprocal_interval (-ub) (-lb) (-f)%F (fun x => g (-x)).
Proof.
intros f g lb ub f_recip_g x x_in_I.
 unfold opp_fct ; rewrite f_recip_g.
  apply Ropp_involutive.
 unfold interval in * ; destruct x_in_I ; split ; lra.
Qed.


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 O B C Bprime Cprime X Y : Universe, ((wd_ Cprime O /\ (wd_ Bprime O /\ (wd_ B O /\ (wd_ B C /\ (wd_ C O /\ (wd_ X Y /\ (wd_ X B /\ (wd_ B Bprime /\ (wd_ Cprime B /\ (wd_ C Bprime /\ (wd_ Cprime C /\ (wd_ Cprime Bprime /\ (col_ O Bprime Cprime /\ (col_ B O C /\ (col_ O X Y /\ (col_ X Y B /\ col_ X Y C)))))))))))))))) -> col_ B X O)).
Proof.
  time tac.
Qed.

End FOFProblem.


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 O E Eprime A B C Oprime Aprime Bprime Cprime A1 : Universe, ((wd_ O E /\ (wd_ Oprime Eprime /\ (wd_ A O /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ Oprime E /\ (wd_ B O /\ (wd_ Aprime O /\ (wd_ O Oprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ Oprime Eprime Aprime /\ (col_ Oprime Eprime Bprime /\ (col_ Oprime Eprime Cprime /\ (col_ O Eprime A1 /\ col_ O A Aprime)))))))))))))))) -> col_ Aprime O E)).
Proof.
  time tac.
Qed.

End FOFProblem.


(** * Extract: Running Coq programs in ML *)

(** Coq's [Extraction] feature allows you to write a functional
    program inside Coq; (presumably) use Coq's logic to prove some
    correctness properties about it; then print it out as an ML (or
    Haskell) program that you can compile with your optimizing ML (or
    Haskell) compiler.

    The \CHAPV1{Extraction} chapter of _Logical Foundations_ gave a
    simple example of Coq's program extraction features.  In this
    chapter, we'll take a deeper look. *)

Require Import Perm.

Module Sort1.
Fixpoint insert (i:nat) (l: list nat) :=
  match l with
  | nil => i::nil
  | h::t => if i <=? h then i::h::t else h :: insert i t
 end.

Fixpoint sort (l: list nat) : list nat :=
  match l with
  | nil => nil
  | h::t => insert h (sort t)
end.

(** The [Extraction] command prints out a function as Ocaml code. *)

Extraction sort.

(** You can see the translation of "sort" from Coq to Ocaml,
    in the "Messages" window of your IDE.
   Examine it there, and notice the similarities and differences.

  However, we really want the whole program, including the [insert]
  function.  We get that as follows: *)

Recursive Extraction  sort.

(** The first thing you see there is a redefinition of the [bool] type.
  But Ocaml already has a [bool] type whose inductive structure is
  isomorphic.  We want our extracted functions to be compatible with,
  callable by, ordinary Ocaml code.  So we want to use Ocaml's standard
  notation for the inductive definition, [bool].  The following directive
  accomplishes that: *)

Extract Inductive bool => "bool" [ "true" "false" ].
Extract Inductive list => "list" [ "[]" "(::)" ].
Recursive Extraction  sort.

End Sort1.

(** This is better.  But the program still uses a unary representation of
  natural numbers:  the number 7 is really (S (S (S (S (S (S (S O))))))). which in
  Ocaml will be a data structure that's seven pointers deep.  The [leb] function
  takes time proportional to the difference in value between [n] and [m],
  which is terrible.  We'd like natural numbers to be represented as Ocaml [int].
  Unfortunately, there are only a finite number of [int] values in Ocaml
  (2^31, or 2^63, depending on your implementation); so there are things
  you could prove about some programs, in Coq, that wouldn't be true in Ocaml.

  There are two solutions to this problem:
  - Instead of using [nat], use a more efficient constructive type, such as [Z].
  - Instead of using [nat], use an _abstract type_, and instantiate it with
       Ocaml integers.

  The first alternative uses Coq's [Z] type, an inductive type with
  constructors [xI] [xH] etc.  [Z] represents 7 as [Zpos (xI (xI xH))],
  that is,  +(  1+2*(  1+2*  1 )).
  A number [n] is represented as a data structure of size log(n), and
  the operations (plus, less-than) also take about log(n) each.

  [Z]'s log-time per operation is much better than linear time; but in
  Ocaml we are used to having constant-time operations.  Thus, here
  we will explore the second alternative: program with abstract types,
  then use an extraction directive to get efficiency. *)

Require Import ZArith.
Open Scope Z_scope.

(** We will be using [Parameter] and [Axiom] in Coq.   You already saw
 these keywords, in a [Module Type], in the [ADT] chapter.
 There, they describe interface components that must be instantiated
 by any [Module] that satisfies the type.  Here, we will use this
 feature in a different (and more dangerous) way:  To axiomatize
 a mathematical theory without actually constructing it.  The reason
 that's dangerous is that if your axioms are inconsistent, then you
 can prove [False], or in fact, you can prove _anything_, so all your
 proofs are worthless.  So we must take care!

 Here, we will axiomatize a _very weak_ mathematical theory:
 We claim that there exists some type [int] with a function [ltb],
 so that [int] injects into [Z], and [ltb] corresponds to the < relation
 on Z.  That seems true enough (for example, take [int=Z]), but
 we're not _proving_ it here. *)

Parameter int : Type.  (* This is the Ocaml [int] type. *)
Extract Inlined Constant int => "int".  (* so, extract it that way! *)

Parameter ltb: int -> int -> bool.  (* This is the Ocaml (<) operator. *)
Extract Inlined Constant ltb => "(<)".  (* so, extract it that way! *)

(** Now, we need to axiomatize [ltb] so that we can reason about
  programs that use it.  We need to take great care here: the
  axioms had better be consistent with Ocaml's behavior, otherwise
  our proofs will be meaningless.

  One axiomatization of [ltb] is just that it's a total order, irreflexive
  and transitive.  This would work just fine.  But instead, I choose to
  claim that there's an injection from "int" into the mathematical integers,
  Coq's [Z] type.  The reason to do this is then we get to use the [omega]
  tactic, and other Coq libraries about integer comparisons. *)

Parameter int2Z: int -> Z.
Axiom ltb_lt : forall n m : int, ltb n m = true <-> int2Z n < int2Z m.

(** Both of these axioms are sound.  There does (abstractly) exist a
  function from "int" to [Z], and that function _is_ consistent with
  the [ltb_lt] axiom.  But you should think about this until you are
  convinced.

  Notice that we do not give extraction directives for [int2Z] or [ltb_lt].
  That's because they will not appear in _programs_, only in proofs that
  are not meant to be extracted.

  Now, here's a dangerous axiom:

  [Parameter ocaml_plus : int -> int -> int.]

  [Extract Inlined Constant ocaml_plus => "(+)".]

  [Axiom ocaml_plus_plus:
     forall a b c: int,
       ocaml_plus a b = c <-> int2Z a + int2Z b = int2Z c.]

  The first two lines are OK:  there really is a "+" function in Ocaml,
  and its type really is  [int -> int -> int].

  But [ocaml_plus_plus] is unsound!   From it, you could prove,

  [(int2Z max_int + int2Z max_int) = int2Z (ocaml_plus max_int max_int)],

  which is not true in Ocaml, because overflow wraps around, modulo
  [2^(wordsize-1)].

  So we won't axiomatize Ocaml addition. *)

(* ################################################################# *)
(** * Utilities for Ocaml integer comparisons. *)

(** Just like in Perm.v, but for [int] and [Z] instead of [nat]. *)

Lemma int_blt_reflect : forall x y, reflect (int2Z x < int2Z y) (ltb x y).
Proof.
  intros x y.
  apply iff_reflect. symmetry. apply ltb_lt.
Qed.

Lemma Z_eqb_reflect : forall x y, reflect (x=y) (Z.eqb x y).
Proof.
  intros x y.
  apply iff_reflect. symmetry. apply Z.eqb_eq.
Qed.

Lemma Z_ltb_reflect : forall x y, reflect (x<y) (Z.ltb x y).
Proof.
  intros x y.
  apply iff_reflect. symmetry. apply Z.ltb_lt.
Qed.

(* Add these three lemmas to the Hint database for [bdestruct],
  so the [bdestruct] tactic will work with them. *)
Hint Resolve int_blt_reflect Z_eqb_reflect Z_ltb_reflect : bdestruct.

(* ################################################################# *)
(** * SearchTrees, extracted *)

(** Let us re-do binary search trees, but with Ocaml integers instead of  Coq nats. *)

(* ================================================================= *)
(** ** Maps, on [Z] instead of [nat]. *)
(** Our original proof with nats used [Maps.total_map] in its abstraction relation,
     but that won't work here because we need maps over [Z] rather than [nat].
     So, we copy-paste-edit to make [total_map] over [Z]. *)

Require Import Coq.Logic.FunctionalExtensionality.

Module IntMaps.
Definition total_map (A:Type) := Z -> A.
Definition t_empty {A:Type} (v : A) : total_map A :=  (fun _ => v).
Definition t_update {A:Type} (m : total_map A) (x : Z) (v : A) :=
  fun x' => if Z.eqb x x' then v else m x'.
Lemma t_update_eq : forall A (m: total_map A) x v, (t_update m x v) x = v.
Proof.
  intros. unfold t_update.
  bdestruct (x=?x); auto.
  omega.
Qed.

Theorem t_update_neq : forall (X:Type) v x1 x2 (m : total_map X),
  x1 <> x2 ->  (t_update m x1 v) x2 = m x2.
Proof.
  intros. unfold t_update.
  bdestruct (x1=?x2); auto.
  omega.
Qed.

Lemma t_update_shadow : forall A (m: total_map A) v1 v2 x,
    t_update (t_update m x v1) x v2  = t_update m x v2.
Proof.
  intros. unfold t_update.
  extensionality x'.
  bdestruct (x=?x'); auto.
Qed.

End IntMaps.

Import IntMaps.

(* ================================================================= *)
(** ** Trees, on [int] instead of [nat]. *)

Module SearchTree2.
Section TREES.
Variable V : Type.
Variable default: V.

Definition key := int.

Inductive tree : Type :=
 | E : tree
 | T: tree -> key -> V -> tree -> tree.

Definition empty_tree : tree := E.

Fixpoint lookup (x: key) (t : tree) : V :=
  match t with
  | E => default
  | T tl k v tr => if ltb x k then lookup x tl
                         else if ltb k x then lookup x tr
                         else v
  end.

Fixpoint insert (x: key) (v: V) (s: tree) : tree :=
 match s with
 | E => T E x v E
 | T a y v' b => if  ltb x y then T (insert x v a) y v' b
                        else if ltb y x then T a y v' (insert x v b)
                        else T a x v b
 end.

Fixpoint elements' (s: tree) (base: list (key*V)) : list (key * V) :=
 match s with
 | E => base
 | T a k v b => elements' a ((k,v) :: elements' b base)
 end.

Definition elements (s: tree) : list (key * V) := elements' s nil.

Definition combine {A} (pivot: Z) (m1 m2: total_map A) : total_map A :=
  fun x => if Z.ltb x pivot  then m1 x else m2 x.

Inductive Abs:  tree -> total_map V -> Prop :=
| Abs_E: Abs E (t_empty default)
| Abs_T: forall a b l k v r,
      Abs l a ->
      Abs r b ->
      Abs (T l k v r)  (t_update (combine (int2Z k) a b) (int2Z k) v).

Theorem empty_tree_relate: Abs empty_tree (t_empty default).
Proof.
constructor.
Qed.

(** **** Exercise: 3 stars (lookup_relate)  *)
Theorem lookup_relate:
  forall k t cts ,   Abs t cts -> lookup k t =  cts (int2Z k).
Proof.  (* Copy your proof from SearchTree.v, and adapt it. *)
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (insert_relate)  *)
Theorem insert_relate:
 forall k v t cts,
    Abs t cts ->
    Abs (insert k v t) (t_update cts (int2Z k) v).
Proof.  (* Copy your proof from SearchTree.v, and adapt it. *)
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 1 star (unrealistically_strong_can_relate)  *)
Lemma unrealistically_strong_can_relate:
 forall t,  exists cts, Abs t cts.
Proof.  (* Copy-paste your proof from SearchTree.v; it should work as is. *)
(* FILL IN HERE *) Admitted.
(** [] *)

End TREES.
(** Now, run this command and examine the results in the "results"
   window of your IDE: *)

Recursive Extraction empty_tree insert lookup elements.

(** Next, we will extract it into an Ocaml source file, and measure its
  performance. *)

Extraction "searchtree.ml" empty_tree insert lookup elements.

(** Note: we've done the extraction _inside_ the module, even though
   Coq warns against it, for a specific reason:  We want to extract only
   the program, not the proofs. *)

End SearchTree2.

(* ################################################################# *)
(** * Performance tests *)

(** Read the Ocaml program, test_searchtree.ml:

let test (f: int -> int) (n: int) =
 let rec build (j, t) = if j=0 then t
                    else build(j-1, insert (f j) 1 t)
  in let t1 = build(n,empty_tree)
  in let rec g (j,count) = if j=0 then count
                       else if lookup 0 (f j) t1 = 1
                            then g(j-1,count+1)
                            else g(j-1,count)
  in let start = Sys.time()
  in let answer = g(n,0)
      in (answer, Sys.time() -. start)

let print_test name (f: int -> int) n =
  let (answer, time) = test f n
  in (print_string "Insert and lookup "; print_int n;
      print_string " "; print_string name; print_string " integers in ";
      print_float time; print_endline " seconds.")

let test_random n = print_test "random" (fun _ -> Random.int n) n
let test_consec n = print_test "consecutive" (fun i -> n-i) n

let run_tests() = (test_random 1000000; test_random 20000; test_consec 20000)

let _ = run_tests ()
>> *)

(** You can run this inside the ocaml top level by:

#use "searchtree.ml";;
#use "test_searchtree.ml";;
run_tests();;

On my machine, in the byte-code interpreter this prints,

Insert and lookup 1000000 random integers in 1.076 seconds.
Insert and lookup 20000 random integers in 0.015 seconds.
Insert and lookup 20000 consecutive integers in 5.054 seconds.

You can compile and run this with the ocaml native-code compiler by:

ocamlopt searchtree.mli searchtree.ml -open Searchtree test_searchtree.ml -o test_searchtree
./test_searchtree

On my machine this prints,

Insert and lookup 1000000 random integers in 0.468 seconds.
Insert and lookup 20000 random integers in 0. seconds.
Insert and lookup 20000 consecutive integers in 0.374 seconds.
*)

(* ################################################################# *)
(** * Unbalanced binary search trees *)
(** Why is the performance of the algorithm so much worse when the
   keys are all inserted consecutively?  To examine this, let's compute
   with some searchtrees inside Coq.  We cannot do this with the search
   trees defined thus far in this file, because they use a key-comparison
   function [ltb]  that is abstract and uninstantiated (only during
   Extraction to Ocaml does [ltb] get instantiated).

   So instead, we'll use the SearchTree module,
   where everything runs inside Coq. *)

Require SearchTree.
Module Experiments.
Open Scope nat_scope.
Definition empty_tree := SearchTree.empty_tree nat.
Definition insert := SearchTree.insert nat.
Definition lookup := SearchTree.lookup nat 0.
Definition E := SearchTree.E nat.
Definition T := SearchTree.T nat.

Goal insert 5 1 (insert 4 1 (insert 3 1 (insert 2 1 (insert 1 1 (insert 0 1 empty_tree))))) <> E.
simpl. fold E; repeat fold T.

(** Look here!  The tree is completely unbalanced.  Looking up [5] will take linear time.
   That's why the runtime on consecutive integers is so bad. *)

Abort.

(* ################################################################# *)
(** * Balanced binary search trees *)

(** To achieve robust performance (that stays N log N for a sequence
    of N operations, and does not degenerate to N*N), we must keep the
    search trees balanced.  The next chapter, [Redblack],
    implements that idea. *)

End Experiments.


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

From QArithSternBrocot Require Export Qpositive.

Fixpoint Qpositive_le_bool (w w' : Qpositive) {struct w'} : bool :=
  match w with
  | One => match w' with
           | dL y => false
           | _ => true
           end
  | dL y => match w' with
            | dL y' => Qpositive_le_bool y y'
            | _ => true
            end
  | nR y => match w' with
            | nR y' => Qpositive_le_bool y y'
            | _ => false
            end
  end.

Definition Qpositive_le (w w' : Qpositive) := Qpositive_le_bool w w' = true.

Definition Qpositive_le' (w w' : Qpositive) :=
  match Qpositive_i w, Qpositive_i w' with
  | (p, q), (p', q') => p * q' <= p' * q
  end.

Theorem Qpositive_le_to_Qpositive_le' :
 forall w w' : Qpositive, Qpositive_le w w' -> Qpositive_le' w w'.
intros w w'; generalize w; elim w'; clear w w'.

intros w'1 Hrec w; case w.
(* 1 *)
unfold Qpositive_le in |- *; simpl in |- *.
intros w1 H; generalize (Hrec w1 H).
unfold Qpositive_le' in |- *.
simpl in |- *.
case (Qpositive_i w1); case (Qpositive_i w'1).
intros p' q' p q Hle; repeat rewrite Nat.mul_add_distr_r.
rewrite (Nat.mul_comm q').
apply Nat.add_le_mono_r.
auto.
(* 1 *)

(* 2 *)
intros w1; unfold Qpositive_le in |- *.
simpl in |- *.
unfold Qpositive_le' in |- *; simpl in |- *; intros H; case (Qpositive_i w1);
 case (Qpositive_i w'1); intros p' q' p q.
rewrite Nat.mul_add_distr_r.
repeat rewrite <- (Nat.mul_comm (p + q)).
repeat rewrite Nat.mul_add_distr_r.
rewrite (Nat.add_comm (p * p' + q * p')).
repeat rewrite <- Nat.add_assoc.
auto with arith.
(* 2 *)

(* Focus 3 *)
unfold Qpositive_le, Qpositive_le' in |- *.
simpl in |- *.
case (Qpositive_i w'1).
intros; lia.
(* 3 *)

intros w'1 Hrec w; case w; clear w; unfold Qpositive_le in |- *;
 simpl in |- *.

(* 1 *)
intros q H; discriminate H.
(* 2 *)
intros w1 H; generalize (Hrec w1 H); unfold Qpositive_le' in |- *.
simpl in |- *; case (Qpositive_i w1); case (Qpositive_i w'1);
 intros p' q' p q.
repeat rewrite (Nat.mul_comm p); repeat rewrite (Nat.mul_comm p');
 repeat rewrite Nat.mul_add_distr_r.
intros H1.
rewrite (Nat.mul_comm p').
apply Nat.add_le_mono_l.
auto.
(* 3 *)
intros H; discriminate H.

unfold Qpositive_le, Qpositive_le' in |- *.
intros w; case w.
3: simpl in |- *; auto.
intros w1; simpl in |- *.
intros Heq; discriminate Heq.
 intros w'; simpl in |- *.
 case (Qpositive_i w').
 intros; lia.
Qed.

Theorem Qpositive_le'_to_Qpositive_le :
 forall w w' : Qpositive, Qpositive_le' w w' -> Qpositive_le w w'.
intros w w'; generalize w; elim w'; clear w w'.
(* Focus 1 *)
intros w'1 Hrec w; case w; clear w.
(* 1.1 *)
intros w; unfold Qpositive_le', Qpositive_le in |- *; simpl in |- *.
generalize (Hrec w); clear Hrec; unfold Qpositive_le, Qpositive_le' in |- *;
 simpl in |- *.
elim (interp_non_zero w); intros p Hex; elim Hex; intros q Heq; clear Hex;
 rewrite Heq.
elim (interp_non_zero w'1); intros p' Hex; elim Hex; intros q' Heq1;
 clear Hex; rewrite Heq1.
intros H H1; (lapply H; [ intros H0; try exact H0 | idtac ]).
apply (fun p n m : nat => Nat.add_le_mono_l n m p) with (S q * S q').
replace (S q * S q' + S p * S q') with ((S p + S q) * S q').
replace (S q * S q' + S p' * S q) with ((S p' + S q') * S q).
auto.
ring.
ring.
(* 1.2 *)
unfold Qpositive_le in |- *; simpl in |- *; auto.
(* 1.3 *)
unfold Qpositive_le in |- *; simpl in |- *.
auto.
(* Focus 2 *)
intros w'1 Hrec w; case w; clear w; unfold Qpositive_le in |- *;
 simpl in |- *; auto.
(* 2.1 *)
intros w1; unfold Qpositive_le' in |- *; simpl in |- *.
elim (interp_non_zero w1); intros p Hex; elim Hex; intros q Heq; clear Hex;
 rewrite Heq.
elim (interp_non_zero w'1); intros p' Hex; elim Hex; intros q' Heq1;
 clear Hex; rewrite Heq1.
rewrite Nat.mul_add_distr_r.
repeat rewrite <- (Nat.mul_comm (S p' + S q')).
repeat rewrite Nat.mul_add_distr_r.
repeat rewrite <- (Nat.add_comm (S p' * S q)) || rewrite Nat.add_assoc;
 repeat rewrite <- Nat.add_assoc.
pattern (S p' * S q) at 2 in |- *; rewrite plus_n_O.
intros H; pose proof H as H1; apply Nat.add_le_mono_l in H1; simpl in |- *;
 inversion H1.
(* 2.2 *)
intros w; unfold Qpositive_le', Qpositive_le in |- *; simpl in |- *.
generalize (Hrec w); clear Hrec; unfold Qpositive_le, Qpositive_le' in |- *;
 simpl in |- *.
elim (interp_non_zero w); intros p Hex; elim Hex; intros q Heq; clear Hex;
 rewrite Heq.
elim (interp_non_zero w'1); intros p' Hex; elim Hex; intros q' Heq1;
 clear Hex; rewrite Heq1.
intros H H1; (lapply H; [ intros H0; try exact H0 | idtac ]).
apply (fun p n m : nat => Nat.add_le_mono_l n m p) with (S p * S p').
replace (S p * S p' + S p * S q') with (S p * (S p' + S q')).
replace (S p * S p' + S p' * S q) with (S p' * (S p + S q)).
auto.
ring.
ring.
(* 2.3 *)
unfold Qpositive_le' in |- *; simpl in |- *.
elim (interp_non_zero w'1); intros p' Hex; elim Hex; intros q' Heq1;
 clear Hex; rewrite Heq1.
rewrite <- plus_n_O; rewrite <- (Nat.mul_comm 1); simpl in |- *; intros H.
 pose proof (le_S_n _ _ H) as H1; apply Nat.add_le_mono_l in H1; inversion H1.
(* Focus 3 *)
intros w; case w; clear w; unfold Qpositive_le', Qpositive_le in |- *;
 simpl in |- *.
(* 3.1 *)
intros w; elim (interp_non_zero w).
intros p Hex; elim Hex; intros q Heq; rewrite Heq.
rewrite Nat.mul_1_r.
rewrite (Nat.add_comm (S p)).
intros H; apply Nat.add_le_mono_l in H; inversion H.
(* 3.2 *)
auto.
(* 3.3 *)
auto.
Qed.

Theorem Qpositive_le_trans :
 forall w w' w'' : Qpositive,
 Qpositive_le w w' -> Qpositive_le w' w'' -> Qpositive_le w w''.
intros w w'; generalize w; elim w'; unfold Qpositive_le in |- *;
 simpl in |- *; clear w w'.

(* Focus 1 *)
intros w' Hrec w; case w.
(* 1.3 *)
3: intros w''; case w''; simpl in |- *; auto.
(* 1.1 *)
intros w0 w''; case w''; simpl in |- *; auto.
(* 1.2 *)
intros w0 w''; case w''; simpl in |- *; auto.
intros w''0 H H1; discriminate H1.

(* Focus 2 *)
intros w' Hrec w; case w.
(* 2.3 *)
3: intros w'' H; discriminate H.
(* 2.1 *)
intros w0 w'' H; discriminate H.
(* 2.2 *)
intros w0 w''; case w''; simpl in |- *; auto.

(* Focus 3 *)
intros w; case w; clear w; simpl in |- *.
(* 3.3 *)
3: auto.
(* 3.1 *)
intros w w'' H; discriminate H.
(* 3.2 *)
intros w w''; case w''; simpl in |- *; auto.
intros w''0 H H1; discriminate H1.

Qed.

Theorem Qpositive_le_antisym :
 forall w w' : Qpositive, Qpositive_le w w' -> Qpositive_le w' w -> w = w'.
intros w; elim w; unfold Qpositive_le in |- *; simpl in |- *.
intros w0 Hrec w'; case w'; simpl in |- *.
3: intros H; discriminate H.
intros; apply f_equal with (f := nR); auto.
intros w'0 H; discriminate H.
intros w0 Hrec w'; case w'; simpl in |- *.
3: intros H H1; discriminate H1.
intros w'1 H H1; discriminate H1.
intros; apply f_equal with (f := dL); auto.

intros w'; case w'; auto with *.
intros w'0 H H1; discriminate H1.
intros w'0 H; discriminate H.

Qed.

Theorem Qpositive_le_refl : forall w : Qpositive, Qpositive_le w w.
intros w; unfold Qpositive_le in |- *; elim w; simpl in |- *; auto.
Qed.

Theorem Qpositive_le_total :
 forall w w' : Qpositive, Qpositive_le w w' \/ Qpositive_le w' w.
intros w w'; cut (Qpositive_le' w w' \/ Qpositive_le' w' w).
intros H; elim H; intros H1;
 generalize (Qpositive_le'_to_Qpositive_le _ _ H1);
 auto.
unfold Qpositive_le' in |- *.
case (Qpositive_i w'); case (Qpositive_i w); intros p q p' q'.
elim (Nat.le_gt_cases (p * q') (p' * q)); auto with arith.
Qed.

Theorem not_Qpositive_le_not_eq :
 forall n m : Qpositive, ~ Qpositive_le n m -> n <> m.
intros n m H; red in |- *; intros H1; elim H; rewrite H1;
 apply Qpositive_le_refl.
Qed.

Theorem not_Qpositive_le_Qpositive_le' :
 forall n m : Qpositive, ~ Qpositive_le n m -> Qpositive_le m n.
intros n m Hle; elim (Qpositive_le_total n m); auto.
intros H; elim Hle; auto.
Qed.

Lemma Qpositive_le_noneq_explicit: forall qp qp', Qpositive_le qp qp' -> ~ qp=qp' ->
  let (p, q) := Qpositive_i qp in
    let (p', q') := Qpositive_i qp' in (p * q' < p' * q)%nat.
Proof.
 intros qp qp' H_le H_neq; generalize (Qpositive_le_to_Qpositive_le' qp qp' H_le); unfold Qpositive_le';
 destruct (interp_non_zero qp) as [p [q H]];
 destruct (interp_non_zero qp') as [p' [q' H']];
 rewrite H; rewrite H'; intros H_le_unfold; destruct (le_lt_eq_dec _ _ H_le_unfold) as [H1|H1]; trivial;
 apply False_ind; apply H_neq;
 rewrite <- (construct_correct qp (S p) (S q) (S p+S q)%nat H); auto with arith;
 rewrite <- (construct_correct qp' (S p') (S q') (S p'+S q')%nat H'); auto with arith;
 apply construct_correct4'; auto with arith.
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. *)

From Coq Require Import Lia.
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 Z.le_trans with e.
- apply valid_exp with (1 := He).
  now apply Z.le_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.
  lia.
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 (Z.pred (Z.succ 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.
lia.
Qed.

Definition truncate_aux t k :=
  let '(m, e, l) := t in
  let p := Zpower beta k in
  (Z.div 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 Z.le_refl.
split.
now apply Zlt_le_weak.
apply Znot_gt_le.
contradict Hd.
apply Zdiv_small.
apply conj with (1 := Hm).
rewrite <- Z.abs_eq with (1 := Hm).
apply Zpower_gt_Zdigits.
apply Zlt_le_weak.
now apply Z.gt_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.
lia.
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)).
lia.
rewrite scaled_mantissa_generic with (1 := Fx).
now rewrite Zfloor_IZR.
(* *)
split.
apply refl_equal.
unfold k in Hk.
lia.
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).
  lia.
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.
      lia.
    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. lia.
  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 Z.opp_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
    (Z.div 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.
lia.
right.
split.
exact H2.
rewrite H2 in H1.
inversion_clear H1.
rewrite H.
apply generic_format_F2R.
unfold cexp.
lia.
Qed.

End Fcalc_round.


Require Import mathcomp.ssreflect.all_ssreflect.

Generalizable All Variables.
Set Implicit Arguments.
Unset Strict Implicit.

Import Prenex Implicits.

Section ETree.
  Variable E : Type -> Type.
  Variable R : Type.
  Variable VAR : Type.
  Inductive gtree : Type :=
  | Vis {A} (e : E A) (k : A -> gtree)
  | Ret (r : R)
  | Fix (k : VAR -> gtree)
  | Var (v : VAR)
  .

End ETree.

Arguments Vis [_ _ _ _] e k.
Arguments Ret [_ _ _] r.
Arguments Fix [_ _ _] k.
Arguments Var [_ _ _] v.
Definition etree E T := forall var, gtree E T var.
Definition etree1 E T := forall var, var -> gtree E T var.

Section Flatten.
  Variable E : Type -> Type.
  Variable R : Type.
  Variable VAR : Type.

  Fixpoint flatten (e : gtree E R (gtree E R VAR)) : gtree E R VAR :=
    match e with
    | Vis _ e k => Vis e (fun x => flatten (k x))
    | Ret r => Ret r
    | Fix k => Fix (fun x => flatten (k (Var x)))
    | Var v => v
    end.

  Fixpoint ntree (n : nat) : Type :=
    match n with
    | 0 => gtree E R VAR
    | n.+1 => gtree E R (ntree n)
    end.

  Fixpoint nvar (n : nat) (v : VAR) : ntree n :=
    match n return ntree n with
    | 0 => Var v
    | m.+1 => Var (nvar m v)
    end.

  Fixpoint flatten_n n : gtree E R (ntree n) -> gtree E R VAR :=
    (fix traverse e :=
       match e with
       | Vis _ e k => Vis e (fun x => traverse (k x))
       | Ret r => Ret r
       | Fix k => Fix (fun x => traverse (k (nvar _ x)))
       | Var v => match n return ntree n -> gtree E R VAR with
                  | 0 => fun v => v
                  | m.+1 => fun v => flatten_n v
                  end v
       end).
End Flatten.

Arguments nvar [E R VAR] n v.

Section Unroll.
  Variable E : Type -> Type.
  Variable R : Type.
  Variable VAR : Type.

  Fixpoint unroll1 (e : gtree E R (gtree E R VAR)) : gtree E R VAR :=
    match e with
    | Vis _ e k => Vis e (fun x => unroll1 (k x))
    | Ret r => Ret r
    | Fix k => flatten (k (Fix (fun x => unroll1 (k (Var x)))))
    | Var v => v
    end.

End Unroll.

Definition unroll {E R} (e : etree E R) : etree E R := fun _ => unroll1 (e _).

Module Examples.

Inductive LTy : Type -> Type :=
| LSend A : LTy A
| LRecv A : LTy A.

Definition always_send1 : etree LTy unit :=
  fun _ =>
    Fix (fun k =>
           Vis (LSend nat) (fun _ => Var k)).

Eval compute in (unroll always_send1 _).
End Examples.

Section StateM.
  Variable E : Type -> Type.
  Variable R : Type.
  Variable VAR : Type.

  (* QUESTION: Does it need to be finite? *)
  (* Definition has_next (l : etree E R) : Type := *)
  (*     match unroll l VAR with *)
  (*     | Vis A e k => A *)
  (*     | _ => False *)
  (*     end. *)

  (* Definition next_type (l : etree E R) : Type := *)
  (*     match unroll l VAR with *)
  (*     | Vis A e k => A *)
  (*     | _ => False *)
  (*     end. *)

  (* Definition run_event (l : etree E R) := *)
  (*   match unroll l VAR *)
  (*         as U *)
  (*         return match U with *)
  (*                | Vis A _ _ => E A *)
  (*                | _ => True *)
  (*                end *)
  (*   with *)
  (*     | Vis A e k => e *)
  (*     | _ => I *)
  (*     end. *)

  (* Definition next_type (l : etree E R) : E (next_type l) *)

  (* Definition swap_v (f : forall V, option ({A & (E A * (A -> gtree E R V))%type})) *)
  (*   : option ({A & (E A * (A -> etree E R))%type}) *)
  (*   := *)
  (*     match f _ with *)
  (*     | None => None *)
  (*     | Some (existT _ (e, k)) => Some (existT _ _ (e, fun x => fun _ => k x))  *)
  (*     end. *)

  (* Definition next_event (l : etree E R) : option (E (next_type l)) *)
  (*   := match unroll l True with *)
  (*      | Vis _ e _ => Some e *)
  (*      | _ => None *)
  (*      end. *)

End StateM.

Module ITree.
  Section Syntax.
    Context (E : Type -> Type).
    Context (R : Type).

    Inductive itreeF (itree : Type) : Type :=
    | Vis {A} (e : E A) (k : A -> itree)
    | Tau (i : itree)
    | Ret (r : R)
    .

    Set Primitive Projections.
    CoInductive itree := go { observe : itreeF itree }.
    Unset Primitive Projections.
  End Syntax.

  Arguments Vis [E R itree A] e k.
  Arguments Tau [E R itree] i.
  Arguments Ret [E R itree] r.

  Section Peek.
    Context (E : Type -> Type).
    Context (R : Type).

    Inductive etree : Type :=
    | eVis {A} (e : E A) (k : A -> etree)
    | eRec (i : itree E R)
    | eRet (r : R)
    .
    Arguments eVis [_] e k.
    Arguments eRec i : clear implicits.
    Arguments eRet r : clear implicits.

    Definition run (i : itree E R) : itreeF E R (itree E R) :=
      match observe i with
      | Vis _ e k => Vis e k
      | Tau t => observe t
      | Ret r => Ret r
      end.

    Definition event_type (i : itree E R) : Type :=
      match run i with
      | Vis A _ _ => A
      | Tau t => False
      | Ret r => False
      end.

    Definition run_cont (i : itree E R) : event_type i -> itree E R
      :=
        match run i as ri
              return match ri with
                     | Vis A _ _ => A
                     | Tau _ => False
                     | Ret _ => False
                     end -> itree E R
        with
      | Vis B e k => k
      | Tau _ => fun x => match x with end
      | Ret _ => fun x => match x with end
      end.

    (* Fixpoint observe_n (n : nat) (i : itree E R) : etree := *)
    (*   match n with *)
    (*   | 0 => eRec i *)
    (*   | m.+1 => *)
    (*     match observe i with *)
    (*     | Vis _ e k => eVis e (fun x => observe_n m (k x)) *)
    (*     | Tau t => observe_n m t *)
    (*     | Ret r => eRet r *)
    (*     end *)
    (*   end. *)

    (* Fixpoint unroll (n : nat) (i : etree) : etree := *)
    (*     match i with *)
    (*     | eVis _ e k => eVis e (fun x => unroll n (k x)) *)
    (*     | eRec t => observe_n n t *)
    (*     | eRet r => eRet r *)
    (*     end. *)
  End Peek.
  Arguments run_cont [E R] i _.

  Section Constraint.
    Variable P : Type.

    Inductive LTy (A : Type) := | LSend (p : P) | LRecv (p : P).

    Inductive Proc : Type -> Type :=
    | Send (p : P) {A} (x : A) : Proc unit
    | Recv (p : P) A : Proc A.

    Definition type_of {A} (p : Proc A) : Type :=
      match p with
      | Send _ A _ => A
      | Recv _ A => A
      end.

    Definition erase {A} (l : Proc A) : LTy (type_of l) :=
      match l with
      | Send p A _ => LSend A p
      | Recv p A => LRecv A p
      end.

    Definition down {A} (l : Proc A) : A -> type_of l
      := match l in Proc A return A -> type_of l with
         | Send _ _ x => fun _ => x
         | Recv _ _ => fun x => x
         end.

    Definition up {A} (l : Proc A) : type_of l -> A
      := match l in Proc A return type_of l -> A with
         | Send _ _ _ => fun _ => tt
         | Recv _ _ => fun x => x
         end.

    CoFixpoint erasure {A} (t : itree Proc A) : itree LTy A :=
      go match observe t with
         | Vis _ e k => Vis (erase e) (fun x => erasure (k (up x)))
         | Tau k => Tau (erasure k)
         | Ret x => Ret x
         end.

    Inductive event : Type -> Type :=
    | p_snd (p : P) (A : Type) (x : A) : event unit
    | p_rcv (p : P) (A : Type) : event A.

    Definition ety {A} (e : event A) : Type :=
      match e with
      | p_snd _ A _ => A
      | p_rcv _ A => A
      end.

    Definition ev_lt {A} (e : event A) : LTy (ety e)
      := match e with
         | p_snd p A _ => LSend A p
         | p_rcv p A => LRecv A p
         end.

    Definition cont {A} (e : event A) : A -> ety e
      :=
      match e in event A return A -> ety e with
      | p_snd _ _ x => fun=>x
      | p_rcv _ _ => fun x=>x
      end.

    Definition recv_type (l : itreeF LTy Set (itree LTy Set)) : Type :=
      match l with
      | Vis A (LRecv p) _ => A
      | _ => False
      end.

    Definition run_recv (l : itree LTy Set) : recv_type (run l) -> itree LTy Set :=
      match run l
            as rl
            return recv_type rl -> itree LTy Set
      with
      | Vis _ (LRecv _) k => fun x => k x
      | _ => fun f => match f with end
      end.

    (** no Tau so far **)
    Inductive procF (proc : itree LTy Set -> Type) : itree LTy Set -> Type :=
    | p_event {A} (e : event A) kl l (_ : Vis (ev_lt e) kl = run l)
      : (forall (x : A), proc (kl (cont e x))) -> procF proc l
    (* | p_tau {l} : procF proc l -> procF proc l *)
    | p_end (A : Set) l2 (_ : Ret A = run l2) : A -> procF proc l2.

    Arguments p_event [proc A] e {kl l} _ _.
    Arguments p_end [proc A l2] _ _.

    CoInductive proc (l : itree LTy Set) : Type :=
      goP { observeP : procF proc l }.

    Definition part_of (l : itreeF LTy Set (itree LTy Set)) :=
      match l with
      | Vis _ (LSend p') _ => {p | p = p'}
      | Vis _ (LRecv p') _ => {p | p = p'}
      | _ => False
      end.

    Definition send_type (l : itreeF LTy Set (itree LTy Set)) :=
      match l with
      | Vis A (LSend p) _ => A
      | _ => False
      end.

    Inductive ret_lty (l : itree LTy Set) : Type := | lty_sing.

    Definition part_send (l : itreeF LTy Set (itree LTy Set)) :=
      match l with
      | Vis _ (LSend p') _ => {p | p = p'}
      | _ => False
      end.

    Definition part_recv (l : itreeF LTy Set (itree LTy Set)) : Type :=
      match l with
      | Vis _ (LRecv p') _ => {p | p = p'}
      | _ => False
      end.

    Lemma rename_part T (e : P -> LTy T) p k (l : itree LTy Set) :
      Vis (e p) k = run l ->
      forall pp : {p' | p' = p},
      Vis (e (sval pp)) k = run l.
    Proof. by move=>EQ [p' /=->]. Qed.

    (* Definition send (l : itree LTy Set) : *)
    (*   part_send (run l) -> send_type (run l) -> procF ret_lty l  *)
    (*   := match run l as rl return *)
    (*            rl = run l -> *)
    (*                 part_send rl -> *)
    (*                 send_type rl -> *)
    (*                 procF ret_lty l *)
    (*      with *)
    (*           | Vis _ (LSend _) k => *)
    (*             fun EQ pp x => *)
    (*               let EQ' := rename_part EQ pp in *)
    (*               p_event (p_snd (sval pp) x) EQ' (fun=>lty_sing (k x)) *)
    (*           | _ => fun _ F=>match F with end *)
    (*      end erefl. *)

    Definition send_lty (l : itreeF LTy Set (itree LTy Set)) :
      part_send l -> send_type l -> itree LTy Set
      := match l as rl return
               part_send rl ->
               send_type rl ->
               itree LTy Set
         with
         | Vis _ (LSend _) k => fun _ x => k x
         | _ => fun _ F=>match F with end
         end.

    Definition recv_lty (l : itreeF LTy Set (itree LTy Set)) :
      part_recv l -> recv_type l -> itree LTy Set
      := match l as rl return
               part_recv rl ->
               recv_type rl ->
               itree LTy Set
         with
         | Vis _ (LRecv _) k => fun _ x => k x
         | _ => fun _ F=>match F with end
         end.

    Definition _send (l : itree LTy Set)  :
      forall p x, proc (@send_lty (run l) p x) -> proc l :=
      match run l as rl return
            rl = run l ->
            forall (p : part_send rl)
                   (x : send_type rl),
              proc (send_lty p x) ->
              proc l
      with
      | Vis _ (LSend _) k =>
        fun EQ pp x K => let EQ' := rename_part EQ pp in
                         goP (p_event (p_snd (sval pp) x) EQ' (fun=>K))
      | _ => fun _ F=>match F with end
      end erefl.

    Definition _cont_type (l : itreeF LTy Set (itree LTy Set)) l0 :=
      match l with
      | Vis T (LSend p) k => {p0 | p0 = p} -> forall x : T, {l' & proc l' -> proc l0}
      (* | Vis T (LRecv p) k => {p0 | p0 = p} -> {k' & (forall (x : T), proc (k' x)) -> proc l0} *)
      | _ => False -> proc l0
      end.

    Definition _step (l : itree LTy Set) : _cont_type (run l) l
      :=
        match run l as rl
              return
              rl = run l ->
              _cont_type rl l
        with
        | Vis T (LSend p) k => fun EQ ep x =>
                                 let EQ' := rename_part EQ ep in
                                 existT (fun l' => proc l' -> proc l) (k x) (fun (kp : proc (k x)) =>
                                               goP (p_event (p_snd (sval ep) x) EQ' (fun=> kp)))
        | _ => fun _ F => match F with end
        end erefl.

    Definition _seq l l' (f : proc l' -> proc l) : _cont_type (run l') l
      := match run l' as rl
               return
               _cont_type rl l' ->
               _cont_type rl l

         with
         | Vis _ (LSend _) kl =>
           fun k p x =>
             let r := k p x in
             existT (fun l1 => proc l1 -> proc l)
                    (projT1 r)
                    (fun kp => f (projT2 r kp))
              | _ => fun _ F => match F with end
              end (_step l').

      Variable p : P.

    (* CoFixpoint lt : itree LTy Set := *)
    (*   go (Vis (LSend nat p) (fun=> go (Vis (LSend bool p) (fun=>lt)))). *)

    CoFixpoint lt : itree LTy Set :=
      go (Vis (LSend nat p) (fun=> go (Vis (LSend bool p) (fun=>lt)))).

    CoFixpoint prog1 : proc lt :=
      projT2 (_seq (projT2 (_step lt (exist _ p erefl) 1)) (exist _ p erefl) true) prog1.

    (* Extraction is awful*)
    (* I need to go back to the original idea, a*)

  End Constraint.
    Require Extraction.
    Require Import ExtrOcamlIntConv.

    Extraction Inline _seq.
    Extraction Inline _step.
    Extraction Inline run.
    Extraction Inline projT1.
    Extraction Inline projT2.
    Recursive Extraction prog1.

    Definition _run_type (l : itree LTy Set) : _cont_type (run l) (itree LTy Set)
      := match run l as rl return _cont_type rl (itree LTy Set) with
         | Vis T (LSend p) k => fun _ x => k x
         | _ => fun F => match F with end
         end.

    Definition _run_seq (l : itree LTy Set) : _cont_type (run l) ()
      := match run l as rl return _cont_type rl (itree LTy Set) with
         | Vis T (LSend p) k => fun _ x => k x
         | _ => fun F => match F with end
         end.

    Definition seq l (m : {l' & proc l' -> proc l}) : _cont_type (run (projT1 m)) -> proc l.

    Definition send (l : itree LTy Set)
               (p : part_send (run l)) (x : send_type (run l))
      : {l' & proc l' -> proc l}
      := existT _ (@send_lty (run l) p x) (@_send l p x).

    Definition recv (l : itree LTy Set) :
      forall p, (forall x, proc (@recv_lty (run l) p x)) -> proc l
      := match run l as rl return
               rl = run l ->
               forall p, (forall x, proc (@recv_lty rl p x)) -> proc l
         with
         | Vis T (LRecv _) k =>
           fun EQ pp K => let EQ' := rename_part EQ pp in
                          goP (p_event (p_rcv (sval pp) T) EQ' K)
         | _ => fun _ F=>match F with end
         end erefl.

    Definition comp l
               (f1 : {l1 & proc l1 -> proc l})
               (f2 : {l2 & proc l2 -> proc (projT1 f1)}) :
      {l2 & proc l2 -> proc l} :=
      existT (fun l2 => proc l2 -> proc l) (projT1 f2) (fun f => projT2 f1 (projT2 f2 f)).

    (* Sequencing has to "peek" into the continuation of l' *)
    Definition seq l (m : {l' & proc l' -> proc l}) (f : proc (projT1 m)) : proc l
      := projT2 m f.
    Arguments seq [l] m f.
    About comp.
    Arguments comp [l] f1 f2.

    Definition inact (A : Set) (x : A) : proc (go (Ret A))
      := goP (p_end (erefl (run (go (Ret A)))) x).

    CoFixpoint lt1 : itree LTy Set :=
      go (Vis (LSend (nat + bool) p)
              (fun nb =>
                 match nb with
                 | inl _ => go (Ret nat)
                 | inr _ => lt1
                 end)).

    CoFixpoint prog1 (n : nat) : proc lt1 :=
      if n > 27 then
        seq (@send lt1 (exist _ p erefl) (inl n)) (inact n)
      else
        seq (@send lt1 (exist _ p erefl) (inl n)) (inact n)

  End Constraint.
    Require Extraction.
    Require Import ExtrOcamlIntConv.

    Recursive Extraction prog1.

    Definition bnd_type (l : itreeF LTy Set (itree LTy Set)) R :=
      match l with
      | Vis _ (LSend _) _ => part_send l -> send_type l -> R
      | Vis _ (LRecv _) _ => part_recv l -> R
      | Ret T => T -> R
      | Tau _ => False
      end.

    Definition continuation (l : itree LTy Set) (e : procF ret_lty l) : Type.

      refine (match e in procF _ l
              with
              | p_event T e kl l EQ K =>
                _
                (* match esym EQ in *)
                (*       run i Vis _ (LSend p A) k *)
                (*       return *)
              | _ => _
              end)=>/=.

    Definition bind (l : itree LTy Set) (e : procF ret_lty l) :
      bnd_type (run l) (proc l) -> proc l.
      refine (match e in procF _ l
                    return
                    bnd_type (run l) (proc l) -> proc l
              with
              | p_event T e kl l EQ K =>
                _
                (* match esym EQ in *)
                (*       run i Vis _ (LSend p A) k *)
                (*       return *)
              | _ => _
              end)=>/=.

      refine (match e in event T return
                    forall (kl : ety e -> itree LTy Set)
                           (EQ : Vis (ev_lt e) kl = run l)
                           (K : forall x : T, ret_lty (kl (cont e x))),
                           bnd_type (run l) (proc l) -> proc l
              with
              | p_snd p T x => fun kl EQ _ =>
                                 match EQ
                                       in (_ = i)
                                       return bnd_type i (proc l) -> proc l
                                 with
                                 | erefl => fun F => F (exist _ _ erefl) x
                                 end
              | p_rcv p _ => fun kl EQ _ =>
                                 match EQ
                                       in (_ = i)
                                       return bnd_type i (proc l) -> proc l
                                 with
                                 | erefl => _
                                 end
              end kl EQ K).

    Definition run_send (l : itree LTy Set) : send_type l -> itree LTy Set :=
      match run l
            as rl
            return
            match rl with
            | Vis A (LSend _) _ => A
            | _ => False
            end -> itree LTy Set
      with
      | Vis _ (LSend _) k => fun x => k x
      | _ => fun f => match f with end
      end.

    (** Examples **)
    Variable p : P.

    CoFixpoint lt1 : itree LTy Set :=
      go (Vis (LSend nat p) (fun _ => lt1)).

    CoFixpoint always_send1 : proc lt1 :=
      goP (p_event (p_snd p 1) (erefl (run lt1)) (fun=>always_send1)).

    Definition always_send2 : proc lt1 :=
      goP (p_event (p_snd p 2) (erefl (run lt1)) (fun=>always_send1)).

    CoFixpoint always_send3 : proc lt1 :=
      goP (p_event (p_snd p 1) (erefl (run lt1))
          (fun=>goP (
                p_event (p_snd p 2) (erefl (run lt1)) (fun=>always_send3)))).

    CoFixpoint ping_pong_lt : itree LTy Set :=
      go (Vis (LSend nat p)
              (fun=>go (Vis (LRecv nat p)
                            (fun n =>
                               if n >= 10
                               then go (Ret nat)
                               else ping_pong_lt)))).

    CoFixpoint ping_pong (n : nat) : proc ping_pong_lt :=
      goP (p_event (p_snd p n) (erefl (run ping_pong_lt))
                  (fun=>goP (p_event (p_rcv p nat)
                               (erefl (run (run_cont ping_pong_lt n)))
                               (fun m : nat =>
                                  match
                                    ifP (9 < m) _ _ in (if_spec _ _ _ _ _ y)
                                    return proc y
                                  with
                                  | IfSpecTrue x => goP (p_end (erefl (run (go (Ret nat)))) m)
                                  | IfSpecFalse x => ping_pong m.+1
                                  end
                               )
          ))).

  End Constraint.
    Require Extraction.
    Require Import ExtrOcamlIntConv.

    Extraction Implicit p_send [proc A k1 l2].
    Extraction Implicit p_recv [proc A k1 l2].
    Recursive Extraction ping_pong.
    (* Inductive procF (proc : itree LTy Set -> Type) : itree LTy Set -> Type := *)
    (* | p_send (p : P) (A : Type) (x : A) k1 l2 *)
    (*          (_ : Vis (LSend A p) k1 = run l2) : proc (k1 x) -> procF proc l2 *)
    (* | p_recv (p : P) (A : Type) k1 l2 *)
    (*          (_ : Vis (LRecv A p) k1 = run l2) : (forall x, proc (k1 x)) -> procF proc l2 *)
    (* | p_end (A : Set) l2 *)
    (*          (_ : Ret A = run l2) : A -> procF proc l2 *)

End ITree.