(** * Stlc: The Simply Typed Lambda-Calculus *)

Require Import Maps.
Require Import Smallstep.
Require Import Types.

(* ###################################################################### *)
(** * The Simply Typed Lambda-Calculus *)

(** The simply typed lambda-calculus (STLC) is a tiny core
    calculus embodying the key concept of _functional abstraction_,
    which shows up in pretty much every real-world programming
    language in some form (functions, procedures, methods, etc.).

    We will follow exactly the same pattern as in the previous chapter
    when formalizing this calculus (syntax, small-step semantics,
    typing rules) and its main properties (progress and preservation).
    The new technical challenges all arise from the mechanisms of
    _variable binding_ and _substitution_.  It which will take some
    work to deal with these. *)

(* ###################################################################### *)
(** ** Overview *)

(** The STLC is built on some collection of _base types_ --
    booleans, numbers, strings, etc.  The exact choice of base types
    doesn't matter much -- the construction of the language and its
    theoretical properties work out the same no matter what we
    choose -- so for the sake of brevity let's take just [Bool] for
    the moment.  At the end of the chapter we'll see how to add more
    base types, and in later chapters we'll enrich the pure STLC with
    other useful constructs like pairs, records, subtyping, and
    mutable state.

    Starting from boolean constants and conditionals, we add three
    things:
        - variables
        - function abstractions
        - application

    This gives us the following collection of abstract syntax
    constructors (written out first in informal BNF notation -- we'll
    formalize it below).

*)
(**
       t ::= x                       variable
           | \x:T1.t2                abstraction
           | t1 t2                   application
           | true                    constant true
           | false                   constant false
           | if t1 then t2 else t3   conditional
*)

(** The [\] symbol in a function abstraction [\x:T1.t2] is generally
    written as a greek letter "lambda" (hence the name of the
    calculus).  The variable [x] is called the _parameter_ to the
    function; the term [t2] is its _body_.  The annotation [:T1]
    specifies the type of arguments that the function can be applied
    to. *)

(** Some examples:

      - [\x:Bool. x]

        The identity function for booleans.

      - [(\x:Bool. x) true]

        The identity function for booleans, applied to the boolean [true].

      - [\x:Bool. if x then false else true]

        The boolean "not" function.

      - [\x:Bool. true]

        The constant function that takes every (boolean) argument to
        [true]. *)
(**
      - [\x:Bool. \y:Bool. x]

        A two-argument function that takes two booleans and returns
        the first one.  (Note that, as in Coq, a two-argument function
        is really a one-argument function whose body is also a
        one-argument function.)

      - [(\x:Bool. \y:Bool. x) false true]

        A two-argument function that takes two booleans and returns
        the first one, applied to the booleans [false] and [true].

        Note that, as in Coq, application associates to the left --
        i.e., this expression is parsed as [((\x:Bool. \y:Bool. x)
        false) true].

      - [\f:Bool->Bool. f (f true)]

        A higher-order function that takes a _function_ [f] (from
        booleans to booleans) as an argument, applies [f] to [true],
        and applies [f] again to the result.

      - [(\f:Bool->Bool. f (f true)) (\x:Bool. false)]

        The same higher-order function, applied to the constantly
        [false] function. *)

(** As the last several examples show, the STLC is a language of
    _higher-order_ functions: we can write down functions that take
    other functions as arguments and/or return other functions as
    results.

    Another point to note is that the STLC doesn't provide any
    primitive syntax for defining _named_ functions -- all functions
    are "anonymous."  We'll see in chapter [MoreStlc] that it is easy
    to add named functions to what we've got -- indeed, the
    fundamental naming and binding mechanisms are exactly the same.

    The _types_ of the STLC include [Bool], which classifies the
    boolean constants [true] and [false] as well as more complex
    computations that yield booleans, plus _arrow types_ that classify
    functions. *)
(**
      T ::= Bool
          | T1 -> T2
    For example:

      - [\x:Bool. false] has type [Bool->Bool]

      - [\x:Bool. x] has type [Bool->Bool]

      - [(\x:Bool. x) true] has type [Bool]

      - [\x:Bool. \y:Bool. x] has type [Bool->Bool->Bool] (i.e., [Bool -> (Bool->Bool)])

      - [(\x:Bool. \y:Bool. x) false] has type [Bool->Bool]

      - [(\x:Bool. \y:Bool. x) false true] has type [Bool]
*)

(* ###################################################################### *)
(** ** Syntax *)

Module STLC.

(* ################################### *)
(** *** Types *)

Inductive ty : Type :=
  | TBool  : ty
  | TArrow : ty -> ty -> ty.

(* ################################### *)
(** *** Terms *)

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm.

(** Note that an abstraction [\x:T.t] (formally, [tabs x T t]) is
    always annotated with the type [T] of its parameter, in contrast
    to Coq (and other functional languages like ML, Haskell, etc.),
    which use _type inference_ to fill in missing annotations.  We're
    not considering type inference here, to keep things simple. *)

(** Some examples... *)

Definition x := (Id 0).
Definition y := (Id 1).
Definition z := (Id 2).
Hint Unfold x.
Hint Unfold y.
Hint Unfold z.

(** [idB = \x:Bool. x] *)

Notation idB :=
  (tabs x TBool (tvar x)).

(** [idBB = \x:Bool->Bool. x] *)

Notation idBB :=
  (tabs x (TArrow TBool TBool) (tvar x)).

(** [idBBBB = \x:(Bool->Bool) -> (Bool->Bool). x] *)

Notation idBBBB :=
  (tabs x (TArrow (TArrow TBool TBool)
                      (TArrow TBool TBool))
    (tvar x)).

(** [k = \x:Bool. \y:Bool. x] *)

Notation k := (tabs x TBool (tabs y TBool (tvar x))).

(** [notB = \x:Bool. if x then false else true] *)

Notation notB := (tabs x TBool (tif (tvar x) tfalse ttrue)).

(** (We write these as [Notation]s rather than [Definition]s to make
    things easier for [auto].) *)

(* ###################################################################### *)
(** ** Operational Semantics *)

(** To define the small-step semantics of STLC terms, we begin -- as
    always -- by defining the set of values.  Next, we define the
    critical notions of _free variables_ and _substitution_, which are
    used in the reduction rule for application expressions.  And
    finally we give the small-step relation itself. *)

(* ################################### *)
(** *** Values *)

(** To define the values of the STLC, we have a few cases to consider.

    First, for the boolean part of the language, the situation is
    clear: [true] and [false] are the only values.  An [if]
    expression is never a value. *)

(** Second, an application is clearly not a value: It represents a
    function being invoked on some argument, which clearly still has
    work left to do. *)

(** Third, for abstractions, we have a choice:

      - We can say that [\x:T.t1] is a value only when [t1] is a
        value -- i.e., only if the function's body has been
        reduced (as much as it can be without knowing what argument it
        is going to be applied to).

      - Or we can say that [\x:T.t1] is always a value, no matter
        whether [t1] is one or not -- in other words, we can say that
        reduction stops at abstractions.

    Coq, in its built-in functional programming langauge, makes the
    first choice -- for example,
         Compute (fun x:bool => 3 + 4)
    yields [fun x:bool => 7].

    Most real-world functional programming languages make the second
    choice -- reduction of a function's body only begins when the
    function is actually applied to an argument.  We also make the
    second choice here. *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (tabs x T t)
  | v_true :
      value ttrue
  | v_false :
      value tfalse.

Hint Constructors value.

(** Finally, we must consider what constitutes a _complete_ program.

  Intuitively, a "complete" program must not refer to any undefined
  variables.  We'll see shortly how to define the "free" variables
  in a STLC term.  A program is "closed", that is, it contains no
  free variables.

*)

(** Having made the choice not to reduce under abstractions,
    we don't need to worry about whether variables are values, since
    we'll always be reducing programs "from the outside in," and that
    means the [step] relation will always be working with closed
    terms (ones with no free variables).  *)

(* ###################################################################### *)
(** *** Substitution *)

(** Now we come to the heart of the STLC: the operation of
    substituting one term for a variable in another term.

    This operation will be used below to define the operational
    semantics of function application, where we will need to
    substitute the argument term for the function parameter in the
    function's body.  For example, we reduce
       (\x:Bool. if x then true else x) false
    to
       if false then true else false
    by substituting [false] for the parameter [x] in the body of the
    function.

    In general, we need to be able to substitute some given
    term [s] for occurrences of some variable [x] in another term [t].
    In informal discussions, this is usually written [ [x:=s]t ] and
    pronounced "substitute [x] with [s] in [t]." *)

(** Here are some examples:

      - [[x:=true] (if x then x else false)] yields [if true then true else false]

      - [[x:=true] x] yields [true]

      - [[x:=true] (if x then x else y)] yields [if true then true else y]

      - [[x:=true] y] yields [y]

      - [[x:=true] false] yields [false] (vacuous substitution)

      - [[x:=true] (\y:Bool. if y then x else false)] yields [\y:Bool. if y then true else false]
      - [[x:=true] (\y:Bool. x)] yields [\y:Bool. true]

      - [[x:=true] (\y:Bool. y)] yields [\y:Bool. y]

      - [[x:=true] (\x:Bool. x)] yields [\x:Bool. x]

    The last example is very important: substituting [x] with [true] in
    [\x:Bool. x] does _not_ yield [\x:Bool. true]!  The reason for
    this is that the [x] in the body of [\x:Bool. x] is _bound_ by the
    abstraction: it is a new, local name that just happens to be
    spelled the same as some global name [x]. *)

(** Here is the definition, informally...
   [x:=s]x = s
   [x:=s]y = y                                   if x <> y
   [x:=s](\x:T11.t12)   = \x:T11. t12
   [x:=s](\y:T11.t12)   = \y:T11. [x:=s]t12      if x <> y
   [x:=s](t1 t2)        = ([x:=s]t1) ([x:=s]t2)
   [x:=s]true           = true
   [x:=s]false          = false
   [x:=s](if t1 then t2 else t3) =
                   if [x:=s]t1 then [x:=s]t2 else [x:=s]t3
*)

(**    ... and formally: *)

Reserved Notation "'[' x ':=' s ']' t" (at level 20).

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tvar x' =>
      if beq_id x x' then s else t
  | tabs x' T t1 =>
      tabs x' T (if beq_id x x' then t1 else ([x:=s] t1))
  | tapp t1 t2 =>
      tapp ([x:=s] t1) ([x:=s] t2)
  | ttrue =>
      ttrue
  | tfalse =>
      tfalse
  | tif t1 t2 t3 =>
      tif ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
  end

where "'[' x ':=' s ']' t" := (subst x s t).

(** _Technical note_: Substitution becomes trickier to define if we
    consider the case where [s], the term being substituted for a
    variable in some other term, may itself contain free variables.
    Since we are only interested here in defining the [step] relation
    on closed terms (i.e., terms like [\x:Bool. x], that do not mention
    variables are not bound by some enclosing lambda), we can skip
    this extra complexity here, but it must be dealt with when
    formalizing richer languages. *)

(** **** Exercise: 3 stars (substi)  *)

(** The definition that we gave above uses Coq's [Fixpoint] facility
    to define substitution as a _function_.  Suppose, instead, we
    wanted to define substitution as an inductive _relation_ [substi].
    We've begun the definition by providing the [Inductive] header and
    one of the constructors; your job is to fill in the rest of the
    constructors. *)

Inductive substi (s:tm) (x:id) : tm -> tm -> Prop :=
  | s_var1 :
      substi s x (tvar x) s
  (* FILL IN HERE *)
.

Hint Constructors substi.

Theorem substi_correct : forall s x t t',
  [x:=s]t = t' <-> substi s x t t'.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################### *)
(** *** Reduction *)

(** The small-step reduction relation for STLC now follows the same
    pattern as the ones we have seen before.  Intuitively, to reduce a
    function application, we first reduce its left-hand side until it
    becomes a literal function; then we reduce its right-hand
    side (the argument) until it is also a value; and finally we
    substitute the argument for the bound variable in the body of the
    function.  This last rule, written informally as
      (\x:T.t12) v2 ==> [x:=v2]t12
    is traditionally called "beta-reduction". *)

(**
                               value v2
                     ----------------------------                   (ST_AppAbs)
                     (\x:T.t12) v2 ==> [x:=v2]t12

                              t1 ==> t1'
                           ----------------                           (ST_App1)
                           t1 t2 ==> t1' t2

                              value v1
                              t2 ==> t2'
                           ----------------                           (ST_App2)
                           v1 t2 ==> v1 t2'
*)
(** ... plus the usual rules for booleans:
                    --------------------------------                (ST_IfTrue)
                    (if true then t1 else t2) ==> t1

                    ---------------------------------              (ST_IfFalse)
                    (if false then t1 else t2) ==> t2

                              t1 ==> t1'
         ----------------------------------------------------           (ST_If)
         (if t1 then t2 else t3) ==> (if t1' then t2 else t3)
*)

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (tapp (tabs x T t12) v2) ==> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         tapp t1 t2 ==> tapp t1' t2
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         tapp v1 t2 ==> tapp v1  t2'
  | ST_IfTrue : forall t1 t2,
      (tif ttrue t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
      (tif tfalse t1 t2) ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      (tif t1 t2 t3) ==> (tif t1' t2 t3)

where "t1 '==>' t2" := (step t1 t2).

Hint Constructors step.

Notation multistep := (multi step).
Notation "t1 '==>*' t2" := (multistep t1 t2) (at level 40).

(* ##################################### *)

(* ##################################### *)
(** *** Examples *)

(** Example:
    ((\x:Bool->Bool. x) (\x:Bool. x)) ==>* (\x:Bool. x)
i.e.,
    (idBB idB) ==>* idB
*)

Lemma step_example1 :
  (tapp idBB idB) ==>* idB.
Proof.
  eapply multi_step.
    apply ST_AppAbs.
    apply v_abs.
  simpl.
  apply multi_refl.  Qed.

(** Example:
((\x:Bool->Bool. x) ((\x:Bool->Bool. x) (\x:Bool. x)))
      ==>* (\x:Bool. x)
i.e.,
  (idBB (idBB idB)) ==>* idB.
*)

Lemma step_example2 :
  (tapp idBB (tapp idBB idB)) ==>* idB.
Proof.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_AppAbs. auto.
  eapply multi_step.
    apply ST_AppAbs. simpl. auto.
  simpl. apply multi_refl.  Qed.

(** Example:
((\x:Bool->Bool. x) (\x:Bool. if x then false
                              else true)) true)
      ==>* false
i.e.,
  ((idBB notB) ttrue) ==>* tfalse.
*)

Lemma step_example3 :
  tapp (tapp idBB notB) ttrue ==>* tfalse.
Proof.
  eapply multi_step.
    apply ST_App1. apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_IfTrue. apply multi_refl.  Qed.

(** Example:
((\x:Bool -> Bool. x) ((\x:Bool. if x then false
                               else true) true))
      ==>* false
i.e.,
  (idBB (notB ttrue)) ==>* tfalse.
*)

Lemma step_example4 :
  tapp idBB (tapp notB ttrue) ==>* tfalse.
Proof.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_IfTrue.
  eapply multi_step.
    apply ST_AppAbs. auto. simpl.
  apply multi_refl.  Qed.

(** A more automatic proof *)

Lemma step_example1' :
  (tapp idBB idB) ==>* idB.
Proof. normalize.  Qed.

(** Again, we can use the [normalize] tactic from above to simplify
    the proof. *)

Lemma step_example2' :
  (tapp idBB (tapp idBB idB)) ==>* idB.
Proof.
  normalize.
Qed.

Lemma step_example3' :
  tapp (tapp idBB notB) ttrue ==>* tfalse.
Proof. normalize.  Qed.

Lemma step_example4' :
  tapp idBB (tapp notB ttrue) ==>* tfalse.
Proof. normalize.  Qed.

(** **** Exercise: 2 stars (step_example3)  *)
(** Try to do this one both with and without [normalize]. *)

Lemma step_example5 :
       (tapp (tapp idBBBB idBB) idB)
  ==>* idB.
Proof.
  (* FILL IN HERE *) Admitted.

(* FILL IN HERE *)
(** [] *)

(* ###################################################################### *)
(** ** Typing *)

(* ################################### *)
(** *** Contexts *)

(** _Question_: What is the type of the term "[x y]"?

    _Answer_: It depends on the types of [x] and [y]!

    I.e., in order to assign a type to a term, we need to know
    what assumptions we should make about the types of its free
    variables.

    This leads us to a three-place "typing judgment", informally
    written [Gamma |- t \in T], where [Gamma] is a
    "typing context" -- a mapping from variables to their types. *)

(** Informally, we'll write [Gamma, x:T] for "extend the partial
    function [Gamma] to also map [x] to [T]."  Formally, we use the
    function [extend] to add a binding to a partial map. *)

Definition context := partial_map ty.

(* ################################### *)
(** *** Typing Relation *)

(**
                             Gamma x = T
                            --------------                              (T_Var)
                            Gamma |- x \in T

                      Gamma , x:T11 |- t12 \in T12
                     ----------------------------                       (T_Abs)
                     Gamma |- \x:T11.t12 \in T11->T12

                        Gamma |- t1 \in T11->T12
                          Gamma |- t2 \in T11
                        ----------------------                          (T_App)
                         Gamma |- t1 t2 \in T12

                         --------------------                          (T_True)
                         Gamma |- true \in Bool

                        ---------------------                         (T_False)
                        Gamma |- false \in Bool

       Gamma |- t1 \in Bool    Gamma |- t2 \in T    Gamma |- t3 \in T
       --------------------------------------------------------          (T_If)
                  Gamma |- if t1 then t2 else t3 \in T

    We can read the three-place relation [Gamma |- t \in T] as:
    "to the term [t] we can assign the type [T] using as types for
    the free variables of [t] the ones specified in the context
    [Gamma]." *)

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      Gamma |- tvar x \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      update Gamma x T11 |- t12 \in T12 ->
      Gamma |- tabs x T11 t12 \in TArrow T11 T12
  | T_App : forall T11 T12 Gamma t1 t2,
      Gamma |- t1 \in TArrow T11 T12 ->
      Gamma |- t2 \in T11 ->
      Gamma |- tapp t1 t2 \in T12
  | T_True : forall Gamma,
       Gamma |- ttrue \in TBool
  | T_False : forall Gamma,
       Gamma |- tfalse \in TBool
  | T_If : forall t1 t2 t3 T Gamma,
       Gamma |- t1 \in TBool ->
       Gamma |- t2 \in T ->
       Gamma |- t3 \in T ->
       Gamma |- tif t1 t2 t3 \in T

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type.

(* ################################### *)
(** *** Examples *)

Example typing_example_1 :
  empty |- tabs x TBool (tvar x) \in TArrow TBool TBool.
Proof.
  apply T_Abs. apply T_Var. reflexivity.  Qed.

(** Note that since we added the [has_type] constructors to the hints
    database, auto can actually solve this one immediately. *)

Example typing_example_1' :
  empty |- tabs x TBool (tvar x) \in TArrow TBool TBool.
Proof. auto.  Qed.

(** Another example:
     empty |- \x:A. \y:A->A. y (y x))
           \in A -> (A->A) -> A.
*)

Example typing_example_2 :
  empty |-
    (tabs x TBool
       (tabs y (TArrow TBool TBool)
          (tapp (tvar y) (tapp (tvar y) (tvar x))))) \in
    (TArrow TBool (TArrow (TArrow TBool TBool) TBool)).
Proof with auto using update_eq.
  apply T_Abs.
  apply T_Abs.
  eapply T_App. apply T_Var...
  eapply T_App. apply T_Var...
  apply T_Var...
Qed.

(** **** Exercise: 2 stars, optional (typing_example_2_full)  *)
(** Prove the same result without using [auto], [eauto], or
    [eapply]. *)

Example typing_example_2_full :
  empty |-
    (tabs x TBool
       (tabs y (TArrow TBool TBool)
          (tapp (tvar y) (tapp (tvar y) (tvar x))))) \in
    (TArrow TBool (TArrow (TArrow TBool TBool) TBool)).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars (typing_example_3)  *)
(** Formally prove the following typing derivation holds: *)
(**
   empty |- \x:Bool->B. \y:Bool->Bool. \z:Bool.
               y (x z)
         \in T.
*)

Example typing_example_3 :
  exists T,
    empty |-
      (tabs x (TArrow TBool TBool)
         (tabs y (TArrow TBool TBool)
            (tabs z TBool
               (tapp (tvar y) (tapp (tvar x) (tvar z)))))) \in
      T.
Proof with auto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** We can also show that terms are _not_ typable.  For example, let's
    formally check that there is no typing derivation assigning a type
    to the term [\x:Bool. \y:Bool, x y] -- i.e.,
    ~ exists T,
        empty |- \x:Bool. \y:Bool, x y : T.
*)

Example typing_nonexample_1 :
  ~ exists T,
      empty |-
        (tabs x TBool
            (tabs y TBool
               (tapp (tvar x) (tvar y)))) \in
        T.
Proof.
  intros Hc. inversion Hc.
  (* The [clear] tactic is useful here for tidying away bits of
     the context that we're not going to need again. *)
  inversion H. subst. clear H.
  inversion H5. subst. clear H5.
  inversion H4. subst. clear H4.
  inversion H2. subst. clear H2.
  inversion H5. subst. clear H5.
  inversion H1.  Qed.

(** **** Exercise: 3 stars, optional (typing_nonexample_3)  *)
(** Another nonexample:
    ~ (exists S, exists T,
          empty |- \x:S. x x : T).
*)

Example typing_nonexample_3 :
  ~ (exists S, exists T,
        empty |-
          (tabs x S
             (tapp (tvar x) (tvar x))) \in
          T).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

End STLC.

(** $Date: 2016-03-07 17:05:52 -0500 (Mon, 07 Mar 2016) $ *)


Require Import Bool.
Require Import ZArith.
Require Import Reals.
From Flocq Require Import Core Digits Round Relative.
Require Import Gappa_definitions.
Require Import Gappa_dyadic.
Require Import Gappa_pred_bnd.
Require Import Gappa_round_def.
Require Import Gappa_round_aux.
Require Import Gappa_round.

Global Notation rounding_float rdir p d :=
  (Generic_fmt.round radix2 (FLT_exp d (Zpos p)) rdir) (only parsing).

Global Notation rounding_floatx rdir p :=
  (Generic_fmt.round radix2 (FLX_exp (Zpos p)) rdir) (only parsing).

Definition float_ulp (p : positive) (d m e : Z) :=
 match m with
 | Zpos n => FLT_exp d (Zpos p) (e + Zpos (digits n))%Z
 | Zneg n => FLT_exp d (Zpos p) (e + Zpos (digits n))%Z
 | Z0 => d
 end.

Definition floatx_ulp (p : positive) (m e : Z) :=
 match m with
 | Zpos n => FLX_exp (Zpos p) (e + Zpos (digits n))%Z
 | Zneg n => FLX_exp (Zpos p) (e + Zpos (digits n))%Z
 | Z0 => Z0
 end.

Lemma float_absolute_ne_sym :
  forall p d x,
  (Rabs (rounding_float rndNE p d x - x) = Rabs (rounding_float rndNE p d (Rabs x) - Rabs x))%R.
Proof.
intros p d x.
destruct (Rle_or_lt 0 x) as [H|H].
rewrite (Rabs_right _ (Rle_ge _ _ H)).
exact (refl_equal _).
rewrite (Rabs_left _ H).
rewrite round_NE_opp.
unfold Rminus.
rewrite <- Ropp_plus_distr.
now rewrite Rabs_Ropp.
Qed.

Lemma floatx_absolute_ne_sym :
  forall p x,
  (Rabs (rounding_floatx rndNE p x - x) = Rabs (rounding_floatx rndNE p (Rabs x) - Rabs x))%R.
Proof.
intros p x.
destruct (Rle_or_lt 0 x) as [H|H].
rewrite (Rabs_right _ (Rle_ge _ _ H)).
exact (refl_equal _).
rewrite (Rabs_left _ H).
rewrite round_NE_opp.
unfold Rminus.
rewrite <- Ropp_plus_distr.
now rewrite Rabs_Ropp.
Qed.

Instance zpos_gt_0 : forall p, Prec_gt_0 (Zpos p).
easy.
Qed.

Lemma float_absolute_n_whole :
  forall c p d k x,
  (Rabs x < bpow radix2 k)%R ->
  (Rabs (rounding_float (Znearest c) p d x - x) <= bpow radix2 (FLT_exp d (Zpos p) k - 1))%R.
Proof with auto with typeclass_instances.
intros c p d k x Hx.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0, round_0, Rminus_0_r, Rabs_R0...
apply bpow_ge_0.
apply Rle_trans with (/2 * ulp radix2 (FLT_exp d (Zpos p)) x)%R.
apply error_le_half_ulp...
rewrite ulp_neq_0; trivial.
rewrite <- (bpow_plus radix2 (-1)).
apply bpow_le.
unfold Zminus.
rewrite (Zplus_comm _ (-1)).
apply Zplus_le_compat_l.
unfold cexp.
apply monotone_exp...
now apply mag_le_bpow.
Qed.

Lemma floatx_absolute_n_whole :
  forall c p k x,
  (Rabs x < bpow radix2 k)%R ->
  (Rabs (rounding_floatx (Znearest c) p x - x) <= bpow radix2 (FLX_exp (Zpos p) k - 1))%R.
Proof with auto with typeclass_instances.
intros c p k x Hx.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0, round_0, Rminus_0_r, Rabs_R0...
apply bpow_ge_0.
apply Rle_trans with (/2 * ulp radix2 (FLX_exp (Zpos p)) x)%R.
apply error_le_half_ulp...
rewrite ulp_neq_0; trivial.
rewrite <- (bpow_plus radix2 (-1)).
apply bpow_le.
unfold Zminus.
rewrite (Zplus_comm _ (-1)).
apply Zplus_le_compat_l.
unfold cexp.
apply monotone_exp...
now apply mag_le_bpow.
Qed.

Lemma float_absolute_inv_n_whole :
  forall c p d k x,
  (Rabs (rounding_float (Znearest c) p d x) < bpow radix2 k)%R ->
  (Rabs (rounding_float (Znearest c) p d x - x) <= bpow radix2 (FLT_exp d (Zpos p) k - 1))%R.
Proof with auto with typeclass_instances.
intros c p d k x Hx.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0, round_0, Rminus_0_r, Rabs_R0...
apply bpow_ge_0.
apply Rle_trans with (/2 * ulp radix2 (FLT_exp d (Zpos p)) x)%R.
apply error_le_half_ulp...
rewrite ulp_neq_0; trivial.
rewrite <- (bpow_plus radix2 (-1)).
apply bpow_le.
unfold Zminus.
rewrite (Zplus_comm _ (-1)).
apply Zplus_le_compat_l.
unfold cexp.
destruct (Zle_or_lt (mag radix2 x) k) as [Hk1|Hk1].
apply monotone_exp...
destruct (Zle_or_lt (mag radix2 x) d) as [Hk2|Hk2].
unfold FLT_exp.
clear -Hk1 Hk2 ; zify ; omega.
elim Rlt_not_le with (1 := Hx) ; clear Hx.
apply Rle_trans with (bpow radix2 (Z.max k d)).
apply bpow_le.
apply Z.le_max_l.
apply abs_round_ge_generic...
apply generic_format_bpow.
unfold FLT_exp.
clear ; zify ; omega.
destruct (mag radix2 x) as (ex,Ex) ; simpl in *.
apply Rle_trans with (2 := proj1 (Ex Hx0)).
apply bpow_le.
clear -Hk1 Hk2 ; zify ; omega.
Qed.

Lemma floatx_absolute_inv_n_whole :
  forall c p k x,
  (Rabs (rounding_floatx (Znearest c) p x) < bpow radix2 k)%R ->
  (Rabs (rounding_floatx (Znearest c) p x - x) <= bpow radix2 (FLX_exp (Zpos p) k - 1))%R.
Proof with auto with typeclass_instances.
intros c p k x Hx.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0, round_0, Rminus_0_r, Rabs_R0...
apply bpow_ge_0.
apply Rle_trans with (/2 * ulp radix2 (FLX_exp (Zpos p)) x)%R.
apply error_le_half_ulp...
rewrite ulp_neq_0; trivial.
rewrite <- (bpow_plus radix2 (-1)).
apply bpow_le.
unfold Zminus.
rewrite (Zplus_comm _ (-1)).
apply Zplus_le_compat_l.
unfold cexp.
apply monotone_exp...
destruct (Zle_or_lt (mag radix2 x) k) as [Hk1|Hk1].
exact Hk1.
elim Rlt_not_le with (1 := Hx) ; clear Hx.
apply abs_round_ge_generic...
apply generic_format_bpow.
unfold FLX_exp.
clear ; zify ; omega.
destruct (mag radix2 x) as (ex,Ex) ; simpl in *.
apply Rle_trans with (2 := proj1 (Ex Hx0)).
apply bpow_le.
clear -Hk1 ; omega.
Qed.

Lemma Zmax_inf_l :
 forall m n : Z, (n <= m)%Z -> Z.max m n = m.
intros m n H.
generalize (Z.le_ge _ _ H).
unfold Z.max, Z.ge.
case (m ?= n)%Z ; intros ; try exact (refl_equal _).
elim H0.
exact (refl_equal _).
Qed.

Lemma float_relative_n_whole :
  forall c p d x,
  (bpow radix2 (d + Zpos p - 1) <= Rabs x)%R ->
  (Rabs ((rounding_float (Znearest c) p d x - x) / x) <= bpow radix2 (-Zpos p))%R.
Proof.
intros c p d x Hx.
assert (Hx0: x <> 0%R).
intros Hx0.
apply Rle_not_lt with (1 := Hx).
rewrite Hx0, Rabs_R0.
apply bpow_gt_0.
destruct (relative_error_N_FLT_ex radix2 d (Zpos p) (refl_equal _) c x Hx) as (eps, (Hr1, Hr2)).
rewrite Hr2.
replace ((x * (1 + eps) - x) / x)%R with eps by now field.
revert Hr1.
rewrite <- (bpow_plus radix2 (-1)%Z).
now rewrite (Zplus_comm (- Zpos p)), Zplus_assoc.
Qed.

Lemma float_relative_inv_n_whole :
  forall c p d x,
  (bpow radix2 (d + Zpos p - 1) < Rabs (rounding_float (Znearest c) p d x))%R ->
  (Rabs ((rounding_float (Znearest c) p d x - x) / x) <= bpow radix2 (-Zpos p))%R.
Proof with auto with typeclass_instances.
intros c p d x Hx.
apply float_relative_n_whole.
apply Rnot_lt_le.
contradict Hx.
apply Rle_not_lt.
apply abs_round_le_generic...
apply generic_format_bpow.
unfold FLT_exp.
ring_simplify (d + Zpos p - 1 + 1 - Zpos p)%Z.
rewrite Zmax_idempotent.
clear ; zify ; omega.
now apply Rlt_le.
Qed.

Theorem fix_of_float :
  forall rdir x p k1 k2,
  Zle_bool k2 k1 = true ->
  FIX (rounding_float rdir p k1 x) k2.
Proof.
intros rdir x p k1 k2 H.
generalize (Zle_bool_imp_le _ _ H). clear H. intro H.
unfold FIX.
eexists (Float2 _ _) ; repeat split.
simpl.
unfold cexp.
apply Z.le_trans with (1 := H).
apply Z.le_max_r.
Qed.

Theorem flt_of_float :
  forall rdir {Hrnd : Valid_rnd rdir} x p1 p2 k,
  Zle_bool (Zpos p1) (Zpos p2) = true ->
  FLT (rounding_float rdir p1 k x) p2.
Proof with auto with typeclass_instances.
intros rdir Hrnd x p1 p2 k H.
generalize (Zle_bool_imp_le _ _ H). clear H. intro H.
unfold FLT.
destruct (FLT_format_generic radix2 k (Zpos p1) (Generic_fmt.round radix2 (FLT_exp k (Zpos p1)) rdir x))
  as ((m, e), H1, H2, _).
apply generic_format_round...
rewrite H1.
eexists (Float2 _ _) ; repeat split.
apply Z.lt_le_trans with (1 := H2).
change (Zpower_pos 2 p2) with (Zpower radix2 (Zpos p2)).
now apply Zpower_le.
Qed.

Theorem flt_of_floatx :
  forall rdir {Hrnd : Valid_rnd rdir} x p1 p2,
  Zle_bool (Zpos p1) (Zpos p2) = true ->
  FLT (rounding_floatx rdir p1 x) p2.
Proof with auto with typeclass_instances.
intros rdir Hrnd x p1 p2 H.
generalize (Zle_bool_imp_le _ _ H). clear H. intro H.
unfold FLT.
destruct (FLX_format_generic radix2 (Zpos p1) (Generic_fmt.round radix2 (FLX_exp (Zpos p1)) rdir x))
  as ((m, e), H1, H2).
apply generic_format_round...
rewrite H1.
eexists (Float2 _ _) ; repeat split.
apply Z.lt_le_trans with (1 := H2).
change (Zpower_pos 2 p2) with (Zpower radix2 (Zpos p2)).
now apply Zpower_le.
Qed.

Theorem float_of_fix_flt :
  forall rdir {Hrnd : Valid_rnd rdir},
  forall x : R,
  forall d1 d2 : Z, forall p1 p2 : positive,
  FIX x d1 -> FLT x p1 ->
  Zle_bool d2 d1 && Zle_bool (Zpos p1) (Zpos p2) = true ->
  rounding_float rdir p2 d2 x = x.
Proof with auto with typeclass_instances.
intros rdir Hrnd x d1 d2 p1 p2 (f1,(Hx1,Hx2)) (f2,(Hx3,Hx4)) Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Zle_bool_imp_le _ _ H1). clear H1. intro H1.
generalize (Zle_bool_imp_le _ _ H2). clear H2. intro H2.
apply round_generic...
destruct f1 as (m1, e1).
destruct f2 as (m2, e2).
destruct (Z.eq_dec m2 0) as [Hm|Hm].
rewrite <- Hx3.
unfold float2R.
rewrite Hm, F2R_0.
apply generic_format_0.
assert (mag radix2 (F2R (Float radix2 m2 e2)) <= Zpos p2 + e2)%Z.
rewrite mag_F2R with (1 := Hm).
apply Zplus_le_compat_r.
apply Z.le_trans with (2 := H2).
apply bpow_lt_bpow with radix2.
destruct (mag radix2 (IZR m2)) as (n2, Hn).
simpl.
specialize (Hn (IZR_neq _ _ Hm)).
apply Rle_lt_trans with (1 := proj1 Hn).
rewrite <- abs_IZR.
now apply IZR_lt.
destruct (Zle_or_lt e1 e2) as [He|He].
(* *)
rewrite <- Hx3.
apply generic_format_F2R.
intros _ ; simpl.
apply Z.max_lub.
clear -H ; omega.
apply Z.le_trans with (1 := H1).
now apply Z.le_trans with e1.
(* *)
rewrite <- Hx1.
apply generic_format_F2R.
intros _ ; simpl.
apply Z.max_lub.
unfold float2R in Hx1. simpl in Hx1.
rewrite Hx1, <- Hx3.
unfold float2R. simpl.
omega.
now apply Z.le_trans with d1.
Qed.

Theorem floatx_of_flt :
  forall rdir {Hrnd : Valid_rnd rdir},
  forall x : R,
  forall p1 p2 : positive,
  FLT x p1 ->
  Zle_bool (Zpos p1) (Zpos p2) = true ->
  rounding_floatx rdir p2 x = x.
Proof with auto with typeclass_instances.
intros rdir Hrnd x p1 p2 [[m e] [Hx1 Hx2]] Hb.
generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1.
apply round_generic...
rewrite <- Hx1.
apply generic_format_F2R.
unfold cexp.
intros Hm ; simpl.
rewrite mag_F2R with (1 := Hm).
simpl.
unfold FLX_exp.
cut (mag radix2 (IZR m) <= Zpos p1)%Z.
clear -H1 ; omega.
apply bpow_lt_bpow with radix2.
destruct (mag radix2 (IZR m)) as [n Hn].
simpl.
specialize (Hn (IZR_neq _ _ Hm)).
apply Rle_lt_trans with (1 := proj1 Hn).
rewrite <- abs_IZR.
now apply IZR_lt.
Qed.

Existing Instance valid_rnd_Gf.

Definition round_helper (rnd : float2 -> float2) (xi zi : FF) :=
 Fle2 (lower zi) (rnd (lower xi)) &&
 Fle2 (rnd (upper xi)) (upper zi).

Theorem float_round :
  forall rdir p d x xi zi,
  BND x xi ->
  round_helper (round (rndG_g rdir) (FLT_exp d (Zpos p))) xi zi = true ->
  BND (rounding_float (rndG_f rdir) p d x) zi.
Proof with auto with typeclass_instances.
intros rdir p d x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). rewrite rndG_conversion. clear H1. intro H1.
generalize (Fle2_correct _ _ H2). rewrite rndG_conversion. clear H2. intro H2.
split.
apply Rle_trans with (1 := H1).
apply round_le...
apply Hx.
apply Rle_trans with (2 := H2).
apply round_le...
apply Hx.
Qed.

Definition float_round_dn := float_round roundDN_cs.
Definition float_round_up := float_round roundUP_cs.
Definition float_round_zr := float_round roundZR_cs.
Definition float_round_ne := float_round roundNE_cs.
Definition float_round_na := float_round roundNA_cs.

Theorem floatx_round :
  forall rdir p x xi zi,
  BND x xi ->
  round_helper (round (rndG_g rdir) (FLX_exp (Zpos p))) xi zi = true ->
  BND (rounding_floatx (rndG_f rdir) p x) zi.
Proof with auto with typeclass_instances.
intros rdir p x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). rewrite rndG_conversion. clear H1. intro H1.
generalize (Fle2_correct _ _ H2). rewrite rndG_conversion. clear H2. intro H2.
split.
apply Rle_trans with (1 := H1).
apply round_le...
apply Hx.
apply Rle_trans with (2 := H2).
apply round_le...
apply Hx.
Qed.

Definition floatx_round_dn := floatx_round roundDN_cs.
Definition floatx_round_up := floatx_round roundUP_cs.
Definition floatx_round_zr := floatx_round roundZR_cs.
Definition floatx_round_ne := floatx_round roundNE_cs.
Definition floatx_round_na := floatx_round roundNA_cs.

Definition enforce_helper (fexp : Z -> Z) (xi zi : FF) :=
 Fle2 (lower zi) (round roundUP fexp (lower xi)) &&
 Fle2 (round roundDN fexp (upper xi)) (upper zi).

Theorem float_enforce :
  forall rdir {Hrnd : Valid_rnd rdir} p d x xi zi,
  BND (rounding_float rdir p d x) xi ->
  enforce_helper (FLT_exp d (Zpos p)) xi zi = true ->
  BND (rounding_float rdir p d x) zi.
Proof with auto with typeclass_instances.
intros rdir Hrnd p d x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). rewrite (rndG_conversion roundUP_cs). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). rewrite (rndG_conversion roundDN_cs). clear H2. intro H2.
revert Hx.
intros (Hx1, Hx2).
split.
apply Rle_trans with (1 := H1).
rewrite <- (round_generic _ _ rndUP _ (generic_format_round radix2 (FLT_exp d (Zpos p)) rdir x)).
apply round_le...
apply Rle_trans with (2 := H2).
rewrite <- (round_generic _ _ rndDN _ (generic_format_round radix2 (FLT_exp d (Zpos p)) rdir x)).
apply round_le...
Qed.

Theorem floatx_enforce :
  forall rdir {Hrnd : Valid_rnd rdir} p x xi zi,
  BND (rounding_floatx rdir p x) xi ->
  enforce_helper (FLX_exp (Zpos p)) xi zi = true ->
  BND (rounding_floatx rdir p x) zi.
Proof with auto with typeclass_instances.
intros rdir Hrnd p x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). rewrite (rndG_conversion roundUP_cs). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). rewrite (rndG_conversion roundDN_cs). clear H2. intro H2.
revert Hx.
intros (Hx1, Hx2).
split.
apply Rle_trans with (1 := H1).
rewrite <- (round_generic _ _ rndUP _ (generic_format_round radix2 (FLX_exp (Zpos p)) rdir x)).
apply round_le...
apply Rle_trans with (2 := H2).
rewrite <- (round_generic _ _ rndDN _ (generic_format_round radix2 (FLX_exp (Zpos p)) rdir x)).
apply round_le...
Qed.

Definition float_absolute_n_helper (p : positive) (d : Z) (xi : FF) (zi : FF) :=
 let u := upper xi in
 let e := (float_ulp p d (Fnum u) (Fexp u) - 1)%Z in
 Fle2 (lower zi) (Float2 (-1) e) &&
 Fle2 (Float2 1 e) (upper zi).

Theorem float_absolute_n :
  forall c p d x xi zi,
  ABS x xi ->
  float_absolute_n_helper p d xi zi = true ->
  BND (rounding_float (Znearest c) p d x - x) zi.
Proof with auto with typeclass_instances.
intros c p d x xi zi Hx Hb.
assert (H: (Rabs (rounding_float (Znearest c) p d x - x) <= bpow radix2 (float_ulp p d (Fnum (upper xi)) (Fexp (upper xi)) - 1))%R).
(* *)
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0, round_0, Rminus_0_r, Rabs_R0...
apply bpow_ge_0.
replace (bpow radix2 (float_ulp p d (Fnum (upper xi)) (Fexp (upper xi)) - 1)) with (/2 * ulp radix2 (FLT_exp d (Zpos p)) (upper xi))%R.
(* . *)
apply Rle_trans with (/2 * ulp radix2 (FLT_exp d (Zpos p)) x)%R.
apply error_le_half_ulp...
apply Rmult_le_compat_l.
apply Rlt_le.
apply Rinv_0_lt_compat.
now apply IZR_lt.
rewrite <- ulp_abs.
apply ulp_le_pos...
apply Rabs_pos.
apply Hx.
(* . *)
assert (Hm0: (Fnum (upper xi)) <> Z0).
assert (Hx1 := Rabs_no_R0 _ Hx0).
contradict Hx1.
apply Rle_antisym.
replace 0%R with (float2R (upper xi)).
apply Hx.
clear -Hx1.
destruct (upper xi).
simpl in Hx1.
rewrite Hx1.
apply float2_zero.
apply Rabs_pos.
rewrite ulp_neq_0.
2: now apply F2R_neq_0.
rewrite <- (bpow_plus radix2 (-1)).
unfold Zminus.
rewrite (Zplus_comm _ (-1)).
apply (f_equal (fun e => bpow radix2 (-1 + e))).
clear -Hm0.
destruct (upper xi) as (m, e).
unfold cexp, float2R.
rewrite mag_F2R with (1 := Hm0).
rewrite <- Zdigits_mag with (1 := Hm0).
simpl.
rewrite <- Zdigits_abs.
rewrite Zplus_comm.
destruct m as [|m|m] ; unfold Z.abs.
now elim Hm0.
now rewrite <- digits2_digits.
now rewrite <- digits2_digits.
(* *)
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). clear H2. intro H2.
split.
apply Rle_trans with (1 := H1).
unfold float2R.
rewrite (F2R_Zopp _ 1%Z).
rewrite F2R_bpow.
apply Ropp_le_cancel.
rewrite Ropp_involutive.
apply (Rle_trans _ _ _ (Rabs_idem _)).
now rewrite Rabs_Ropp.
apply Rle_trans with (2 := H2).
unfold float2R.
rewrite F2R_bpow.
now apply (Rle_trans _ _ _ (Rabs_idem _)).
Qed.

Definition float_absolute_ne := float_absolute_n (fun x => negb (Z.even x)).
Definition float_absolute_na := float_absolute_n (Zle_bool 0).

Theorem float_absolute_inv_n :
  forall c p d x xi zi,
  ABS (rounding_float (Znearest c) p d x) xi ->
  float_absolute_n_helper p d xi zi = true ->
  BND (rounding_float (Znearest c) p d x - x) zi.
Proof with auto with typeclass_instances.
intros c p d x xi zi Hx Hb.
assert (H: (Rabs (rounding_float (Znearest c) p d x - x) <= bpow radix2 (float_ulp p d (Fnum (upper xi)) (Fexp (upper xi)) - 1))%R).
(* *)
replace (float_ulp p d (Fnum (upper xi)) (Fexp (upper xi))) with
  (FLT_exp d (Zpos p) (if Z.eq_dec (Fnum (upper xi)) Z0 then d else (Fexp (upper xi) + Zpos (digits (pos_of_Z (Z.abs (Fnum (upper xi))))))%Z)).
apply float_absolute_inv_n_whole.
apply Rle_lt_trans with (1 := proj2 (proj2 Hx)).
unfold float2R.
case Z.eq_dec ; intros Zx.
rewrite Zx, F2R_0.
apply bpow_gt_0.
rewrite digits2_digits.
rewrite Zpos_pos_of_Z.
rewrite Zdigits_abs, Zplus_comm.
rewrite <- mag_F2R_Zdigits with (1 := Zx).
destruct mag as (ex,Ex) ; simpl.
apply Rle_lt_trans with (1 := RRle_abs _).
apply Ex.
contradict Zx.
apply eq_0_F2R with (1 := Zx).
clear -Zx ; zify ; omega.
unfold float_ulp.
case Z.eq_dec ; intros Zx.
rewrite Zx.
unfold FLT_exp.
clear ; zify ; omega.
revert Zx.
case Fnum ; simpl ; [|easy|easy].
intros H.
now elim H.
(* *)
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). clear H2. intro H2.
split.
apply Rle_trans with (1 := H1).
unfold float2R.
rewrite (F2R_Zopp _ 1%Z).
rewrite F2R_bpow.
apply Ropp_le_cancel.
rewrite Ropp_involutive.
apply (Rle_trans _ _ _ (Rabs_idem _)).
now rewrite Rabs_Ropp.
apply Rle_trans with (2 := H2).
unfold float2R.
rewrite F2R_bpow.
now apply (Rle_trans _ _ _ (Rabs_idem _)).
Qed.

Definition float_absolute_inv_ne := float_absolute_inv_n (fun x => negb (Z.even x)).
Definition float_absolute_inv_na := float_absolute_inv_n (Zle_bool 0).

Definition float_absolute_wide_ne_helper (p : positive) (d : Z) (xi : FF) (zi : FF) :=
 let u := upper xi in
 let e := (float_ulp p d (Fnum u) (Fexp u) - 2)%Z in
 Zle_bool d (Fexp u - Zpos p) &&
 Fle2 u (Float2 (Zpos (xI (shift_pos p xH))) e) &&
 Fle2 (lower zi) (Float2 (-1) e) &&
 Fle2 (Float2 1 e) (upper zi).

Theorem float_absolute_wide_ne :
  forall p d x xi zi,
  ABS x xi ->
  float_absolute_wide_ne_helper p d xi zi = true ->
  BND (rounding_float rndNE p d x - x) zi.
Proof with auto with typeclass_instances.
intros p d x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4).
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Zle_bool_imp_le _ _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). unfold float2R. simpl. clear H2. intro H2.
generalize (Fle2_correct _ _ H3). unfold float2R. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H3. intro H3.
generalize (Fle2_correct _ _ H4). unfold float2R. simpl. rewrite F2R_bpow. clear H4. intro H4.
set (e := (float_ulp p d (Fnum (upper xi)) (Fexp (upper xi)) - 2)%Z) in H2, H3, H4.
cut (Rabs (rounding_float rndNE p d x - x) <= bpow radix2 e)%R.
(* *)
split.
apply Rle_trans with (1 := H3).
apply Ropp_le_cancel.
rewrite Ropp_involutive.
apply Rle_trans with (2 := H).
rewrite <- Rabs_Ropp.
apply Rabs_idem.
apply Rle_trans with (2 := H4).
apply Rle_trans with (2 := H).
apply Rabs_idem.
(* *)
destruct Hx as (_,(_,Hx)).
clear H3 H4 zi.
induction (upper xi).
induction Fnum ; simpl.
cutrewrite (x = R0).
rewrite round_0...
rewrite Rminus_0_r.
rewrite Rabs_R0.
apply bpow_ge_0.
elim (Req_dec x 0) ; intro H.
exact H.
elim Rlt_not_le with (2 := Hx).
rewrite float2_zero.
now apply Rabs_pos_lt.
(* *)
simpl in e, H1.
assert (H9: (e = Fexp + Zpos (digits p0) - Zpos p - 2)%Z).
unfold e, FLT_exp.
rewrite Zmax_inf_l.
exact (refl_equal _).
generalize (Zgt_pos_0 (digits p0)).
omega.
destruct (Rle_or_lt (bpow radix2 (Fexp + Zpos (digits p0) - 1)) (Rabs x)).
(* . *)
rewrite float_absolute_ne_sym.
cutrewrite (rounding_float rndNE p d (Rabs x) = bpow radix2 (Fexp + Zpos (digits p0) - 1) :>R).
rewrite Rabs_left1.
rewrite Ropp_minus_distr.
apply Rle_trans with (F2R (Float radix2 (Zpos (xI (shift_pos p 1))) e) - bpow radix2 (Fexp + Zpos (digits p0) - 1))%R.
unfold Rminus.
apply Rplus_le_compat_r.
exact (Rle_trans _ _ _ Hx H2).
rewrite H9.
rewrite <- F2R_bpow.
change (Float2 (Zpos (shift_pos p 1)~1) (Fexp + Zpos (digits p0) - Zpos p - 2) - Float2 1 (Fexp + Zpos (digits p0) - 1) <=
  bpow radix2 (Fexp + Zpos (digits p0) - Zpos p - 2))%R.
rewrite <- Fminus2_correct.
unfold Fminus2, Fshift2.
simpl.
clear H H9 H2 e H1 Hx xi x d.
cutrewrite (Fexp + Zpos (digits p0) - Zpos p - 2 - (Fexp + Zpos (digits p0) - 1) = Zneg (p + 1))%Z.
cutrewrite (Zpos (xI (shift_pos p 1)) - Zpos (shift_pos (p + 1) 1) = 1)%Z.
unfold float2R.
rewrite F2R_bpow.
apply Rle_refl.
unfold shift_pos.
repeat rewrite iter_nat_of_P.
rewrite <- Pplus_one_succ_r.
rewrite nat_of_P_succ_morphism.
simpl.
now rewrite Z.pos_sub_diag.
rewrite <- Zneg_plus_distr.
rewrite <- (Zopp_neg p).
ring.
apply Rplus_le_reg_r with (Rabs x).
unfold Rminus.
now rewrite Rplus_assoc, Rplus_opp_l, Rplus_0_r, Rplus_0_l.
apply Rle_antisym.
cutrewrite (bpow radix2 (Fexp + Zpos (digits p0) - 1) =
  Generic_fmt.round radix2 (FLT_exp d (Zpos p)) rndNE (F2R (Float radix2 (Zpos (xI (shift_pos p 1))) e)) :>R).
(* .. *)
apply round_le...
exact (Rle_trans _ _ _ Hx H2).
change (F2R (Float radix2 (Zpos (shift_pos p 1)~1) e)) with (float2R (Float2 (Zpos (shift_pos p 1)~1) e)).
rewrite <- (rndG_conversion roundNE_cs).
unfold round, round_pos.
simpl.
cutrewrite (FLT_exp d (Zpos p) (e + Zpos (Pos.succ (digits (shift_pos p 1)))) = e + 2)%Z.
cutrewrite (e + 2 - e = 2)%Z. 2: ring.
unfold shr, shr_aux, shift_pos.
simpl.
rewrite iter_nat_of_P.
destruct (ZL4 p) as (p1,H3).
rewrite H3.
simpl.
rewrite H9.
cutrewrite (Fexp + Zpos (digits p0) - Zpos p - 2 + 2 = Fexp + Zpos (digits p0) - Zpos p)%Z.
2: ring.
destruct (Psucc_pred p) as [H4|H4].
rewrite H4.
rewrite H4 in H3.
injection H3.
intro H5.
rewrite <- H5.
now rewrite <- F2R_bpow.
rewrite <- F2R_bpow.
change (F2R (Float radix2 1 (Fexp + Zpos (digits p0) - 1))) with (float2R (Float2 1 (Fexp + Zpos (digits p0) - 1))).
rewrite <- (float2_shl_correct 1 (Fexp + Zpos (digits p0) - 1)%Z (Pos.pred p)).
simpl.
unfold shift_pos.
rewrite iter_nat_of_P.
rewrite <- H4 in H3.
rewrite nat_of_P_succ_morphism in H3.
injection H3.
intro H5.
rewrite H5.
cutrewrite (Fexp + Zpos (digits p0) - Zpos p = Fexp + Zpos (digits p0) - 1 - Zpos (Pos.pred p))%Z.
exact (refl_equal _).
pattern p at 1 ; rewrite <- H4.
rewrite Zpos_succ_morphism.
unfold Z.succ.
ring.
rewrite H9.
cutrewrite (digits (shift_pos p 1) = Pos.succ p)%Z.
repeat rewrite Zpos_succ_morphism.
unfold Z.succ.
cutrewrite (Fexp + Zpos (digits p0) - Zpos p - 2 + (Zpos p + 1 + 1) = Fexp + Zpos (digits p0))%Z. 2: ring.
unfold FLT_exp.
rewrite Zmax_inf_l.
ring.
generalize (Zgt_pos_0 (digits p0)).
omega.
clear H H9 H2 e H1 Hx Fexp p0 xi x d.
unfold shift_pos.
rewrite iter_nat_of_P.
rewrite <- P_of_succ_nat_o_nat_of_P_eq_succ.
induction (nat_of_P p).
exact (refl_equal _).
simpl.
rewrite IHn.
exact (refl_equal _).
(* .. *)
rewrite <- (round_generic radix2 (FLT_exp d (Zpos p)) rndNE (bpow radix2 (Fexp + Zpos (digits p0) - 1))).
apply round_le...
(* . *)
apply generic_format_bpow.
unfold FLT_exp.
rewrite Zmax_inf_l.
generalize (Zgt_pos_0 p).
omega.
generalize (Zgt_pos_0 (digits p0)).
omega.
cutrewrite (e = FLT_exp d (Zpos p) (Fexp + Zpos (digits p0) - 1) - 1)%Z.
now apply float_absolute_n_whole.
unfold e, FLT_exp.
assert (H3 := Zgt_pos_0 (digits p0)).
assert (H4 := Zgt_pos_0 p).
repeat rewrite Zmax_inf_l ; omega.
elim Rlt_not_le with (2 := Hx).
apply Rlt_le_trans with (Float2 0 Fexp).
now apply F2R_lt.
unfold float2R.
rewrite F2R_0.
apply Rabs_pos.
Qed.

Definition float_relative_n_helper (p : positive) (d : Z) (xi zi : FF) :=
 Fle2 (Float2 1 (d + Zpos p - 1)) (lower xi) &&
 Fle2 (lower zi) (Float2 (-1) (Zneg p)) &&
 Fle2 (Float2 1 (Zneg p)) (upper zi).

Theorem float_relative_n :
  forall c p d x xi zi,
  ABS x xi ->
  float_relative_n_helper p d xi zi = true ->
  REL (rounding_float (Znearest c) p d x) x zi.
Proof.
intros c p d x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). unfold float2R. simpl. rewrite F2R_bpow. clear H1. intro H1.
generalize (Fle2_correct _ _ H2). unfold float2R. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H2. intro H2.
generalize (Fle2_correct _ _ H3). unfold float2R. simpl. rewrite F2R_bpow. clear H3. intro H3.
exists ((rounding_float (Znearest c) p d x - x) / x)%R.
split.
assert (Rabs ((rounding_float (Znearest c) p d x - x) / x) <= bpow radix2 (- Zpos p))%R.
apply float_relative_n_whole.
apply Rle_trans with (1 := H1).
apply Hx.
split.
apply Rle_trans with (1 := H2).
apply Ropp_le_cancel.
rewrite Ropp_involutive.
apply Rle_trans with (2 := H).
rewrite <- Rabs_Ropp.
apply Rabs_idem.
apply Rle_trans with (2 := H3).
apply Rle_trans with (2 := H).
apply Rabs_idem.
field.
intros H.
apply Rle_not_lt with (1 := H1).
apply Rle_lt_trans with (1 := proj1 (proj2 Hx)).
rewrite H, Rabs_R0.
apply bpow_gt_0.
Qed.

Definition float_relative_ne := float_relative_n (fun x => negb (Z.even x)).
Definition float_relative_na := float_relative_n (Zle_bool 0).

Definition floatx_relative_n_helper (p : positive) (zi : FF) :=
 Fle2 (lower zi) (Float2 (-1) (Zneg p)) &&
 Fle2 (Float2 1 (Zneg p)) (upper zi).

Theorem floatx_relative_n :
  forall c p x zi,
  floatx_relative_n_helper p zi = true ->
  REL (rounding_floatx (Znearest c) p x) x zi.
Proof.
intros c p x zi Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). unfold float2R. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H1. intro H1.
generalize (Fle2_correct _ _ H2). unfold float2R. simpl. rewrite F2R_bpow. clear H2. intro H2.
destruct (relative_error_N_FLX_ex radix2 (Zpos p) (refl_equal _) c x) as (eps, (Hr1, Hr2)).
exists eps.
refine (conj _ Hr2).
rewrite <- (bpow_plus radix2 (-1)%Z) in Hr1.
rewrite (Zplus_comm (- Zpos p)), Zplus_assoc in Hr1.
split.
apply Rle_trans with (1 := H1).
apply Ropp_le_cancel.
rewrite Ropp_involutive.
apply Rle_trans with (2 := Hr1).
rewrite <- Rabs_Ropp.
apply Rabs_idem.
apply Rle_trans with (2 := H2).
apply Rle_trans with (2 := Hr1).
apply Rabs_idem.
Qed.

Definition floatx_relative_ne := floatx_relative_n (fun x => negb (Z.even x)).
Definition floatx_relative_na := floatx_relative_n (Zle_bool 0).

Definition float_relative_inv_n_helper (p : positive) (d : Z) (xi zi : FF) :=
 Flt2 (Float2 1 (d + Zpos p - 1)) (lower xi) &&
 Fle2 (lower zi) (Float2 (-1) (Zneg p)) &&
 Fle2 (Float2 1 (Zneg p)) (upper zi).

Theorem float_relative_inv_n :
  forall c p d x xi zi,
  ABS (rounding_float (Znearest c) p d x) xi ->
  float_relative_inv_n_helper p d xi zi = true ->
  REL (rounding_float (Znearest c) p d x) x zi.
Proof with auto with typeclass_instances.
intros c p d x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Flt2_correct _ _ H1). unfold float2R. simpl. rewrite F2R_bpow. clear H1. intro H1.
generalize (Fle2_correct _ _ H2). unfold float2R. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H2. intro H2.
generalize (Fle2_correct _ _ H3). unfold float2R. simpl. rewrite F2R_bpow. clear H3. intro H3.
exists ((rounding_float (Znearest c) p d x - x) / x)%R.
split.
assert (Rabs ((rounding_float (Znearest c) p d x - x) / x) <= bpow radix2 (- Zpos p))%R.
apply float_relative_inv_n_whole.
apply Rlt_le_trans with (1 := H1).
apply Hx.
split.
apply Rle_trans with (1 := H2).
apply Ropp_le_cancel.
rewrite Ropp_involutive.
apply Rle_trans with (2 := H).
rewrite <- Rabs_Ropp.
apply Rabs_idem.
apply Rle_trans with (2 := H3).
apply Rle_trans with (2 := H).
apply Rabs_idem.
field.
intros H.
apply Rlt_not_le with (1 := H1).
apply Rle_trans with (1 := proj1 (proj2 Hx)).
rewrite H, round_0, Rabs_R0...
apply bpow_ge_0.
Qed.

Definition float_relative_inv_ne := float_relative_inv_n (fun x => negb (Z.even x)).
Definition float_relative_inv_na := float_relative_inv_n (Zle_bool 0).

Definition rel_of_fix_float_n_helper (p : positive) (d xn : Z) (zi : FF) :=
 Zle_bool d xn &&
 Fle2 (lower zi) (Float2 (-1) (Zneg p)) &&
 Fle2 (Float2 1 (Zneg p)) (upper zi).

Theorem rel_of_fix_float_n :
  forall c p d xn x zi,
  FIX x xn ->
  rel_of_fix_float_n_helper p d xn zi = true ->
  REL (rounding_float (Znearest c) p d x) x zi.
Proof with auto with typeclass_instances.
intros c p d xn x zi ((mx, ex), (Hx1, Hx2)) Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Zle_bool_imp_le _ _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). unfold float2R. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H2. intro H2.
generalize (Fle2_correct _ _ H3). unfold float2R. simpl. rewrite F2R_bpow. clear H3. intro H3.
destruct (Rle_or_lt (Rabs x) (bpow radix2 (d + Zpos p))) as [He|He].
(* *)
rewrite round_generic...
exists 0%R.
repeat split.
apply Rle_trans with (1 := H2).
rewrite <- Ropp_0.
apply Ropp_le_contravar.
apply bpow_ge_0.
apply Rle_trans with (2 := H3).
apply bpow_ge_0.
now rewrite Rplus_0_r, Rmult_1_r.
apply generic_format_FLT_FIX...
rewrite <- Hx1.
apply generic_format_F2R.
intros _.
now apply Z.le_trans with xn.
(* *)
exists ((rounding_float (Znearest c) p d x - x) / x)%R.
assert (Rabs ((rounding_float (Znearest c) p d x - x) / x) <= bpow radix2 (- Zpos p))%R.
apply float_relative_n_whole.
apply Rlt_le.
apply Rlt_trans with (2 := He).
apply bpow_lt.
pattern (d + Zpos p)%Z at 2 ; rewrite <- Zplus_0_r.
now apply Zplus_lt_compat_l.
repeat split.
apply Rle_trans with (1 := H2).
apply Ropp_le_cancel.
rewrite Ropp_involutive.
apply Rle_trans with (2 := H).
rewrite <- Rabs_Ropp.
apply Rabs_idem.
apply Rle_trans with (2 := H3).
apply Rle_trans with (2 := H).
apply Rabs_idem.
field.
intros H0.
apply Rlt_not_le with (1 := He).
rewrite H0, Rabs_R0.
apply bpow_ge_0.
Qed.

Definition rel_of_fix_float_ne := rel_of_fix_float_n (fun x => negb (Z.even x)).
Definition rel_of_fix_float_na := rel_of_fix_float_n (Zle_bool 0).

Theorem fix_float_of_fix :
  forall rdir {Hrnd : Valid_rnd rdir} p d xn zn x,
  FIX x xn ->
  Zle_bool zn xn = true ->
  FIX (rounding_float rdir p d x) zn.
Proof with auto with typeclass_instances.
intros rdir Hrnd p d xn zn x Hx Hb.
generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1.
apply FIX_iff_generic.
apply generic_round_generic...
apply FIX_iff_generic.
now apply fix_le with xn.
Qed.

Theorem fix_floatx_of_fix :
  forall rdir {Hrnd : Valid_rnd rdir} p xn zn x,
  FIX x xn ->
  Zle_bool zn xn = true ->
  FIX (rounding_floatx rdir p x) zn.
Proof with auto with typeclass_instances.
intros rdir Hrnd p xn zn x Hx Hb.
generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1.
apply FIX_iff_generic.
apply generic_round_generic...
apply FIX_iff_generic.
now apply fix_le with xn.
Qed.

Theorem flt_float_of_flt :
  forall rdir {Hrnd : Valid_rnd rdir} p d xn zn x,
  FLT x xn ->
  Zle_bool (Zpos xn) (Zpos zn) = true ->
  FLT (rounding_float rdir p d x) zn.
Proof with auto with typeclass_instances.
intros rdir Hrnd p d xn zn x H Hb.
generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1.
apply FLT_iff_generic.
apply generic_round_generic...
apply FLT_iff_generic.
now apply flt_le with xn.
Qed.

Theorem flt_floatx_of_flt :
  forall rdir {Hrnd : Valid_rnd rdir} p xn zn x,
  FLT x xn ->
  Zle_bool (Zpos xn) (Zpos zn) = true ->
  FLT (rounding_floatx rdir p x) zn.
Proof with auto with typeclass_instances.
intros rdir Hrnd p xn zn x H Hb.
generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1.
apply FLT_iff_generic.
apply generic_round_generic...
apply FLT_iff_generic.
now apply flt_le with xn.
Qed.


(**

This file describes the semantics of an imperative lambda calculus with
records and arrays.

Author: Ramon Fernandez I Mir and Arthur Charguéraud.

License: MIT.

*)

Set Implicit Arguments.
Require Export SemanticsLL.

Open Scope set_scope.
Open Scope container_scope.
Open Scope Z_scope.

(* ---------------------------------------------------------------------- *)
(** Semantics of binary operations *)

Inductive redbinop : binop -> val -> val -> val -> Prop :=
  | redbinop_add : forall n1 n2,
      redbinop binop_add (val_int n1) (val_int n2) (val_int (n1 + n2))
  | redbinop_sub : forall n1 n2,
      redbinop binop_sub (val_int n1) (val_int n2) (val_int (n1 - n2))
  | redbinop_mul : forall n1 n2,
      redbinop binop_mul (val_int n1) (val_int n2) (val_int (n1 * n2))
  | redbinop_div : forall n1 n2,
      n2 <> 0%Z ->
      redbinop binop_div (val_int n1) (val_int n2) (val_int (n1 / n2)%Z)
  | redbinop_mod : forall n1 n2,
      n2 <> 0%Z ->
      redbinop binop_mod (val_int n1) (val_int n2) (val_int (n1 mod n2)%Z)
  | redbinop_eq_true : forall v1 v2,
      v1 = v2 ->
      redbinop binop_eq v1 v2 (val_bool true)
  | redbinop_eq_false : forall v1 v2,
      v1 <> v2 ->
      redbinop binop_eq v1 v2 (val_bool false).

(* ---------------------------------------------------------------------- *)
(** Uninitialized values construction *)

Inductive uninitialized (C:typdefctx) : typ -> val -> Prop :=
  | uninitialized_bool :
      uninitialized C typ_bool val_uninitialized
  | uninitialized_int :
      uninitialized C typ_int val_uninitialized
  | uninitialized_double :
      uninitialized C typ_double val_uninitialized
  | uninitialized_ptr : forall T,
      uninitialized C (typ_ptr T) val_uninitialized
  | uninitialized_array : forall os T Ta a,
      typing_array C Ta T os ->
      (forall n,
        os = Some n ->
        length a = n) ->
      (forall i,
        index a i ->
        uninitialized C T a[i]) ->
      uninitialized C Ta (val_array Ta a)
  | uninitialized_struct : forall Ts Tfs vfs,
      typing_struct C Ts Tfs ->
      dom Tfs = dom vfs ->
      (forall f,
        f \indom Tfs ->
        uninitialized C Tfs[f] vfs[f]) ->
      uninitialized C Ts (val_struct Ts vfs).

(* ---------------------------------------------------------------------- *)
(** Semantics of memory accesses *)

(** v[π] = w *)

Inductive read_accesses : val -> accesses -> val -> Prop :=
  | read_accesses_nil : forall v,
      read_accesses v nil v
  | read_accesses_array : forall a (i:Z) T π v,
      index a i ->
      read_accesses a[i] π v ->
      read_accesses (val_array T a) ((access_array T i)::π) v
  | read_accesses_struct : forall T s f π v2,
      f \indom s ->
      read_accesses s[f] π v2 ->
      read_accesses (val_struct T s) ((access_field T f)::π) v2.

(** m(l)[π] = v *)

Inductive read_state (m:state) (l:loc) (π:accesses) (v:val) : Prop :=
  | read_state_intro :
      l \indom m ->
      read_accesses m[l] π v ->
      read_state m l π v.

(** v[π := w] = v' *)

Inductive write_accesses : val -> accesses -> val -> val -> Prop :=
  | write_accesses_nil : forall v w,
      write_accesses v nil w w
  | write_accesses_array : forall v a1 i T π w a2,
      index a1 i ->
      write_accesses a1[i] π w v ->
      a2 = a1[i:=v] ->
      write_accesses (val_array T a1) ((access_array T i)::π) w (val_array T a2)
  | write_accesses_struct : forall T s1 s2 f π w v,
      f \indom s1 ->
      write_accesses s1[f] π w v ->
      s2 = s1[f := v] ->
      write_accesses (val_struct T s1) ((access_field T f)::π) w (val_struct T s2).

(** m[l := m(l)[π := w]] = m' *)

Inductive write_state (m:state) (l:loc) (π:accesses) (w:val) (m':state) : Prop :=
  | write_state_intro : forall v2,
      l \indom m ->
      write_accesses m[l] π w v2 ->
      m' = m[l := v2] ->
      write_state m l π w m'.

(* ---------------------------------------------------------------------- *)
(** Big-step evaluation *)

(** <C, S, m, t> // <m', v> *)

(* TODO: Temporary *)
Definition α : alpha := (fun l => Some l).

Inductive red (C:typdefctx) (LLC:ll_typdefctx) : stack -> state -> trm -> state -> val -> Prop :=
  (* Basic language constructs *)
  | red_val : forall S m v,
      red C LLC S m (trm_val v) m v
  | red_var : forall S m x v,
      Ctx.lookup x S = Some v ->
      red C LLC S m (trm_var x) m v
  | red_if : forall m2 b S m1 t0 t1 t2 m3 vr,
      red C LLC S m1 t0 m2 (val_bool b) ->
      red C LLC S m2 (if b then t1 else t2) m3 vr ->
      red C LLC S m1 (trm_if t0 t1 t2) m3 vr
  | red_let : forall m2 v1 S m1 z t1 t2 m3 vr,
      red C LLC S m1 t1 m2 v1 ->
      ~ is_error v1 ->
      red C LLC (Ctx.add z v1 S) m2 t2 m3 vr ->
      red C LLC S m1 (trm_let z t1 t2) m3 vr
  (* Binary operations *)
  | red_binop : forall S (op:binop) m v1 v2 vr,
      is_basic v1 ->
      is_basic v2 ->
      ~ is_error v1 ->
      ~ is_error v2 ->
      redbinop op v1 v2 vr ->
      red C LLC S m (trm_app op ((trm_val v1)::(trm_val v2)::nil)) m vr
  (* Operations on the abstract heap *)
  | red_get : forall l π S T v1 m vr,
      v1 = val_abstract_ptr l π ->
      read_state m l π vr ->
      ~ is_uninitialized vr ->
      red C LLC S m (trm_app (prim_get T) ((trm_val v1)::nil)) m vr
  | red_set : forall l π  S m1 T v1 v2 m2 vr,
      v1 = val_abstract_ptr l π ->
      vr = val_unit ->
      ~ is_error v2 ->
      write_state m1 l π v2 m2 ->
      red C LLC S m1 (trm_app (prim_set T) ((trm_val v1)::(trm_val v2)::nil)) m2 vr
  | red_new : forall l v S m1 T m2 vr,
      vr = val_abstract_ptr l nil ->
      l <> null ->
      l \notindom m1 ->
      wf_typ C T ->
      uninitialized C T v ->
      m2 = m1[l:=v] ->
      red C LLC S m1 (trm_app (prim_new T) nil) m2 vr
  | red_new_array : forall l n a S m1 T v1 m2 vr,
      v1 = val_int n ->
      vr = val_abstract_ptr l nil ->
      l <> null ->
      l \notindom m1 ->
      wf_typ C T ->
      uninitialized C (typ_array T (Some n)) (val_array (typ_array T (Some n)) a) ->
      m2 = m1[l:=(val_array (typ_array T None) a)] ->
      red C LLC S m1 (trm_app (prim_new_array T) ((trm_val v1)::nil)) m2 vr
  | red_struct_access : forall l π S T f v1 m vr,
      v1 = val_abstract_ptr l π ->
      vr = val_abstract_ptr l (π ++((access_field T f)::nil)) ->
      red C LLC S m (trm_app (prim_struct_access T f) ((trm_val v1)::nil)) m vr
  | red_array_access : forall l π i S T v1 v2 m vr,
      v1 = val_abstract_ptr l π ->
      v2 = val_int i ->
      vr = val_abstract_ptr l (π++(access_array T i)::nil) ->
      red C LLC S m (trm_app (prim_array_access T) ((trm_val v1)::(trm_val v2)::nil)) m vr
  (* Operations on composed values *)
  | red_struct_get : forall s f S T v1 m vr,
      v1 = val_struct T s ->
      vr = s[f] ->
      f \indom s ->
      red C LLC S m (trm_app (prim_struct_get T f) ((trm_val v1)::nil)) m vr
  | red_array_get : forall a i S T v1 v2 m vr,
      v1 = val_array T a ->
      v2 = val_int i ->
      vr = a[i] ->
      index a i ->
      red C LLC S m (trm_app (prim_array_get T) ((trm_val v1)::(trm_val v2)::nil)) m vr
  (* Low-level operations *)
  | red_ll_get : forall l n o S T v1 m ws vr,
      v1 = val_concrete_ptr l o ->
      read_ll_state m l o n ws ->
      tr_ll_val C LLC α T vr ws ->
      typ_size (typvar_sizes LLC) T n ->
      ~ is_undef vr ->
      red C LLC S m (trm_app (prim_ll_get T) ((trm_val v1)::nil)) m vr
  | red_ll_set : forall l o n S m1 T v1 v2 ws m2 vr,
      v1 = val_concrete_ptr l o ->
      vr = val_unit ->
      typ_size (typvar_sizes LLC) T n ->
      tr_ll_val C LLC α T v2 ws ->
      length ws = n ->
      write_ll_state m1 l o ws m2 ->
      red C LLC S m1 (trm_app (prim_ll_set T) ((trm_val v1)::(trm_val v2)::nil)) m2 vr
  | red_ll_new : forall l n ws S m1 T m2 vr,
      vr = val_concrete_ptr l 0 ->
      l <> null ->
      l \notindom m1 ->
      wf_typ C T ->
      typ_size (typvar_sizes LLC) T n ->
      ws = LibListZ.make n word_undef ->
      m2 = m1[l := (val_words ws)] ->
      red C LLC S m1 (trm_app (prim_ll_new T) nil) m2 vr
  | red_ll_access : forall l o o' S m1 T v1 v2 m2 vr,
      vr = val_concrete_ptr l (o+o') ->
      v1 = val_concrete_ptr l o ->
      v2 = val_int o' ->
      red C LLC S m1 (trm_app (prim_ll_access T) ((trm_val v1)::(trm_val v2)::nil)) m2 vr
  (* Arguments *)
  | red_args_1 : forall v1 m2 S m1 op t1 ts m3 vr,
      ~ is_val t1 ->
      red C LLC S m1 t1 m2 v1 ->
      red C LLC S m2 (trm_app op ((trm_val v1)::ts)) m3 vr ->
      red C LLC S m1 (trm_app op (t1::ts)) m3 vr
  | red_args_2 : forall m2 v2 S m1 op v1 t2 ts m3 vr,
      ~ is_val t2 ->
      red C LLC S m1 t2 m2 v2 ->
      red C LLC S m2 (trm_app op ((trm_val v1)::(trm_val v2)::ts)) m3 vr ->
      red C LLC S m1 (trm_app op ((trm_val v1)::t2::ts)) m3 vr
  (* Error cases *)
  | red_var_error : forall S x m,
      Ctx.lookup x S = None ->
      red C LLC S m (trm_var x) m val_error
  | red_if_error_not_a_bool : forall v0 S m1 t0 t1 t2 m2,
      red C LLC S m1 t0 m2 v0 ->
      ~ is_bool v0 ->
      red C LLC S m1 (trm_if t0 t1 t2) m2 val_error
  | red_let_error_let : forall S m1 z t1 t2 m2,
      red C LLC S m1 t1 m2 val_error ->
      red C LLC S m1 (trm_let z t1 t2) m2 val_error
  | red_binop_error : forall S (op:binop) v1 v2 m,
      ~ (exists v, redbinop op v1 v2 v) ->
      red C LLC S m (trm_app op ((trm_val v1)::(trm_val v2)::nil)) m val_error
  | red_get_error_not_a_ptr : forall S T v1 m,
      ~ is_ptr v1 ->
      red C LLC S m (trm_app (prim_get T) ((trm_val v1)::nil)) m val_error
  | red_get_error_bad_address : forall l π S T v1 m,
      v1 = val_abstract_ptr l π ->
      ~ (exists w, read_state m l π w) ->
      red C LLC S m (trm_app (prim_get T) ((trm_val v1)::nil)) m val_error
  | red_set_error_not_a_ptr : forall S T v1 v2 m,
      ~ is_ptr v1 ->
      red C LLC S m (trm_app (prim_set T) ((trm_val v1)::(trm_val v2)::nil)) m val_error
  | red_set_error_bad_address : forall l π  S T v1 v2 m,
      v1 = val_abstract_ptr l π ->
      ~ (exists m', write_state m l π v2 m') ->
      red C LLC S m (trm_app (prim_set T) ((trm_val v1)::(trm_val v2)::nil)) m val_error
  | red_new_error : forall S T m,
      ~ (exists v, uninitialized C T v) ->
      red C LLC S m (trm_app (prim_new T) nil) m val_error
  | red_new_array_error : forall n S m T v1,
      v1 = val_int n ->
      ~ (exists a, uninitialized C (typ_array T (Some n)) (val_array (typ_array T (Some n)) a)) ->
      red C LLC S m (trm_app (prim_new_array T) ((trm_val v1)::nil)) m val_error
  | red_struct_access_error_not_a_ptr : forall S T f v1 m,
      ~ is_ptr v1 ->
      red C LLC S m (trm_app (prim_struct_access T f) ((trm_val v1)::nil)) m val_error
  | red_array_access_error_not_a_ptr : forall S T v1 v2 m,
      ~ is_ptr v1 ->
      red C LLC S m (trm_app (prim_array_access T) ((trm_val v1)::(trm_val v2)::nil)) m val_error
  | red_array_access_error_not_an_int : forall S T v1 v2 m,
      ~ is_int v2 ->
      red C LLC S m (trm_app (prim_array_access T) ((trm_val v1)::(trm_val v2)::nil)) m val_error
  | red_struct_get_error_not_a_struct : forall S T f v1 m,
      ~ is_struct v1 ->
      red C LLC S m (trm_app (prim_struct_get T f) ((trm_val v1)::nil)) m val_error
  | red_struct_get_error_invalid_field : forall s S T f v1 m,
      v1 = val_struct T s ->
      f \notindom s ->
      red C LLC S m (trm_app (prim_struct_get T f) ((trm_val v1)::nil)) m val_error
  | red_array_get_error_not_an_array : forall S T v1 v2 m,
      ~ is_array v1 ->
      red C LLC S m (trm_app (prim_array_get T) ((trm_val v1)::(trm_val v2)::nil)) m val_error
  | red_array_get_error_not_an_int : forall S T v1 v2 m,
      ~ is_int v2 ->
      red C LLC S m (trm_app (prim_array_get T) ((trm_val v1)::(trm_val v2)::nil)) m val_error
  | red_array_get_error_out_of_bounds : forall a i S T v1 v2 m,
      v1 = val_array T a ->
      v2 = val_int i ->
      ~ (index a i) ->
      red C LLC S m (trm_app (prim_array_get T) ((trm_val v1)::(trm_val v2)::nil)) m val_error
  | red_args_1_error : forall S m1 op t1 ts m2,
      red C LLC S m1 t1 m2 val_error ->
      red C LLC S m1 (trm_app op (t1::ts)) m2 val_error
  | red_args_2_error : forall S m1 op v1 t2 ts m2,
      ~ is_error v1 ->
      red C LLC S m1 t2 m2 val_error ->
      red C LLC S m1 (trm_app op ((trm_val v1)::t2::ts)) m2 val_error.

(** Derived rule. *)

Lemma red_seq : forall C LLC S m1 m2 m3 t1 t2 r1 r,
  red C LLC S m1 t1 m2 r1 ->
  ~ is_error r1 ->
  red C LLC S m2 t2 m3 r ->
  red C LLC S m1 (trm_seq t1 t2) m3 r.
Proof using. intros. applys* red_let. Qed.

(* ---------------------------------------------------------------------- *)
(** Lemmas about accesses *)

Lemma read_write_accesses_same : forall v1 v2 π w,
  write_accesses v1 π w v2 ->
  read_accesses v2 π w.
Proof using.
  introv H. induction H; subst; constructors*; rew_reads~.
Qed.

Hint Extern 1 (?j \in dom (?m[?i:=?v])) => applys @indom_update.

Lemma read_write_state_same : forall m m' l π w,
  write_state m l π w m' ->
  read_state m' l π w.
Proof using.
  introv H. induction H. subst. constructors*.
  { applys* read_write_accesses_same. rew_reads*. }
Qed.

(* ---------------------------------------------------------------------- *)
(** Lemmas about the stack structure *)

Lemma ctx_lookup_add_inv {A:Type} : forall C (z1 z2:var) (w1 w2:A),
  Ctx.lookup z1 (Ctx.add z2 w1 C) = Some w2 ->
      (z1 = z2 /\ w1 = w2)
  \/  (z1 <> z2 /\ Ctx.lookup z1 C = Some w2).
Proof using.
  introv H. simpls. rewrite var_eq_spec in *. case_if*. { inverts* H. }
Qed.

(* ---------------------------------------------------------------------- *)
(** Lemmas about the error cases *)

Lemma not_is_error_args_1 : forall C LLC S m op ts m' v w,
  red C LLC S m (trm_app op (trm_val w :: ts)) m' v ->
  ~ is_error v ->
  ~ is_error w.
Proof using.
  introv HR He HN. destruct w; try inverts HN.
  inverts HR; tryfalse*.
  inverts_head red; tryfalse*.
Qed.

Lemma not_is_error_args_2 : forall C LLC S m op t ts m' v w,
  red C LLC S m (trm_app op (t :: trm_val w :: ts)) m' v ->
  ~ is_error v ->
  ~ is_error w.
Proof using.
  introv HR He HN. destruct w; try inverts HN.
  inverts HR; tryfalse*.
  { inverts_head tr_ll_val. }
  { inverts_head red; tryfalse*. inverts_head tr_ll_val. }
Qed.

(* ---------------------------------------------------------------------- *)
(** Lemmas about the completeness of the reduction rules *)

Lemma red_complete : forall C LLC S m1 t,
  exists v m2, red C LLC S m1 t m2 v.
Proof using.
  intros. gen C S m1. induction t; intros.
  { (* var *)
    tests: (exists w, Ctx.lookup v S = Some w).
    { inverts C0 as (w&HCl). exists x m1. constructors~. }
    { asserts: (Ctx.lookup v S = None).
      { induction S.
        { unfolds*. }
        { destruct a. unfolds. case_if.
          { forwards: C0 v1. case_if in H. }
          { folds Ctx.lookup. applys~ IHS. intros.
            forwards: C0 x. case_if~ in H. } } }
      exists val_error m1. applys~ red_var_error. } }
  { (* val *)
    exists~ v m1. constructors. }
  { (* if *)
    forwards (v1&m2&Ht1): IHt1 C S m1.
    tests: (is_bool v1).
    { unfolds is_bool. destruct* v1. destruct* b.
      { forwards (v2&m3&Ht2): IHt2 C S m2.
        exists v2 m3. constructors*. }
      { forwards (v2&m3&Ht2): IHt3 C S m2.
        exists v2 m3. constructors*. } }
    { exists val_error m2. applys* red_if_error_not_a_bool. } }
  { (* let *)
    forwards (v1&m2&Ht1): IHt1 C S m1.
    tests: (is_error v1).
    { unfolds is_error. destruct* v1.
      exists val_error m2. applys~ red_let_error_let. }
    { forwards (v2&m3&Ht2): IHt2 C (Ctx.add b v1 S) m2.
      exists v2 m3. constructors*. } }
  { (* app *)
    (* NOTE: In order to make this work all the application cases need to
       have error cases for the wrong number of arguments.*)
    admit. }
  { (* while. NOTE: Won't be provable. *)
    admit. }
  { (* for. NOTE: Won't be provable. *)
    admit. }
Admitted.

(* ---------------------------------------------------------------------- *)
(* * Results of the connection between semantics and well-foundedness *)

Section SemanticsWellformedLemmas.

(** Binary operations preserve well-formedness. *)

Lemma wf_redbinop : forall op v1 v2 C vr,
  redbinop op v1 v2 vr ->
  wf_val C v1 ->
  wf_val C v2 ->
  wf_val C vr.
Proof using.
  introv HR Hv1 Hv2. induction HR; constructors*.
Qed.

(** Reading into a value preserves well-formedness. *)

Lemma wf_read_accesses : forall v1 π C v2,
  read_accesses v1 π v2 ->
  wf_val C v1 ->
  wf_accesses C π ->
  wf_val C v2.
Proof using.
  introv HR Hv1 Hπ. induction HR.
  { auto. }
  { inverts Hπ. inverts Hv1 as Hv1 Hai.
    applys~ IHHR. }
  { inverts Hπ. inverts Hv1 as Hv1 Hsf.
    applys~ IHHR. }
Qed.

(** Reading into the state preserves well-formedness. *)

Lemma wf_read_state : forall m l π C v,
  read_state m l π v ->
  wf_state C m ->
  wf_accesses C π ->
  wf_val C v.
Proof using.
  introv HR Hm Hπ. unfolds wf_state. inverts HR.
  forwards*: Hm. applys* wf_read_accesses.
Qed.

(** Writing into a value preserves well-formedness. *)

Lemma wf_write_accesses : forall v1 w π C v2,
  write_accesses v1 π w v2 ->
  wf_val C v1 ->
  wf_val C w ->
  wf_accesses C π ->
  wf_val C v2.
Proof using.
  introv HW Hv1 Hw Hπ. induction HW.
  { auto. }
  { subst. inverts Hπ. inverts Hv1 as Hv1 Ha0i.
    constructors*. introv Hi. rew_index~ in Hi. rew_reads*. }
  { subst. inverts Hπ. inverts Hv1 as Hv1 Hs1f.
    constructors*. introv Hf. rew_reads*. }
Qed.

(** Writing into memory preserves well-formedness. *)

Lemma wf_write_state : forall m1 l π v C m2,
  write_state m1 l π v m2 ->
  wf_state C m1 ->
  wf_accesses C π ->
  wf_val C v ->
  wf_state C m2.
Proof using.
  introv HW Hm1 Hπ Hv. inverts HW. unfolds wf_state.
  forwards*: Hm1. introv Hl0. rew_reads*; intros.
  { applys* wf_write_accesses. }
  { applys~ Hm1. applys~ indom_update_inv_neq l l0 v2. }
Qed.

(** Creating an uninitialized value preserves well-formedness. *)

Lemma wf_uninitialized : forall v C T,
  wf_typ C T ->
  uninitialized C T v ->
  wf_val C v.
Proof using.
  introv HT Hu. induction Hu; try solve [ constructors* ].
  { constructors~. introv Hi. applys~ H2.
    applys* wf_typing_array. }
  { constructors~. introv Hf. rewrite <- H0 in Hf. applys~ H2.
    applys* wf_typing_struct. }
Qed.

(** Main theorem. Preservation of well-foundedness by the semantics. *)

Theorem wf_red : forall LLC S m1 t C m2 v,
  red C LLC S m1 t m2 v ->
  wf_stack C S ->
  wf_state C m1 ->
  wf_trm C t ->
      wf_state C m2
  /\  wf_val C v.
Proof using.
  introv HR HS Hm1 Ht. induction HR; intros;
  try solve [ inverts Ht ; splits* ; constructors* ].
  { (* if *)
    inverts Ht. forwards* (Hm2&HVb): IHHR1.
    applys~ IHHR2. case_if*. }
  { (* let *)
    inverts Ht. forwards* (Hm2&HVb): IHHR1.
    applys~ IHHR2. applys~ wf_stack_add. }
  { (* binop *)
    inverts Ht as Hop Hv1 Hv2.
    inverts Hv1 as Hv1. inverts Hv2 as Hv2.
    splits~. applys* wf_redbinop. }
  { (* get *)
    subst. inverts Ht as Hop Hp. inverts Hp as Hp.
    inverts Hp as Hπ. splits~.
    applys* wf_read_state. }
  { (* set *)
    subst. inverts Ht as Hop Hp Hv2.
    inverts Hv2 as Hv2. inverts Hp as Hp.
    inverts Hp as Hπ. splits; try constructors*.
    applys* wf_write_state. }
  { (* new *)
    subst. splits.
    { unfolds wf_state. introv Hl0. rew_reads; intros; subst.
      { applys wf_uninitialized. eapply H2. auto. }
      { applys~ Hm1. applys~ indom_update_inv_neq l l0 v. } }
    { repeat constructors*. } }
  { (* new_array *)
    subst. splits.
    { unfolds wf_state. introv Hl0. rew_reads; intros; subst.
      { forwards* HV: wf_uninitialized H4.
        { constructors~. }
        inverts HV as HV HVai. repeat constructors~. }
      { applys~ Hm1. applys* indom_update_inv_neq l l0. } }
    { repeat constructors*. } }
  { (* struct_access *)
    subst. inverts Ht as Hop Hp. inverts Hop. inverts Hp as Hπ.
    splits~. constructors~. inverts Hπ. applys~ wf_accesses_app.
    repeat constructors~. }
  { (* array_access *)
    subst. inverts Ht as Hop Hp Hi. inverts Hop. inverts Hp as Hπ.
    splits~. constructors~. inverts Hπ. applys~ wf_accesses_app.
    repeat constructors~. }
  { (* struct_get *)
    subst. inverts Ht as Hop Hs. inverts Hop. inverts Hs as Hs.
    inverts Hs as Hs Hsf0. splits~. }
  { (* array_get *)
    subst. inverts Ht as Hop Ha Hi. inverts Ha as Ha.
    inverts Ha as Ha Hai. splits~. }
  { (* ll_get *)
    admit. }
  { (* ll_set *)
    admit. }
  { (* ll_new *)
    admit. }
  { (* ll_access *)
    admit. }
  { (* args_1 *)
    forwards* (Hm2&Hv1): IHHR1.
    { inverts~ Ht. }
    applys~ IHHR2.
    { inverts~ Ht; repeat constructors~. } }
  { (* args_2 *)
    forwards* (Hm2&Hv1): IHHR1.
    { inverts~ Ht. }
    applys~ IHHR2.
    { inverts~ Ht; repeat constructors~. } }
Qed.

End SemanticsWellformedLemmas.


Require Import FP.Data.Sum.
Require Import FP.Data.Ascii.
Require Import FP.Data.Bool.
Require Import FP.Data.String.
Require Import FP.Data.Function.
Require Import FP.Data.Type.
Require Import FP.Relations.RelDec.
Require Import FP.Structures.EqDec.
Require Import FP.Structures.Eqv.
Require Import FP.Structures.Lattice.
Require Import FP.Structures.Monad.
Require Import FP.Structures.MonadError.
Require Import FP.Structures.FUnit.
Require Import FP.Structures.MonadFix.
Require Import FP.Structures.MonadPlus.
Require Import FP.Structures.MonadDeriving.
Require Import FP.Structures.FUnitDeriving.
Require Import FP.Structures.Additive.
Require Import FP.Structures.Monoid.
Require Import FP.Structures.Ord.
Require Import FP.Structures.Show.
Require Import FP.Structures.Injection.
Require Import FP.Data.Identity.
Require Import FP.Relations.Function.
Require Import FP.Relations.Setoid.

Import AdditiveNotation.
Import ProperNotation.
Import CharNotation.
Import EqDecNotation.
Import EqvNotation.
Import FunctionNotation.
Import MonadNotation.
Import MonoidNotation.
Import OrdNotation.
Import StringNotation.
Import LatticeNotation.

Section sum_t_Monad.
  Context {A:Type} {m} {M:Monad m}.

  Definition run_sum_t {B} : sum_t A m B -> m (A+B) := un_sum_t.

  Section Monad.
    Definition sum_t_funit {B} : B -> sum_t A m B := SumT '.' ret '.' inr.
    Global Instance sum_t_FUnit : FUnit (sum_t A m) :=
      { funit := @sum_t_funit }.

    Definition sum_t_bind {B C} (bMM:sum_t A m B) (f:B -> sum_t A m C) : sum_t A m C :=
      SumT $ begin
        ab <- un_sum_t bMM ;;
        match ab with
        | inl x => ret $ inl x
        | inr y => un_sum_t $ f y
        end
      end.
    Global Instance sum_t_Monad : MBind (sum_t A m) :=
      { bind := @sum_t_bind }.
  End Monad.

  Section MonadError.
    Definition sum_t_throw {B} : A -> sum_t A m B := SumT '.' ret '.' inl.
    Definition sum_t_catch {B}
        (bMM:sum_t A m B) (h:A -> sum_t A m B) : sum_t A m B :=
      SumT $ begin
        ab <-  un_sum_t bMM ;;
        match ab with
        | inl x => un_sum_t $ h x
        | inr y => ret $ inr y
        end
      end.
    Global Instance sum_t_MonadError : MError A (sum_t A m) :=
      { throw := @sum_t_throw
      ; catch := @sum_t_catch
      }.
  End MonadError.

  Section MonadPlus.
    Context {AM:Monoid A}.

    Definition sum_t_mzero {B} : sum_t A m B := SumT $ ret $ inl gunit.
    Definition sum_t_mplus {B C} (bMM:sum_t A m B) (cMM:sum_t A m C)
        : sum_t A m (B+C) :=
      SumT $ begin
        ab <- un_sum_t bMM ;;
        match ab with
        | inl e1 =>
            ac <- un_sum_t cMM ;;
            match ac with
            | inl e2 => ret $ inl $ e1 ** e2
            | inr c => ret $ inr $ inr c
            end
        | inr b => ret $ inr $ inl b
        end
      end.
    (*
    Global Instance sum_t_MonadPlus : MonadPlus (sum_t A m) :=
      { mzero := @sum_t_mzero
      ; mplus := @sum_t_mplus
      }.
*)
  End MonadPlus.

  Section MonadFix.
    Context {MF:MFix m}.

    Definition sum_t_mfix {B C}
        (ff:(B -> sum_t A m C) -> B -> sum_t A m C) (b:B) : sum_t A m C :=
      let ff' (f':B -> m (A+C)) :=
        let f := SumT '.' f' in
        un_sum_t '.' ff f
      in
      SumT $ mfix ff' b.
    Global Instance sum_t_MonadFix : MFix (sum_t A m) :=
      { mfix := @sum_t_mfix }.
  End MonadFix.
End sum_t_Monad.

Instance sum_sum_t_FunctorInjection {A} : HasFunctorInjection (sum A) (sum_t A identity) :=
  { finject := fun _ => SumT '.' Identity }.
Instance sum_t_sum_FunctorInjection {A} : HasFunctorInjection (sum_t A identity) (sum A) :=
  { finject := fun _ => run_identity '.' run_sum_t }.

Instance sum_FUnit {A} : FUnit (sum A) := Deriving_FUnit (sum_t A identity).
Instance sum_MBind {A} : MBind (sum A) := Deriving_MBind (sum_t A identity).
(*
Instance sum_MonadPlus {A} {AM:Monoid A} : MonadPlus (sum A) :=
  iso_MonadPlus (sum_t A identity).
Instance sum_MonadError {A} : MonadError A (sum A) :=
  iso_MonadError (sum_t A identity).
*)


(** Copyright (c) 2018 by Swirlds, Inc.
   Implemented by Karl Crary.
*)

Require Import Nat.
Require Import Bool.
Require Import List.
Require Import Omega.

Require Import Tact.
Require Import Relation.
Require Import Decide.
Require Import Weight.
Require Import Calculate.
Require Import Weight.
Require Import Majority.
Require Import HashgraphFacts.
Require Import Sees.
Require Import Round.
Require Import Vote.

Definition decision (s : sample) (x y : event) (v : bool) :=
  exists m n t f,
    rwitness m x
    /\ rwitness n y
    /\ m + first_regular < n
    /\ (n - m) mod coin_freq <> 0
    /\ election (vote s x) (pred n) y t f
    /\ (if v then t else f) > two_thirds total_stake.

Lemma elector_rwitness :
  forall n x y, elector n x y -> rwitness n x.
Proof.
intros n x y H.
destruct H; auto.
Qed.

Lemma elector_unique :
  forall W n x y z z',
    member W z
    -> member W z'
    -> creator x = creator y
    -> elector n x z
    -> elector n y z'
    -> x = y.
Proof.
intros W n x y z z' Wz Wz' Heq Helectorx Helectory.
destruct Helectorx as (Hwitx & Hssx).
destruct Helectory as (Hwity & Hssy).
eapply (stseen_witness_unique _#4 z z'); eauto.
Qed.

Lemma elector_minimum :
  forall n x e,
    round (S n) x
    -> weight creatorstake (fun w => elector n w x) e
    -> e > two_thirds total_stake.
Proof.
intros n x e Hroundx Hcard.
so (stsees_many_witnesses _ _ Hroundx) as Hmaj.
destruct Hmaj as (p & q & _ & Hcardp & Hcardpeers & Hgt).
so (weight_fun _#5 the_total_stake Hcardpeers); subst q.
eapply lt_le_trans; eauto.
refine (weight_map_surj _ _ stake creatorstake _ _ creator _ _ _ _ Hcardp Hcard).
  {
  intros w Helector.
  split; auto.
  exists w.
  destruct Helector.
  do2 2 split; auto.
  }

  {
  intros a H.
  destruct H as (w & Heqcr & Hss & Hwit).
  subst a.
  exists w.
  split; auto.
  split; auto.
  }
Qed.

Lemma election_fun :
  forall s n x y t t' f f',
    election (vote s x) n y t f
    -> election (vote s x) n y t' f'
    -> t = t' /\ f = f'.
Proof.
intros s n x y t t' f f' Helect Helect'.
eapply election_fun_gen; eauto.
intros w _ v v' Hv Hv'.
eapply vote_fun; eauto.
Qed.

Lemma decision_fun :
  forall s x y v v',
    decision s x y v
    -> decision s x y v'
    -> v = v'.
Proof.
intros s x y v v' Hdecision Hdecision'.
destruct Hdecision as (m & n & t & f & Hwitx & Hwity & Hlt & Hnocoin & Helect & Htally).
destruct Hdecision' as (m' & n' & t' & f' & Hwitx' & Hwity' & _ & _ & Helect' & Htally').
so (rwitness_fun _#3 Hwitx Hwitx'); subst m'.
so (rwitness_fun _#3 Hwity Hwity'); subst n'.
so (election_fun _#8 Helect Helect') as (<- & <-).
so (maximum_votes _#5 Helect).
so (four_thirds_le total_stake).
destruct v; destruct v'; auto; omega.
Qed.

Lemma decision_decide :
  forall s x y b,
    decidable (decision s x y b).
Proof.
intros s x y b.
so (witness_decide x) as [Hwitx | Hnwit].
2:{
  right.
  contradict Hnwit.
  destruct Hnwit as (? & ? & ? & ? & (_ & H) & _).
  exact H.
  }
so (witness_decide y) as [Hwity | Hnwit].
2:{
  right.
  contradict Hnwit.
  destruct Hnwit as (? & ? & ? & ? & _ & (_ & H) & _).
  exact H.
  }
so (round_defined x) as (m & Hroundx).
so (round_defined y) as (n & Hroundy).
so (dec_lt (m + first_regular) n) as [Hlt | Hnlt].
2:{
  right.
  contradict Hnlt.
  destruct Hnlt as (m' & n' & _ & _ & (Hroundx' & _) & (Hroundy' & _) & Hlt & _).
  so (round_fun _#3 Hroundx Hroundx'); subst m'.
  so (round_fun _#3 Hroundy Hroundy'); subst n'.
  exact Hlt.
  }
so (eq_nat_dec ((n - m) mod coin_freq) 0) as [Hcoin | Hnocoin].
  {
  right.
  contradict Hcoin.
  destruct Hcoin as (m' & n' & _ & _ & (Hroundx' & _) & (Hroundy' & _) & _ & Hnocoin & _).
  so (round_fun _#3 Hroundx Hroundx'); subst m'.
  so (round_fun _#3 Hroundy Hroundy'); subst n'.
  exact Hnocoin.
  }
assert (m < pred n) as Hmn.
  {
  so first_regular_min.
  omega.
  }
so (election_defined' s _#3 y (conj Hroundx Hwitx) Hmn) as (t & f & Helection).
so (dec_lt (two_thirds total_stake) (if b then t else f)) as [Htally | Hntally].
2:{
  right.
  contradict Hntally.
  destruct Hntally as (_ & n' & t' & f' & _ & (Hroundy' & _) & _ & _ & Helection' & Htally).
  so (round_fun _#3 Hroundy Hroundy'); subst n'.
  so (election_fun _#8 Helection Helection') as (<- & <-).
  exact Htally.
  }
left.
exists m, n, t, f.
do2 5 split; auto; split; auto.
Qed.

Lemma destruct_election :
  forall s n x y t f,
    election (vote s  x) n y t f
    -> weight creatorstake (fun w => elector n w y) (t + f)
       /\ weight creatorstake (fun w => elector n w y /\ vote s x w true) t
       /\ weight creatorstake (fun w => elector n w y /\ vote s x w false) f.
Proof.
intros s n x y t f H.
destruct H as (T & F & Htf & Ht & Hf & HT & HF).
exploit (weight_partition _ creatorstake T F (fun w => elector n w y) t f) as Hdec; auto.
  {
  intros w Hw.
  apply HT; auto.
  }

  {
  intros w Hw.
  apply HF; auto.
  }

  {
  intros w _.
  apply stake_positive.
  }

  {
  intros w HTw HFw.
  so (HT _ HTw ander) as Htrue.
  so (HF _ HFw ander) as Hfalse.
  so (vote_fun _#5 Htrue Hfalse) as Heq.
  discriminate Heq.
  }
do2 2 split; auto.
  {
  eapply weight_iff; eauto.
  intros w.
  split; auto.
  intros (Helector, Hvote).
  so (Hdec _ Helector) as [HTw | HFw]; auto.
  so (HF _ HFw ander) as Hvote'.
  so (vote_fun _#5 Hvote Hvote') as Heq.
  discriminate Heq.
  }

  {
  eapply weight_iff; eauto.
  intros w.
  split; auto.
  intros (Helector, Hvote).
  so (Hdec _ Helector) as [HTw | HFw]; auto.
  so (HT _ HTw ander) as Hvote'.
  so (vote_fun _#5 Hvote Hvote') as Heq.
  discriminate Heq.
  }
Qed.

Lemma destruct_election' :
  forall s n x y t f,
    election (vote s x) n y t f
    -> weight creatorstake (fun w => elector n w y) (t + f)
       /\ forall v, weight creatorstake (fun w => elector n w y /\ vote s x w v) (if v then t else f).
Proof.
intros s n x y t f Helection.
so (destruct_election _#6 Helection) as (Htf & Ht & Hf).
split; auto.
intros v.
destruct v; auto.
Qed.

Definition peer_vote (s : sample) (W : world) (w : event) (n : nat) (a : peer) (v : bool) :=
  exists x y, creator x = a /\ round n x /\ vote s w x v /\ stsees x y /\ member W y.

Definition offer (n : nat) (a : peer) (y : event) :=
  exists x, creator x = a /\ elector n x y.

Lemma elector_vote_peer :
  forall s W n x y z v,
    member W z
    -> elector n y z
    -> vote s x y v
    -> peer_vote s W x n (creator y) v.
Proof.
intros s W n x y z v Wz Helector Hvote.
exists y.
exists z.
destruct Helector as (Hwit & Hss).
do2 4 split; auto.
destruct Hwit; auto.
Qed.

Lemma peer_vote_elector :
  forall s W x n a v y z,
    member W z
    -> peer_vote s W x n a v
    -> creator y = a
    -> elector n y z
    -> vote s x y v.
Proof.
intros s W x n a v y z Wz Hvotea <- Helector.
destruct Hvotea as (w & z' & Heq & Hround & Hvote & Hss' & Wz').
force_exact Hvote.
f_equal.
eapply (elector_unique _#4 z' z); eauto.
split; eauto.
split; auto.
eapply vote_witness; eauto.
Qed.

Lemma peer_vote_offer :
  forall s W x n a v y,
    member W y
    -> peer_vote s W x n a v
    -> offer n a y
    -> exists z, creator z = a /\ elector n z y /\ vote s x z v.
Proof.
intros s W x n a v y Wy Hvotea Hoffer.
destruct Hoffer as (z & Helector & Hvote).
exists z.
do2 2 split; auto.
eapply peer_vote_elector; eauto.
Qed.

Lemma decision_vote_consistent :
  forall s W w x y n v v',
    member W x
    -> member W y
    -> round n x
    -> round n y
    -> decision s w x v
    -> vote s w y v'
    -> v = v'.
Proof.
intros s W w x y n v v' Wx Wy Hroundx Hroundy Hdecision Hvote.
destruct Hdecision as (m & n' & t & f & Hwitw & Hwitx & Hlt & Hnocoin & Helect & Htally).
so Hwitx as (Hroundx' & _).
so (round_fun _#3 Hroundx Hroundx'); subst n'.
assert (exists n', n = S n') as (n' & ?).
  {
  exists (pred n).
  omega.
  }
subst n.
rename n' into n.
invert Hvote.
  {
  intros m' n' Hwitw' Hwity Hlt' Hgeq Hv.
  so (rwitness_fun _#3 Hwitw Hwitw'); subst m'.
  so Hwity as (Hroundy' & _).
  so (round_fun _#3 Hroundy Hroundy'); subst n'.
  omega.
  }

2:{
  intros m' n' _ _ Hwitw' Hwity _ Hcoin _ _.
  so (rwitness_fun _#3 Hwitw Hwitw'); subst m'.
  so Hwity as (Hroundy' & _).
  so (round_fun _#3 Hroundy Hroundy'); subst n'.
  contradiction.
  }

2:{
  intros m' n' _ _ Hwitw' Hwity _ Hcoin _ _ _ _.
  so (rwitness_fun _#3 Hwitw Hwitw'); subst m'.
  so Hwity as (Hroundy' & _).
  so (round_fun _#3 Hroundy Hroundy'); subst n'.
  contradiction.
  }
intros m' n' t' f' Hwitw' Hwity _ _ Helect' Htally'.
so (rwitness_fun _#3 Hwitw Hwitw'); subst m'.
so Hwity as (Hroundy' & _).
so (round_fun _#3 Hroundy Hroundy'); subst n'.
cbn in Helect, Helect'.
so (destruct_election' _#6 Helect) as (_ & Htfx).
so (destruct_election' _#6 Helect') as (Hally & Htfy).
assert (supermajority stake (fun a => peer_vote s W w n a v /\ offer n a x) every) as Hmajx.
  {
  exists (if v then t else f), total_stake.
  do2 3 split; auto.
    2:{ exact the_total_stake. }
  eassert _ as H; [refine (weight_image _ _ creatorstake stake _ creator _ _ _ (Htfx v)) |]; auto.
    {
    intros z z' (Helector, _) (Helector', _) Heq.
    eapply (elector_unique _#4 x x); eauto.
    }
  refine (weight_iff _#5 _ H).
  intro a.
  split.
    {
    intros (z & -> & Helector & Hvotez).
    split.
      { eapply (elector_vote_peer _#5 x); eauto. }
    exists z.
    split; auto.
    }

    {
    intros (Hvotea & Hoffer).
    so (peer_vote_offer _#7 Wx Hvotea Hoffer) as (z & Heqcr & Helector & Hvotez).
    exists z.
    do2 2 split; auto.
    }
  }
assert (supermajority stake (fun a => offer n a y) every) as Hmajy.
  {
  so (stsees_many_witnesses _ _ (Hwity andel)) as Hmaj.
  refine (supermajority_iff _#5 _ Hmaj).
  intro a.
  split.
    {
    intros (z & Heq & Hss & Hwit).
    exists z.
    split; auto.
    split; auto.
    }

    {
    intros H.
    destruct H as (z & Heq & Helector).
    destruct Helector.
    exists z.
    auto.
    }
  }
so (supermajority_intersect_2 _#5 eq_peer_decide Hmajx Hmajy) as (A & Hmajx' & Hmajy').
so (majority_incl _#4 Hmajx') as HAx.
destruct Hmajy' as (d & e & HAy & Hd & He & Hgt).
assert (d <= if v then t' else f') as Hle.
  {
  refine (weight_corr_le _#6 (fun a z => creator z = a) _ _ _ _ Hd (Htfy v)).
    {
    intros a a' z _ _ _ Heq Heq'.
    transitivity (creator z); auto.
    }

    {
    intros a Ha.
    so (HAy a Ha) as Hoffer.
    so (HAx a Ha) as (Hvotea & _).
    so (peer_vote_offer _#7 Wy Hvotea Hoffer) as (z & Heqcr & Helector & Hvotez).
    exists z.
    subst a.
    do2 2 split; auto.
    }
  }
assert (e = t' + f').
  {
  refine (weight_corr_eq _#6 (fun a z => creator z = a) _ _ _ _ _ _ He Hally).
    {
    intros a a' z _ _ _ Heq Heq'.
    transitivity (creator z); auto.
    }

    {
    intros a z z' _ Helector Helector' ? ?.
    subst a.
    eapply elector_unique; eauto.
    }

    {
    intros a Hoffer.
    destruct Hoffer as (z & <- & Helector).
    exists z.
    split; auto.
    }

    {
    intros z Helector.
    exists (creator z).
    do2 2 split; auto.
    exists z.
    auto.
    }
  }
subst e; clear He.
assert ((if v then t' else f') > (if v then f' else t')).
  {
  eapply lt_le_trans; [| exact Hle].
  eapply le_lt_trans; [| exact Hgt].
  destruct v.
    {
    apply majority_complement; omega.
    }

    {
    replace (t' + f') with (f' + t') in Hgt |- * by omega.
    apply majority_complement; omega.
    }
  }
destruct v; destruct Htally' as [(Hord & ->) | (Hord & ->)]; auto; omega.
Qed.

Lemma unanimous_election :
  forall s W n x y v e,
    member W y
    -> rwitness (S n) y
    -> (forall w, member W w -> rwitness n w -> vote s x w v)
    -> weight creatorstake (fun w => elector n w y) e
    -> election (vote s x) n y (if v then e else 0) (if v then 0 else e).
Proof.
intros s W n x y v e Wy Hwitx Hunan Helectors.
destruct v.
  {
  exists (fun w => elector n w y), (fun w => False).
  do2 4 split; auto.
    {
    replace (e + 0) with e by omega.
    auto.
    }

    { apply weight_empty. }

    {
    intros w Hw.
    split; auto.
    apply Hunan.
      {
      eapply world_closed; eauto.
      apply stsees_impl_ancestor.
      exact (Hw ander).
      }

      {
      eapply elector_rwitness; eauto.
      }
    }

    {
    intros w Hw.
    destruct Hw.
    }
  }

  {
  exists (fun w => False), (fun w => elector n w y).
  do2 4 split; auto.
    { apply weight_empty. }

    {
    intros w Hw.
    destruct Hw.
    }

    {
    intros w Hw.
    split; auto.
    apply Hunan.
      {
      eapply world_closed; eauto.
      apply stsees_impl_ancestor.
      exact (Hw ander).
      }

      {
      eapply elector_rwitness; eauto.
      }
    }
  }
Qed.

Lemma unanimity_persists :
  forall s W m n x v,
    round m x
    -> m + first_regular < n
    -> (forall y, member W y -> rwitness n y -> vote s x y v)
    -> (forall y, member W y -> rwitness (S n) y -> vote s x y v).
Proof.
intros s W m n x v Hroundx Hlt Hunan y Wy Hwity.
so (elector_weight n y) as (e & Helectors).
so (elector_minimum _ _ _ (Hwity andel) Helectors) as Hlte.
so (unanimous_election _#7 Wy Hwity Hunan Helectors) as Helection.
assert (witness x) as Hwitx.
  {
  so (ancestor_witness n (S n) y (Nat.le_succ_diag_r n) (Hwity andel)) as (z & Hzy & Hwitz).
  so (Hunan z (world_closed _#3 Hzy Wy) Hwitz) as Hvote.
  so (vote_witness _#4 Hvote) as (Hwitx & _).
  exact Hwitx.
  }
so (dec_eq_nat ((S n - m) mod coin_freq) 0) as [Hcoin | Hnocoin].
  {
  apply (@vote_coin_super s x y m (S n) (if v then e else 0) (if v then 0 else e) v); auto.
    { split; auto. }

    { omega. }

    { destruct v; auto. }
  }

  {
  apply (@vote_regular s x y m (S n) (if v then e else 0) (if v then 0 else e) v); auto.
    { split; auto. }

    {
    destruct v.
      {
      left.
      split; auto.
      omega.
      }

      {
      right.
      split; auto.
      omega.
      }
    }
  }
Qed.

Lemma unanimity :
  forall s W m n x y v,
    member W y
    -> round m y
    -> m <= n
    -> decision s x y v
    -> forall z, member W z -> rwitness n z -> vote s x z v.
Proof.
intros s W m n x y v Wy Hroundy Hleq Hdecision.
induct Hleq.

(** eq *)
{
intros z Wz Hwitz.
so Hdecision as (l & m' & _ & _ & Hwitx & Hwity & Hlt & _).
so (round_fun _#3 (Hwity andel) Hroundy); subst m'.
assert (l < m) as Hlt' by omega.
so (vote_defined s _#4 Hwitx Hwitz Hlt') as (v' & Hvote).
so (decision_vote_consistent _#8 Wy Wz Hroundy (Hwitz andel) Hdecision Hvote).
subst v'.
exact Hvote.
}

(** leq *)
{
intros n Hle IH z.
destruct Hdecision as (l & m' & _ & _ & (Hroundx & _) & (Hroundy' & _) & Hlt & _).
so (round_fun _#3 Hroundy Hroundy'); subst m'.
eapply unanimity_persists; eauto.
omega.
}
Qed.

Lemma decision_consistent :
  forall s W x y y' v v',
    member W y
    -> member W y'
    -> decision s x y v
    -> decision s x y' v'
    -> v = v'.
Proof.
intros s W.
cut (forall x y z m n v v',
       member W y
       -> member W z
       -> round m y
       -> round n z
       -> m <= n
       -> decision s x y v
       -> decision s x z v'
       -> v = v').

  {
  intros Hprop x y z v v' Wy Wz Hdecision Hdecision'.
  so (round_defined y) as (m & Hroundy).
  so (round_defined z) as (n & Hroundz).
  so (le_dec m n) as [Hle | Hnle].
    {
    apply (Hprop x y z m n v v'); auto.
    }

    {
    symmetry.
    apply (Hprop x z y n m v' v); auto.
    omega.
    }
  }
intros x y z m n v v' Wy Wz Hroundy Hroundz Hleq Hdecisiony Hdecisionz.
so Hdecisionz as (_ & n' & _ & _ & _ & Hwitz & _).
so (round_fun _#3 Hroundz (Hwitz andel)); subst n'.
so (unanimity _#7 Wy Hroundy Hleq Hdecisiony z Wz Hwitz) as Hvote.
so (decision_vote_consistent _#8 Wz Wz Hroundz Hroundz Hdecisionz Hvote).
subst v'.
auto.
Qed.

Lemma unanimity_impl_decision :
  forall s W x y m n v,
    member W y
    -> round m x
    -> (forall z, member W z -> rwitness n z -> vote s x z v)
    -> rwitness (S n) y
    -> m + first_regular < S n
    -> (S n - m) mod coin_freq <> 0
    -> decision s x y v.
Proof.
intros s W x y m n v Wy Hroundx Hunan Hwity Hlt Hnocoin.
so (elector_weight n y) as (e & Helectors).
so (elector_minimum _ _ _ (Hwity andel) Helectors) as Hlte.
so (unanimous_election _#7 Wy Hwity Hunan Helectors) as Helection.
assert (witness x) as Hwitx.
  {
  so (ancestor_witness n (S n) y (Nat.le_succ_diag_r n) (Hwity andel)) as (z & Hzy & Hwitz).
  so (Hunan z (world_closed _#3 Hzy Wy) Hwitz) as Hvote.
  so (vote_witness s _#3 Hvote) as (Hwitx & _).
  exact Hwitx.
  }
exists m, (S n), (if v then e else 0), (if v then 0 else e).
do2 5 split; auto.
  { split; auto. }

  {
  destruct v; auto.
  }
Qed.

Lemma decisions_propagate :
  forall s W x y l m v,
    member W y
    -> round l x
    -> round m y
    -> decision s x y v
    -> forall n z,
         member W z
         -> m < n
         -> (n - l) mod coin_freq <> 0
         -> rwitness n z
         -> decision s x z v.
Proof.
intros s W x y l m v Wy Hroundx Hroundy Hdecision n z Wz Ht Hnocoin Hwitz.
destruct n as [| n]; [omega |].
eapply unanimity_impl_decision; eauto.
  {
  eapply (unanimity _#5 y); eauto.
  omega.
  }

  {
  so Hdecision as (l' & m' & _ & _ & (Hroundx' & _) & (Hroundy' & _) & Hlt & _).
  so (round_fun _#3 Hroundx Hroundx'); subst l'.
  so (round_fun _#3 Hroundy Hroundy'); subst m'.
  omega.
  }
Qed.

Lemma succ_no_coin :
  forall n,
    n mod coin_freq = 0
    -> (S n) mod coin_freq <> 0.
Proof.
intros n Heq.
so first_regular_min.
so coin_freq_min.
replace (S n) with (n + 1) by omega.
rewrite -> Nat.add_mod; [| omega].
rewrite -> Heq.
cbn.
rewrite -> Nat.mod_mod; [| omega].
rewrite -> Nat.mod_small; omega.
Qed.

(** Lemma 5.15 *)
Corollary decisions_propagate_round :
  forall s W x y m v,
    member W y
    -> nonterminating W
    -> round m y
    -> decision s x y v
    -> exists n,
         n <= m + 2
         /\ forall z,
              member W z
              -> rwitness n z
              -> decision s x z v.
Proof.
intros s W x y m v Wy Hnt Hroundy Hdecision.
so Hdecision as (l & m' & _ & _ & (Hroundx & _) & (Hroundy' & _) & Hleq & _).
so (round_fun _#3 Hroundy Hroundy'); subst m'.
so (dec_eq_nat ((S m - l) mod coin_freq) 0) as [Heq | Hneq].
  {
  exists (m + 2).
  split; auto.
  intros z HGz Hwitz.
  eapply (decisions_propagate s W x y) with (n := (m + 2)); eauto; [omega |].
  replace (m + 2 - l) with (S (S m - l)) by omega.
  apply succ_no_coin; auto.
  }

  {
  exists (S m).
  split; [omega |].
  intros z HGz Hwitz.
  eapply (decisions_propagate s W x y) with (n := S m); eauto.
  }
Qed.