(** * 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 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.  (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].

        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.

    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 *)

(** We begin by formalizing the syntax of the STLC. *)

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. *)

(** 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 Gallina,
    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 complete 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.  *)

(* ----------------------------------------------------------------- *)
(** *** Substitution *)

(** Now we come to the heart of the STLC: the operation of
    substituting one term for a variable in another term.  This
    operation is 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 include
    binders for all of the variables they mention), we can avoid 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 and prove that the relation you've defined coincides
    with the function given above. *)

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 (the function) until it becomes an abstraction; 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 abstraction.  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)
*)

(** Formally: *)

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.

(** We can use the [normalize] tactic defined in the [Types] chapter
    to simplify these proofs. *)

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

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.

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

(* ================================================================= *)
(** ** Typing *)

(** Next we consider the typing relation of the STLC. *)

(* ----------------------------------------------------------------- *)
(** *** 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] (or [...]). *)

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 \in 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-05-26 17:51:14 -0400 (Thu, 26 May 2016) $ *)


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Arith.Arith.
Require Import maps.
Require Import imp.
Require Import smallstep.

Hint Constructors multi.

(*
    t ::= tru
        | fls
        | test t then t else t
        | zro
        | scc t
        | prd t
        | iszro t
 *)
Inductive tm : Type :=
  | tru : tm
  | fls : tm
  | test : tm -> tm -> tm -> tm
  | zro : tm
  | scc : tm -> tm
  | prd : tm -> tm
  | iszro : tm -> tm.

Inductive bvalue : tm -> Prop :=
  | bv_tru : bvalue tru
  | bv_fls : bvalue fls.

Inductive nvalue : tm -> Prop :=
  | nv_zro : nvalue zro
  | nv_scc : forall t, nvalue t -> nvalue (scc t).

Definition value (t : tm) := bvalue t \/ nvalue t.

Hint Constructors bvalue nvalue.
Hint Unfold value.
Hint Unfold update.

(*
                   -------------------------------                  (ST_TestTru)
                   test tru then t1 else t2 --> t1

                   -------------------------------                  (ST_TestFls)
                   test fls then t1 else t2 --> t2

                               t1 --> t1'
            ----------------------------------------------------       (ST_Test)
            test t1 then t2 else t3 --> test t1' then t2 else t3

                             t1 --> t1'
                         ------------------                             (ST_Scc)
                         scc t1 --> scc t1'

                           ---------------                           (ST_PrdZro)
                           prd zro --> zro

                         numeric value v1
                        -------------------                          (ST_PrdScc)
                        prd (scc v1) --> v1

                              t1 --> t1'
                         ------------------                             (ST_Prd)
                         prd t1 --> prd t1'

                          -----------------                        (ST_IszroZro)
                          iszro zro --> tru

                         numeric value v1
                      ----------------------                       (ST_IszroScc)
                      iszro (scc v1) --> fls

                            t1 --> t1'
                       ----------------------                         (ST_Iszro)
                       iszro t1 --> iszro t1'
 *)

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

Inductive step : tm -> tm -> Prop :=
  | ST_TestTru : forall t1 t2,
      (test tru t1 t2) --> t1
  | ST_TestFls : forall t1 t2,
      (test fls t1 t2) --> t2
  | ST_Test : forall t1 t1' t2 t3,
      t1 --> t1' ->
      (test t1 t2 t3) --> (test t1' t2 t3)
  | ST_Scc : forall t1 t1',
      t1 --> t1' ->
      (scc t1) --> (scc t1')
  | ST_PrdZro :
      (prd zro) --> zro
  | ST_PrdScc : forall t1,
      nvalue t1 ->
      (prd (scc t1)) --> t1
  | ST_Prd : forall t1 t1',
      t1 --> t1' ->
      (prd t1) --> (prd t1')
  | ST_IszroZro :
      (iszro zro) --> tru
  | ST_IszroScc : forall t1,
       nvalue t1 ->
      (iszro (scc t1)) --> fls
  | ST_Iszro : forall t1 t1',
      t1 --> t1' ->
      (iszro t1) --> (iszro t1')

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

Hint Constructors step.

Notation step_normal_form := (normal_form step).

Definition stuck (t : tm) : Prop :=
  step_normal_form t /\ ~ value t.

Hint Unfold stuck.

Example some_term_is_stuck :
  exists t, stuck t.
Proof.
  unfold stuck, step_normal_form. exists (scc tru). split. intros H. inversion H. inversion H0. inversion H2.
  intros H. inversion H. inversion H0. inversion H0. inversion H2.
Qed.

Lemma value_is_nf : forall t,
  value t -> step_normal_form t.
Proof.
  induction t; intros; intros H1.
  inversion H1; inversion H0.
  inversion H1; inversion H0.
  inversion H; inversion H0.
  inversion H1; inversion H0.
  induction IHt;
    inversion H1; inversion H0; inversion H; subst. inversion H5. inversion H5; subst. unfold value. right; assumption. exists t1'. apply H3. exists t1'. apply H3.
  inversion H. inversion H0. inversion H0.
  inversion H. inversion H0. inversion H0.
Qed.

Theorem step_deterministic:
  deterministic step.
Proof with eauto.

  unfold deterministic.
  intros. generalize dependent y2.
  induction H; intros y2 H1; inversion H1; subst; try reflexivity; try solve_by_invert.
  try (apply IHstep in H5; rewrite H5; reflexivity).
  try apply IHstep in H2; rewrite H2; reflexivity.

  inversion H2. induction (value_is_nf  t1). unfold value. right. assumption. exists t1'0; assumption.
  inversion H. induction (value_is_nf y2 ). unfold value. right; assumption. exists t1'0; assumption.

  apply IHstep in H2. rewrite H2. reflexivity.
  inversion H1.

  inversion H1. induction (value_is_nf t1). unfold value. right; assumption. inversion H7. exists t1'2; assumption.
  inversion H; subst. induction (value_is_nf t0). unfold value; right; assumption. exists t1'0; assumption.
  inversion H1. apply IHstep in H2. rewrite H2. reflexivity.
Qed.

(*型付け*)
Inductive ty : Type :=
  | Bool : ty
  | Nat : ty.

(*
                           ---------------                     (T_Tru)
                           |- tru \in Bool

                          ---------------                      (T_Fls)
                          |- fls \in Bool

             |- t1 \in Bool    |- t2 \in T    |- t3 \in T
             --------------------------------------------     (T_Test)
                    |- test t1 then t2 else t3 \in T

                             --------------                    (T_Zro)
                             |- zro \in Nat

                            |- t1 \in Nat
                          -----------------                    (T_Scc)
                          |- scc t1 \in Nat

                            |- t1 \in Nat
                          -----------------                    (T_Prd)
                          |- prd t1 \in Nat

                            |- t1 \in Nat
                        --------------------                 (T_IsZro)
                        |- iszro t1 \in Bool
 *)

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

Inductive has_type : tm -> ty -> Prop :=
  | T_Tru :
       |- tru \in Bool
  | T_Fls :
       |- fls \in Bool
  | T_Test : forall t1 t2 t3 T,
       |- t1 \in Bool ->
       |- t2 \in T ->
       |- t3 \in T ->
       |- test t1 t2 t3 \in T
  | T_Zro :
       |- zro \in Nat
  | T_Scc : forall t1,
       |- t1 \in Nat ->
       |- scc t1 \in Nat
  | T_Prd : forall t1,
       |- t1 \in Nat ->
       |- prd t1 \in Nat
  | T_Iszro : forall t1,
       |- t1 \in Nat ->
       |- iszro t1 \in Bool

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

Hint Constructors has_type.

Example has_type_1 :
  |- test fls zro (scc zro) \in Nat.
Proof.
  apply T_Test.
    - apply T_Fls.
    - apply T_Zro.
    - apply T_Scc.
       + apply T_Zro.
Qed.

Example has_type_not :
  ~ ( |- test fls zro tru \in Bool ).
Proof.
  intros Contra. solve_by_inverts 2. Qed.

Example scc_hastype_nat__hastype_nat : forall t,
  |- scc t \in Nat ->
  |- t \in Nat.
Proof.
  intros. inversion H. assumption.
Qed.

Lemma bool_canonical : forall t,
  |- t \in Bool -> value t -> bvalue t.
Proof.
  intros t HT [Hb | Hn].
  - assumption.
  - induction Hn; inversion HT; auto.
Qed.

Lemma nat_canonical : forall t,
  |- t \in Nat -> value t -> nvalue t.
Proof.
  intros t HT [Hb | Hn].
  - inversion Hb; subst; inversion HT.
  - assumption.
Qed.

(*
進行
　　もし項に型がつくなら、項は値であるか、または1ステップは進める
 *)
Theorem progress : forall t T,
  |- t \in T ->
  value t \/ exists t', t --> t'.
Proof with auto.
  intros t T HT.
  induction HT.
  - left. unfold value. left. apply bv_tru.
  - left. unfold value. left. apply bv_fls.
  -
    right. inversion IHHT1; clear IHHT1.
    +
    apply (bool_canonical t1 HT1) in H.
    inversion H; subst; clear H.
      exists t2. apply ST_TestTru.
      exists t3. apply ST_TestFls.
    +
      inversion H as [t1' H1].
      exists (test t1' t2 t3). apply ST_Test. assumption.
  - left. unfold value. right. apply nv_zro.
  - inversion IHHT.
    + left. inversion H. inversion H0; subst; inversion HT. right. apply nv_scc; assumption.
    + right. inversion H. exists (scc x). apply ST_Scc; assumption.
  - inversion IHHT.
    + inversion H. inversion H0; subst; inversion HT.
      inversion H0. right. exists zro. apply ST_PrdZro. right. exists t. apply ST_PrdScc; assumption.
    + inversion H. right. exists (prd x). apply ST_Prd; assumption.
  - inversion IHHT.
    + inversion H. inversion H0; subst; inversion HT. inversion H0.
      right. exists tru. apply ST_IszroZro. right. exists fls. apply ST_IszroScc; assumption.
    + inversion H. right. exists (iszro x). apply ST_Iszro; assumption.
Qed.

(*
型保存
　　型のついた項を一段階簡約すると、簡約結果もまた型のつく項である*)
Theorem preservation : forall t t' T,
  |- t \in T ->
  t --> t' ->
  |- t' \in T.
Proof.
  intros t t' T HT HE.
  generalize dependent t'.
  induction HT;

         intros t' HE;

         try solve_by_invert.
    - inversion HE; subst; clear HE.
      + assumption.
      + assumption.
      + apply T_Test; try assumption.
        apply IHHT1; assumption.
    - inversion HE; subst. apply T_Scc. apply IHHT; assumption.
    - inversion HE; subst; try assumption.
      + inversion HT. assumption.
      + apply T_Prd. apply IHHT; assumption.
    - inversion HE; subst.
      + apply T_Tru.
      + apply T_Fls.
      + apply T_Iszro. apply IHHT; assumption.
Qed.

(*進行と型保存を合わせると、型のついた項は決して行き詰まらないことを示せます。*)
Definition multistep := (multi step).
Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).
Corollary soundness : forall t t' T,
  |- t \in T ->
  t -->* t' ->
  ~(stuck t').
Proof.
  intros t t' T HT P. induction P; intros [R S].
  destruct (progress x T HT); auto.
  apply IHP. apply (preservation x y T HT H).
  unfold stuck. split; auto. Qed.


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

 Provide standard test objects for all test files.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import FormalSyntax.

Definition k  := A.
Definition ka := A.
Definition kb := B.

(* Bug 4 i_i does not handle negative numbers! *)
Definition v'    := (i_e (i_i 4)).
Definition v''   := (i_e (i_i 6)).
Definition v     := (i_e (i_i 3)).
Definition v0    := (i_e (i_i Z0)).
Definition v1    := (i_e (i_i 1)).
Definition vi0   := (i_e (i_i Z0)).
Definition vi1   := (i_e (i_i 1)).
Definition vi2   := (i_e (i_i 2)).

Definition e    := (i_e (i_i Z0)).
Definition e'   := (i_e (i_i 1)).
Definition e0   := (i_e (i_i Z0)).
Definition e1   := (i_e (i_i 1)).
Definition e2   := (i_e (i_i 1)).

Definition s  := (retn (i_e (i_i 0))).
Definition s' := (retn (i_e (i_i 0))).
Definition s1 := (retn (i_e (i_i 1))).
Definition s2 := (retn (i_e (i_i 2))).

Definition x     := (evar 0).
Definition x'    := (evar 3).
Definition y     := (evar 1).
Definition y'    := (evar 4).
Definition z     := (evar 2).
Definition z'    := (evar 8).

Definition alpha := (tvar 0).
Definition beta  := (tvar 1).
Definition gamma := (tvar 2).

Definition i     := (i_i 0).
Definition i1    := (i_i 1).
Definition i2    := (i_i 2).
Definition i3    := (i_i 3).

Definition tau  := cint.
Definition tau' := cross cint cint.
Definition t    := cint.
Definition t'   := cross cint cint.
Definition t0   := cint.
Definition t1   := cross cint cint.

Definition pdot := [] : P.
Definition p0   := [(i_pe zero_pe)].
Definition p1   := [(i_pe one_pe)].

Definition hdot := [] : H.
Definition h    := [(x,e)] : H.

Definition ddot := [] : Delta.
(* Definition d1   :=  *)

Definition udot := [] : Upsilon.
(* Definition u1   :=  *)

Definition gdot := [] : Gamma.

Definition q := aliases.

(* We use these to show that substitution ignores expresions without
  type variables, f, substitutes all alphas falphaalpha, and ignores
  type other type variables, fbetabeta. *)
Definition f           :=
  (dfun tau   x tau (retn (inst (p_e x pdot) tau))).
Definition faa :=
  (dfun tau   x (tv_t alpha) (retn (inst (p_e x pdot) (tv_t alpha)))).
Definition fbb  :=
  (dfun tau   x (tv_t beta) (retn (inst (p_e x pdot) (tv_t beta)))).

Definition applff  := (e_s (appl (f_e f)   (f_e f))).
Definition applfaa := (e_s (appl (f_e faa) (f_e faa))).
Definition applfbb := (e_s (appl (f_e fbb) (f_e fbb))).

Definition ufg  := (ufun gamma A faa).
Definition ufaa := (ufun alpha A faa).
Definition ufbb := (ufun beta  A faa).


Require Import Platform.Cito.SyntaxExpr.

(* The depth of stack actually used by compileExpr *)
Fixpoint depth expr :=
  match expr with
    | Var _ => 0
    | Const _ => 0
    | Binop _ a b => max (depth a) (S (depth b))
    | TestE _ a b => max (depth a) (S (depth b))
  end.


(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

Require Import SMain.
Require Import Field_tac.
Require Import Program.
Require Import EGroup.
Require Import FGroup.
Require Import UList.
Require Import Arith.
Require Import Znumtheory.
Require Import ZAux.
Require Import FilterMap.
Require Import Znumtheory.
Require Import SMain.
Require Import Ring.
Require Import PrimeLib.
Require Import Padding.
Require Import EC.
Require Import EncodingAux.
Require Import RO.

Set Implicit Arguments.

Module Type SOLVE_DEGREE_4 (A : FIELD).

 Parameter solve_degree_4 : forall k (a b c d e : A.t k), list (A.t k).

 Notation "x + y" := (A.kplus x y).
 Notation "x * y" := (A.kmul x y).

 Parameter solve_degree_4_correct : forall k (a b c d e sol : A.t k),
  In sol (solve_degree_4 a b c d e) <->
  (fun x => a * x*x*x*x + b * x*x*x + c * x*x + d * x + e) sol = A.kO k.

 Parameter solve_degree_4_size : forall k (a b c d e : A.t k),
  (length (solve_degree_4 a b c d e) <= 4)%nat.

 Parameter solve_degree_4_NoDup : forall k (a b c d e : A.t k),
  NoDup (solve_degree_4 a b c d e).

End SOLVE_DEGREE_4.

Declare Module F : FIELD
 with Definition order_mod1 := fun (_:nat) => 3%Z
 with Definition order_mod2 := fun (_:nat) => 2%Z.

Declare Module CP : CURVE_PROPERTIES F.

Declare Module S4 : SOLVE_DEGREE_4 F.

Module EC_GROUP <: CFG  := (EC.EC F CP).

Module PAD := Padding.Padding EC_GROUP.

Module IcartEncoding <: ENCODING F PAD.B.

 Import F CP S4.

 Section ENC.

  Variable k : nat.

  Add Field Kfield : (@K_field k) (abstract).

  Notation "x + y" := (kplus x y).
  Notation "x * y" := (kmul x y).
  Notation "x - y" := (ksub x y).
  Notation "- x" := (kopp x).
  Notation "/ x" := (kinv x).
  Notation "x / y" := (kdiv x y).
  Notation "0" := (kO k).
  Notation "1" := (kI k).
  Notation "2" := (1+1).
  Notation "3" := (1+1+1).
  Notation "4" := (2*2).
  Notation "5" := (4+1).
  Notation "6" := (2*3).
  Notation "8" := (2*2*2).
  Notation "16" := (2*2*2*2).
  Notation "20" := (4*5).
  Notation "27" := (3*3*3).
  Notation "256" := (2*2*2*2*2*2*2*2).

  Notation "x ^ n" := (kpow x n).

  Lemma kpow_S : forall (x:t k) n, x ^ (S n) = x * (x ^ n).
  Proof.
   intros; simpl; trivial.
  Qed.

  Lemma kpow_kplus : forall (x:t k) n m, ((x ^ n) * (x ^ m) = x ^ (n + m)).
  Proof.
   intros x n m.
   induction m; simpl.
   rewrite plus_0_r; field.
   rewrite <- plus_n_Sm, kpow_S, <- IHm; field.
  Qed.

  Lemma kpow_pow : forall x n1 n2, kpow (@kpow k x n1) n2 = kpow x (n1 * n2).
  Proof.
   intros x n1 n2.
   induction n2.
   rewrite mult_0_r; simpl; trivial.
   rewrite mult_succ_r, <- kpow_kplus; simpl.
   rewrite IHn2; field.
  Qed.

  Lemma kpow_kplus_n : forall (x y:t k) n, (x ^ n) * (y ^ n) = (x * y) ^ n.
  Proof.
   intros x y n.
   induction n; simpl.
   ring.
   rewrite <- IHn; ring.
  Qed.

  Definition sqr (x : t k) : t k := x * x.

  Definition cube (x : t k) : t k := x * x * x.

  Definition pow4 (x : t k) : t k := x * x * x * x.

  Lemma cube_pow (x : t k) : cube x = kpow x 3%nat.
  Proof.
   intros; unfold cube; simpl; ring.
  Qed.

  Lemma cube_plus a b :
   cube (a + b) = (cube a) + 3 * a*a * b + 3 * b*b * a + (cube b).
  Proof.
   intros a b; unfold cube; ring.
  Qed.

  Lemma cube_minus a b :
   cube (a - b) = (cube a) - 3 * a*a * b + 3 * b*b * a - (cube b).
  Proof.
   intros a b; unfold cube; ring.
  Qed.

  Definition cube_root (x : t k) : t k :=
   kpow x (Zabs_nat ((2 * (orderZ k) - 1) / 3)).

  Lemma order_pos : (0 < orderZ k)%Z.
  Proof.
   change 0%Z with (Z_of_nat 0).
   apply inj_lt.
   generalize (@elems_notnil k).
   destruct (elems k); intros; simpl.
   elim H; trivial.
   omega.
  Qed.

  Lemma cube_root_spec : forall x, cube_root (cube x) = x.
  Proof.
   intros x; unfold cube_root.
   assert (Ho := order_pos).
   rewrite cube_pow, kpow_pow.
   change 3%nat with (Zabs_nat 3).
   rewrite <- Zabs_nat_mult, <- Zdivide_Zdiv_eq;[ | omega | ].
   cutrewrite (2 * orderZ k - 1 = 1 + (orderZ k - 1) + (orderZ k - 1))%Z;[ | ring].
   repeat rewrite Zabs_nat_Zplus; try omega.
   repeat rewrite <- kpow_kplus; simpl.
   cutrewrite (Zabs_nat (orderZ k - 1) = (order k - 1)%nat ).
   repeat rewrite fermat; ring.
   rewrite Zabs_nat_Zminus.
   unfold orderZ; rewrite Zabs_nat_Z_of_nat; auto.
   omega.
   apply Zmod_divide; [ omega | ].
   rewrite <- Zminus_mod_idemp_l, Zmult_comm, <- Zmult_mod_idemp_l, order_mod.
   vm_compute; trivial.
  Qed.

  Lemma cube_spec : forall x, cube (cube_root x) = x.
  Proof.
   intros x; unfold cube_root.
   rewrite cube_pow, kpow_pow, mult_comm, <- kpow_pow, <- cube_pow.
   apply cube_root_spec.
  Qed.

  Lemma cube_root_mul x y : cube_root x * cube_root y = cube_root (x * y).
  Proof.
   intros x y; unfold cube_root.
   rewrite kpow_kplus_n; trivial.
  Qed.

  Lemma diff_opp_0 x : x <> 0 -> -x <> 0.
  Proof.
   intros x H1 Heq.
   apply H1.
   apply (f_equal (fun x => kopp x)) in Heq.
   cutrewrite (- - x = x) in Heq; [ | ring ].
   ring [Heq].
  Qed.

  Lemma mult_inj x y z : z <> 0 ->  x * z = y * z -> x = y.
  Proof.
   intros x y z Hz H.
   apply (f_equal (fun x => x / z)) in H.
   cutrewrite (x = x * z / z).
   rewrite H.
   field; trivial.
   field; trivial.
  Qed.

  Lemma diff_1_0 : 1 <> 0.
  Proof.
   generalize (K_field k); intros.
   inversion H; trivial.
  Qed.

  Lemma diff_1_2_0 : 1 + 2 <> 0.
  Proof.
   cutrewrite (1 + 2 = 3).
   apply diff_3_0.
   ring.
  Qed.

  Lemma diff_3_0' : 1 + 1 + 1 <> 0.
  Proof.
   apply diff_3_0.
  Qed.

  Lemma diff_4_0 : 4 <> 0.
  Proof.
   apply diff_mul_0; apply diff_2_0.
  Qed.

  Lemma diff_6_0 : 2 * (1 + 2) <> 0.
  Proof.
   apply diff_mul_0.
   apply diff_2_0.
   apply diff_1_2_0.
  Qed.

  Lemma diff_8_0 : 8 <> 0.
  Proof.
   apply diff_mul_0.
   apply diff_4_0.
   apply diff_2_0.
  Qed.

  Lemma diff_27_0 : 1 + 2 * (1 + 2 * (2 * (1 + 2))) <> 0.
  Proof.
   cutrewrite (1 + 2 * (1 + 2 * (2 * (1 + 2))) = 3 * 3 * 3).
   apply diff_mul_0.
   apply diff_mul_0.
   apply diff_3_0.
   apply diff_3_0.
   apply diff_3_0.
   ring.
  Qed.

  Hint Resolve diff_1_2_0 diff_1_0 diff_2_0 diff_3_0 diff_3_0'
   diff_4_0 diff_6_0 diff_27_0 diff_8_0 diff_opp_0.

  Lemma is_zero_eq_false : forall x, is_zero x = false <-> x <> 0.
  Proof.
   generalize (EC_GROUP.ECB.Eth k); intros.
   inversion H; trivial.
   split; intro He.
   intro Heq.
   apply is_zero_correct in Heq.
   rewrite He in Heq; discriminate.
   apply not_true_is_false.
   intro Heq.
   apply is_zero_correct in Heq.
   subst.
   elim He; trivial.
  Qed.

  Lemma mult_sqr (x y : t k) : x = y \/ x = -y -> x * x = y * y.
  Proof.
   intros x y [H | H]; subst; ring.
  Qed.

  Lemma eqb_dec : forall (x y : F.t k), {x = y} + {x <> y}.
  Proof.
   intros.
   generalize (eqb_spec x y).
   case (eqb x y); auto.
  Qed.

  Definition f_def : F.t k -> PAD.B.t k.
   intro u.

   destruct (eqb_dec u 0).

   destruct (eqb_dec (A k) 0).

   pose (x := cube_root (- B k )).

   (* if A = 0 then f(0) = ( (-b)^(1/3), 0). cf (mail with Thomas Icart) *)
   refine (curve_elt (kI k) (@kplus k) (@kmul k) (A k) (B k) x 0 _).
   symmetry; unfold SMain.pow.
   rewrite e0.
   ring_simplify.
   cutrewrite (x * x * x = cube x); auto.
   unfold x.
   rewrite cube_spec.
   ring.

   (* A <> 0 (Icart's paper)  *)
   exact (PAD.B.default k).

   pose (v := kdiv ((3 * A k) - (u*u*u*u)) (6 * u)).
   pose (x := cube_root ((v * v) - B k - ((u ^ 6) / 27)) + ( (u^2) / 3)).
   pose (y := (u * x) + v).
   refine (curve_elt (kI k) (@kplus k) (@kmul k) (A k) (B k) x y _).
   symmetry; unfold SMain.pow.
   ring_simplify.
   assert (x = cube_root (v * v - B k - u ^ 6 / 27) + u ^ 2 / 3) by trivial.
   apply (f_equal cube) in H.
   assert (cube (x - ((u*u) / 3)) = (v*v) - B k - (u^6)/27).
   rewrite cube_minus, H, cube_plus, cube_spec; clear H; unfold x.
   generalize (v * v - B k - u ^ 6 / 27); intro.
   rewrite <- (cube_spec t0) at 1 8; unfold cube.
   cutrewrite (u ^ 2 = u * u); [ | unfold kpow]; ring.
   assert (cube x = u * u * x * x - ((u * u * u * u) / 3) * x + (- B k + v * v)).
   cutrewrite <- (cube (x - u * u / 3) + u ^ 6 / 27  = - B k + v * v);
    [ | ring [H0] ].
   rewrite cube_minus; set (n1 := 1); unfold kpow, cube; field; auto.
   cutrewrite (u * u * u * u / 3 = A k - 2 * u * v) in H1.
   unfold y; unfold cube in H1; ring [H1].
   unfold v; set (n1 := 1); field.
   split;[  | split ]; auto.
   apply diff_2_0.
  Defined.

  Lemma Feqb : forall a b : t k, {a = b} + {a <> b}.
  Proof.
   intros.
   generalize (eqb_spec a b).
   case (eqb a b); intros; auto.
  Qed.

  Lemma Geqb : forall a b : PAD.B.t k, {a = b} + {a <> b}.
  Proof.
   intros.
   generalize (PAD.B.eqb_spec _ a b).
   case (PAD.B.eqb _ a b); intros; auto.
  Qed.

  Definition Im_f := nodup Geqb (map f_def (elems k)).

  Lemma NoDup_Im_f : NoDup Im_f.
  Proof.
   apply Nodup_nodup.
  Qed.

  Definition finv_def : (PAD.B.t k) -> list (F.t k).
   intros p.

   destruct p.
   destruct (eqb_dec (A k) 0).
   exact nil.
   exact [0].

   destruct (eqb_dec (A k) 0).
   refine (solve_degree_4 0 1 0 (- x * 6) (6 * y)). (* cf. Icart's suggestion *)
   refine (solve_degree_4 1 0 (- x * 6) (6 * y) (- A k * 3)).
  Defined.

  Definition finv_len : nat := 4%nat.

  Parameter cost_f : F.t k -> nat.

  Parameter cost_f_poly : polynomial.

  Parameter cost_f_poly_spec : forall (x:F.t k),
   (cost_f x <= peval cost_f_poly k)%nat.

  Parameter cost_finv : PAD.B.t k -> nat.

  Parameter cost_finv_poly : polynomial.

  Parameter cost_finv_poly_spec : forall (x:PAD.B.t k),
   (cost_finv x <= peval cost_finv_poly k)%nat.

  Definition finv_len_poly := pcst 4.

  Lemma finv_len_poly_spec : finv_len <= finv_len_poly k.
  Proof.
   unfold finv_len, finv_len_poly.
   rewrite pcst_spec; auto.
  Qed.

  Ltac elim_if :=
   match goal with
    |- context [if ?a then ?b else ?c] => case_eq a; intros
   end.

  Lemma finv_len_spec : forall x, length (finv_def x) <= finv_len.
  Proof.
   unfold finv_def, finv_len; intros.
   destruct x; repeat elim_if; simpl; auto;
    apply solve_degree_4_size.
  Qed.

  Lemma finv_len_not_0 : 0 < finv_len.
  Proof.
   unfold finv_len; auto.
  Qed.

 End ENC.

End IcartEncoding.

Require Import ssreflect.

Module Icart_PI <: POLYNOMIALLY_INVERTIBLE_ENCODING F PAD.B IcartEncoding.

 Import IcartEncoding CP F.

 Section PI.

  Variable k : nat.

  Add Field Kfield : (@K_field k) (abstract).

  Notation "x + y" := (kplus x y).
  Notation "x * y" := (kmul x y).
  Notation "x - y" := (ksub x y).
  Notation "- x" := (kopp x).
  Notation "/ x" := (kinv x).
  Notation "x / y" := (kdiv x y).
  Notation "0" := (kO k).
  Notation "1" := (kI k).
  Notation "2" := (1+1).
  Notation "3" := (1+1+1).
  Notation "4" := (2*2).
  Notation "5" := (4+1).
  Notation "6" := (2*3).
  Notation "8" := (2*2*2).
  Notation "16" := (2*2*2*2).
  Notation "20" := (4*5).
  Notation "27" := (3*3*3).
  Notation "256" := (2*2*2*2*2*2*2*2).

  Notation "x ^ n" := (kpow x n).

  Lemma finv_NoDup : forall (x:PAD.B.t k), NoDup (finv_def x).
  Proof.
   intros; unfold finv_def.
   destruct x.
   destruct (eqb_dec (CP.A k) (F.kO k)); auto.
   destruct (eqb_dec (CP.A k) (F.kO k));
    apply S4.solve_degree_4_NoDup.
  Qed.

  Hint Resolve diff_1_2_0 diff_1_0 diff_2_0 diff_3_0 diff_3_0'
   diff_4_0 diff_6_0 diff_27_0 diff_8_0 diff_opp_0.

  Lemma finv_spec1 : forall (g : PAD.B.t k) (u : F.t k),
   In u (finv_def g) -> f_def u = g.
  Proof.
   intros g u; unfold finv_def, f_def.
   (* case_eq ( p_in g Im_f ); intros Hpin. *)
   destruct g; simpl; intros.
   (** inf *)
   destruct (eqb_dec (A k) 0); simpl in *.
   elim H.
   destruct H.
   subst.
   destruct (eqb_dec 0 0); intros.
   auto.
   elim n0; trivial.
   elim H.

   (** (x,y) *)
   unfold SMain.pow in e.
   destruct (eqb_dec (A k) 0).
   (*** A = 0 *)
   apply S4.solve_degree_4_correct in H.
   destruct (eqb_dec u 0); intros.
   (**** u = 0 *)
   rewrite e1 in H.
   ring_simplify in H.
   assert (y = 0).
   rewrite e0 in e.
   cutrewrite (2 * (1 + 2) * y = y * (2 * (1 + 2))) in H;[ | ring ].
   cutrewrite (0 = 0 * (2 * (1 + 2))) in H.
   apply mult_inj in H; auto.
   ring.
   apply (curve_elt_irr (EC_GROUP.ECB.Eth k)).
   rewrite H0 e0 in e.
   cutrewrite (- B k = x * x * x).
   apply cube_root_spec.
   cutrewrite (x * x * x = - (0 * 0) + x * x * x);[ | ring].
   rewrite e; ring.
   auto.

   (**** u <> 0 *)
   ring_simplify in H.
   assert (u * u * u - x * 6 * u + 6 * y = 0).
   rewrite <- H; ring.
   clear H.

   assert (u * u * u / 6 = x * u - y).
   cutrewrite (u * u * u = u * u * u - 0);[ | ring ].
   rewrite <- H0; field; auto.

   assert (B k = y * y - x * x * x).
   rewrite e e0; ring.

   pose (v := - (u * u * u / 6)).
   assert (y = u * x + v).
   unfold v.
   rewrite H.
   ring.

   assert (v * v - B k - u ^ 6 / 27 = cube (x - u * u / 3)).
   cutrewrite <- (u * u * x * x + 2 * u * v * x + v * v = y * y) in e.
   rewrite e0 in e.
   ring_simplify in e.

   assert ((x * x * x + B k) - u * u * x * x  - 2 * u * v * x - v * v = 0).
   rewrite <- e; ring.
   clear e.

   assert (x * x * x - u * u * x * x + (- (2 * u * v)) * x + B k - v * v = 0).
   rewrite <- H3; ring.
   clear H3.

   rewrite cube_minus.
   assert (  v * v - B k = cube x - 3 * x * x * (u * u / 3) + 3 * (u * u / 3) * (u * u / 3) * x ).
   cutrewrite (v * v = v * v + 0);[ | ring ].
   rewrite <- H4.
   unfold v.
   ring_simplify.
   unfold cube; field; auto.
   rewrite H3.
   unfold cube.
   simpl; field; auto.
   rewrite H2; ring.

   simpl in H3.

   assert ( cube_root
     ((3 * 0 - u * u * u * u) / (6 * u) * ((3 * 0 - u * u * u * u) / (6 * u)) -
      B k - u * (u * (u * (u * (u * (u * 1))))) / 27) = x - u * (u * 1) / 3).
   apply (f_equal (@cube_root k)) in H3.
   rewrite cube_root_spec in H3.
   cutrewrite ( x - u * (u * 1) / 3 = x - u * u / 3 );[ | field; auto ].
   rewrite <- H3.
   f_equal.
   unfold v; field; auto.

   apply (curve_elt_irr (EC_GROUP.ECB.Eth k)).
   rewrite e0 H4.
   field; auto.
   rewrite e0 H4 H2.
   unfold v.
   field; auto.

   (*** A <> 0 *)
   apply S4.solve_degree_4_correct in H.
   destruct (eqb_dec u 0); intros.
   (**** u = 0 *)
   rewrite e0 in H.
   ring_simplify in H.
   cutrewrite (0 = 0 * (A k)) in H.
   apply mult_inj in H; trivial.
   assert (- (1 + 2) <> 0).
   apply diff_opp_0; auto.
   elim H0; trivial.
   ring.
   (**** u <> 0 *)
   ring_simplify in H.
   assert (u * u * u * u - x * 6 * u * u + 6 * y * u - A k * 3 = 0).
   rewrite <- H; ring.
   clear H.
   pose (v := kdiv ((3 * A k ) - (u * u * u * u)) (6 * u)).
   assert (y = u * x + v).
   unfold v.
   assert (3 * A k = u * u * u * u - x * 6 * u * u + 6 * y * u).
   cutrewrite (3 * A k = 3 * A k + 0);[ | ring ].
   rewrite <- H0; field.
   rewrite H; field.
   split; auto.
   assert (v * v - B k - u ^ 6 / 27 = cube (x - u * u / 3)).
   generalize e; intro He.
   cutrewrite <- (u * u * x * x + 2 * u * v * x + v * v = y * y) in He.
   assert ((x*(x*x) + A k * x + B k) - u * u * x * x  - 2 * u * v * x - v * v = 0).
   rewrite <- He; ring.
   clear He.
   assert (x * x * x - u * u * x * x + (A k - 2 * u * v) * x + B k - v * v = 0).
   rewrite <- H1; ring.
   clear H1.
   cutrewrite (A k - 2 * u * v = u * u * u * u / 3) in H2.
   cutrewrite (v * v = v * v + 0);[ | ring ].
   rewrite <- H2.
   unfold cube; simpl; field; auto.
   unfold v; field; auto.
   rewrite H; field.
   simpl in H1.
   apply (curve_elt_irr (EC_GROUP.ECB.Eth k)).
   fold v.
   rewrite H1 cube_root_spec.
   simpl; field; auto.
   fold v.
   rewrite H1 cube_root_spec.
   rewrite H.
   simpl; field; auto.
  Qed.

  Lemma finv_spec2 : forall (g : PAD.B.t k) (u : F.t k),
   f_def u = g -> In u (finv_def g).
  Proof.
   intros g u; unfold finv_def, f_def; intros.
   destruct (eqb_dec u 0); destruct (eqb_dec (A k) 0);
    destruct g; try discriminate.
   apply S4.solve_degree_4_correct.
   injection H; intros; subst; ring.
   subst; simpl; auto.
   apply S4.solve_degree_4_correct.
   injection H; intros; subst; clear H.
   rewrite e; field; auto.
   injection H; intros; subst; clear H.
   apply S4.solve_degree_4_correct.
   field; auto.
  Qed.

  Lemma finv_spec : forall (g : PAD.B.t k) (u : F.t k),
   In u (finv_def g) <-> f_def u = g.
  Proof.
   intros; split.
   apply finv_spec1.
   apply finv_spec2.
  Qed.

  Lemma finv_len_group : (length (F.elems k) <= length (PAD.B.elems k) * finv_len).
  Proof.
   apply le_trans with
    (length (nodup (@Geqb k) (map (@f_def k) (elems k))) * finv_len)%nat.
   apply length_surj_mult with (finv := @finv_def k).
   intros; apply finv_spec.
   intros; apply finv_len_spec.
   apply elems_NoDup.
   apply mult_le_compat_r.
   apply le_trans with (length (PAD.B.elems k)).
   apply length_surj.
   apply Nodup_nodup.
   red; intros.
   apply PAD.B.elems_full.
   auto.
  Qed.

 End PI.

End Icart_PI.


Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq tuple fintype.
Require Import ZArith zint.
Require Export Setoid Relation_Definitions.

Require Import WhileLang.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Definition ident := positive.

Open Scope Z_scope.

(** * Combined State

   The product construction demands ...
*)
Section StateJoin.

Definition idA (f:ident->ident) (i:ident*Z) : ident*Z := (f i.1, i.2).

(** a bijection between [Z+Z] and [Z]                     *)
Definition id_i1 x := xO x.

Lemma id_i1_Nodd: forall x y, xI x == id_i1 y = false.
Proof. move => x y; apply/negP => /eqP H; discriminate H. Qed.

Definition id_i2 x :=
 match x with
 | xI p => xI (xO p)
 | xO p => xI (Pos.pred x)
 | xH => xH
 end.

Lemma id_i2_Neven: forall x y, xO x == id_i2 y = false.
Proof. move => x [y|y|]; apply/negP => /eqP H; discriminate H. Qed.

Lemma id_i2_sel: forall x,
 id_i2 (Pos.succ x) = xI x.
Proof. by move => [x|x|] //=; rewrite Pos.pred_double_succ. Qed.

Definition id_sel (f1 f2:ident -> Z) (i:ident) : Z :=
 match i with
 | xO i' => f1 i'
 | xI i' => f2 (Pos.succ i')
 | xH => f2 xH
 end.
Definition id_selA (f1 f2:ident*Z -> Z) (i:ident*Z) : Z :=
 match i.1 with
 | xO i' => f1 (i',i.2)
 | xI i' => f2 (Pos.succ i',i.2)
 | xH => f2 (xH, i.2)
 end.

Lemma id_sel_i2: forall (f1 f2:ident -> Z) (x:ident),
 id_sel f1 f2 (id_i2 x) = f2 x.
Proof.
move => f1 f2 [x|x|] //=.
by rewrite Pos.succ_pred_double.
Qed.

Lemma id_selA_i2: forall f1 f2 x z,
 id_selA f1 f2 (id_i2 x,z) = f2 (x,z).
Proof.
move => f1 f2 [x|x|] //= z.
by rewrite /id_selA /= Pos.succ_pred_double.
Qed.

Definition joinState (s1 s2:State) : State :=
 (id_sel s1.1 s2.1, id_selA s1.2 s2.2).

Definition splitState (s:State) : State*State :=
 ( (fun i => s.1 (id_i1 i), fun ai => s.2 (idA id_i1 ai))
 , (fun i => s.1 (id_i2 i), fun ai => s.2 (idA id_i2 ai)) ).

Lemma split_joinState_1: forall st1 st2,
 eqstate (splitState (joinState st1 st2)).1 st1.
Proof. by []. Qed.

Lemma split_joinState_2: forall st1 st2,
 eqstate (splitState (joinState st1 st2)).2 st2.
Proof.
rewrite /splitState /joinState => st1 st2 x /=; split.
 by rewrite id_sel_i2.
by move => i; rewrite id_selA_i2.
Qed.

Lemma join_splitState: forall st,
 eqstate (joinState (splitState st).1 (splitState st).2) st.
Proof.
move => st [i|i|]; rewrite /joinState /splitState /idA //=; split.
 by rewrite id_i2_sel.
by rewrite /id_selA /= id_i2_sel.
Qed.

Definition joinStateEqLow (lowMap:VarRestr) (s:State) : Prop :=
 eqstateR lowMap (splitState s).1 (splitState s).2.

Lemma joinState_compat: forall st1 st1',
 eqstate st1 st1' -> forall st2 st2',
 eqstate st2 st2' -> eqstate (joinState st1 st2) (joinState st1' st2').
Proof.
rewrite /joinState => st1 st1' EqS1 st2 st2' EqS2 [x|x|];
rewrite /id_sel /id_selA //=.
Qed.

Lemma splitState_compat1: forall st st',
 eqstate st st' -> eqstate (splitState st).1 (splitState st').1.
Proof.
rewrite /splitState => st st' EqS i /=.
by move: {EqS} (EqS (id_i1 i)) => [H1 H2]; split.
Qed.

Lemma splitState_compat2: forall st st',
 eqstate st st' -> eqstate (splitState st).2 (splitState st').2.
Proof.
rewrite /splitState => st st' EqS i /=.
by move: {EqS} (EqS (id_i2 i)) => [H1 H2]; split.
Qed.

Variable ops: opSig.

Fixpoint ren_expr f (e: expr ops) : expr ops :=
 match e with
 | ValOf l => ValOf (ren_lvalue f l)
 | Const z => @Const ops z
 | Minus e1 e2 => Minus (ren_expr f e1) (ren_expr f e2)
 | Mult e1 e2 => Mult (ren_expr f e1) (ren_expr f e2)
 | Equal e1 e2 => Equal (ren_expr f e1) (ren_expr f e2)
 | Op o args => @Op ops _ (@ren_texpr f (op_arity o) args)
 end
with ren_texpr f {n:nat} (x:texpr ops n) : texpr ops n :=
 match x with
 | t_nil => @t_nil ops
 | t_cons _ x l => t_cons (ren_expr f x) (ren_texpr f l)
 end
with ren_lvalue f l :=
 match l with
 | Var v => @Var _ (f v)
 | ArrCell a e => ArrCell (f a) (ren_expr f e)
 end.

Lemma ren_Minus: forall f (e1 e2:expr ops),
 ren_expr f (Minus e1 e2) = Minus (ren_expr f e1) (ren_expr f e2).
Proof. by []. Qed.

Lemma ren_Mult: forall f (e1 e2:expr ops),
 ren_expr f (Mult e1 e2) = Mult (ren_expr f e1) (ren_expr f e2).
Proof. by []. Qed.

Lemma ren_Equal: forall f (e1 e2:expr ops),
 ren_expr f (Equal e1 e2) = Equal (ren_expr f e1) (ren_expr f e2).
Proof. by []. Qed.

Lemma ren_tcons: forall f (e:expr ops) n (t:texpr ops n),
 ren_texpr f (t_cons e t) = t_cons (ren_expr f e) (ren_texpr f t).
Proof. by []. Qed.

Lemma ren_ArrCell: forall f a (e:expr ops),
 ren_lvalue f (ArrCell a e) = ArrCell (f a) (ren_expr f e).
Proof. by []. Qed.

Definition expr_i1 e := ren_expr id_i1 e.
Definition expr_i2 e := ren_expr id_i2 e.
Definition lvalue_i1 e := ren_lvalue id_i1 e.
Definition lvalue_i2 e := ren_lvalue id_i2 e.

Lemma eval_expr_join_i1: forall e st1 st2,
 eval_expr (joinState st1 st2) (expr_i1 e) = eval_expr st1 e.
Proof.
pose P1 e := (forall st1 st2 : State,
 eval_expr (joinState st1 st2) (ren_expr xO e) = eval_expr st1 e).
pose P2 n (args: texpr ops n) := (forall (st1 st2 : State) zl,
 eval_texpr (joinState st1 st2) zl (ren_texpr xO args)
 = eval_texpr st1 zl args).
pose P3 l := (forall st1 st2 : State,
 eval_lvalue (joinState st1 st2) (ren_lvalue xO l) = eval_lvalue st1 l).
apply (@expr_mixed_ind ops P1 P2 P3); unfold P1, P2, P3.
(* ValOf *)
move => l IH st1 st2.
by apply IH.
(* Const *)
by move => z st1 st2 /=.
(* Minus *)
move => e1 IH1 e2 IH2 st1 st2 /=.
have ->: forall st e1 e2,
         eval_expr st (Minus e1 e2) = eval_expr st e1 - eval_expr st e2 by [].
by rewrite IH1 IH2.
(* Mult *)
move => e1 IH1 e2 IH2 st1 st2 /=.
have ->: forall st e1 e2,
         eval_expr st (Mult e1 e2) = eval_expr st e1 * eval_expr st e2 by [].
by rewrite IH1 IH2.
(* Equal *)
move => e1 IH1 e2 IH2 st1 st2 /=.
have ->: forall st e1 e2,
         eval_expr st (Equal e1 e2)
         = (if eval_expr st e1 == eval_expr st e2 then 1 else 0) by [].
by rewrite IH1 IH2.
(* Op *)
move => o args IH st1 st2 /=.
have ->: forall st (args:texpr ops (op_arity o)),
         eval_expr st (Op args)
         = op_sem o (eval_texpr st [::] args) by [].
by rewrite IH.
(* t_nil *)
by move => st1 st2.
(* t_cons *)
move => n e IHe args IHargs st1 st2 zl /=.
have E: forall st zl n e (args:texpr ops n),
         eval_texpr st zl (t_cons e args)
         = eval_texpr st [:: eval_expr st e & zl] args by [].
by rewrite !E IHe IHargs.
(* Var *)
move => v st1 st2 /=.
have E: forall st v,
         eval_lvalue st (Var ops v)
         = st.1 v by [].
by rewrite !E.
(* ArrCell *)
move => a i IHi st1 st2 /=.
have E: forall st a e,
         eval_lvalue st (ArrCell a e)
         = st.2 (a,eval_expr st e) by [].
by rewrite !E /= /id_selA /= IHi.
Qed.

Lemma eval_expr_join_i2: forall e st1 st2,
 eval_expr (joinState st1 st2) (expr_i2 e) = eval_expr st2 e.
Proof.
pose P1 e := (forall st1 st2 : State,
 eval_expr (joinState st1 st2) (ren_expr id_i2 e) = eval_expr st2 e).
pose P2 n (args: texpr ops n) := (forall (st1 st2 : State) zl,
 eval_texpr (joinState st1 st2) zl (ren_texpr id_i2 args)
 = eval_texpr st2 zl args).
pose P3 l := (forall st1 st2 : State,
 eval_lvalue (joinState st1 st2) (ren_lvalue id_i2 l) = eval_lvalue st2 l).
apply (@expr_mixed_ind ops P1 P2 P3); unfold P1, P2, P3.
(* ValOf *)
move => l IH st1 st2.
by apply IH.
(* Const *)
by move => z st1 st2 /=.
(* Minus *)
move => e1 IH1 e2 IH2 st1 st2 /=.
have ->: forall st e1 e2,
         eval_expr st (Minus e1 e2) = eval_expr st e1 - eval_expr st e2 by [].
by rewrite IH1 IH2.
(* Mult *)
move => e1 IH1 e2 IH2 st1 st2 /=.
have ->: forall st e1 e2,
         eval_expr st (Mult e1 e2) = eval_expr st e1 * eval_expr st e2 by [].
by rewrite IH1 IH2.
(* Equal *)
move => e1 IH1 e2 IH2 st1 st2 /=.
have ->: forall st e1 e2,
         eval_expr st (Equal e1 e2)
         = (if eval_expr st e1 == eval_expr st e2 then 1 else 0) by [].
by rewrite IH1 IH2.
(* Op *)
move => o args IH st1 st2 /=.
have ->: forall st (args:texpr ops (op_arity o)),
         eval_expr st (Op args)
         = op_sem o (eval_texpr st [::] args) by [].
by rewrite IH.
(* t_nil *)
by move => st1 st2.
(* t_cons *)
move => n e IHe args IHargs st1 st2 zl /=.
have E: forall st zl n e (args:texpr ops n),
         eval_texpr st zl (t_cons e args)
         = eval_texpr st [:: eval_expr st e & zl] args by [].
by rewrite !E IHe IHargs.
(* Var *)
move => v st1 st2 /=.
have E: forall st v,
         eval_lvalue st (Var ops v)
         = st.1 v by [].
by rewrite !E /= id_sel_i2.
(* ArrCell *)
move => a i IHi st1 st2 /=.
have E: forall st a e,
         eval_lvalue st (ArrCell a e)
         = st.2 (a,eval_expr st e) by [].
by rewrite !E /= IHi id_selA_i2 /=.
Qed.

Lemma updLValue_join_i1: forall st1 st2 x y,
 eqstate (updLValue (joinState st1 st2) (lvalue_i1 x) y)
         (joinState (updLValue st1 x y) st2).
Proof.
move => st1 st2 [v|a e] y x /=; rewrite /upd; split => //=.
 move: x => [x|x|] //=.
 by rewrite id_i1_Nodd.
move: x => [x|x|] z; rewrite /id_selA xpair_eqE ?id_i1_Nodd //=.
by rewrite xpair_eqE /id_i1 eval_expr_join_i1.
Qed.
Lemma updLValue_join_i2: forall st1 st2 x y,
 eqstate (updLValue (joinState st1 st2) (lvalue_i2 x) y)
         (joinState st1 (updLValue st2 x y)).
Proof.
have P: forall x y, Pos.succ x == y = (xI x == id_i2 y).
 move => x y; case E: (y==Pos.succ x).
  rewrite (eqP E) eq_refl /id_i2 /= ; destruct x => //=.
   by rewrite Pos.pred_double_succ eq_refl.
  by rewrite eq_refl.
 rewrite eq_sym in E; rewrite E /id_i2; symmetry; apply/negP => /eqP HH.
 move/negP: E; apply; apply/eqP.
 destruct y; rewrite //= in HH; injection HH => -> //=.
 by rewrite Pos.succ_pred_double.
move => st1 st2 [v|a e] y x /=; rewrite /upd; split => //=.
 move: x => [x|x|] //=.
   by rewrite P.
  by rewrite id_i2_Neven.
 by destruct v.
move: x => [x|x|] z;
rewrite /id_selA xpair_eqE ?id_i2_Neven //= xpair_eqE eval_expr_join_i2.
 by rewrite P.
by destruct a.
Qed.

Lemma eval_updLValue_i1: forall st1 st2 x y e,
 eval_expr (updLValue (joinState st1 st2) (lvalue_i1 x) y) (expr_i2 e)
 = eval_expr (joinState st1 st2) (expr_i2 e).
Proof.
by move=> st1 st2 x y e; rewrite updLValue_join_i1 !eval_expr_join_i2.
Qed.

End StateJoin.

Definition eqstatePair (ssa ssb:State*State) : Prop :=
 eqstate ssa.1 ssb.1 /\ eqstate ssa.2 ssb.2.

Lemma eqstatePair_refl: forall ss, eqstatePair ss ss.
Proof. rewrite /eqstatePair; move => [s1 s2] /=; split; reflexivity. Qed.

Lemma eqstatePair_sym: forall ss1 ss2,
 eqstatePair ss1 ss2 -> eqstatePair ss2 ss1.
Proof.
by rewrite /eqstatePair; move => [s11 s12] [s21 s22] /= [-> ->]; split.
Qed.

Lemma eqstatePair_trans: forall ss1 ss2 ss3,
 eqstatePair ss1 ss2 -> eqstatePair ss2 ss3 -> eqstatePair ss1 ss3.
Proof.
rewrite /eqstatePair.
by move => [s11 s12] [s21 s22] [s31 s32] /= [-> ->] [-> ->]; split.
Qed.

Add Parametric Relation : (State*State) eqstatePair
 reflexivity proved by eqstatePair_refl
 symmetry proved by eqstatePair_sym
 transitivity proved by eqstatePair_trans
 as eqstatePair_equiv.

Add Parametric Morphism : joinState
 with signature eqstate ==> eqstate ==> eqstate
 as joinState_morph.
Proof. by apply joinState_compat. Qed.

Add Parametric Morphism : splitState
 with signature eqstate ==> eqstatePair
 as splitState_morph.
Proof.
rewrite /eqstatePair => s1 s2 EqS.
by rewrite splitState_compat1 // splitState_compat2 //.
Qed.

Add Parametric Morphism : (@fst State State)
 with signature eqstatePair ==> eqstate
 as fstState_morph.
Proof.
by rewrite /eqstatePair; move => [s11 s12] [s21 s22] /= [-> _].
Qed.

Add Parametric Morphism : (@snd State State)
 with signature eqstatePair ==> eqstate
 as sndState_morph.
Proof.
by rewrite /eqstatePair; move => [s11 s12] [s21 s22] /= [_ ->].
Qed.

Section ProdTrf.

Variable ops: opSig.

(** * Leakage-specification:

*)
Record LeakSpec :=
 { lFun :> @LeakFun ops
 ; preleak: expr ops -> seq (expr ops)
 ; preleak_ren: forall f e,
     preleak (ren_expr f e) = map (ren_expr f) (preleak e)
 ; preleak_prod: forall s1 s2 e,
     (leak_expr preleak s1 e == leak_expr preleak s2 e)
     = (leak_expr lFun s1 e == leak_expr lFun s2 e)
 }.

Variable lspec: LeakSpec.

Definition EqLeak (e1 e2: expr ops): expr ops :=
 EqSeqExpr (preleak lspec e1) (preleak lspec e2).

Lemma isTrue_EqLeak: forall st1 st2 e,
 isTrue_expr (joinState st1 st2) (EqLeak (expr_i1 e) (expr_i2 e))
 <-> leak_expr (preleak lspec) st1 e = leak_expr (preleak lspec) st2 e.
Proof.
move=> st1 st2 e;
rewrite isTrue_EqSeqExpr /leak_expr !preleak_ren -map_comp.
have ->:[seq eval_expr (joinState st1 st2) (ren_expr id_i1 x)
        | x <- preleak lspec e] = [seq eval_expr st1 x | x <- preleak lspec e].
 by apply eq_map => x; rewrite eval_expr_join_i1.
rewrite -map_comp.
have ->:[seq eval_expr (joinState st1 st2) (ren_expr id_i2 x)
        | x <- preleak lspec e] = [seq eval_expr st2 x | x <- preleak lspec e].
 by apply eq_map => x; rewrite eval_expr_join_i2.
have ->: [seq inr (eval_expr st1 e0) | e0 <- preleak lspec e] =
         map (@inr bool Z) [seq eval_expr st1 x | x <- preleak lspec e] .
 by rewrite map_comp.
have ->: [seq inr (eval_expr st2 e0) | e0 <- preleak lspec e] =
         map (@inr bool Z) [seq eval_expr st2 x | x <- preleak lspec e] .
 by rewrite map_comp.
split => H; first by rewrite H.
have inr_inj: injective (@inr bool Z) by move=> x1 x2 [->].
by apply (inj_map inr_inj).
Qed.

Definition assertEqLeakTest (e1 e2: expr ops): cmd ops :=
 Assert (And (Equal (IsTrue e1) (IsTrue e2))
             (EqLeak e1 e2)).

Fixpoint prod_cmd (c:cmd ops) : cmd ops :=
 match c with
 | Skip => @Skip _
 | Assume e => Seq (Assume (expr_i1 e)) (Assume (expr_i2 e))
 | Assert e => Seq (Assert (expr_i1 e)) (Assert (expr_i2 e))
 | Assign l e =>
    Seq (Assert (And (EqLeak (ValOf (lvalue_i1 l)) (ValOf (lvalue_i2 l)))
                     (EqLeak (expr_i1 e) (expr_i2 e))))
        (Seq (Assign (lvalue_i1 l) (expr_i1 e))
             (Assign (lvalue_i2 l) (expr_i2 e)))
 | Seq c1 c2 => Seq (prod_cmd c1) (prod_cmd c2)
 | If b c1 c2 =>
    Seq (assertEqLeakTest (expr_i1 b) (expr_i2 b))
        (If (expr_i1 b) (prod_cmd c1) (prod_cmd c2))
 | While b c =>
    Seq (assertEqLeakTest (expr_i1 b) (expr_i2 b))
        (While (expr_i1 b)
               (Seq (prod_cmd c)
                    (assertEqLeakTest (expr_i1 b) (expr_i2 b))))
 end.

Lemma prod_cmdA: forall c,
 assertionCmd (prod_cmd c) = false.
Proof. by move => [||||||]. Qed.

(** A specialised induction principle for handling evaluation of the
   transformed program...                                                 *)
Lemma eval_prod_ind
  (P : State -> cmd ops -> Leakage -> State -> Prop)
  (Hskip: forall st st' : State, eqstate st st' -> P st (Skip ops) [::] st')
  (Hassume: forall (st st' : State) (e : expr ops),
             eqstate st st' ->
             isTrue_expr st (expr_i1 e) ->
             isTrue_expr st (expr_i2 e) -> P st (Assume e) [::] st')
  (Hassert: forall (st st' : State) (e : expr ops),
             eqstate st st' ->
             isTrue_expr st (expr_i1 e) ->
             isTrue_expr st (expr_i2 e) -> P st (Assert e) [::] st')
  (Hassign: forall (st st' : State) (x : lvalue ops) (e : expr ops),
             eqstate
              (updLValue
               (updLValue st (lvalue_i1 x) (eval_expr st (expr_i1 e)))
               (lvalue_i2 x) (eval_expr (updLValue st (lvalue_i1 x) (eval_expr st (expr_i1 e))) (expr_i2 e))) st' ->
             isTrue_expr st (EqLeak (expr_i1 (ValOf x)) (expr_i2 (ValOf x))) ->
             isTrue_expr st (EqLeak (expr_i1 e) (expr_i2 e)) ->
             P st (Assign x e)
               (leak_expr lspec st (expr_i1 (ValOf x)) ++
                leak_expr lspec st (expr_i1 e) ++
                leak_expr lspec
                    (updLValue st (lvalue_i1 x) (eval_expr st (expr_i1 e)))
                    (expr_i2 (ValOf x)) ++
                leak_expr lspec
                    (updLValue st (lvalue_i1 x) (eval_expr st (expr_i1 e)))
                    (expr_i2 e)) st')
  (Hseq: forall (st1 st2 st3 : State) (c1 c2 : cmd ops) (l1 l2 : Leakage),
          eval_cmd lspec st1 (prod_cmd c1) l1 (Some st2) ->
          P st1 c1 l1 st2 ->
          eval_cmd lspec st2 (prod_cmd c2) l2 (Some st3) ->
          P st2 c2 l2 st3 -> P st1 (Seq c1 c2) (l1 ++ l2) st3)
  (HifT: forall (st1 st2 : State) (b : expr ops) (c1 c2 : cmd ops) l1,
          isTrue_expr st1 (expr_i1 b) ->
          isTrue_expr st1 (EqLeak (expr_i1 b) (expr_i2 b)) ->
          isTrue_expr st1 (Equal (IsTrue (expr_i1 b)) (IsTrue (expr_i2 b))) ->
          eval_cmd lspec st1 (prod_cmd c1) l1 (Some st2) ->
          P st1 c1 l1 st2 ->
          P st1 (If b c1 c2)
            (leak_expr lspec st1 (expr_i1 b) ++ inl true :: l1) st2)
  (HifF: forall (st1 st2 : State) (b : expr ops) (c1 c2 : cmd ops) l1,
          ~~ isTrue_expr st1 (expr_i1 b) ->
          isTrue_expr st1 (EqLeak (expr_i1 b) (expr_i2 b)) ->
          isTrue_expr st1 (Equal (IsTrue (expr_i1 b)) (IsTrue (expr_i2 b))) ->
          eval_cmd lspec st1 (prod_cmd c2) l1 (Some st2) ->
          P st1 c2 l1 st2 ->
          P st1 (If b c1 c2)
            (leak_expr lspec st1 (expr_i1 b) ++ inl false :: l1) st2)
  (HwhileT: forall (st1 st2 st3 : State) (b : expr ops) (c : cmd ops) l1 l2,
          isTrue_expr st1 (expr_i1 b) ->
          isTrue_expr st1 (EqLeak (expr_i1 b) (expr_i2 b)) ->
          isTrue_expr st1 (Equal (IsTrue (expr_i1 b)) (IsTrue (expr_i2 b))) ->
          eval_cmd lspec st1 (prod_cmd c) l1 (Some st2) ->
          P st1 c l1 st2 ->
          isTrue_expr st2 (EqLeak (expr_i1 b) (expr_i2 b)) ->
          isTrue_expr st2 (Equal (IsTrue (expr_i1 b)) (IsTrue (expr_i2 b))) ->
          eval_cmd lspec st2
               (While (expr_i1 b)
                 (Seq (prod_cmd c) (assertEqLeakTest (expr_i1 b) (expr_i2 b))))
               l2 (Some st3) ->
          P st2 (While b c) l2 st3 ->
          P st1 (While b c)
               (leak_expr lspec st1 (expr_i1 b) ++ inl true :: l1 ++ l2) st3)
  (HwhileF: forall (st st' : State) (b : expr ops) (c : cmd ops),
          eqstate st st' ->
          ~~ isTrue_expr st (expr_i1 b) ->
          isTrue_expr st (EqLeak (expr_i1 b) (expr_i2 b)) ->
          isTrue_expr st (Equal (IsTrue (expr_i1 b)) (IsTrue (expr_i2 b))) ->
          P st (While b c)
               (leak_expr lspec st (expr_i1 b) ++ [:: inl false]) st')
  : forall (s : State) (c : cmd ops) (l : Leakage) (s' : State),
   eval_cmd lspec s (prod_cmd c) l (Some s') -> P s c l s'.
Proof.
move => s c l s' H; move: (H).
move/eval_cmd_unsafe: H.
move: {1 3}(Some s') (eqstateOpt_refl (Some s')) => os Es.
move: {1 3}(unsafe (prod_cmd c)) (Logic.eq_refl (unsafe (prod_cmd c)))
=> c' E H.
elim: H s' Es c E => {os s l c'}
 [ st st' EqS1
 | st st' e EqS1 Ee
 | st st' e EqS1 Ee | st e Ee
 | st st' x e EqS1
 | sta1 sta2 [sta3|] c1 c2 l1 l2 H1 IH1 H2 IH2
 | sta1 c1 c2 l1 l2 IH
 | st st' b c1 c2 l1 Eb H1 IH1
 | st st' b c1 c2 l1 Eb H IH
 | st st' st'' b c' l1' l2' Eb H1 IH1 H2 IH2
 | st b c' l' Eb H1 IH
 | st st' b c' Eb EqS1] s //= Es c Ec Heval.
- (* skip *)
move: c Ec Heval => [|e|e|? ?|? ?|? ? ?|? ?] /= Ec;
(discriminate Ec || subst).
   (* skip *)
   by move=> _; apply Hskip; rewrite EqS1.
  (* assume *)
  move=> /= /eval_cmd_SeqSI [s' [l1' [l2' [H1 H2 _]]]].
  move/eval_cmd_AssumeI: H1 => [Te1 /= Es1 _].
  move/eval_cmd_AssumeI: H2 => [Te2 /= Es2 _].
  by apply Hassume => //; rewrite Es1.
 (* assert *)
 move=> /= /eval_cmd_SeqSI [s' [l1' [l2' [H1 H2 _]]]].
 move/eval_cmd_AssertSI: H1 => [Te1 /= Es1 _].
 move/eval_cmd_AssertSI: H2 => [Te2 /= Es2 _].
 by apply Hassert => //; rewrite Es1.
(* seq *)
rewrite !prod_cmdA in Ec; discriminate Ec.
- (* assume *)
move: c Ec Heval => [|?|?|? ?|? ?|? ? ?|? ?] /= Ec;
rewrite /= ?prod_cmdA in Ec; discriminate Ec.
- (* assertT *)
move: c Ec Heval => [|?|?|? ?|? ?|? ? ?|? ?] /= Ec;
rewrite /= ?prod_cmdA in Ec; discriminate Ec.
- (* assign *)
move: c Ec Heval => [|?|?|? ?|? ?|? ? ?|? ?] /= Ec;
rewrite /= ?prod_cmdA in Ec; discriminate Ec.
- (* seqS *)
move: c Ec Heval => [|?|?|xa ea|ca cb|? ? ?|? ?] /= Ec;
(discriminate Ec || move: Ec).
 (* assign *)
 move=> [Ec1 Ec2]; subst.
 move=> /eval_cmd_SeqSI [sa1 [la1 [la2 [Ha Hb El1]]]].
 move: Ha => /eval_cmd_AssertSI.
 rewrite isTrue_And => [[/andP[Ha1 Ha2] Ha3 Ha4]].
 move: Hb => /eval_cmd_SeqSI [sb1 [lb1 [lb2 [Hb Hc El2]]]].
 move: Hb => /eval_cmd_AssignI [/= Hb1 Hb2].
 move: Hc => /eval_cmd_AssignI [/= Hc1 Hc2]; subst.
 rewrite El1 /= -!Ha3 -!catA.
 change (ValOf (lvalue_i1 xa)) with (expr_i1 (ValOf xa)).
 change (ValOf (lvalue_i2 xa)) with (expr_i2 (ValOf xa)).
 rewrite Hb1 -Ha3; apply Hassign => //.
 by rewrite Hc1 Hb1 Ha3.
(* seq *)
rewrite /= ?prod_cmdA => /= [[Ec1 Ec2] Heval]; subst.
move: Heval => /eval_cmd_SeqSI [sa1 [la1 [la2 [Ha Hb _]]]].
move: {H1} (eval_cmd_determ H1 (eval_cmd_unsafe Ha) (eqstate_refl sta1))
=> [El1 /= Es1].
move: {H2} (eval_cmd_determ H2 (eval_cmd_unsafe Hb) Es1) => [El2 /= H2]; subst.
apply Hseq with sta2 => //.
   by rewrite Es1.
  by apply IH1; rewrite // Es1.
 by rewrite Es1.
by apply IH2; rewrite // Es1.
- (* ifT *)
move: c Ec Heval => [|?|?|? ?|? ?|b' ca cb|? ?] /= Ec;
(discriminate Ec || move: Ec).
 (* seq *)
 rewrite !prod_cmdA => Ec; discriminate Ec.
(* if *)
move=> /= [Ec1 [Ec2 Ec3]]; subst.
move=> /eval_cmd_SeqSI [sa1 [la1 [la2 [Ha Hb _]]]].
move: Ha => /eval_cmd_AssertSI.
rewrite isTrue_And => [[/andP[Ha1 Ha2] Ha3 Ha4]].
move: Hb => /eval_cmd_IfI [l'].
rewrite -> Ha3 in Eb; rewrite Eb.
move => [Hb1 Hb2].
move: {H1} (eval_cmd_determ H1 (eval_cmd_unsafe Hb1) Ha3) => [El2 H1]; subst.
apply HifT => //.
  by rewrite Ha3.
 by rewrite Ha3.
apply IH1 => //.
by rewrite Ha3.
- (* ifF *)
move: c Ec Heval => [|?|?|? ?|? ?|b' ca cb|? ?] /= Ec;
(discriminate Ec || move: Ec).
 (* seq *)
 rewrite !prod_cmdA => Ec; discriminate Ec.
(* if *)
move=> /= [Ec1 [Ec2 Ec3]]; subst.
move=> /eval_cmd_SeqSI [sa1 [la1 [la2 [Ha Hb _]]]].
move: Ha => /eval_cmd_AssertSI.
rewrite isTrue_And => [[/andP[Ha1 Ha2] Ha3 Ha4]].
move: Hb => /eval_cmd_IfI [l'].
rewrite -> Ha3 in Eb; rewrite (negPf Eb).
move => [Hb1 Hb2].
move: {H} (eval_cmd_determ H (eval_cmd_unsafe Hb1) Ha3) => [El2 H]; subst.
apply HifF => //.
  by rewrite Ha3.
 by rewrite Ha3.
apply IH => //.
by rewrite Ha3.
- (* whileT *)
move: c Ec Heval => [|?|?|? ?|? ?|? ? ?|ba ca] /= Ec;
(discriminate Ec || move: Ec).
 (* seq *)
 rewrite !prod_cmdA => Ec; discriminate Ec.
(* whileT *)
move=> [Ec1 Ec2]; rewrite prod_cmdA in Ec2 ; subst.
move=> /eval_cmd_SeqSI [sa1 [la1 [la2 [Ha Hb _]]]].
move: Ha => /eval_cmd_AssertSI.
rewrite isTrue_And => [[/andP[Ha1 Ha2] Ha3 Ha4]].
move: Hb => /eval_cmd_WhileSI.
rewrite -> Ha3 in Eb; rewrite Eb.
move=> [sb [lb1 [lb2 [Hb1 Hb2 Hb3]]]].
move: Hb1 => /eval_cmd_SeqSI [sc [lc1 [lc2 [Hc1]]]].
move=> /eval_cmd_AssertSI.
rewrite isTrue_And; move=> [/andP [Hc2 Hc3] Hc4] Hc5 Hc6; subst.
move: {H1} (eval_cmd_determ H1 (eval_cmd_unsafe Hc1) Ha3) => [El2 /=H1].
move: (eval_cmd_unsafe Hb2); rewrite /= !prod_cmdA => H2'.
rewrite -> Hc4 in H1; move: {H2} (eval_cmd_determ H2 H2' H1).
rewrite Es /=; move=> [El3 /= H2]; subst.
apply HwhileT with st' => //.
      by rewrite Ha3.
     by rewrite Ha3 H1 -Hc4.
    apply IH1 => //=.
    by rewrite Ha3 H1 -Hc4.
   by rewrite H1 -Hc4.
  by rewrite H1 -Hc4.
 by rewrite H1.
apply IH2 => //=; first by rewrite !prod_cmdA.
change lb2 with ([::]++lb2).
apply eval_SeqS with st'.
 constructor => //.
 by rewrite H1 -Hc4 isTrue_And; apply/andP; split.
by rewrite H1.
- (* whileF *)
move: c Ec Heval => [|?|?|? ?|? ?|? ? ?|ba ca] /= Ec;
(discriminate Ec || move: Ec).
 (* seq *)
 rewrite !prod_cmdA => Ec; discriminate Ec.
(* whileF *)
move=> [Ec1 Ec2]; rewrite prod_cmdA in Ec2 ; subst.
move=> /eval_cmd_SeqSI [sa1 [la1 [la2 [Ha Hb _]]]].
move: Ha => /eval_cmd_AssertSI.
rewrite isTrue_And => [[/andP[Ha1 Ha2] Ha3] Ha4].
move: Hb => /eval_cmd_WhileSI.
rewrite -> Ha3 in Eb; rewrite (negPf Eb); move => [Hb1 Hb2]; subst.
apply HwhileF => //=.
 by rewrite EqS1 Es.
by rewrite Ha3.
Qed.

Lemma prod_cmd_sound': forall st1 c l1 st1' st2 l2 st2',
 eval_cmd lspec st1 c l1 (Some st1') ->
 eval_cmd lspec st2 c l2 (Some st2') ->
 l1 == l2 ->
 exists l : Leakage,
  eval_cmd lspec (joinState st1 st2)
           (prod_cmd c) l (Some (joinState st1' st2')).
Proof.
move => st1 c l1 st1' st2 l2 st2'.
move: {1 3}(Some st1') (eqstateOpt_refl (Some st1')) => os Eos H1.
elim: H1 st1' Eos st2 l2 st2'
=> [ sta stb EqSab
   | sta stb e EqSab Ee
   | sta stb e EqSab Ee | sta e Ee
   | sta stb x e EqSab
   | sta stb stc ca cb la lb Ha /= IHa Hb IHb
   | sta c1 c2 la lb /= IH
   | sta stb b ca cb la Eb Ha /= IHa
   | sta stb b ca cb lb Eb Hb /= IHb
   | sta stb stc b cb la lb Eb Ha /= IHa Hb IHb
   | sta b cb lb Eb Ha IHa
   | sta stb b cb Eb EqSab] st1' //= Es1' st2 l2 st2'.
- (* Skip *)
move=> /eval_cmd_SkipI [/= EqS _] _.
exists [::]; constructor.
by rewrite EqSab Es1' EqS.
- (* Assume *)
move=> /eval_cmd_AssumeI [H /= EqS _] _.
exists ([::]++[::]); apply eval_SeqS with (joinState sta st2).
 constructor => //.
 by rewrite /isTrue_expr eval_expr_join_i1.
constructor => //.
 by rewrite EqSab Es1' EqS.
by rewrite /isTrue_expr eval_expr_join_i2.
- (* AssertS *)
move=> /eval_cmd_AssertSI [H /= EqS _] _.
exists ([::]++[::]); apply eval_SeqS with (joinState sta st2).
 constructor => //.
 by rewrite /isTrue_expr eval_expr_join_i1.
constructor => //.
 by rewrite EqSab Es1' EqS.
by rewrite /isTrue_expr eval_expr_join_i2.
- (* Assign *)
move=> /eval_cmd_AssignI [//= Es1 ->].
rewrite eqleak_split => /andP [El1 El2].
exists ([::]++
   (leak_expr lspec (joinState sta st2) (expr_i1 (ValOf x))
    ++leak_expr lspec (joinState sta st2) (expr_i1 e))
    ++(leak_expr lspec (joinState (updLValue sta x (eval_expr sta e)) st2) (expr_i2 (ValOf x))
    ++leak_expr lspec (joinState (updLValue sta x (eval_expr sta e)) st2) (expr_i2 e))).
apply eval_SeqS with (joinState sta st2).
 constructor => //.
 change (ValOf (lvalue_i1 x)) with (expr_i1 (ValOf x)).
 change (ValOf (lvalue_i2 x)) with (expr_i2 (ValOf x)).
 rewrite isTrue_And; apply/andP; split.
  by rewrite isTrue_EqLeak; apply/eqP; rewrite preleak_prod.
 by rewrite isTrue_EqLeak; apply/eqP; rewrite preleak_prod.
apply eval_SeqS with (joinState stb st2).
 constructor => //.
 by rewrite updLValue_join_i1 eval_expr_join_i1 EqSab.
rewrite !EqSab; constructor => //.
by  rewrite updLValue_join_i2 eval_expr_join_i2 -Es1 Es1'.
- (* seq *)
move=> /eval_cmd_SeqI [[//= H1 H2] H3|[s' [l1' [l2' [H1 H2 H3 H4]]]]]; subst.
move: {H4} (eval_cmd_leak_split Ha H1 H4) => /andP [/eqP El1 /eqP El2]; subst.
move: {IHa Ha H1} (IHa _ (eqstate_refl stb) _ _ _ H1 (eq_refl _)).
move=> [lta Hta].
rewrite -> Es1' in Hb.
move: {IHb Hb H2} (IHb _ Es1' _ _ _ H2 (eq_refl _)).
move=> [ltb Htb].
by exists (lta++ltb); apply eval_SeqS with (joinState stb s').
- (* ifT *)
move=> /eval_cmd_IfI [l'].
case/boolP: (isTrue_expr st2 b); last first.
 by move=> _ [_ ->]; rewrite eqleak_split !eqE /= andbF.
move=> Eb' [H1 El2]; rewrite El2 eqleak_split !eqE /= =>/andP[El El'].
move: {IHa Ha H1} (IHa _ Es1' _ _ _ H1 El') => [lta Hta].
exists ([::] ++ (leak_expr lspec (joinState sta st2) (expr_i1 b) ++ inl true :: lta)); apply eval_SeqS with (joinState sta st2).
 constructor => //.
 rewrite isTrue_And isTrue_Equal; apply/andP; split.
  rewrite !eval_IsTrue eval_expr_join_i1 eval_expr_join_i2.
  by move: Eb Eb'; rewrite /isTrue_expr => /negPf -> /negPf ->.
 by rewrite isTrue_EqLeak; apply/eqP; rewrite preleak_prod.
constructor => //.
by rewrite /isTrue_expr eval_expr_join_i1.
- (* ifF *)
move=> /eval_cmd_IfI [l'].
case/boolP: (isTrue_expr st2 b).
 by move=> _ [_ ->]; rewrite eqleak_split !eqE /= andbF.
move=> Eb' [H1 El2]; rewrite El2 eqleak_split !eqE /= =>/andP[El El'].
move: {IHb Hb H1} (IHb _ Es1' _ _ _ H1 El') => [ltb Htb].
exists ([::] ++ (leak_expr lspec (joinState sta st2) (expr_i1 b) ++ inl false :: ltb)); apply eval_SeqS with (joinState sta st2).
 constructor => //.
 rewrite isTrue_And isTrue_Equal; apply/andP; split.
  rewrite !eval_IsTrue eval_expr_join_i1 eval_expr_join_i2.
  by move: Eb Eb'; rewrite /isTrue_expr => /negPn -> /negPn ->.
 by rewrite isTrue_EqLeak; apply/eqP; rewrite preleak_prod.
constructor => //.
by rewrite /isTrue_expr eval_expr_join_i1.
- (* whileT *)
move=> /eval_cmd_WhileSI; case/boolP: (isTrue_expr st2 b); last first.
 by move=> _ [_ ->]; rewrite eqleak_split !eqE /= andbF.
move=> Eb' [s' [l1' [l2' [H1 H2 El2]]]].
rewrite El2 eqleak_split !eqE /= =>/andP [Eleak Ell].
move: {Ell} (eval_cmd_leak_split Ha H1 Ell) => /andP [Ela Elb].
move: {IHa Ha H1} (IHa _ (eqstate_refl stb) _ _ _ H1 Ela) => [lta Hta].
move: {IHb Hb H2} (IHb _ Es1' _ _ _ H2 Elb) => [ltb].
move=> /eval_cmd_SeqSI [sb [ltb1 [ltb2 []]]].
move=> /eval_cmd_AssertSI [Hleak2 <- -> Htb /= Eltb].
exists ([::] ++ (leak_expr lspec (joinState sta st2) (expr_i1 b) ++ inl true :: lta ++ ltb)).
apply eval_SeqS with (joinState sta st2).
 constructor => //.
 rewrite isTrue_And isTrue_Equal; apply/andP; split.
  rewrite !eval_IsTrue eval_expr_join_i1 eval_expr_join_i2.
  by move: Eb Eb'; rewrite /isTrue_expr => /negPf -> /negPf ->.
 by rewrite isTrue_EqLeak; apply/eqP; rewrite preleak_prod.
apply eval_WhileTS with (joinState stb s') => //.
  by rewrite /isTrue_expr eval_expr_join_i1.
 rewrite -[lta]cats0.
 apply eval_SeqS with (joinState stb s') => //.
 by constructor.
by rewrite Eltb.
- (* whileF *)
move=> /eval_cmd_WhileSI; case/boolP: (isTrue_expr st2 b).
 by move=> _ [? [? [? [_ _ ->]]]]; rewrite eqleak_split !eqE /= andbF.
move=> Eb' [Es2 ->] El.
exists ([::]++(leak_expr lspec (joinState sta st2) (expr_i1 b) ++ [:: inl false])).
apply eval_SeqS with (joinState sta st2); constructor => //.
  rewrite isTrue_And; apply/andP; split.
   rewrite /isTrue_expr eval_Equal !eval_IsTrue
           eval_expr_join_i1 eval_expr_join_i2.
   by move: Eb Eb'; rewrite /isTrue_expr => /negPn -> /negPn ->.
  rewrite isTrue_EqLeak; apply/eqP; rewrite preleak_prod.
  by move: El; rewrite eqleak_split => /andP [? _].
 by rewrite /isTrue_expr eval_expr_join_i1.
by rewrite EqSab Es1' Es2.
Qed.

Lemma prod_cmd_complete': forall c st1 st2 l st',
 eval_cmd lspec (joinState st1 st2) (prod_cmd c) l (Some st') ->
 exists (l: Leakage),
  eval_cmd lspec st1 c l (Some (splitState st').1) /\
  eval_cmd lspec st2 c l (Some (splitState st').2).
Proof.
move => c st1 st2 l st'.
move: {1 3}(joinState st1 st2) (eqstate_refl (joinState st1 st2)).
move => s12 Es12 H.
move: H st1 st2 Es12.
pose P s12 c (l:Leakage) st' := forall st1 st2 : State,
   eqstate s12 (joinState st1 st2) ->
   exists l: Leakage,
     eval_cmd lspec st1 c l (Some (splitState st').1) /\
     eval_cmd lspec st2 c l (Some (splitState st').2).
apply (@eval_prod_ind P); rewrite /P {c l s12 st' P}.
(* skip *)
move=> sa sb Es s1 s2 Es'.
exists [::].
by rewrite -!Es !Es' split_joinState_1 split_joinState_2; split; constructor.
(* assume *)
move=> sa sb e Es Ee1 Ee2 s1 s2 Es'.
exists [::].
rewrite -!Es !Es' split_joinState_1 split_joinState_2; split; constructor=> //.
 by move: Ee1; rewrite Es' /isTrue_expr eval_expr_join_i1.
by move: Ee2; rewrite Es' /isTrue_expr eval_expr_join_i2.
(* assert *)
move=> sa sb e Es Ee1 Ee2 s1 s2 Es'.
exists [::].
rewrite -!Es !Es' split_joinState_1 split_joinState_2; split; constructor=> //.
 by move: Ee1; rewrite Es' /isTrue_expr eval_expr_join_i1.
by move: Ee2; rewrite Es' /isTrue_expr eval_expr_join_i2.
(* assign *)
move=> sa sb x e Es El1 El2 s1 s2 Es'.
exists (leak_expr lspec s1 (ValOf x)
        ++leak_expr lspec s1 e).
split.
 constructor.
 rewrite -Es Es' updLValue_join_i1 updLValue_join_i2 split_joinState_1.
 by rewrite eval_expr_join_i1.
move: El1 El2; rewrite !Es' !isTrue_EqLeak => /eqP El1 /eqP El2.
move: El1; rewrite preleak_prod => /eqP ->.
move: El2; rewrite preleak_prod => /eqP ->.
constructor.
rewrite -Es Es' updLValue_join_i1 updLValue_join_i2 split_joinState_2.
by rewrite eval_expr_join_i2.
(* seq *)
move=> sa sb sc c1 c2 l1 l2 H1 IH1 H2 IH2 s1 s2 Es.
move: {IH1} (IH1 _ _ Es) => [lta [Hta1 Hta2]].
move: {IH2} (IH2 (splitState sb).1 (splitState sb).2 (eqstate_sym (join_splitState sb))) => [ltb [Htb1 Htb2]].
exists (lta++ltb); split.
 by apply eval_SeqS with (splitState sb).1.
by apply eval_SeqS with (splitState sb).2.
(* ifT *)
move=> sa sb b c1 c2 l1 Eb El Eeqb H1 IH1 s1 s2 Es.
move: {IH1} (IH1 _ _ Es) => [lta [Hta1 Hta2]].
exists (leak_expr lspec s1 b ++ inl true :: lta); split.
 constructor => //.
 by move: Eb; rewrite Es /isTrue_expr eval_expr_join_i1.
move: El; rewrite !Es isTrue_EqLeak => /eqP El.
move: El; rewrite preleak_prod => /eqP ->.
constructor => //.
move: Eb; rewrite /isTrue_expr -(@eval_expr_join_i2 _ b s1 s2) => Eb.
move: Eeqb; rewrite isTrue_Equal !eval_IsTrue (negPf Eb).
case: (ifP _) => // /negP H _.
by move: H; rewrite Es => H; apply/negP.
(* ifF *)
move=> sa sb b c1 c2 l1 Eb El Eeqb H1 IH1 s1 s2 Es.
move: {IH1} (IH1 _ _ Es) => [lta [Hta1 Hta2]].
exists (leak_expr lspec s1 b ++ inl false :: lta); split.
 constructor => //.
 by move: Eb; rewrite Es /isTrue_expr eval_expr_join_i1.
move: El; rewrite !Es isTrue_EqLeak => /eqP El.
move: El; rewrite preleak_prod => /eqP ->.
constructor => //.
move: Eb; rewrite /isTrue_expr -(@eval_expr_join_i2 _ b s1 s2) => /negPn Eb.
move: Eeqb; rewrite isTrue_Equal !eval_IsTrue /eqP Eb.
case: (ifP _) => // H _.
by move: H; rewrite Es => H; apply/negPn.
(* whileT *)
move=> sa sb sc b c l1 l2 Eb Ela Eea H1 IH1 Elb Eeb H2 IH2 s1 s2 Es.
move: {IH1} (IH1 _ _ Es) => [lta [Hta1 Hta2]].
move: {IH2} (IH2 (splitState sb).1 (splitState sb).2 (eqstate_sym (join_splitState sb))) => [ltb [Htb1 Htb2]].
exists (leak_expr lspec s1 b ++ inl true:: lta++ltb); split.
 apply eval_WhileTS with (splitState sb).1 => //.
 by move: Eb; rewrite Es /isTrue_expr eval_expr_join_i1.
move: Ela; rewrite !Es isTrue_EqLeak => /eqP Ela.
move: Ela; rewrite preleak_prod => /eqP ->.
apply eval_WhileTS with (splitState sb).2 => //.
move: Eb; rewrite /isTrue_expr -(@eval_expr_join_i2 _ b s1 s2).
move: Eea; rewrite isTrue_Equal !eval_IsTrue Es
                   eval_expr_join_i1 eval_expr_join_i2.
by case: (ifP _); case: (ifP _).
(* whileF *)
move=> sa sb b c Es Eb El Eeqb s1 s2 Es'.
exists (leak_expr lspec s1 b ++ [:: inl false]); split.
 constructor.
  by move: Eb; rewrite Es' /isTrue_expr eval_expr_join_i1.
 by rewrite -Es Es' split_joinState_1.
move: El; rewrite !Es' isTrue_EqLeak => /eqP El.
move: El; rewrite preleak_prod => /eqP ->.
constructor => //.
 move: Eeqb Eb; rewrite Es' isTrue_Equal !eval_IsTrue /isTrue_expr
                   eval_expr_join_i1 eval_expr_join_i2.
 by case: (ifP _); case: (ifP _).
by rewrite -Es Es' split_joinState_2.
Qed.

Theorem prod_cmd_sound_and_complete:
 forall c lowInputs,
  Safe lspec (joinStateEqLow lowInputs) (prod_cmd c)
  <-> strict_leakSecure lspec lowInputs c.
Proof.
move => c lowIn; split.
 rewrite /Safe /joinStateEqLow => H st1 st2 EsLow.
 have HH: eqstateR lowIn (splitState (joinState st1 st2)).1
                         (splitState (joinState st1 st2)).2.
  by rewrite split_joinState_1 split_joinState_2.
 move: {H} (H _ HH) => [ss [ll H]].
 move: (prod_cmd_complete' H) => [l [H1 H2]].
 exists (splitState ss).1, (splitState ss).2, l, l.
 split => //; split => //.
rewrite /strict_leakSecure /leakSecure /Safe => H st Hst.
have HH: eqstateR lowIn (splitState st).1 (splitState st).2.
 by move: Hst; rewrite /joinStateEqLow.
move: (H _ _ HH) => [s1 [s2 [l1 [l2 [H1 [H2 H3]]]]]].
have H3': eqstateR lowVars0 s1 s2.
 by rewrite /eqstateR /lowVars0 /= => x; split.
move: {H3 H3'} (H3 H3') H1 H2 => /eqP H3 H1 H2.
exists (joinState s1 s2).
move: (@prod_cmd_sound' _ _ _ _ _ _ _ H1 H2 H3) => [ll].
by rewrite join_splitState => Hll; exists ll.
Qed.

End ProdTrf.


Goal forall A B C (p : forall (x : A) (y : B), C x y) (x : A) (y : B), True.
Proof.
  intros A B C p x y.
  match type of p with
    | forall x y, @?F x y => pose F as C1
  end.
  match type of p with
    | forall x y, @?F y x => pose F as C2
  end.
  assert (C1 x y) as ?.
  assert (C2 y x) as ?.
Abort.

Goal forall A B C D (p : forall (x : A) (y : B) (z : C), D x y) (x : A) (y : B), True.
Proof.
  intros A B C D p x y.
  match type of p with
    | forall x y z, @?F x y => pose F as C1
  end.
  assert (C1 x y) as ?.
Abort.

Goal forall A B C D (p : forall (z : C) (x : A) (y : B), D x y) (x : A) (y : B), True.
Proof.
  intros A B C D p x y.
  match type of p with
    | forall z x y, @?F x y => pose F as C1
  end.
  assert (C1 x y) as ?.
Abort.

(** Those should fail *)

Goal forall A B C (p : forall (x : A) (y : B), C x y) (x : A) (y : B), True.
Proof.
  intros A B C p x y.
  Fail match type of p with
    | forall x, @?F x y => pose F as C1
  end.
  Fail match type of p with
    | forall x y, @?F x x y => pose F as C1
  end.
  Fail match type of p with
    | forall x y, @?F x => pose F as C1
  end.
Abort.

(** This one is badly typed *)

Goal forall A (B : A -> Type) (C : forall x, B x -> Type), (forall x y, C x y) -> True.
Proof.
intros A B C p.
Fail match type of p with
| forall x y, @?F y x => idtac
end.
Abort.

Goal forall A (B : A -> Type) (C : Type) (D : forall x, B x -> Type), (forall x (z : C) y, D x y) -> True.
Proof.
intros A B C D p.
match type of p with
| forall x z y, @?F x y => idtac
end.
Abort.


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

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(*  ---                       dicho_strat.v                    --- *)
(*                                                                          *)
(* Author: Pierre Casteran.                                                 *)
(*    LABRI, URA CNRS 1304,                                                 *)
(*    Departement d'Informatique, Universite Bordeaux I,                    *)
(*    33405 Talence CEDEX,                                                  *)
(*    e-mail:  casteran@labri.u-bordeaux.fr                                 *)

(*

 This file presents our favorite strategy, which gave the best results
 (see the included paper)

 Briefly:

 dicho-strat(n)=
     let l=(ceiling_log2 log2 n)
     in (eucl_dev (two_power (eucl_dev 2 l)) n)

  (recall that in the distribution (quotient b a) is the notation
   for the euclidean division of a by b !)

 For instance let n be 87,
 The ceiling logarithm (base 2) of n is l=7 since 64<n<=128 ;
 thus the quotient of 87 by 2^3 is 10.

 Perhaps it's easier to understand this strategy in terms of
binary representation of natural integers:

 For instance, 87 is represented by 1010111; if we cut this
representation in two halves (the shorter at the right hand side,
if the number of digits is odd), we have two words:
   -   1011 -> 10 (it is just dicho_strat(10))
   -    111 -> 7
 Since we have 87=8*10+7,
 the code for (CALL_M 87) will be the  code for (CALL_C 87 10),
 i.e. the concatenation of the code for (CALL_K 10 7),
 the code for (CALL_M 8), and a MUL statement:

    Statement  register  stack

 code for (CALL_K 10 7):

                x         []
    PUSH        x         [x]
    PUSH        x         [x,x]
    SQR         x^2       [x,x]
    MUL         x^3       [x]
    PUSH        x^3       [x^3,x]
    SWAP        x^3       [x,x^3]
    SQR         x^6       [x,x^3]
    MUL         x^7       [x^3]
    PUSH        x^7       [x^7,x^3]
    SWAP        x^7       [x^3,x^7]
    MUL         x^10      [x^7]

 code for (CALL_M 8):

    SQR         x^20      [x^7]
    SQR         x^40      [x^7]
    SQR         x^80      [x^7]

 the final MUL:
    MUL         x^87      []

  The proof is very long, and we hope to shorten it
  quickly.

*)

Require Import strategies.
Require Import Arith.
Require Import euclid.
Require Import shift.
Require Import two_power.
Require Import log2_spec.
Require Import Euclid.
Require Import Le_lt_compl.
Require Import Mult_compl.
Require Import Constants.

Section import_log2.
Variable log2_r : forall n : nat, 0 < n -> log2_spec n.

Lemma dicho : strategy.
(*******************)
Proof.
 split.
 intros n H.
 elim (ceiling_log2 log2_r n).
 2: apply lt_trans with four; unfold one, four in |- *; auto with arith.
 intros x y.
 elim y; intros.
 cut (0 < 2).
 2: auto with arith.
 intro H'.
 elim (quotient 2 H' x); intros.
 refine match quotient (two_power x0) _ n with
        | exist n0 e => exist _ n0 _
        end.

 unfold gt in |- *.
 apply lt_le_trans with 1; auto with arith.

 elim p; intros.
 elim e; intros.
 elim H2; intros H4 H5.
 elim H3; intros H6 H7.
 clear y p e H2 H3 H'.
 cut (0 < x0).
 2: case (lt_or_Zero x0); [ auto with arith | intro ].
 2: cut (x <= one).
 2: intro.
 2: absurd (n <= two).
 2: unfold not in |- *; intro.
 2: absurd (four < two).
 2: apply le_not_lt; auto with arith.
 2: unfold four, two in |- *; auto with arith.
 2: apply lt_le_trans with n; auto with arith.
 2: replace two with (two_power one).
 2: apply le_trans with (two_power x).
 2: auto with arith.
 2: apply two_power_le; auto with arith.
 2: simpl in |- *; auto with arith.
 2: rewrite H4; rewrite H2; simpl in |- *; auto with arith.
 intro x0_pos.
 cut (1 < two_power x0).
 2: replace 1 with (two_power 0).
 2: apply two_power_mono; auto with arith.
 2: simpl in |- *; auto with arith.
 intro H8. (* (lt (S O) (two_power x0) *)
 cut (x0 < x).
 2: rewrite H4.
 2: apply lt_le_trans with (x0 * 2).
 2: rewrite mult_comm; apply mult_p_lt_qp; auto with arith.
 2: auto with arith.
 intro H9.
 cut (x0 <= pred x).
 2: apply le_S_n.
 2: elim (S_pred _ _ H9).
 2: auto with arith.
 intro H10.
 cut (0 < n0).
 2: case (lt_or_Zero n0); [ auto with arith | intro ].
 2: absurd (n < two_power x0).
 2: apply le_not_lt.
 2: apply le_trans with (two_power (pred x)).
 2: apply two_power_le; auto with arith.
 2: auto with arith.
 2: rewrite H6; rewrite H2; simpl in |- *.
 2: auto with arith.
 intro H11. (* lt O n0 *)
 split.
 apply lt_le_trans with (n0 * two_power x0).
 rewrite mult_comm; apply mult_p_lt_qp; auto with arith.
 rewrite H6; auto with arith.

 apply not_lt_le.
 unfold not in |- *; intro H12.
 case (enum1 n0 H12); intro.
 absurd (0 < n0); [ rewrite H2; auto with arith | auto with arith ].

 cut (n < two_power (S x0)).
 2: rewrite H6.
 2: rewrite H2.
 2: rewrite mult_1_l.
 2: rewrite two_power_S.
 2: rewrite mult_comm; simpl in |- *.
 2: rewrite <- plus_n_O.
 2: apply plus_lt_compat_l.
 2: auto with arith.
 intro.
 cut (two_power x0 <= n).
 intro H13.
 cut (S x0 <= x); [ intro H14 | auto with arith ].
 case (le_lt_or_eq _ _ H14); intro.
 cut (S x0 <= pred x); [ intro | auto with arith ].
 absurd (n < n); [ auto with arith | idtac ].
 apply lt_trans with (two_power (S x0)).
 auto with arith.
 apply le_lt_trans with (two_power (pred x)).
 apply two_power_le; auto with arith.
 auto with arith.

 cut (x0 <= 1).
 intro H16.
 absurd (n < four).
 apply lt_asym.
 auto with arith.

 apply lt_le_trans with (two_power (S x0)).
 auto with arith.
 replace four with (two_power 2).
 apply two_power_le; auto with arith.
 unfold four in |- *; simpl in |- *; auto with arith.
 apply (fun p n m : nat => plus_le_reg_l n m p) with x0.
 replace (x0 + x0) with (x0 * 2).
 rewrite plus_comm; simpl in |- *.
 apply le_trans with x.
 rewrite H4; auto with arith.
 elim H15; auto with arith.
 rewrite mult_comm; simpl in |- *; rewrite <- plus_n_O; auto with arith.
 rewrite <- (mult_1_l (two_power x0)).
 elim H2; rewrite H6; auto with arith.
Qed.

End import_log2.