(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Arithmetic and logical operators for the Compcert C and Clight languages *)

Require Import Coqlib.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Ctypes.

Section WITHMEM.
Context `{Hmem: Mem.MemoryModel}.

(** * Syntax of operators. *)

Inductive unary_operation : Type :=
  | Onotbool : unary_operation          (**r boolean negation ([!] in C) *)
  | Onotint : unary_operation           (**r integer complement ([~] in C) *)
  | Oneg : unary_operation.             (**r opposite (unary [-]) *)

Inductive binary_operation : Type :=
  | Oadd : binary_operation             (**r addition (binary [+]) *)
  | Osub : binary_operation             (**r subtraction (binary [-]) *)
  | Omul : binary_operation             (**r multiplication (binary [*]) *)
  | Odiv : binary_operation             (**r division ([/]) *)
  | Omod : binary_operation             (**r remainder ([%]) *)
  | Oand : binary_operation             (**r bitwise and ([&]) *)
  | Oor : binary_operation              (**r bitwise or ([|]) *)
  | Oxor : binary_operation             (**r bitwise xor ([^]) *)
  | Oshl : binary_operation             (**r left shift ([<<]) *)
  | Oshr : binary_operation             (**r right shift ([>>]) *)
  | Oeq: binary_operation               (**r comparison ([==]) *)
  | One: binary_operation               (**r comparison ([!=]) *)
  | Olt: binary_operation               (**r comparison ([<]) *)
  | Ogt: binary_operation               (**r comparison ([>]) *)
  | Ole: binary_operation               (**r comparison ([<=]) *)
  | Oge: binary_operation.              (**r comparison ([>=]) *)

Inductive incr_or_decr : Type := Incr | Decr.

(** * Type classification and semantics of operators. *)

(** Most C operators are overloaded (they apply to arguments of various
  types) and their semantics depend on the types of their arguments.
  The following [classify_*] functions take as arguments the types
  of the arguments of an operation.  They return enough information
  to resolve overloading for this operator applications, such as
  ``both arguments are floats'', or ``the first is a pointer
  and the second is an integer''.  This classification is used in the
  compiler (module [Cshmgen]) to resolve overloading statically.

  The [sem_*] functions below compute the result of an operator
  application.  Since operators are overloaded, the result depends
  both on the static types of the arguments and on their run-time values.
  The corresponding [classify_*] function is first called on the
  types of the arguments to resolve static overloading.  It is then
  followed by a case analysis on the values of the arguments. *)

(** ** Casts and truth values *)

Inductive classify_cast_cases : Type :=
  | cast_case_neutral                   (**r int|pointer -> int32|pointer *)
  | cast_case_i2i (sz2:intsize) (si2:signedness)   (**r int -> int *)
  | cast_case_f2f (sz2:floatsize)                  (**r float -> float *)
  | cast_case_i2f (si1:signedness) (sz2:floatsize) (**r int -> float *)
  | cast_case_f2i (sz2:intsize) (si2:signedness)   (**r float -> int *)
  | cast_case_f2bool                    (**r float -> bool *)
  | cast_case_p2bool                    (**r pointer -> bool *)
  | cast_case_struct (id1: ident) (fld1: fieldlist) (id2: ident) (fld2: fieldlist) (**r struct -> struct *)
  | cast_case_union (id1: ident) (fld1: fieldlist) (id2: ident) (fld2: fieldlist) (**r union -> union *)
  | cast_case_void                                 (**r any -> void *)
  | cast_case_default.

Function classify_cast (tfrom tto: type) : classify_cast_cases :=
  match tto, tfrom with
  | Tint I32 si2 _, (Tint _ _ _ | Tpointer _ _ | Tarray _ _ _ | Tfunction _ _) => cast_case_neutral
  | Tint IBool _ _, Tfloat _ _ => cast_case_f2bool
  | Tint IBool _ _, (Tpointer _ _ | Tarray _ _ _ | Tfunction _ _) => cast_case_p2bool
  | Tint sz2 si2 _, Tint sz1 si1 _ => cast_case_i2i sz2 si2
  | Tint sz2 si2 _, Tfloat sz1 _ => cast_case_f2i sz2 si2
  | Tfloat sz2 _, Tfloat sz1 _ => cast_case_f2f sz2
  | Tfloat sz2 _, Tint sz1 si1 _ => cast_case_i2f si1 sz2
  | Tpointer _ _, (Tint _ _ _ | Tpointer _ _ | Tarray _ _ _ | Tfunction _ _) => cast_case_neutral
  | Tstruct id2 fld2 _, Tstruct id1 fld1 _ => cast_case_struct id1 fld1 id2 fld2
  | Tunion id2 fld2 _, Tunion id1 fld1 _ => cast_case_union id1 fld1 id2 fld2
  | Tvoid, _ => cast_case_void
  | _, _ => cast_case_default
  end.

(** Semantics of casts.  [sem_cast v1 t1 t2 = Some v2] if value [v1],
  viewed with static type [t1], can be cast to type [t2],
  resulting in value [v2].  *)

Definition cast_int_int (sz: intsize) (sg: signedness) (i: int) : int :=
  match sz, sg with
  | I8, Signed => Int.sign_ext 8 i
  | I8, Unsigned => Int.zero_ext 8 i
  | I16, Signed => Int.sign_ext 16 i
  | I16, Unsigned => Int.zero_ext 16 i
  | I32, _ => i
  | IBool, _ => if Int.eq i Int.zero then Int.zero else Int.one
  end.

Definition cast_int_float (si : signedness) (i: int) : float :=
  match si with
  | Signed => Float.floatofint i
  | Unsigned => Float.floatofintu i
  end.

Definition cast_float_int (si : signedness) (f: float) : option int :=
  match si with
  | Signed => Float.intoffloat f
  | Unsigned => Float.intuoffloat f
  end.

Definition cast_float_float (sz: floatsize) (f: float) : float :=
  match sz with
  | F32 => Float.singleoffloat f
  | F64 => f
  end.

Function sem_cast (v: val) (t1 t2: type) : option val :=
  match classify_cast t1 t2 with
  | cast_case_neutral =>
      match v with
      | Vint _ | Vptr _ _ => Some v
      | _ => None
      end
  | cast_case_i2i sz2 si2 =>
      match v with
      | Vint i => Some (Vint (cast_int_int sz2 si2 i))
      | _ => None
      end
  | cast_case_f2f sz2 =>
      match v with
      | Vfloat f => Some (Vfloat (cast_float_float sz2 f))
      | _ => None
      end
  | cast_case_i2f si1 sz2 =>
      match v with
      | Vint i => Some (Vfloat (cast_float_float sz2 (cast_int_float si1 i)))
      | _ => None
      end
  | cast_case_f2i sz2 si2 =>
      match v with
      | Vfloat f =>
          match cast_float_int si2 f with
          | Some i => Some (Vint (cast_int_int sz2 si2 i))
          | None => None
          end
      | _ => None
      end
  | cast_case_f2bool =>
      match v with
      | Vfloat f =>
          Some(Vint(if Float.cmp Ceq f Float.zero then Int.zero else Int.one))
      | _ => None
      end
  | cast_case_p2bool =>
      match v with
      | Vint i => Some (Vint (cast_int_int IBool Signed i))
      | Vptr _ _ => Some (Vint Int.one)
      | _ => None
      end
  | cast_case_struct id1 fld1 id2 fld2 =>
      if ident_eq id1 id2 && fieldlist_eq fld1 fld2 then Some v else None
  | cast_case_union id1 fld1 id2 fld2 =>
      if ident_eq id1 id2 && fieldlist_eq fld1 fld2 then Some v else None
  | cast_case_void =>
      Some v
  | cast_case_default =>
      None
  end.

(** The following describes types that can be interpreted as a boolean:
  integers, floats, pointers.  It is used for the semantics of
  the [!] and [?] operators, as well as the [if], [while], [for] statements. *)

Inductive classify_bool_cases : Type :=
  | bool_case_i                           (**r integer *)
  | bool_case_f                           (**r float *)
  | bool_case_p                           (**r pointer *)
  | bool_default.

Definition classify_bool (ty: type) : classify_bool_cases :=
  match typeconv ty with
  | Tint _ _ _ => bool_case_i
  | Tpointer _ _ => bool_case_p
  | Tfloat _ _ => bool_case_f
  | _ => bool_default
  end.

(** Interpretation of values as truth values.
  Non-zero integers, non-zero floats and non-null pointers are
  considered as true.  The integer zero (which also represents
  the null pointer) and the float 0.0 are false. *)

Function bool_val (v: val) (t: type) : option bool :=
  match classify_bool t with
  | bool_case_i =>
      match v with
      | Vint n => Some (negb (Int.eq n Int.zero))
      | _ => None
      end
  | bool_case_f =>
      match v with
      | Vfloat f => Some (negb (Float.cmp Ceq f Float.zero))
      | _ => None
      end
  | bool_case_p =>
      match v with
      | Vint n => Some (negb (Int.eq n Int.zero))
      | Vptr b ofs => Some true
      | _ => None
      end
  | bool_default => None
  end.

(** Common-sense relation between Boolean value and casting to [_Bool] type. *)

Lemma cast_bool_bool_val:
  forall v t,
  sem_cast v t (Tint IBool Signed noattr) =
  match bool_val v t with None => None | Some b => Some(Val.of_bool b) end.
Proof.
  intros.
  assert (A: classify_bool t =
    match t with
    | Tint _ _ _ => bool_case_i
    | Tpointer _ _ | Tarray _ _ _ | Tfunction _ _ => bool_case_p
    | Tfloat _ _ => bool_case_f
    | _ => bool_default
    end).
  unfold classify_bool; destruct t; simpl; auto. destruct i; auto. destruct s; auto.

  unfold bool_val. rewrite A. unfold sem_cast. destruct t; simpl; auto; destruct v; auto.
  destruct (Int.eq i0 Int.zero); auto.
  destruct (Float.cmp Ceq f0 Float.zero); auto.
  destruct (Int.eq i Int.zero); auto.
  destruct (Int.eq i Int.zero); auto.
  destruct (Int.eq i Int.zero); auto.
Qed.

(** ** Unary operators *)

(** *** Boolean negation *)

Function sem_notbool (v: val) (ty: type) : option val :=
  match classify_bool ty with
  | bool_case_i =>
      match v with
      | Vint n => Some (Val.of_bool (Int.eq n Int.zero))
      | _ => None
      end
  | bool_case_f =>
      match v with
      | Vfloat f => Some (Val.of_bool (Float.cmp Ceq f Float.zero))
      | _ => None
      end
  | bool_case_p =>
      match v with
      | Vint n => Some (Val.of_bool (Int.eq n Int.zero))
      | Vptr _ _ => Some Vfalse
      | _ => None
      end
  | bool_default => None
  end.

(** Common-sense relation between Boolean value and Boolean negation. *)

Lemma notbool_bool_val:
  forall v t,
  sem_notbool v t =
  match bool_val v t with None => None | Some b => Some(Val.of_bool (negb b)) end.
Proof.
  intros. unfold sem_notbool, bool_val.
  destruct (classify_bool t); auto; destruct v; auto; rewrite negb_involutive; auto.
Qed.

(** *** Opposite *)

Inductive classify_neg_cases : Type :=
  | neg_case_i(s: signedness)              (**r int *)
  | neg_case_f                             (**r float *)
  | neg_default.

Definition classify_neg (ty: type) : classify_neg_cases :=
  match ty with
  | Tint I32 Unsigned _ => neg_case_i Unsigned
  | Tint _ _ _ => neg_case_i Signed
  | Tfloat _ _ => neg_case_f
  | _ => neg_default
  end.

Function sem_neg (v: val) (ty: type) : option val :=
  match classify_neg ty with
  | neg_case_i sg =>
      match v with
      | Vint n => Some (Vint (Int.neg n))
      | _ => None
      end
  | neg_case_f =>
      match v with
      | Vfloat f => Some (Vfloat (Float.neg f))
      | _ => None
      end
  | neg_default => None
  end.

(** *** Bitwise complement *)

Inductive classify_notint_cases : Type :=
  | notint_case_i(s: signedness)              (**r int *)
  | notint_default.

Definition classify_notint (ty: type) : classify_notint_cases :=
  match ty with
  | Tint I32 Unsigned _ => notint_case_i Unsigned
  | Tint _ _ _ => notint_case_i Signed
  | _ => notint_default
  end.

Function sem_notint (v: val) (ty: type): option val :=
  match classify_notint ty with
  | notint_case_i sg =>
      match v with
      | Vint n => Some (Vint (Int.xor n Int.mone))
      | _ => None
      end
  | notint_default => None
  end.

(** ** Binary operators *)

(** For binary operations, the "usual binary conversions", adapted to a 32-bit
  platform, state that:
- If both arguments are of integer type, an integer operation is performed.
  For operations that behave differently at unsigned and signed types
  (e.g. division, modulus, comparisons), the unsigned operation is selected
  if at least one of the arguments is of type "unsigned int32", otherwise
  the signed operation is performed.
- If both arguments are of float type, a float operation is performed.
  We choose to perform all float arithmetic in double precision,
  even if both arguments are single-precision floats.
- If one argument has integer type and the other has float type,
  we convert the integer argument to float, then perform the float operation.
*)

(** *** Addition *)

Inductive classify_add_cases : Type :=
  | add_case_ii(s: signedness)         (**r int, int *)
  | add_case_ff                        (**r float, float *)
  | add_case_if(s: signedness)         (**r int, float *)
  | add_case_fi(s: signedness)         (**r float, int *)
  | add_case_pi(ty: type)(a: attr)     (**r pointer, int *)
  | add_case_ip(ty: type)(a: attr)     (**r int, pointer *)
  | add_default.

Definition classify_add (ty1: type) (ty2: type) :=
  match typeconv ty1, typeconv ty2 with
  | Tint I32 Unsigned _, Tint _ _ _ => add_case_ii Unsigned
  | Tint _ _ _, Tint I32 Unsigned _ => add_case_ii Unsigned
  | Tint _ _ _, Tint _ _ _ => add_case_ii Signed
  | Tfloat _ _, Tfloat _ _ => add_case_ff
  | Tint _ sg _, Tfloat _ _ => add_case_if sg
  | Tfloat _ _, Tint _ sg _ => add_case_fi sg
  | Tpointer ty a, Tint _ _ _ => add_case_pi ty a
  | Tint _ _ _, Tpointer ty a => add_case_ip ty a
  | _, _ => add_default
  end.

Function sem_add (v1:val) (t1:type) (v2: val) (t2:type) : option val :=
  match classify_add t1 t2 with
  | add_case_ii sg =>                   (**r integer addition *)
      match v1, v2 with
      | Vint n1, Vint n2 => Some (Vint (Int.add n1 n2))
      | _,  _ => None
      end
  | add_case_ff =>                      (**r float addition *)
      match v1, v2 with
      | Vfloat n1, Vfloat n2 => Some (Vfloat (Float.add n1 n2))
      | _,  _ => None
      end
  | add_case_if sg =>                   (**r int plus float *)
      match v1, v2 with
      | Vint n1, Vfloat n2 => Some (Vfloat (Float.add (cast_int_float sg n1) n2))
      | _, _ => None
      end
  | add_case_fi sg =>                   (**r float plus int *)
      match v1, v2 with
      | Vfloat n1, Vint n2 => Some (Vfloat (Float.add n1 (cast_int_float sg n2)))
      | _, _ => None
      end
  | add_case_pi ty _ =>                 (**r pointer plus integer *)
      match v1,v2 with
      | Vptr b1 ofs1, Vint n2 =>
        Some (Vptr b1 (Int.add ofs1 (Int.mul (Int.repr (sizeof ty)) n2)))
      | _,  _ => None
      end
  | add_case_ip ty _ =>                 (**r integer plus pointer *)
      match v1,v2 with
      | Vint n1, Vptr b2 ofs2 =>
        Some (Vptr b2 (Int.add ofs2 (Int.mul (Int.repr (sizeof ty)) n1)))
      | _,  _ => None
      end
  | add_default => None
end.

(** *** Subtraction *)

Inductive classify_sub_cases : Type :=
  | sub_case_ii(s: signedness)          (**r int , int *)
  | sub_case_ff                         (**r float , float *)
  | sub_case_if(s: signedness)          (**r int, float *)
  | sub_case_fi(s: signedness)          (**r float, int *)
  | sub_case_pi(ty: type)               (**r pointer, int *)
  | sub_case_pp(ty: type)               (**r pointer, pointer *)
  | sub_default.

Definition classify_sub (ty1: type) (ty2: type) :=
  match typeconv ty1, typeconv ty2 with
  | Tint I32 Unsigned _, Tint _ _ _ => sub_case_ii Unsigned
  | Tint _ _ _, Tint I32 Unsigned _ => sub_case_ii Unsigned
  | Tint _ _ _, Tint _ _ _ => sub_case_ii Signed
  | Tfloat _ _ , Tfloat _ _ => sub_case_ff
  | Tint _ sg _, Tfloat _ _ => sub_case_if sg
  | Tfloat _ _, Tint _ sg _ => sub_case_fi sg
  | Tpointer ty _, Tint _ _ _ => sub_case_pi ty
  | Tpointer ty _ , Tpointer _ _ => sub_case_pp ty
  | _ ,_ => sub_default
  end.

Function sem_sub (v1:val) (t1:type) (v2: val) (t2:type) : option val :=
  match classify_sub t1 t2 with
  | sub_case_ii sg =>            (**r integer subtraction *)
      match v1,v2 with
      | Vint n1, Vint n2 => Some (Vint (Int.sub n1 n2))
      | _,  _ => None
      end
  | sub_case_ff =>               (**r float subtraction *)
      match v1,v2 with
      | Vfloat f1, Vfloat f2 => Some (Vfloat(Float.sub f1 f2))
      | _,  _ => None
      end
  | sub_case_if sg =>            (**r int minus float *)
      match v1, v2 with
      | Vint n1, Vfloat n2 => Some (Vfloat (Float.sub (cast_int_float sg n1) n2))
      | _, _ => None
      end
  | sub_case_fi sg =>            (**r float minus int *)
      match v1, v2 with
      | Vfloat n1, Vint n2 => Some (Vfloat (Float.sub n1 (cast_int_float sg n2)))
      | _, _ => None
      end
  | sub_case_pi ty =>            (**r pointer minus integer *)
      match v1,v2 with
      | Vptr b1 ofs1, Vint n2 =>
            Some (Vptr b1 (Int.sub ofs1 (Int.mul (Int.repr (sizeof ty)) n2)))
      | _,  _ => None
      end
  | sub_case_pp ty =>          (**r pointer minus pointer *)
      match v1,v2 with
      | Vptr b1 ofs1, Vptr b2 ofs2 =>
          if zeq b1 b2 then
            if Int.eq (Int.repr (sizeof ty)) Int.zero then None
            else Some (Vint (Int.divu (Int.sub ofs1 ofs2) (Int.repr (sizeof ty))))
          else None
      | _, _ => None
      end
  | sub_default => None
  end.

(** *** Multiplication *)

Inductive classify_mul_cases : Type:=
  | mul_case_ii(s: signedness) (**r int , int *)
  | mul_case_ff                (**r float , float *)
  | mul_case_if(s: signedness) (**r int, float *)
  | mul_case_fi(s: signedness) (**r float, int *)
  | mul_default.

Definition classify_mul (ty1: type) (ty2: type) :=
  match typeconv ty1, typeconv ty2 with
  | Tint I32 Unsigned _, Tint _ _ _ => mul_case_ii Unsigned
  | Tint _ _ _, Tint I32 Unsigned _ => mul_case_ii Unsigned
  | Tint _ _ _, Tint _ _ _ => mul_case_ii Signed
  | Tfloat _ _ , Tfloat _ _ => mul_case_ff
  | Tint _ sg _, Tfloat _ _ => mul_case_if sg
  | Tfloat _ _, Tint _ sg _ => mul_case_fi sg
  | _,_  => mul_default
end.

Function sem_mul (v1:val) (t1:type) (v2: val) (t2:type) : option val :=
 match classify_mul t1 t2 with
  | mul_case_ii sg =>
      match v1,v2 with
      | Vint n1, Vint n2 => Some (Vint (Int.mul n1 n2))
      | _,  _ => None
      end
  | mul_case_ff =>
      match v1,v2 with
      | Vfloat f1, Vfloat f2 => Some (Vfloat (Float.mul f1 f2))
      | _,  _ => None
      end
  | mul_case_if sg =>
      match v1, v2 with
      | Vint n1, Vfloat n2 => Some (Vfloat (Float.mul (cast_int_float sg n1) n2))
      | _, _ => None
      end
  | mul_case_fi sg =>
      match v1, v2 with
      | Vfloat n1, Vint n2 => Some (Vfloat (Float.mul n1 (cast_int_float sg n2)))
      | _, _ => None
      end
  | mul_default =>
      None
end.

(** *** Division *)

Inductive classify_div_cases : Type:=
  | div_case_ii(s: signedness) (**r int , int *)
  | div_case_ff                (**r float , float *)
  | div_case_if(s: signedness) (**r int, float *)
  | div_case_fi(s: signedness) (**r float, int *)
  | div_default.

Definition classify_div (ty1: type) (ty2: type) :=
  match typeconv ty1, typeconv ty2 with
  | Tint I32 Unsigned _, Tint _ _ _ => div_case_ii Unsigned
  | Tint _ _ _, Tint I32 Unsigned _ => div_case_ii Unsigned
  | Tint _ _ _, Tint _ _ _ => div_case_ii Signed
  | Tfloat _ _ , Tfloat _ _ => div_case_ff
  | Tint _ sg _, Tfloat _ _ => div_case_if sg
  | Tfloat _ _, Tint _ sg _ => div_case_fi sg
  | _,_  => div_default
end.

Function sem_div (v1:val) (t1:type) (v2: val) (t2:type) : option val :=
   match classify_div t1 t2 with
  | div_case_ii Unsigned =>
      match v1,v2 with
      | Vint n1, Vint n2 =>
          if Int.eq n2 Int.zero then None else Some (Vint (Int.divu n1 n2))
      | _,_ => None
      end
  | div_case_ii Signed =>
      match v1,v2 with
       | Vint n1, Vint n2 =>
          if Int.eq n2 Int.zero
          || Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone
          then None else Some (Vint(Int.divs n1 n2))
      | _,_ => None
      end
  | div_case_ff =>
      match v1,v2 with
      | Vfloat f1, Vfloat f2 => Some (Vfloat(Float.div f1 f2))
      | _,  _ => None
      end
  | div_case_if sg =>
      match v1, v2 with
      | Vint n1, Vfloat n2 => Some (Vfloat (Float.div (cast_int_float sg n1) n2))
      | _, _ => None
      end
  | div_case_fi sg =>
      match v1, v2 with
      | Vfloat n1, Vint n2 => Some (Vfloat (Float.div n1 (cast_int_float sg n2)))
      | _, _ => None
      end
  | div_default =>
      None
end.

(** *** Integer-only binary operations: modulus, bitwise "and", "or", and "xor" *)

Inductive classify_binint_cases : Type:=
  | binint_case_ii(s: signedness) (**r int , int *)
  | binint_default.

Definition classify_binint (ty1: type) (ty2: type) :=
  match typeconv ty1, typeconv ty2 with
  | Tint I32 Unsigned _, Tint _ _ _ => binint_case_ii Unsigned
  | Tint _ _ _, Tint I32 Unsigned _ => binint_case_ii Unsigned
  | Tint _ _ _, Tint _ _ _ => binint_case_ii Signed
  | _,_  => binint_default
end.

Function sem_mod (v1:val) (t1:type) (v2: val) (t2:type) : option val :=
  match classify_binint t1 t2 with
  | binint_case_ii Unsigned =>
      match v1, v2 with
      | Vint n1, Vint n2 =>
          if Int.eq n2 Int.zero then None else Some (Vint (Int.modu n1 n2))
      | _, _ => None
      end
  | binint_case_ii Signed =>
      match v1,v2 with
      | Vint n1, Vint n2 =>
          if Int.eq n2 Int.zero
          || Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone
          then None else Some (Vint (Int.mods n1 n2))
      | _, _ => None
      end
  | binint_default =>
      None
  end.

Function sem_and (v1:val) (t1:type) (v2: val) (t2:type) : option val :=
  match classify_binint t1 t2 with
  | binint_case_ii sg =>
      match v1, v2 with
      | Vint n1, Vint n2 => Some (Vint(Int.and n1 n2))
      | _, _ => None
      end
  | binint_default => None
  end.

Function sem_or (v1:val) (t1:type) (v2: val) (t2:type) : option val :=
  match classify_binint t1 t2 with
  | binint_case_ii sg =>
      match v1, v2 with
      | Vint n1, Vint n2 => Some (Vint(Int.or n1 n2))
      | _, _ => None
      end
  | binint_default => None
  end.

Function sem_xor (v1:val) (t1:type) (v2: val) (t2:type) : option val :=
  match classify_binint t1 t2 with
  | binint_case_ii sg =>
      match v1, v2 with
      | Vint n1, Vint n2 => Some (Vint(Int.xor n1 n2))
      | _, _ => None
      end
  | binint_default => None
  end.

(** *** Shifts *)

Inductive classify_shift_cases : Type:=
  | shift_case_ii(s: signedness) (**r int , int *)
  | shift_default.

Definition classify_shift (ty1: type) (ty2: type) :=
  match typeconv ty1, typeconv ty2 with
  | Tint I32 Unsigned _, Tint _ _ _ => shift_case_ii Unsigned
  | Tint _ _ _, Tint _ _ _ => shift_case_ii Signed
  | _,_  => shift_default
end.

Function sem_shl (v1:val) (t1:type) (v2: val) (t2:type) : option val :=
  match classify_shift t1 t2 with
  | shift_case_ii sg =>
      match v1, v2 with
      | Vint n1, Vint n2 =>
         if Int.ltu n2 Int.iwordsize then Some (Vint(Int.shl n1 n2)) else None
      | _, _ => None
      end
  | shift_default => None
  end.

Function sem_shr (v1: val) (t1: type) (v2: val) (t2: type): option val :=
  match classify_shift t1 t2 with
  | shift_case_ii Unsigned =>
      match v1,v2 with
      | Vint n1, Vint n2 =>
          if Int.ltu n2 Int.iwordsize then Some (Vint (Int.shru n1 n2)) else None
      | _,_ => None
      end
   | shift_case_ii Signed =>
      match v1,v2 with
      | Vint n1,  Vint n2 =>
          if Int.ltu n2 Int.iwordsize then Some (Vint (Int.shr n1 n2)) else None
      | _,  _ => None
      end
   | shift_default =>
      None
   end.

(** *** Comparisons *)

Inductive classify_cmp_cases : Type:=
  | cmp_case_ii(s: signedness) (**r int, int *)
  | cmp_case_pp                (**r pointer, pointer *)
  | cmp_case_ff                (**r float , float *)
  | cmp_case_if(s: signedness) (**r int, float *)
  | cmp_case_fi(s: signedness) (**r float, int *)
  | cmp_default.

Definition classify_cmp (ty1: type) (ty2: type) :=
  match typeconv ty1, typeconv ty2 with
  | Tint I32 Unsigned _ , Tint _ _ _ => cmp_case_ii Unsigned
  | Tint _ _ _ , Tint I32 Unsigned _ => cmp_case_ii Unsigned
  | Tint _ _ _ , Tint _ _ _ => cmp_case_ii Signed
  | Tfloat _ _ , Tfloat _ _ => cmp_case_ff
  | Tint _ sg _, Tfloat _ _ => cmp_case_if sg
  | Tfloat _ _, Tint _ sg _ => cmp_case_fi sg
  | Tpointer _ _ , Tpointer _ _ => cmp_case_pp
  | Tpointer _ _ , Tint _ _ _ => cmp_case_pp
  | Tint _ _ _, Tpointer _ _ => cmp_case_pp
  | _ , _ => cmp_default
  end.

Function sem_cmp (c:comparison)
                  (v1: val) (t1: type) (v2: val) (t2: type)
                  (m: mem): option val :=
  match classify_cmp t1 t2 with
  | cmp_case_ii Signed =>
      match v1,v2 with
      | Vint n1, Vint n2 => Some (Val.of_bool (Int.cmp c n1 n2))
      | _,  _ => None
      end
  | cmp_case_ii Unsigned =>
      match v1,v2 with
      | Vint n1, Vint n2 => Some (Val.of_bool (Int.cmpu c n1 n2))
      | _,  _ => None
      end
  | cmp_case_pp =>
      match v1,v2 with
      | Vint n1, Vint n2 => Some (Val.of_bool (Int.cmpu c n1 n2))
      | Vptr b1 ofs1,  Vptr b2 ofs2  =>
          if zeq b1 b2 then
            if Mem.weak_valid_pointer m b1 (Int.unsigned ofs1)
               && Mem.weak_valid_pointer m b2 (Int.unsigned ofs2)
            then Some (Val.of_bool (Int.cmpu c ofs1 ofs2))
            else None
          else
            if Mem.valid_pointer m b1 (Int.unsigned ofs1)
               && Mem.valid_pointer m b2 (Int.unsigned ofs2)
            then option_map Val.of_bool (Val.cmp_different_blocks c)
            else None
      | Vptr b ofs, Vint n =>
          if Int.eq n Int.zero
          then option_map Val.of_bool (Val.cmp_different_blocks c)
          else None
      | Vint n, Vptr b ofs =>
          if Int.eq n Int.zero
          then option_map Val.of_bool (Val.cmp_different_blocks c)
          else None
      | _,  _ => None
      end
  | cmp_case_ff =>
      match v1,v2 with
      | Vfloat f1, Vfloat f2 => Some (Val.of_bool (Float.cmp c f1 f2))
      | _,  _ => None
      end
  | cmp_case_if sg =>
      match v1, v2 with
      | Vint n1, Vfloat n2 => Some (Val.of_bool (Float.cmp c (cast_int_float sg n1) n2))
      | _, _ => None
      end
  | cmp_case_fi sg =>
      match v1, v2 with
      | Vfloat n1, Vint n2 => Some (Val.of_bool (Float.cmp c n1 (cast_int_float sg n2)))
      | _, _ => None
      end
  | cmp_default => None
  end.

(** ** Function applications *)

Inductive classify_fun_cases : Type:=
  | fun_case_f (targs: typelist) (tres: type) (**r (pointer to) function *)
  | fun_default.

Definition classify_fun (ty: type) :=
  match ty with
  | Tfunction args res => fun_case_f args res
  | Tpointer (Tfunction args res) _ => fun_case_f args res
  | _ => fun_default
  end.

(** * Combined semantics of unary and binary operators *)

Definition sem_unary_operation
            (op: unary_operation) (v: val) (ty: type): option val :=
  match op with
  | Onotbool => sem_notbool v ty
  | Onotint => sem_notint v ty
  | Oneg => sem_neg v ty
  end.

Definition sem_binary_operation
    (op: binary_operation)
    (v1: val) (t1: type) (v2: val) (t2:type)
    (m: mem): option val :=
  match op with
  | Oadd => sem_add v1 t1 v2 t2
  | Osub => sem_sub v1 t1 v2 t2
  | Omul => sem_mul v1 t1 v2 t2
  | Omod => sem_mod v1 t1 v2 t2
  | Odiv => sem_div v1 t1 v2 t2
  | Oand => sem_and v1 t1 v2 t2
  | Oor  => sem_or v1 t1 v2 t2
  | Oxor  => sem_xor v1 t1 v2 t2
  | Oshl => sem_shl v1 t1 v2 t2
  | Oshr  => sem_shr v1 t1 v2 t2
  | Oeq => sem_cmp Ceq v1 t1 v2 t2 m
  | One => sem_cmp Cne v1 t1 v2 t2 m
  | Olt => sem_cmp Clt v1 t1 v2 t2 m
  | Ogt => sem_cmp Cgt v1 t1 v2 t2 m
  | Ole => sem_cmp Cle v1 t1 v2 t2 m
  | Oge => sem_cmp Cge v1 t1 v2 t2 m
  end.

Definition sem_incrdecr (id: incr_or_decr) (v: val) (ty: type) :=
  match id with
  | Incr => sem_add v ty (Vint Int.one) type_int32s
  | Decr => sem_sub v ty (Vint Int.one) type_int32s
  end.

End WITHMEM.


From iris.proofmode Require Import tactics.
From iris_logrel.F_mu_ref_conc Require Import logrel_binary.
From iris.algebra Require Import gmap dec_agree.
From iris.base_logic Require Import auth.
Import uPred.

Definition stackUR : ucmraT := gmapUR loc (dec_agreeR val).

Lemma stackR_self_op (h : stackUR) : h ≡ h ⋅ h.
Proof.
  intros i. rewrite lookup_op.
  match goal with
    |- ?A ≡ ?B ⋅ ?B => change B with A; destruct A as [c|]
  end; trivial.
  destruct c as [c|]; cbv -[equiv decide];
    try destruct decide; trivial; tauto.
Qed.

Class stackG Σ :=
  StackG { stack_inG :> authG Σ stackUR; stack_name : gname }.

Section Rules.
  Context `{stackG Σ}.
  Notation D := (prodC valC valC -n> iProp Σ).

  Definition stack_mapsto (l : loc) (v: val) : iProp Σ :=
    auth_own stack_name {[ l := DecAgree v ]}.

  Notation "l ↦ˢᵗᵏ v" := (stack_mapsto l v) (at level 20) : uPred_scope.

  Lemma stack_mapsto_dup l v : l ↦ˢᵗᵏ v ⊢ l ↦ˢᵗᵏ v ∗ l ↦ˢᵗᵏ v.
  Proof.
    by rewrite /stack_mapsto /auth_own -own_op -auth_frag_op -stackR_self_op.
  Qed.

  Lemma stack_mapstos_agree l v w:
    l ↦ˢᵗᵏ v ∗ l ↦ˢᵗᵏ w ⊢ l ↦ˢᵗᵏ v ∗ l ↦ˢᵗᵏ w ∧ v = w.
  Proof.
    iIntros "H".
    rewrite -own_op.
    iDestruct (own_valid _ with "H") as %Hvalid.
    rewrite own_op. unfold stack_mapsto, auth_own.
    iDestruct "H" as "[$ $]".
    specialize (Hvalid l). rewrite lookup_op ?lookup_singleton in Hvalid.
    cbv -[decide] in Hvalid; destruct decide; trivial.
  Qed.

  Program Definition StackLink_pre (Q : D) : D -n> D := λne P v,
    (∃ l w, v.1 = LocV l ∗ l ↦ˢᵗᵏ w ∗
            ((w = InjLV UnitV ∧ v.2 = FoldV (InjLV UnitV)) ∨
            (∃ y1 z1 y2 z2, w = InjRV (PairV y1 (FoldV z1)) ∗
              v.2 = FoldV (InjRV (PairV y2 z2)) ∗ Q (y1, y2) ∗ ▷ P(z1, z2))))%I.
  Solve Obligations with solve_proper.

  Global Instance StackLink_pre_contractive Q : Contractive (StackLink_pre Q).
  Proof.
    intros n P1 P2 HP v; simpl. repeat (apply exist_ne => ?).
    repeat apply sep_ne; trivial. rewrite or_ne; trivial.
    repeat (apply exist_ne => ?).
    repeat apply sep_ne; trivial.
    apply later_contractive => i ?. by apply HP.
  Qed.

  Definition StackLink Q := fixpoint (StackLink_pre Q).

  Lemma StackLink_unfold Q v :
    StackLink Q v ≡ (∃ l w,
      v.1 = LocV l ∗ l ↦ˢᵗᵏ w ∗
      ((w = InjLV UnitV ∧ v.2 = FoldV (InjLV UnitV)) ∨
      (∃ y1 z1 y2 z2, w = InjRV (PairV y1 (FoldV z1))
                      ∗ v.2 = FoldV (InjRV (PairV y2 z2))
                      ∗ Q (y1, y2) ∗ ▷ @StackLink Q (z1, z2))))%I.
  Proof. by rewrite {1}/StackLink fixpoint_unfold. Qed.

  Global Opaque StackLink. (* So that we can only use the unfold above. *)

  Lemma StackLink_dup (Q : D) v `{∀ vw, PersistentP (Q vw)} :
    StackLink Q v ⊢ StackLink Q v ∗ StackLink Q v.
  Proof.
    iIntros "H". iLöb as "Hlat" forall (v). rewrite StackLink_unfold.
    iDestruct "H" as (l w) "[% [Hl Hr]]"; subst.
    iDestruct (stack_mapsto_dup with "[Hl]") as "[Hl1 Hl2]"; first eauto.
    iDestruct "Hr" as "[#Hr|Hr]".
    { iSplitL "Hl1".
      - iExists _, _; iFrame "Hl1"; eauto.
      - iExists _, _; iFrame "Hl2"; eauto. }
    iDestruct "Hr" as (y1 z1 y2 z2) "[#H1 [#H2 [#HQ H']]]".
    rewrite later_forall; setoid_rewrite later_wand.
    iDestruct ("Hlat" $! (z1, z2) with "H'") as "[HS1 HS2]".
    iSplitL "Hl1 HS1".
    - iExists _, _; iFrame "Hl1"; eauto 10.
    - iExists _, _; iFrame "Hl2"; eauto 10.
  Qed.

  Lemma stackR_valid (h : stackUR) (i : loc) :
    ✓ h → h !! i = None ∨ ∃ v, h !! i = Some (DecAgree v).
  Proof.
    intros Hh; specialize (Hh i).
    by match type of Hh with
      ✓ ?A => match goal with
             | |- ?B = _ ∨ (∃ _, ?C = _) =>
               change B with A; change C with A;
                 destruct A as [[c|]|]; inversion H; eauto
             end
    end.
  Qed.

  Lemma stackR_alloc (h : stackUR) (i : loc) (v : val) :
    h !! i = None → ● h ~~> ● (<[i := DecAgree v]> h) ⋅ ◯ {[i := DecAgree v]}.
  Proof.
    intros H1; apply cmra_total_update.
    intros n z H2. rewrite (insert_singleton_op h); auto.
    destruct z as [[ze |] zo];
      unfold validN, cmra_validN in *; simpl in *; trivial.
    destruct H2 as [H21 H22]; split.
    - revert H21; rewrite !left_id. apply cmra_monoN_l.
    - intros j. rewrite lookup_op.
      destruct (decide (i = j)) as [|Hneq]; subst.
      + rewrite H1. rewrite lookup_singleton. constructor.
      + rewrite lookup_singleton_ne; trivial.
        specialize (H22 j).
        revert H22.
        match goal with
          |- ✓{_} ?B → ✓{_} (_ ⋅ ?A) =>
          change B with A; destruct A; by try constructor
        end.
  Qed.

  Lemma dec_agree_valid_op_eq (x y : dec_agreeR val) :
    ✓ (Some x ⋅ Some y) → x = y.
  Proof.
    intros H1.
    destruct x as [x|]; destruct y as [y|]; trivial;
      cbv -[decide] in H1; try destruct decide; subst; simpl; intuition trivial.
  Qed.

  Lemma stackR_auth_is_subheap (h h' : stackUR) :
    ✓ (● h ⋅ ◯ h') → ∀ i x, h' !! i = Some x → h !! i = Some x.
  Proof.
    intros H1 i x H2.
    destruct H1 as [H11 H12]; simpl in H11.
    specialize (H11 1).
    destruct H11 as [z H11].
    revert H11; rewrite ucmra_unit_left_id => H11.
    eapply cmra_extend in H11; [| by apply cmra_valid_validN].
    destruct H11 as (z1 & z2 & H31 & H32 & H33); simpl in *.
    specialize (H32 i).
    assert (H4 : ✓ (z1 ⋅ z2))by (by rewrite -H31).
    apply leibniz_equiv.
    rewrite H31. rewrite lookup_op.
    specialize (H4 i). rewrite ?lookup_op in H4.
    revert H32; rewrite H2 => H32.
    match type of H32 with
      ?C ≡{_}≡ _ =>
      match goal with
        |- ?A ⋅ ?B ≡ _ =>
        change C with A in *; destruct A as [a|]; inversion H32; subst
      end
    end.
    match type of H32 with
      ?C ≡{_}≡ _ =>
      match goal with
        |- ?A ⋅ ?B ≡ _ => destruct B
      end
    end.
    - set (H5 := dec_agree_valid_op_eq _ _ H4); clearbody H5. subst.
      inversion H3; subst.
      destruct x as [x|]; cbv -[decide]; try destruct decide;
        constructor; intuition trivial.
    - inversion H3; subst. constructor; trivial.
  Qed.

  Context {iI : heapIG Σ}.

  Definition stack_owns (h : stackUR) :=
    (own stack_name (● h)
        ∗ [∗ map] l ↦ v ∈ h, match v with
                             | DecAgree v' => l ↦ᵢ v'
                             | _ => True
                             end)%I.

  Lemma stack_owns_alloc E h l v :
    stack_owns h ∗ l ↦ᵢ v
      ⊢ |={E}=> stack_owns (<[l := DecAgree v]> h) ∗ l ↦ˢᵗᵏ v.
  Proof.
    iIntros "[[Hown Hall] Hl]".
    iDestruct (own_valid _ with "Hown") as "#Hvalid".
    iDestruct (auth_validI _ with "Hvalid") as "[Ha' Hb]";
      simpl; iClear "Hvalid".
    iDestruct "Hb" as %H1.
    iDestruct "Ha'" as (h') "Ha'"; iDestruct "Ha'" as %Ha'.
    rewrite ->(left_id _ _) in Ha'; setoid_subst.
    specialize (H1 l).
    match type of H1 with
      ✓ ?A => change A with (h' !! l) in H1
    end.
    destruct (h' !! l) as [[w|]|] eqn:Heq; inversion H1.
    - rewrite -{2}(insert_id _ _ _ Heq) -insert_delete.
      rewrite big_sepM_insert; [|apply lookup_delete_None; auto].
      iDestruct "Hall" as "[Hl' Hall]".
      iExFalso. iApply heap_mapsto_dup_invalid; by iFrame "Hl Hl'".
    - iMod (own_update with "Hown") as "Hown".
      by apply stackR_alloc.
      iDestruct "Hown" as "[Hown Hl']".
      iModIntro. iSplitR "Hl'"; [|unfold stack_mapsto, auth_own; trivial].
      iCombine "Hl" "Hall" as "Hall".
      unfold stack_owns. iFrame "Hown".
      rewrite big_sepM_insert; trivial.
  Qed.

  Lemma stack_owns_open h l v :
    stack_owns h ∗ l ↦ˢᵗᵏ v
      ⊢ own stack_name (● h)
           ∗ ([∗ map] l ↦ v ∈ delete l h,
            match v with
            | DecAgree v' => l ↦ᵢ v'
            | DecAgreeBot => True
            end) ∗ l ↦ᵢ v ∗ l ↦ˢᵗᵏ v.
  Proof.
    iIntros "[[Hown Hall] Hl]".
    unfold stack_mapsto, auth_own.
    iCombine "Hown" "Hl" as "Hown".
    iDestruct (own_valid _ with "Hown") as %Hvalid.
    iDestruct "Hown" as "[Hown Hl]".
    assert (Heq : h !! l = Some (DecAgree v)).
    eapply stackR_auth_is_subheap; eauto using lookup_singleton.
    rewrite -{1}(insert_id _ _ _ Heq) -insert_delete.
    rewrite big_sepM_insert; [|apply lookup_delete_None; auto].
    iDestruct "Hall" as "[$ $]"; by iFrame.
  Qed.

  Lemma stack_owns_close h l v :
    own stack_name (● h)
       ∗ ([∗ map] l ↦ v ∈ delete l h,
        match v with
        | DecAgree v' => l ↦ᵢ v'
        | DecAgreeBot => True
        end)
       ∗ l ↦ᵢ v ∗ l ↦ˢᵗᵏ v ⊢ stack_owns h ∗ l ↦ˢᵗᵏ v.
  Proof.
    iIntros "[Hown [Hall [Hl Hl']]]".
    unfold stack_mapsto, auth_own.
    iCombine "Hown" "Hl'" as "Hown".
    iDestruct (own_valid _ with "Hown") as %Hvalid.
    iDestruct "Hown" as "[Hown Hl']".
    assert (Heq : h !! l = Some (DecAgree v)).
    eapply stackR_auth_is_subheap; eauto using lookup_singleton.
    iCombine "Hl" "Hall" as "Hall".
    rewrite -(big_sepM_insert (λ l v,
        match v with
        | DecAgree v' => (l ↦ᵢ v')%I
        | DecAgreeBot => True%I
        end) _ _ (DecAgree v)); eauto using lookup_delete.
    rewrite insert_delete insert_id; auto using lookup_delete.
    unfold stack_owns. by iFrame.
  Qed.

  Lemma stack_owns_open_close h l v :
    stack_owns h ∗ l ↦ˢᵗᵏ v
      ⊢ l ↦ᵢ v ∗ (l ↦ᵢ v -∗ (stack_owns h ∗ l ↦ˢᵗᵏ v)).
  Proof.
    iIntros "[Howns Hls]".
    iDestruct (stack_owns_open with "[Howns Hls]") as "[Hh [Hm [Hl Hls]]]".
    { by iFrame "Howns Hls". }
    iFrame "Hl". iIntros "Hl".
    iApply stack_owns_close. by iFrame.
  Qed.

  Lemma stack_owns_later_open_close h l v :
    ▷ stack_owns h ∗ l ↦ˢᵗᵏ v
      ⊢ ▷ (l ↦ᵢ v ∗ (l ↦ᵢ v -∗ (stack_owns h ∗ l ↦ˢᵗᵏ v))).
  Proof. iIntros "H". by iNext; iApply stack_owns_open_close. Qed.
End Rules.


Add LoadPath "/nfs/users/paulkline/Documents/coqs/protosynth".

Add LoadPath "C:\Users\Paul\Documents\coqStuff\protosynth".
Require Import TrueProtoSynth.
Module example1.

SearchAbout nat.
Definition antivirusVersion := descriptor virusCheckerVersionR.

Definition bankwants := ConsRequestLS (requestItem antivirusVersion (requirement antivirusVersion ( fun (x:(measurementDenote antivirusVersion)) =>  Nat.leb 10 x))
)emptyRequestLS.
Definition bankPrivacy := EmptyPolicy.

Definition Tomwants := emptyRequestLS.
Definition tomPrivacy := @ConsPolicy antivirusVersion (free antivirusVersion) EmptyPolicy.

Definition bankState := mkAppraiserState bankPrivacy bankwants.
Definition tomState := mkAttesterState tomPrivacy.

Theorem finishes: exists bankState' tomState',
((OneProtocolStep bankState,bankState),
 (OneProtocolStep tomState, tomState), nil)
 ⟱⟱
 ((StopStatement, bankState'), (StopStatement, tomState'), nil).
Proof.
eexists. eexists.
eapply dualmultistep_step. apply dualmultistep_id. apply duLeft.
(*bank sends first message. prove it finishes *)
step. proto.
step. unfold proto_handleIsMyTurnToSend. c. simpl. auto.
step. c. c. simpl. refl.
step. proto.
step. unfold proto_handleCantSend. proto.
step. unfold proto_handleExistsNextDesire. c. c. refl.
step. c. c. refl.
c. c. c.  refl. nono.

eapply dualmultistep_step. apply dualmultistep_id. apply duRight.

(*now tom executes his protocol. *)
step. proto.
step. unfold proto_handleNotMyTurnToSend. c. c. c. nono.
step. proto.
step. proto.
c. c. c. refl.
(*tom has received, now he must send. *)

eapply dualmultistep_step. apply dualmultistep_id.
apply duRight.
step. proto.
step. c. simpl. refl.
step. c. c. refl.
step. proto.
step. c. refl.
step. s. c. c. refl.
step. c. c. refl. nono.
step. c. c. refl.
step. c. c. refl.
c. c. c. refl.

(*now the left side must  receive the measurement *)
eapply dualmultistep_step. apply dualmultistep_id. apply duLeft.
step. proto.
step. c. c. refl. nono.
step. proto.
c. c. c. refl.

(*Now the left side must send the stop. *)
apply dualmultistep_id. eapply duFinishLeftFirst.
step. unfold OneProtocolStep. apply E_ChooseTrue. simpl.
unblock_dep_elim. simpl. simpl_eq. refl.
step. apply E_ChooseFalse.  simpl.  unblock_dep_elim.  simpl.  simpl_eq. refl.
simpl.  unblock_dep_elim.  simpl.  simpl_eq.
Tactic Notation "ss" := unblock_dep_elim; simpl; simpl_eq.
c. proto.  refl.

(* now tom must also go to stop. *)
step. proto. unfold proto_handleNotMyTurnToSend. c. c. c. refl.
Qed.

End example1.

Lemma lemma00 : forall st st' stm x x2 n n',
(EffectStatement x  >> EndStatement, st, n) ⇓⇓ (SendStatement x2 (getMe st') (notMe (getMe st')) >> stm, st', n') -> False.
Proof. intros. crush.  dep_destruct H. inv H. inv H1. inv H2. inv H1. inv H7. inv H4.
 clear H1. clear H3. clear H2.
 inv H. inv H1. inv H2. inv H1.

  inv H5. inv H1.
Lemma lemma0 : forall st st' stm x n n', (proto_handleNotMyTurnToSend st, st, n) ⇓⇓ (SendStatement x (getMe st') (notMe (getMe st')) >> stm, st', n') -> False.
Proof. intros.
inv H. inv H1.
inv H2. inv H1.
 inv H7. inv H4.
 inv H5. inv H4.
inv H11. inv H8. inv H9. inv H8.

Lemma lemma1 : forall st d n st' n' stm,
varSubst (variable toSendMESSAGE) st' = Some (constValue d (measure d)) ->
(OneProtocolStep st, st, n) ⇓⇓ (SendStatement (variable toSendMESSAGE) (getMe st') (notMe (getMe st')) >> stm,st',n') ->
(OneProtocolStep st, st, n) ⇓ (proto_handleIsMyTurnToSend st, st, n).
Proof. intros. inv H0. inv H2.
inv H3. inv H2.
exact H2.
(* need to prove not true. *)
inv H8. inv H5.
inv H6. inv H5.
inv H12.
inv H9.
inv H10.
inv H9.
inv H12.
inv H13.
inv H14.
inv H13. inv H13.
inv H16.
inv H18.
inv H19. inv H18.
inv H25. inv H22.
inv H20. inv H22.
inv H31.
inv H12. inv H26. inv H27.
inv H26. inv H23. inv H30.       inv H5.  inv H29.

subst.

exact H
inv ZH2.
Theorem privacyiscool : forall st n d stm st' n',
(OneProtocolStep st, st, n) ⇓⇓ (SendStatement (const (constValue d (measure d))) (getMe st') (notMe (getMe st')) >> stm,st',n') ->
snd3 (handleRequest' (getPrivacy st') d) = constValue d (measure d) .
Proof.  intros.
inv H.
inv H1.

inv H2.  inv H1. clear H2.

inv H7. inv H2.
inv H4.  inv H2.
inv H10.  inv H6.
inv H8.  inv H6.  inv H6. inv H11.

(*yes *)
inv H14.  inv H13.
inv H15.  inv H13.

inv H20.  inv H17.
inv H18.  inv H17. clear H18.  clear H15. clear H8. clear H4.

inv H24. inv H4.
inv H8. inv H4.  simpl  in H4.
inv H23.  inv H18.

simpl.
inv H2.
inv H2.  inv H3.
inv H1.  inv H1.

inv H4.
inv H3.
inv H1.

inv H2.
inv H1.
inv H.
inv H1.
subst.   subst.  inv H1.  subst.
inv H2.  subst.
inv H1.  subst. .
inv H1.  subst.
inv H7.  subst.  inv H5.  subst.  inv H6.  subst.
inv H5.  subst.
inv H5.  subst.
inv H12.  subst.
inv H10. subst.
inv H11. subst.
inv H10.  subst.
inv H17.  subst.
inv H14. subst.

inv H17. subst.
inv H15. subst.
inv H14. subst.
inv H14. subst.

inv H15. subst.
inv H15.  subst.
inv H14. subst.
inv H14. subst.
inv H15. subst.

inv H21. subst.
inv H14.  subst.
inv H15. subst.
inv H14. subst.

inv H17.  subst.
inv H18. subst.
inv H19.  subst.
inv H18. subst.
inv H18. subst.
inv H14. subst.
inv H14. subst.
inv H14. subst.
inv H12.  subst.
inv H11.  subst.
inv H4. subst.
inv H11.  subst.
inv H11.  subst.
inv H4.  subst.
inv H17.  subst.
Theorem X : forall  ppApp ppAtt wants , exists STatt' STapp' n',
( (OneProtocolStep (mkAppraiserState ppApp wants), mkAppraiserState ppApp wants),
  (OneProtocolStep (mkAttesterState ppAtt), mkAttesterState ppAtt), nil)  ⟱⟱
((StopStatement, STapp'), (StopStatement, STatt'), n') .
Proof.  intro. induction ppApp; intros.
eexists. eexists. exists nil.
step.
(*appraiser makes first move*)
eapply duFinishLeftFirst.
step. proto. unfold proto_handleIsMyTurnToSend.
proto.
proto.
proto.
destruct wants. simpl.
proto.
proto.  refl.
c.  c.

proto. destruct r.
step. c.  c.  simpl.   refl.
proto.
simpl.
proto.
c.
proto.
unfold proto_handleCantSend.  step.
proto.
apply E_ChooseFalse; reflexivity.  c.  simpl.
proto.
Ltac proto2 := match goal with

 end. proto2.  refl.   proto2; [ proto|].
proto.  proto. .
 (apply dualmultistep_step) || ((eapply dualmultistep_id) ; [constructor|]).
step.
eapply dualmultistep_step.