(** * Bicolano: Semantic domains *)

(* <Insert License Here>

    $Id: Domain.v 69 2006-03-06 20:16:11Z davidpichardie $ *)

(** Formalization of Java semantic domain.
 Based on The "Java (TM) Virtual Machine Specification, Second Edition,
  Tim Lindholm, Frank Yellin"

 @author David Pichardie, ...  *)
(* Hendra : - Modified to suit DEX program (removed operand stack).
            - Removed reference comparison
            - Also trim the system to contain only Arithmetic *)

Require Export DEX_Program.
Require Export Numeric.
Require Export List.
Open Scope Z_scope.

(** All semantic domains and basic operation are encapsulated in a module signature *)

Module Type DEX_SEMANTIC_DOMAIN.

 (** We depend on the choices done for program data structures *)
 Declare Module DEX_Prog : DEX_PROGRAM. Import DEX_Prog.

 Declare Module Byte  : NUMERIC with Definition power := 7%nat.
 Declare Module Short : NUMERIC with Definition power := 15%nat.
 Declare Module Int   : NUMERIC with Definition power := 31%nat.

 (** conversion *)
 Parameter b2i : Byte.t -> Int.t.
 Parameter s2i : Short.t -> Int.t.
 Parameter i2b : Int.t -> Byte.t.
 Parameter i2s : Int.t -> Short.t.
 Parameter i2bool : Int.t -> Byte.t.

 Inductive DEX_num : Set :=
   | I : Int.t -> DEX_num
   | B : Byte.t -> DEX_num
   | Sh : Short.t -> DEX_num.

 (** Location is the domain of adresses in the heap *)

(* Hendra 10082016 - Only concerns DVM_I
 Parameter DEX_Location : Set.
 Parameter DEX_Location_dec : forall loc1 loc2:DEX_Location,{loc1=loc2}+{~loc1=loc2}.
*)

 Inductive DEX_value : Set :=
   | Num : DEX_num -> DEX_value
(* Hendra 10082016 - Only concerns DVM_I
   | Ref: DEX_Location -> DEX_value
   | Null : DEX_value*).

 Definition init_value (t:DEX_type) : DEX_value :=
    match t with
     (* Hendra 10082016 - Only concerns DVM_I | DEX_ReferenceType _ => Null*)
     | DEX_PrimitiveType _ => Num (I (Int.const 0))
    end.

(* Hendra 10082016 - Only concerns DVM_I
 Definition init_field_value (f:DEX_Field) : DEX_value :=
   match DEX_FIELD.initValue f with
    | DEX_FIELD.Int z => Num (I (Int.const z))
    | DEX_FIELD.NULL => Null
    | DEX_FIELD.UNDEF => init_value (DEX_FIELDSIGNATURE.type (DEX_FIELD.signature f))
  end.
*)

 (** Domain of local variables *)
 Module Type DEX_REGISTERS.
   Parameter t : Type.
   Parameter get : t-> DEX_Reg -> option DEX_value.
   Parameter update : t -> DEX_Reg -> DEX_value -> t.
   Parameter dom : t -> list DEX_Reg.
   (*Parameter ret : DEX_Reg.*)
   (* Hendra 10082016 Removed r0 requirements? Parameter r0 : DEX_Reg. *)
   Parameter get_update_new : forall l x v, get (update l x v) x = Some v.
   Parameter get_update_old : forall l x y v,
     x<>y -> get (update l x v) y = get l y.
 End DEX_REGISTERS.
 Declare Module DEX_Registers : DEX_REGISTERS.

 Parameter listreg2regs : DEX_Registers.t -> nat -> list DEX_Reg -> DEX_Registers.t.

(* 290415 - Some Notes
- According to verified DEX bytecode, every registers have
  to have a value before used. This means we can safely assume
  that we don't need the update to be option anymore because
  the only possible case where it updates empty value is when
  the source is empty, which has been taken care by the assumption
- The special register ret and ex are assigned the number
  65536 and 65537 respectively (in binary) because we know
  that the maximum number of registers is 65535.
*)

(*
 (* Domain of operand stacks *)
 Module Type OPERANDSTACK.
   Definition t : Set := list value.
   Definition empty : t := nil.
   Definition push : value -> t -> t := fun v t => cons v t.
   Definition size : t -> nat := fun t  => length t .
   Definition get_nth : t -> nat -> option value := fun s n => nth_error s n.
 End OPERANDSTACK.
 Declare Module OperandStack : OPERANDSTACK.

 (** Transfert fonction between operand stack and local variables necessary for invoke instructions *)
 Parameter stack2localvar : OperandStack.t -> nat -> LocalVar.t.
 Parameter stack2locvar_prop1 :
   forall s n x, (n <= Var_toN x)%nat -> LocalVar.get (stack2localvar s n) x = None.
 Parameter stack2locvar_prop2 :
   forall s n x, (Var_toN x < n)%nat ->
     LocalVar.get (stack2localvar s n) x = OperandStack.get_nth s (n-(Var_toN x)-1)%nat.
 (** %%nat is a coq command for the notation system *)
*)

(* Hendra 10082016 - Only concerns DVM_I
 Module Type DEX_HEAP.
   Parameter t : Type.

   Inductive DEX_AdressingMode : Set :=
     | StaticField : DEX_FieldSignature -> DEX_AdressingMode
     | DynamicField : DEX_Location -> DEX_FieldSignature -> DEX_AdressingMode
     | ArrayElement : DEX_Location -> Z -> DEX_AdressingMode.

   Inductive DEX_LocationType : Type :=
     | LocationObject : DEX_ClassName -> DEX_LocationType
     | LocationArray : Int.t -> DEX_type -> DEX_Method*DEX_PC -> DEX_LocationType.
   (** (LocationArray length element_type) *)

   Parameter get : t -> DEX_AdressingMode -> option DEX_value.
   Parameter update : t -> DEX_AdressingMode -> DEX_value -> t.
   Parameter typeof : t -> DEX_Location -> option DEX_LocationType.
     (** typeof h loc = None -> no object, no array allocated at location loc *)
   Parameter new : t -> DEX_Program -> DEX_LocationType -> option (DEX_Location * t).
     (** program is required to compute the size of the allocated element, i.e. to know
        the Class associated with a ClassName  *)

   (** Compatibility between a heap and an adress *)
   Inductive Compat (h:t) : DEX_AdressingMode -> Prop :=
     | CompatStatic : forall f,
         Compat h (StaticField f)
     | CompatObject : forall cn loc f,
         typeof h loc = Some (LocationObject cn) ->
         Compat h (DynamicField loc f)
     | CompatArray : forall length tp loc i a,
         0 <= i < Int.toZ length ->
         typeof h loc = Some (LocationArray length tp a) ->
         Compat h (ArrayElement loc i).

   Parameter get_update_same : forall h am v, Compat h am ->  get (update h am v) am = Some v.
   Parameter get_update_old : forall h am1 am2 v, am1<>am2 -> get (update h am1 v) am2 = get h am2.
   Parameter get_uncompat : forall h am, ~ Compat h am -> get h am = None.

   Parameter typeof_update_same : forall h loc am v,
     typeof (update h am v) loc = typeof h loc.

   Parameter new_fresh_location : forall (h:t) (p:DEX_Program) (lt:DEX_LocationType) (loc:DEX_Location) (h':t),
     new h p lt = Some (loc,h') ->
     typeof h loc = None.

   Parameter new_typeof : forall (h:t) (p:DEX_Program) (lt:DEX_LocationType) (loc:DEX_Location) (h':t),
     new h p lt = Some (loc,h') ->
     typeof h' loc = Some lt.

   Parameter new_typeof_old : forall (h:t) (p:DEX_Program) (lt:DEX_LocationType) (loc loc':DEX_Location) (h':t),
     new h p lt = Some (loc,h') ->
     loc <> loc' ->
     typeof h' loc' = typeof h loc'.

   Parameter new_defined_object_field : forall (h:t) (p:DEX_Program) (cn:DEX_ClassName) (fs:DEX_FieldSignature) (f:DEX_Field) (loc:DEX_Location) (h':t),
     new h p (LocationObject cn) = Some (loc,h') ->
     is_defined_field p cn fs f ->
     get h' (DynamicField loc fs) = Some (init_field_value f).

   Parameter new_undefined_object_field : forall (h:t) (p:DEX_Program) (cn:DEX_ClassName) (fs:DEX_FieldSignature) (loc:DEX_Location) (h':t),
     new h p (LocationObject cn) = Some (loc,h') ->
     ~ defined_field p cn fs ->
     get h' (DynamicField loc fs) = None.

  Parameter new_object_no_change :
     forall (h:t) (p:DEX_Program) (cn:DEX_ClassName) (loc:DEX_Location) (h':t) (am:DEX_AdressingMode),
     new h p (LocationObject cn) = Some (loc,h') ->
     (forall (fs:DEX_FieldSignature), am <> (DynamicField loc fs)) ->
     get h' am = get h am.

  Parameter new_valid_array_index : forall (h:t) (p:DEX_Program) (length:Int.t) (tp:DEX_type) a (i:Z) (loc:DEX_Location) (h':t),
     new h p (LocationArray length tp a) = Some (loc,h') ->
     0 <= i < Int.toZ length ->
     get h' (ArrayElement loc i) = Some (init_value tp).

  Parameter new_unvalid_array_index : forall (h:t) (p:DEX_Program) (length:Int.t) (tp:DEX_type) a (i:Z) (loc:DEX_Location) (h':t),
     new h p (LocationArray length tp a) = Some (loc,h') ->
     ~ 0 <= i < Int.toZ length ->
     get h' (ArrayElement loc i) = None.

  Parameter new_array_no_change :
     forall (h:t) (p:DEX_Program) (length:Int.t) (tp:DEX_type) a (loc:DEX_Location) (h':t) (am:DEX_AdressingMode),
     new h p (LocationArray length tp a) = Some (loc,h') ->
     (forall (i:Z), am <> (ArrayElement loc i)) ->
     get h' am = get h am.

(* These properties should be useless
   Parameter get_static_some : forall (h:t) (p:Program) (fs:FieldSignature),
     isStatic p fs ->
     exists v, get h (StaticField fs) = Some v.

   Parameter get_static_some : forall (h:t) (p:Program) (fs:FieldSignature),
     ~ isStatic p fs ->
     exists v, get h (StaticField fs) = None.
*)

 End DEX_HEAP.
 Declare Module DEX_Heap : DEX_HEAP.
*)

  Inductive DEX_ReturnVal : Set :=
   | Normal : option DEX_value -> DEX_ReturnVal
   (* DEX | Exception : Location -> ReturnVal *).

 (** Domain of frames *)
 Module Type DEX_FRAME.
   Inductive t : Type :=
      (*make : Method -> PC -> OperandStack.t -> LocalVar.t -> t.*)
      make : DEX_Method -> DEX_PC -> DEX_Registers.t -> t.
 End DEX_FRAME.
 Declare Module DEX_Frame : DEX_FRAME.

 (** Domain of call stacks *)
 Module Type DEX_CALLSTACK.
   Definition t : Type := list DEX_Frame.t.
 End DEX_CALLSTACK.
 Declare Module DEX_CallStack : DEX_CALLSTACK.
(* DEX
 Module Type EXCEPTION_FRAME.
   Inductive t : Type :=
      make : Method -> PC -> Location -> LocalVar.t -> t.
 End EXCEPTION_FRAME.
 Declare Module ExceptionFrame : EXCEPTION_FRAME.
*)
 (** Domain of states *)
 Module Type DEX_STATE.
   Inductive t : Type :=
      normal : (* Hendra 10082016 - Only concerns DVM_I DEX_Heap.t ->*) DEX_Frame.t -> DEX_CallStack.t -> t
    (* DEX | exception : Heap.t -> ExceptionFrame.t -> DEX_CallStack.t -> t *).
   Definition get_sf (s:t) : DEX_CallStack.t :=
     match s with
       normal (*_ *) _ sf => sf
     (* | exception _ _ sf => sf *)
     end.
   Definition get_m (s:t) : DEX_Method :=
     match s with
       normal (*_ *) (DEX_Frame.make m _ _)_ => m
     (* | exception _ (ExceptionFrame.make m _ _ _) _ => m *)
     end.
 End DEX_STATE.
 Declare Module DEX_State : DEX_STATE.

 (** Some notations *)
 Notation St := DEX_State.normal.
 (* DEX Notation StE := DEX_State.exception. *)
 Notation Fr := DEX_Frame.make.
 (* DEX Notation FrE := DEX_ExceptionFrame.make. *)

  (** compatibility between ArrayKind and type *)
(* Hendra 10082016 - Only concerns DVM_I
  Inductive compat_ArrayKind_type : DEX_ArrayKind -> DEX_type -> Prop :=
    | compat_ArrayKind_type_ref : forall rt,
        compat_ArrayKind_type DEX_Aarray (DEX_ReferenceType rt)
    | compat_ArrayKind_type_int :
        compat_ArrayKind_type DEX_Iarray (DEX_PrimitiveType DEX_INT)
    | compat_ArrayKind_type_byte :
        compat_ArrayKind_type DEX_Barray (DEX_PrimitiveType DEX_BYTE)
    | compat_ArrayKind_type_bool :
        compat_ArrayKind_type DEX_Barray (DEX_PrimitiveType DEX_BOOLEAN)
    | compat_ArrayKind_type_short :
        compat_ArrayKind_type DEX_Sarray (DEX_PrimitiveType DEX_SHORT).
*)
(*
  Inductive isReference : DEX_value -> Prop :=
  | isReference_null : isReference Null
  | isReference_ref : forall loc, isReference (Ref loc).
*)
  (** compatibility between ValKind and value *)
  Inductive compat_ValKind_value : DEX_ValKind -> DEX_value -> Prop :=
    (*| compat_ValKind_value_ref : forall v,
        isReference v -> compat_ValKind_value DEX_Aval v*)
    | compat_ValKind_value_int : forall n,
        compat_ValKind_value DEX_Ival (Num (I n)).

  (** compatibility between ArrayKind and value *)
(* Hendra 10082016 - Only concerns DVM_I
  Inductive compat_ArrayKind_value : DEX_ArrayKind -> DEX_value -> Prop :=
    | compat_ArrayKind_value_ref : forall v,
        isReference v -> compat_ArrayKind_value DEX_Aarray v
    | compat_ArrayKind_value_int : forall n,
        compat_ArrayKind_value DEX_Iarray (Num (I n))
    | compat_ArrayKind_value_byte : forall n,
        compat_ArrayKind_value DEX_Barray (Num (B n))
    | compat_ArrayKind_value_short : forall n,
        compat_ArrayKind_value DEX_Sarray (Num (Sh n)).
*)

  (* convert a value to be pushed on the stack *)
(* Hendra 10082916 - Only concerns DVM I - Definition conv_for_stack (v:DEX_value) : DEX_value :=
    match v with
    | Num (B b) => Num (I (b2i b))
    | Num (Sh s) => Num (I (s2i s))
    | _ => v
    end. *)

  (* convert a value to be store in an array *)
(* Hendra 10082016 - Only concerns DVM_I
  Definition conv_for_array (v:DEX_value) (t:DEX_type) : DEX_value :=
    match v with
    | Ref loc => v
    | Num (I i) =>
       match t with
         DEX_ReferenceType _ => v (* impossible case *)
       | DEX_PrimitiveType DEX_INT => v
       | DEX_PrimitiveType DEX_BOOLEAN => Num (B (i2bool i))
       | DEX_PrimitiveType DEX_BYTE => Num (B (i2b i))
       | DEX_PrimitiveType DEX_SHORT => Num (Sh (i2s i))
       end
    | _ => v (* impossible case *)
    end.
*)
  (** [assign_compatible_num source target] holds if a numeric value [source] can be
    assigned to a variable of type [target]. This point is not clear in the JVM spec. *)
  Inductive assign_compatible_num : DEX_num -> DEX_primitiveType -> Prop :=
   | assign_compatible_int_int : forall i, assign_compatible_num (I i) DEX_INT
   | assign_compatible_short_int : forall sh, assign_compatible_num (Sh sh) DEX_INT
   | assign_compatible_byte_int : forall b, assign_compatible_num (B b) DEX_INT
   | assign_compatible_short_short : forall sh, assign_compatible_num (Sh sh) DEX_SHORT
   | assign_compatible_byte_byte : forall b, assign_compatible_num (B b) DEX_BYTE
   | assign_compatible_byte_boolean : forall b, assign_compatible_num (B b) DEX_BOOLEAN.

  (** [assign_compatible h source target] holds if a value [source] can be
    assigned to a variable of type [target] *)
  Inductive assign_compatible (p:DEX_Program) (*h:DEX_Heap.t*) : DEX_value -> DEX_type -> Prop :=
  (* Hendra 10082016 - Only concerns DVM_I
   | assign_compatible_null : forall t, assign_compatible p h Null (DEX_ReferenceType t)
   | assign_compatible_ref_object_val : forall (loc:DEX_Location) (t:DEX_refType) (cn:DEX_ClassName),
       DEX_Heap.typeof h loc = Some (DEX_Heap.LocationObject cn) ->
       compat_refType p (DEX_ClassType cn) t ->
       assign_compatible p h (Ref loc) (DEX_ReferenceType t)
   | assign_compatible_ref_array_val : forall (loc:DEX_Location) (t:DEX_refType) (length:Int.t) (tp:DEX_type) a,
       DEX_Heap.typeof h loc = Some (DEX_Heap.LocationArray length tp a) ->
       compat_refType p (DEX_ArrayType tp) t ->
       assign_compatible p h (Ref loc) (DEX_ReferenceType t)
  *)
   | assign_compatible_num_val : forall (n:DEX_num) (t:DEX_primitiveType),
       assign_compatible_num n t -> assign_compatible p (*h*) (Num n) (DEX_PrimitiveType t).

(* DEX
  Inductive SemCompRef : CompRef -> DEX_value -> DEX_value -> Prop :=
  | SemCompRef_eq : forall v1 v2,
       isReference v1 -> isReference v2 -> v1 = v2 ->
     (****************************************************)
          SemCompRef EqRef v1 v2
  | SemCompRef_ne : forall v1 v2,
       isReference v1 -> isReference v2 -> v1 <> v2 ->
     (****************************************************)
          SemCompRef NeRef v1 v2.
*)

  Definition SemCompInt (cmp:DEX_CompInt) (z1 z2: Z) : Prop :=
    match cmp with
      DEX_EqInt =>  z1=z2
    | DEX_NeInt => z1<>z2
    | DEX_LtInt => z1<z2
    | DEX_LeInt => z1<=z2
    | DEX_GtInt => z1>z2
    | DEX_GeInt => z1>=z2
    end.

  Definition SemBinopInt (op:DEX_BinopInt) (i1 i2:Int.t) : Int.t :=
    match op with
    | DEX_AddInt => Int.add i1 i2
    | DEX_AndInt => Int.and i1 i2
    | DEX_DivInt => Int.div i1 i2
    | DEX_MulInt => Int.mul i1 i2
    | DEX_OrInt => Int.or i1 i2
    | DEX_RemInt => Int.rem i1 i2
    | DEX_ShlInt => Int.shl i1 i2
    | DEX_ShrInt => Int.shr i1 i2
    | DEX_SubInt => Int.sub i1 i2
    | DEX_UshrInt => Int.ushr i1 i2
    | DEX_XorInt => Int.xor i1 i2
    end.

  (** Lookup in the callstack if one frame catches the thrown exception *)
  (* If an handler can catch the exception then the control flow is transferred
     to the beginning of the handler and the exception caught is the only element
     of the operand stack *)
  (* If lookup in the topmost frame fails, the frame is popped and the lookup
     continues in the next frame *)
  (* FIXME: Check that the object pointed by loc is an instance of Throwable? - gd *)

(*  Inductive CaughtException (p:Program) : Method -> PC*Heap.t*Location -> PC -> Prop :=
    CaughtException_def : forall m pc h loc bm pc' e,
      METHOD.body m = Some bm ->
      Heap.typeof h loc = Some (Heap.LocationObject e) ->
      lookup_handlers p (BYTECODEMETHOD.exceptionHandlers bm) pc e pc' ->
      CaughtException p m (pc,h,loc) pc'.

  Inductive UnCaughtException (p:Program) : Method -> PC*Heap.t*Location -> Prop :=
    UnCaughtException_def : forall m pc h loc bm e,
      METHOD.body m = Some bm ->
      Heap.typeof h loc = Some (Heap.LocationObject e) ->
      (forall pc', ~ lookup_handlers p (BYTECODEMETHOD.exceptionHandlers bm) pc e pc') ->
      UnCaughtException p m (pc,h,loc). *)

End DEX_SEMANTIC_DOMAIN.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Import Coq.ZArith.ZArith.
Require Import Fiat.Common.Enumerable.
Require Import Fiat.Common.Enumerable.BoolProp.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Common.List.ListFacts.
Require Import Fiat.Common.Equality.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.ContextFreeGrammar.PreNotations.
Require Import Fiat.Common.Gensym.
Require Import Fiat.Common.Tactics.BreakMatch.
Require Import Fiat.Common.Tactics.DestructHead.

Local Open Scope type_scope.

Definition default_nonterminal_carrierT : Type := nat.
(** (nonterminal, production_index, drop_count) *)
Definition default_production_carrierT : Type
  := default_nonterminal_carrierT * (nat * nat).

Global Instance dnc_BoolDecR : BoolDecR default_nonterminal_carrierT := _.
Global Instance dnc_BoolDec_bl : BoolDec_bl (@eq default_nonterminal_carrierT)
  := _.
Global Instance dnc_BoolDec_lb : BoolDec_lb (@eq default_nonterminal_carrierT)
  := _.

Local Ltac eassumption' :=
  idtac;
  match goal with
    | [ H : _ |- _ ] => solve [ refine H ]
  end.

Definition default_production_carrierT_beq : default_production_carrierT -> default_production_carrierT -> bool
  := Equality.beq.
Definition default_production_carrierT_bl
: forall {x y}, default_production_carrierT_beq x y = true -> x = y
  := Equality.bl.
Definition default_production_carrierT_lb
: forall {x y}, x = y -> default_production_carrierT_beq x y = true
  := Equality.lb.

Section grammar.
  Context {Char} {G : pregrammar' Char}.

  Local Notation valid_nonterminals := (List.map fst (pregrammar_productions G)).

  Definition some_invalid_nonterminal
    := gensym valid_nonterminals.

  Lemma some_invalid_nonterminal_invalid'
  : ~List.In some_invalid_nonterminal valid_nonterminals.
  Proof.
    apply gensym_fresh.
  Qed.
  Lemma some_invalid_nonterminal_invalid
  : ~List.In some_invalid_nonterminal (Valid_nonterminals G).
  Proof.
    intro H; apply some_invalid_nonterminal_invalid'.
    assumption.
  Qed.

  Definition default_to_nonterminal
  : default_nonterminal_carrierT -> String.string
    := fun nt => List.nth nt valid_nonterminals some_invalid_nonterminal.

  Definition default_of_nonterminal
  : String.string -> default_nonterminal_carrierT
    := fun nt => List.first_index_default
                   (string_beq nt)
                   (List.length valid_nonterminals)
                   valid_nonterminals.

  Lemma default_find_to_nonterminal idx
  : List.first_index_error
      (string_beq (default_to_nonterminal idx))
      valid_nonterminals
    = bool_rect
        (fun _ => option _)
        (Some idx)
        (None)
        (Compare_dec.leb (S idx) (List.length valid_nonterminals)).
  Proof.
    pose proof (nonterminals_unique G) as HNoDup.
    hnf in HNoDup.
    unfold pregrammar_nonterminals in *.
    destruct (Compare_dec.leb (S idx) (List.length valid_nonterminals)) eqn:H0; simpl;
      [ apply Compare_dec.leb_complete in H0
      | apply Compare_dec.leb_complete_conv in H0 ].
      { generalize dependent idx.
        unfold default_to_nonterminal, default_to_nonterminal, Valid_nonterminals, grammar_of_pregrammar, pregrammar_nonterminals.
        replace valid_nonterminals with (uniquize string_beq valid_nonterminals) by (rewrite HNoDup; reflexivity).
        induction valid_nonterminals as [|x xs IHxs].
        { simpl; intros; omega. }
        { simpl.
          simpl in *.
          destruct (list_bin string_beq x (uniquize string_beq xs)) eqn:H''; try assumption.
          { apply (f_equal (@List.length _)) in HNoDup.
            simpl in *.
            pose proof (uniquize_shorter xs string_beq) as H'.
            rewrite HNoDup in H'.
            exfalso; clear -H'.
            omega. }
          apply (f_equal (@List.tl _)) in HNoDup; simpl in *.
          specialize (IHxs HNoDup).
          intros [|idx].
          { simpl.
            rewrite (string_lb eq_refl); trivial. }
          { simpl; intros H'.
            specialize (IHxs idx (Le.le_S_n _ _ H')).
            rewrite first_index_helper_first_index_error, IHxs by omega.
            apply first_index_error_Some_correct in IHxs.
            repeat match goal with
                     | _ => exact (@string_lb)
                     | _ => progress simpl in *
                     | [ H : and _ _ |- _ ] => destruct H
                     | [ H : ex _ |- _ ] => destruct H
                     | [ |- context[if ?E then _ else _] ] => destruct E eqn:?
                     | _ => reflexivity
                     | [ |- Some _ = Some _ ] => apply f_equal
                     | [ |- 0 = S _ ] => exfalso
                     | [ H : string_beq _ _ = true |- _ ] => apply string_bl in H
                     | _ => progress subst
                     | [ H : _ = ?x |- _ ] => is_var x; subst x
                     | [ H : S _ = S _ |- _ ] => apply (f_equal pred) in H
                     | [ H : List.length (uniquize _ _) = List.length _ |- _ ]
                       => apply uniquize_length in H
                     | [ H : uniquize ?beq ?ls = ?ls, H' : context[uniquize ?beq ?ls] |- _ ]
                       => rewrite H in H'
                     | [ H : list_bin _ _ _ = false |- False ]
                       => rewrite list_in_lb in H; [ discriminate | | ]
                     | [ |- List.In (List.nth _ _ _) _ ] => apply List.nth_In; omega
                     | [ |- context[List.nth_error ?n ?ls] ] => destruct (List.nth_error n ls) eqn:?
                     | _ => congruence
                     | _ => progress unfold BoolFacts.Bool.bool_rect_nodep in *
                   end. } } }
      { unfold default_to_nonterminal, default_to_nonterminal.
        simpl.
        rewrite List.nth_overflow by omega.
        apply first_index_error_None_correct; intros elem H''.
        destruct (string_beq some_invalid_nonterminal elem) eqn:H'''; trivial.
        apply string_bl in H'''.
        subst.
        apply some_invalid_nonterminal_invalid' in H''; destruct H''. }
  Qed.

  Lemma list_to_productions_to_nonterminal nt
  : Lookup_string G (default_to_nonterminal nt)
    = Lookup_idx G nt.
  Proof.
    unfold Lookup_string, Lookup_idx.
    unfold list_to_productions at 1; simpl.
    unfold productions, production in *.
    rewrite <- find_first_index_error by exact bl.
    rewrite default_find_to_nonterminal.
    set (ls' := pregrammar_productions G); clearbody ls'.
    revert nt; induction ls' as [|x xs IHxs]; simpl; intro nt;
    destruct nt; simpl; trivial;
    rewrite <- IHxs; clear IHxs.
    edestruct @Compare_dec.leb; simpl; reflexivity.
  Qed.

  Lemma nth_error_default_to_nonterminal nt_idx
    : List.nth_error (pregrammar_productions G) nt_idx
      = if nt_idx <? List.length (pregrammar_productions G)
        then Some (default_to_nonterminal nt_idx, Lookup_idx G nt_idx)
        else None.
  Proof.
    destruct (nt_idx <? List.length (pregrammar_productions G)) eqn:Hlt.
    { apply Nat.ltb_lt in Hlt.
      unfold Lookup_idx, default_to_nonterminal.
      rewrite !nth_error_nth.
      repeat match goal with
             | _ => reflexivity
             | _ => discriminate
             | _ => omega
             | _ => break_innermost_match_step
             | _ => progress subst
             | _ => progress destruct_head' sig
             | _ => progress destruct_head' and
             | [ H : ?x = Some ?y, H' : ?x = Some ?z |- _ ]
               => assert (y = z) by congruence; (subst y || subst z)
             | [ H : ?x = Some _ |- ?x = _ ] => rewrite H
             | [ H : List.nth_error (List.map _ _) _ = Some _ |- _ ]
               => apply ListFacts.nth_error_map'_strong in H
             | [ H : List.nth_error (List.map ?f ?ls) ?idx = None |- _ ]
               => let H' := fresh in
                  destruct (List.nth_error ls idx) eqn:H';
                    [ eapply List.map_nth_error in H'; rewrite H in H'; congruence
                    | clear H ]
             | _ => progress destruct_head' prod
             | [ |- None = Some _ ] => exfalso
             | [ H : List.nth_error _ _ = None |- False ]
               => apply List.nth_error_None in H
             end. }
    { apply List.nth_error_None.
      apply Nat.ltb_ge in Hlt; assumption. }
  Qed.

  Section index.
    Context (idx : default_production_carrierT).

    Let nt_idx := fst idx.
    Let nts := (Lookup_idx G nt_idx).
    Let ps_idx := List.length nts - S (fst (snd idx)).
    Let drop_count := snd (snd idx).
    Let ps := (List.nth ps_idx nts nil).

    Definition default_to_production : production Char
    := List.drop drop_count ps.

    Definition default_production_tl : default_production_carrierT
      := (nt_idx,
          (fst (snd idx),
           if Compare_dec.leb (S drop_count) (List.length ps)
           then S drop_count
           else drop_count)).

    Definition default_production_carrier_valid : bool
      := ((Compare_dec.leb (S nt_idx) (List.length (pregrammar_productions G)))
            && ((Compare_dec.leb (S (fst (snd idx))) (List.length nts))
                  && (Compare_dec.leb drop_count (List.length ps))))%bool.
  End index.

  Global Instance default_production_carrier_valid_enumerable
  : Enumerable { idx : default_production_carrierT | is_true (default_production_carrier_valid idx) }.
  Proof.
    exact _.
  Defined.
End grammar.


From mathcomp Require Import all_ssreflect.

From mathcomp Require Import finmap.

From CKB Require Import Types Parameters Forest Setfs Messages States Network ConsensusHelper.

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

Definition G_syncing (gs : GState) :=
  exists (can_bt : BlockTree) (can_bc : Blockchain) (can_u : UserId),
    [/\ holds can_u gs (has_chain can_bc),
     largest_chain gs can_bc,
     (valid_bt can_bt /\ has_gb can_bt /\ can_bc = btBlockchain can_bt /\ good_bt can_bt),
     (forall (u' : UserId),
       peers (user_state gs u') = rem u' (enum userid_finType)) &
     forall (u' : UserId),
       holds u' gs (fun us => can_bt = foldl bt_upd (btree us) (blocks_for u' gs))
    ].

Definition sync_inv (gs : GState) :=
  Coh gs /\ G_syncing gs.

(* sync invariant holds in the initial state *)
Lemma sync_initial_state :
  sync_inv initGState.
Proof.
  rewrite /sync_inv; split.
  exact Coh_init.
  exists initBlockTree, [:: GenesisBlock], user; split.
  - rewrite /holds /has_chain initGState_user.
      by rewrite /initUState btBlockchain_initBlockTree eqxx.
  - rewrite /largest_chain /holds /has_chain => u bc.
    rewrite initGState_user => /eqP <-.
      by rewrite btBlockchain_initBlockTree; left.
  - repeat split; rewrite /initBlockTree.
    + move => h b; rewrite fnd_set; case: ifP; last by rewrite fnd_fmap0.
        by move => /eqP ->; case => ->.
    + by rewrite /has_gb fnd_set eqxx.
    + by rewrite -/initBlockTree btBlockchain_initBlockTree.
    + move => b; rewrite -/initBlockTree => I; apply /andP.
      split; rewrite compute_blockchain_initBlockTree //;
        by [rewrite /good_blockchain eqxx | apply: init_valid_blockchain].
  - by move => u; rewrite initGState_user /initUState /=.
  - rewrite /holds => u.
      by rewrite initGState_user /initUState /=.
Qed.

(* sync invariant means eventual consensus *)
Lemma sync_eventual_consensus (gs : GState) :
  sync_inv gs -> (forall (u : UserId), blocks_for u gs == [::]) ->
  exists (bc : Blockchain), largest_chain gs bc /\
                            (forall (u : UserId), holds u gs (has_chain bc)).
Proof.
  case => C [can_bt] [can_bc] [can_u] [H1 H2 [H3 [H4 [H5 H6]]] H7 H8] Hnil.
  exists can_bc. split => // u.
  move: (Hnil u) => /eqP Hnilb.
  move: (H8 u). rewrite Hnilb /=.
    by rewrite /has_chain /holds H5 => <-.
Qed.

(* sync invariant holds as long as user states do not change *)
Lemma sync_no_change (gs : GState) :
  forall (p1 p2 : seq Packet) (u : UserId) (us : UState),
    let: gs' := {| user_state := setfs (user_state gs) u us;
                   inflight_msg := p1;
                   consumed_msg := p2 |} in
    peers us = peers (user_state gs u) ->
    btree us = btree (user_state gs u) ->
    (forall (u : UserId), blocks_for u gs = blocks_for u gs') ->
    G_syncing gs -> G_syncing gs'.
Proof.
  move => p1 p2 u us Hpeers Hbtree H.
  rewrite /G_syncing /largest_chain /holds /user_state.
  case => bc [bt] [can_u] [H1 H2 H3 H4 H5].
  exists bc, bt, can_u.
  split => //= => [|u' bc'|u'|u']; rewrite setfsNK; case: ifP.
    by rewrite /has_chain Hbtree /=; move /eqP => <-; apply: H1.
    by move => _; apply: H1.
    by rewrite /has_chain Hbtree /=; move /eqP => <- ; apply: H2.
    by move => _; apply: H2.
    by rewrite Hpeers /=; move /eqP => ->; apply: H4.
    by move => _; apply: H4.
    rewrite (H5 u') H => /eqP ->.
    by rewrite /blocks_for Hbtree /=.
    by rewrite (H5 u') H /blocks_for /=.
Qed.

Lemma irrelevant_message :
  forall (gs : GState) (u : UserId) (p : Packet),
    p \in inflight_msg gs -> (forall (b : Block), msg p != BlkMsg b)->
    blocks_for_rec [seq p0 <- inflight_msg gs | dst p0 == u] =
    blocks_for_rec [seq p0 <- rem p (inflight_msg gs) | dst p0 == u].
Proof.
  move => gs u p /rem_split => Hex Hn.
  case: Hex => p1 [p2] [P_ext [P_nin P_rem]].
  rewrite P_rem P_ext !filter_cat !blocks_for_split /=.
  case: ifP => //= D.
  case M: (msg p) => //= [b'].
    by contradict M; apply /eqP.
Qed.

Lemma irrelevant_broadcast :
  forall (u : UserId) (prs : seq UserId) (ps : seq Packet) (a : pred Packet) (m : Message),
    (forall (b : Block), m != BlkMsg b) ->
    blocks_for_rec [seq p <- ps ++ emitBroadcast u prs m | a p] =
    blocks_for_rec [seq p <- ps | a p].
Proof.
  move => u; elim => [|i prs IH] ps a m Hn /=; first by rewrite cats0.
  rewrite -(IH ps a m Hn).
  rewrite !filter_cat !blocks_for_split /=.
  case: ifP => //=; case: m Hn => [b|ts|hs] Hn;
    by [move: (Hn b); rewrite eqxx |].
Qed.

Lemma filter_all_nil {T : Type} :
  forall (a : pred T) (s : seq T),
    all (fun x => ~~ a x) s -> [seq t <- s | a t] = [::].
Proof.
  move => a; elim => [|h s IH] => //=.
  move => /andP [/negPf N A].
    by rewrite N; apply: IH.
Qed.

Lemma relevant_broadcast :
  forall (from u : UserId) (b : Block) (prs : seq UserId),
  uniq prs -> u \in prs -> VAF b ->
  blocks_for_rec [seq p <- emitBroadcast from prs (BlkMsg b) | dst p == u] = [::b].
Proof.
  move => from u b prs Uniq In V.
  rewrite /emitBroadcast.
  elim: prs Uniq In => [|p prs IH] Uniq In //.
  move: Uniq => /= /andP [Hn Uniq].
  move: In; rewrite inE => /orP; case => [/eqP E | H].
  - subst p; rewrite eqxx /= V.
    suff S : all (fun x => dst x != u) [seq {| src := from; dst := t; msg := BlkMsg b |} | t <- prs]
      by rewrite filter_all_nil => //.
    elim: prs Hn Uniq {IH} => [|p prs IH] //=.
    rewrite inE negb_or => /andP; case => [Neq Nin].
    move /andP => [PNin Uniq]; apply /andP; split; last by apply: IH.
      by apply /negP; rewrite eq_sym; apply /negP.
  - case: ifP => /eqP U; last by apply: IH.
      by subst p; move: Hn; rewrite H.
Qed.

Lemma irrelevant_broadcast' :
  forall (from u : UserId) (b : Block) (prs : seq UserId),
  uniq prs -> u \notin prs ->
  blocks_for_rec [seq p <- emitBroadcast from prs (BlkMsg b) | dst p == u] = [::].
Proof.
  move => from u b prs Uniq Nin.
  rewrite /emitBroadcast.
  elim: prs Uniq Nin => [|p prs IH] Uniq Nin //.
  move: Uniq => /= /andP [Hn Uniq].
  move: Nin. rewrite inE negb_or => /andP; case => Neq Nin.
  rewrite eq_sym; move /negPf: Neq => ->.
    by apply: IH.
Qed.

Lemma foldl_blocks_for_upd :
  forall (bt : {fmap HashValue -> Block}) (p : Packet) (ps : seq Packet) (a : pred Packet) (b : Block),
    a p -> msg p = BlkMsg b -> VAF b ->
    foldl bt_upd bt (undup (blocks_for_rec [seq p0 <- p :: ps | a p0])) =
    foldl bt_upd (bt_upd bt b) (undup (blocks_for_rec [seq p0 <- ps | a p0])).
Proof.
  move => bt p ps a b A M V.
  rewrite /= A /= M V /=.
  case: ifP => Hin; last by done.
  move: Hin; elim: (blocks_for_rec [seq p0 <- ps | a p0]) bt => [|b' bs IH] bt //=.
  rewrite inE => /orP; move => [/eqP H | H].
  - subst b'.
    case: ifP => Hin; first by apply: IH.
      by rewrite /= btupd_dupE.
  - case: ifP => Hin; first by apply: IH.
    rewrite /= bt_updC.
      by apply: IH.
Qed.

Lemma blocks_for_cat :
  forall (s1 s2 : seq Packet) (a : pred Packet),
    blocks_for_rec [seq p <- s1 ++ s2 | a p] =
    blocks_for_rec [seq p <- s1 | a p] ++ blocks_for_rec [seq p <- s2 | a p].
Proof.
  elim => [|h s1 IH] s2 a //=.
  case: ifP => A //=.
  case M: (msg h) => [b|ts|hs] //.
  case V: (VAF b) => //.
    by rewrite cat_cons IH.
Qed.

Lemma relevant_message :
  forall (gs : GState) (p : Packet) (bt : {fmap HashValue -> Block}) (b : Block),
  valid_bt bt ->
  p \in inflight_msg gs ->
  msg p = BlkMsg b -> VAF b ->
  foldl bt_upd bt.[#b b <- b] (undup (blocks_for_rec [seq p0 <- rem p (inflight_msg gs) | dst p0 == dst p]))
  = foldl bt_upd bt (undup (blocks_for_rec [seq p0 <- inflight_msg gs | dst p0 == dst p])).
Proof.
  move => gs p bt b Hv Hin M V.
  move: (rem_split Hin) => [s1] [s2] [Heq [Hn Hrem]].
  rewrite Hrem Heq !blocks_for_cat !foldl_undup_split.
  rewrite [foldl _ (foldl _ bt _) _]foldl_comm.
  rewrite (@foldl_blocks_for_upd bt p s2 _ b) => //.
    by rewrite foldl_comm.
Qed.

Lemma irrelevant_blkmsg:
  forall (gs : GState) (p : Packet) (bt : {fmap HashValue -> Block}) (u : UserId),
  p \in inflight_msg gs ->
  dst p == u = false ->
  foldl bt_upd bt (undup (blocks_for_rec [seq p0 <- rem p (inflight_msg gs) | dst p0 == u]))
  = foldl bt_upd bt (undup (blocks_for_rec [seq p0 <- inflight_msg gs | dst p0 == u])).
Proof.
  move => gs p bt u Hin Ndst.
  move: (rem_split Hin) => [s1] [s2] [Heq [Hn Hrem]].
  rewrite Hrem Heq !blocks_for_cat !foldl_undup_split.
    by rewrite /= Ndst.
Qed.

Lemma in_seq_undup {T : eqType} :
  forall (s : seq T) (x : T),
    x \in s -> x \in undup s.
Proof.
  elim => [|h s IH] x //=.
  rewrite inE => /orP; move => [/eqP H | H]; case: ifP => Hp.
    by subst h; apply: IH.
    by rewrite H mem_head.
    by apply: IH.
    by rewrite inE; apply /orP; right; apply: IH.
Qed.

Lemma in_undup_seq {T : eqType} :
  forall (s : seq T) (x : T),
    x \in undup s -> x \in s.
Proof.
  elim => [|h s IH] x //=.
  case: ifP => E; rewrite inE.
    by move => /IH => H; apply /orP; right.
  move => /orP [/eqP H | H].
    by rewrite H mem_head.
    by rewrite inE; apply /orP; right; apply: IH.
Qed.

Lemma block_in_queue :
  forall (p : Packet) (b : Block) (u : UserId) (gs : GState),
    p \in inflight_msg gs -> dst p = u ->
    msg p = BlkMsg b -> VAF b ->
    b \in blocks_for u gs.
Proof.
  move => p b u gs Hin D M V.
  rewrite /blocks_for.
  elim: (inflight_msg gs) Hin => [|p' ps IH] //=.
  rewrite inE => /orP; move => [/eqP H | H].
    by rewrite -H D eqxx /= M V in_undup.
  case: ifP => /eqP E /=; last by apply: IH.
  case: (msg p').
  move => b'; case: ifP => _; last by apply: IH.
  apply: in_seq_undup; rewrite inE; apply /orP; right.
  apply: in_undup_seq.
    by apply: IH.
    by move => _; apply: IH.
    by move => _; apply: IH.
Qed.

Lemma notin_rem_peers :
  forall (u u' : UserId),
    u \notin rem u' (rem u (enum userid_finType)).
Proof.
  move => u u'.
  move: (enum_uniq userid_finType) => U.
  have H : u \notin rem u (enum userid_finType).
    by rewrite mem_rem_uniqF.
  elim: (rem u (enum userid_finType)) H => [|p ps IH] //=.
  rewrite inE negb_or => /andP; case => /negPf Neq Nin.
  case: ifP => //= F.
  rewrite inE negb_or; apply /andP; split.
    by rewrite Neq.
    by apply: IH.
Qed.

Lemma rem_in_mem {T : eqType} :
  forall (s : seq T) (x y : T),
    x <> y -> x \in s -> x \in rem y s.
Proof.
  elim => [|z s IH] x y N //.
  rewrite inE => /orP; case => [/eqP E | H].
  - subst z; rewrite /=.
    move /eqP/negPf: N => ->.
      by rewrite inE eqxx.
  - rewrite /=; case: ifP => E //.
    rewrite inE; apply /orP; right.
      by apply: IH.
Qed.

Lemma count1_impl_in {T : eqType} :
  forall (s : seq T) (x : T),
    count_mem x s = 1 -> x \in s.
Proof.
  elim => [|y s IH] x //=.
  case E: (y == x) => /=.
  - move /eqP: E => -> _.
      by rewrite inE eqxx.
  - rewrite add0n => /IH.
      by rewrite inE orbC => ->.
Qed.

Lemma in_rem_peers :
  forall (u1 u2 u3: UserId),
    u1 <> u3 -> u3 <> u2 ->
    u3 \in rem u1 (rem u2 (enum userid_finType)).
Proof.
  move => u1 u2 u3 N1 N2.
  have H1 : u3 \in rem u2 (enum userid_finType).
  apply: rem_in_mem => //. rewrite enumT.
  apply: count1_impl_in; apply: enumP.
  apply: rem_in_mem => //.
    by apply /eqP/negPf; move /eqP/negPf: N1; rewrite eq_sym.
Qed.

(* final theorem *)
Theorem sync_inv_step (gs gs' : GState) (s : Schedule) :
  sync_inv gs -> system_step gs gs' s -> sync_inv gs'.
Proof.
  move => [C Isync] S; split; first by apply (Coh_step S).
  case: S;
  (* Idle *)
  first by move => [_ <-].
  (* Deliver *)
  move => p.
  case => [C_uiq C_valid C_gb] S_dst S_flight.
  case P: (proc_msg _ _ _ _) => [us ps] ->.
  case M: (msg p) => [b | ts | hs]; move: P; rewrite M /=.

  (* Block message *)
  - case: ifP => V; last first.
    (* invalid block *)
    case => H_useq H_peq.
    apply: sync_no_change; [by rewrite -H_useq..| | by done].
    rewrite -H_peq /blocks_for /emitZero cats0 /= => u.
    move: (rem_split S_flight) => [p1] [p2] [P_ext [P_nin P_rem]].
    rewrite P_rem P_ext !filter_cat !blocks_for_split /=.
      by case: ifP => //=; rewrite M V.
    (* valid block *)
    case: Isync => can_bt [can_bc] [can_u] [I_chain I_large [I_valid [I_gb [I_ext I_good]]] I_cliq I_sub].
    case: ifP => P; case => H_useq H_peq; exists can_bt, can_bc, can_u; split => //.
    (* no missing transactions *)
    (* has chain *)
    +  rewrite /holds /=.
       rewrite setfsNK; case: ifP => /eqP D; last by apply: I_chain.
       rewrite -H_useq /receive_block_update.
       move: I_chain; rewrite /holds /has_chain D /= => /eqP.
       move: (I_sub (dst p)); rewrite /holds.
       case U: (user_state gs (dst p)) => [u prs bt txp] /= Hbt Hc; apply /eqP.
       have H : btBlockchain bt = btBlockchain (foldl bt_upd bt (blocks_for can_u gs))
         by rewrite D Hc I_ext Hbt.
       rewrite -Hc.
       have Hin : b \in blocks_for can_u gs.
       apply: block_in_queue; [exact S_flight | by rewrite D | exact M | exact V].
       have Hvalid : valid_bt bt by move: (C_valid (dst p)); rewrite /holds U.
       have Hgb : has_gb bt by move: (C_gb (dst p)); rewrite /holds U.
         by rewrite (btBlockchain_seq_same Hvalid Hgb Hin) //.
     (* largest chain *)
     + rewrite /largest_chain /holds /= => u bc.
       rewrite setfsNK; case: ifP => /eqP D; last by apply: I_large.
       rewrite -H_useq /has_chain => /eqP Hc.
       have Hgeq : can_bc >=b btBlockchain (btree (user_state gs (dst p)))
         by apply: (I_large (dst p)); rewrite /has_chain eqxx.
       move: (I_sub (dst p)) Hgeq Hc; rewrite /holds.
       case U: (user_state gs (dst p)) => [id prs bt' txp] /= => Hbt Hgeq Hc.
       have H : can_bc = btBlockchain (foldl bt_upd bt' (blocks_for (dst p) gs))
         by rewrite I_ext Hbt.
       have Hin : b \in blocks_for (dst p) gs.
       apply: block_in_queue; [exact S_flight | done | exact M | exact V].
       subst bc.
       have Hvalid : valid_bt bt' by move: (C_valid (dst p)); rewrite /holds U.
       have Hgb : has_gb bt' by move: (C_gb (dst p)); rewrite /holds U.
         by apply: (btBlockchain_seq_sub_geq Hvalid Hgb Hin Hgeq);left.
     (* cliq property *)
     + move => u /=.
       rewrite setfsNK; case: ifP => /eqP D; last by apply: I_cliq.
       rewrite -H_useq /receive_block_update /= -D.
       move: (I_cliq u) => <-.
         by case: (user_state gs u).
     (* eventual consensus *)
     + rewrite /holds /= => u.
       rewrite setfsNK /blocks_for /=; case: ifP => /eqP D.
       * rewrite -H_useq /receive_block_update /=.
         case U: (user_state gs (dst p)) => [u0 prs0 bt0 txp0] => /=.
         rewrite filter_cat blocks_for_split foldl_undup_split.
         rewrite D relevant_message; [|by move: (C_valid u); rewrite /holds D U/=|by done..].
         move: (I_sub u); rewrite /holds /blocks_for D U /= => <-.
         rewrite -H_peq /=; case: ifP => S //=; rewrite /broadcast_message U /=.
         rewrite irrelevant_broadcast' //=;
                 [by move: (C_uiq (dst p)); rewrite /holds U /=; apply: rem_uniq |
                  move /eqP: S => ->; rewrite mem_rem_uniqF => //].
         by move: (C_uiq (dst p)); rewrite /holds U /=.
         rewrite irrelevant_broadcast' //=;
                 [by move: (C_uiq (dst p)); rewrite /holds U /=; apply: rem_uniq |
                  move: (I_cliq (dst p)); rewrite U /= => ->; apply: notin_rem_peers].
       * rewrite filter_cat blocks_for_split foldl_undup_split.
         move: (I_sub u). rewrite /holds /blocks_for.
         rewrite irrelevant_blkmsg => //; last by apply /eqP => E; apply: D; rewrite E.
         move => Hbt; rewrite -Hbt -H_peq /=.
         case U: (user_state gs (dst p)) => [u0 prs0 bt0 txp0] => /=.
         case: ifP => /eqP S //=.
         ** rewrite S /broadcast_message.
            rewrite irrelevant_broadcast' //=;
              [by move: (C_uiq (dst p)); rewrite /holds U /=; apply: rem_uniq |
              rewrite mem_rem_uniqF => //; by move: (C_uiq (dst p)); rewrite /holds U /=].
         ** rewrite /broadcast_message.
            rewrite relevant_broadcast //=;
            [|by move: (C_uiq (dst p)); rewrite /holds U /=; apply: rem_uniq |
              by move: (I_cliq (dst p)); rewrite U /= => ->;apply: in_rem_peers].
            move: (I_sub (dst p)); rewrite /holds U /=.
            move: (b_in_blocks_for V S_flight M) => Bin Btseq.
            suff Hin : #b b \in can_bt by rewrite /bt_upd btupd_in_noeffect.
              by rewrite Btseq; apply: (foldl_btupd_in_mem_seq) => //;
                 move: (C_valid (dst p)); rewrite /holds U /=.
     (* missing transactions *)
     (* has chain *)
     + rewrite /holds /=.
       rewrite setfsNK; case: ifP => /eqP D; last by apply: I_chain.
       rewrite -H_useq /receive_block_update.
       move: I_chain; rewrite /holds /has_chain D /= => /eqP.
       move: (I_sub (dst p)); rewrite /holds.
       case U: (user_state gs (dst p)) => [u prs bt txp] /= Hbt Hc; apply /eqP.
       have H: btBlockchain bt = btBlockchain (foldl bt_upd bt (blocks_for can_u gs))
         by rewrite D Hc I_ext Hbt.
       rewrite -Hc.
       have Hin : b \in blocks_for can_u gs.
       apply: block_in_queue; [exact S_flight | done | exact M | exact V].
       have Hvalid : valid_bt bt by move: (C_valid (dst p)); rewrite /holds U.
       have Hgb : has_gb bt by move: (C_gb (dst p)); rewrite /holds U.
         by rewrite (btBlockchain_seq_same Hvalid Hgb Hin) //.
     (* largest chain *)
     + rewrite /largest_chain /holds /= => u bc.
       rewrite setfsNK; case: ifP => /eqP D; last by apply: I_large.
       rewrite -H_useq /has_chain => /eqP Hc.
       have Hgeq : can_bc >=b btBlockchain (btree (user_state gs (dst p)))
         by apply: (I_large (dst p)); rewrite /has_chain eqxx.
       move: (I_sub (dst p)) Hgeq Hc; rewrite /holds.
       case U: (user_state gs (dst p)) => [id prs bt' txp] /= => Hbt Hgeq Hc.
       have H : can_bc = btBlockchain (foldl bt_upd bt' (blocks_for (dst p) gs))
         by rewrite I_ext Hbt.
       have Hin : b \in blocks_for (dst p) gs.
       apply: block_in_queue; [exact S_flight | done | exact M | exact V].
       subst bc.
       have Hvalid : valid_bt bt' by move: (C_valid (dst p)); rewrite /holds U.
       have Hgb : has_gb bt' by move: (C_gb (dst p)); rewrite /holds U.
         by apply: (btBlockchain_seq_sub_geq Hvalid Hgb Hin Hgeq); left.
     (* cliq property *)
     + move => u /=.
       rewrite setfsNK; case: ifP => /eqP D; last by apply: I_cliq.
       rewrite -H_useq /receive_block_update /= -D.
       move: (I_cliq u) => <-.
         by case: (user_state gs u).
     (* eventual consensus *)
     + rewrite /holds /= => u.
       rewrite setfsNK /blocks_for /=; case: ifP => /eqP D.
       * rewrite -H_useq /receive_block_update /=.
         case U: (user_state gs (dst p)) => [u0 prs0 bt0 txp0] => /=.
         rewrite filter_cat blocks_for_split foldl_undup_split.
         rewrite D relevant_message; [|by move: (C_valid u); rewrite /holds D U/=|by done..].
         move: (I_sub u); rewrite /holds /blocks_for D U /= => <-.
         rewrite -H_peq /=; rewrite /broadcast_message U /=.
         rewrite irrelevant_broadcast' //=;
           [by move: (C_uiq (dst p)); rewrite /holds U /=; apply: rem_uniq |
           by move: (I_cliq (dst p)); rewrite U /= => ->; apply: notin_rem_peers].
       * rewrite filter_cat blocks_for_split foldl_undup_split.
         move: (I_sub u). rewrite /holds /blocks_for.
         rewrite irrelevant_blkmsg => //; last by apply /eqP => E; apply: D; rewrite E.
         move => Hbt; rewrite -Hbt -H_peq /=.
         case U: (user_state gs (dst p)) => [u0 prs0 bt0 txp0] => /=.
         case S: (src p == u); move /eqP: S => S.
         ** rewrite S irrelevant_broadcast' //=.
            by move: (C_uiq (dst p)); rewrite /holds U /=; apply: rem_uniq.
            move: (I_cliq (dst p)); rewrite U /= => ->; rewrite mem_rem_uniqF //;
              by apply: rem_uniq; rewrite enum_uniq.
         ** rewrite relevant_broadcast //=;
            [|by move: (C_uiq (dst p)); rewrite /holds U /=; apply: rem_uniq |
             by move: (I_cliq (dst p)); rewrite U /= => ->;apply: in_rem_peers].
            move: (I_sub (dst p)); rewrite /holds U /=.
            move: (b_in_blocks_for V S_flight M) => Bin Btseq.
            suff Hin : #b b \in can_bt by rewrite /bt_upd btupd_in_noeffect.
              by rewrite Btseq; apply: (foldl_btupd_in_mem_seq) => //;
                 move: (C_valid (dst p)); rewrite /holds U /=.

  (* Transactions message *)
  - case: ifP => A [H_useq H_peq].
    (* old transactions *)
    apply: sync_no_change; [by rewrite -H_useq..| | by done].
    rewrite -H_peq /blocks_for /emitZero cats0 /= => u.
      by rewrite (irrelevant_message u S_flight); last rewrite M.
    (* new transactions *)
    apply: sync_no_change; last by done.
    rewrite -H_useq /receive_transactions_update /=.
      by case: (user_state gs (dst p)).
    rewrite -H_useq /receive_transactions_update /=.
      by case: (user_state gs (dst p)).
    rewrite -H_peq /blocks_for /broadcast_message => u /=.
    case: (user_state gs (dst p)) => id prs _ _.
    rewrite irrelevant_broadcast; last by done.
      by rewrite (irrelevant_message u S_flight); last rewrite M.

  (* Requests message *)
  - case => H_useq H_peq.
    apply: sync_no_change; [by rewrite -H_useq..| | by done].
    rewrite -H_peq /blocks_for /response_to_transactions /emitOne /= => u.
    rewrite (irrelevant_message u S_flight); last by rewrite M.
    rewrite filter_cat blocks_for_split /=.
      by case: ifP => //=; rewrite cats0.

  (* InternalTransition *)
  move => u int; case => [C_uiq C_valid C_gb] Hallow.
  case P: (proc_int _ _ _) => [us ps] ->.
  case I: int => [ts|]; move: P; rewrite I.
  (* Internal transactions emit *)
  - case => H_useq H_peq.
    apply: sync_no_change; last by done.
    rewrite -H_useq /receive_transactions_update /=.
      by case: (user_state gs u).
    rewrite -H_useq /receive_transactions_update /=.
      by case: (user_state gs u).
    rewrite -H_peq /blocks_for => u' /=.
    rewrite filter_cat blocks_for_split -[emitBroadcast _ _ _]cat0s.
      by rewrite irrelevant_broadcast /=.

  (* Internal mine blocks *)
  - rewrite /=. case: (genProof _ _ _); last first.
    (* failing miner *)
    case => H_useq H_peq; rewrite -H_peq /emitZero cat0s.
    rewrite setfs_nupd; by done.
    move => pfv.
    case: ifP => V; last first.
    case => <- <-; rewrite /emitZero cat0s.
      by rewrite setfs_nupd.
    (* successful miner *)
    case: Isync => can_bt [can_bc] [can_u] [I_chain I_large [I_valid [I_gb [I_ext I_good]]] I_cliq I_sub].
    move: V; set new_b := {|
      prev_blk := #b last_blk (btBlockchain (btree (user_state gs u)));
      prop_txs := [seq hashPID t
                  | t <- txpool (user_state gs u)
                    & t
                        \notin [seq t0 <- txpool (user_state gs u)
                               | commTxsValid t0 (btBlockchain (btree (user_state gs u)))]];
      comm_txs := [seq t <- txpool (user_state gs u) | commTxsValid t (btBlockchain (btree (user_state gs u)))];
      proof := pfv |} => V.
    case => H_useq H_peq.
    (* updated canonical block tree is still comlete *)
    have Good : good_bt can_bt.[#b new_b <- new_b].
    rewrite /good_bt => b.
    rewrite inE dom_setf in_fset1U => /orP.
    case => [/eqP /hashB_inj Heq | Hin].
    + subst b.
      move: (btBlockchain_good can_bt) => Gbc.
      have HP : prev_blk new_b = #b last_blk (btBlockchain (btree (user_state gs u))) by done.
      move /andP: V => [Vnew Vall].
      move: (btupd_mint_goodness (C_valid u) (C_gb u) (btBlockchain_good _) Vnew Vall HP); case => HG HV.
      change (good_blockchain (compute_blockchain (bt_upd can_bt new_b) new_b) &&
              valid_blockchain (compute_blockchain (bt_upd can_bt new_b) new_b)).
      rewrite (I_sub u) /= bt_updE foldl_comm /=.
      rewrite good_bt_add_seq_same_chain //;
        [by rewrite HG HV
        |by apply: btupd_validP (C_valid u)
        |by apply: btupd_gbP (C_gb u)].
    + move: (I_good b Hin) => /andP; case => HG HV.
      move: (good_bt_add_block_same_chain new_b I_valid I_gb HG).
        by rewrite /bt_upd => ->; rewrite HG HV.
    (* consider whether the newly mined block contributes to the canonical chain *)
    case T: (btBlockchain (btree us) >b can_bc); last first.
    (* Case 1: new block does not contribute to the canonical chain *)
    move: T => /FCR_ngtT T.
    exists can_bt.[#b new_b <- new_b], can_bc, can_u; split => //.
    (* has chain *)
    + rewrite /holds /=.
      rewrite setfsNK; case: ifP => /eqP E; last by apply: I_chain.
      subst can_u; move: I_chain; rewrite /holds -H_useq /has_chain /= => /eqP E.
      case: T => T; first by rewrite T -H_useq /= eqxx.
      move: E T => <-; rewrite -H_useq /= => contra.
      contradict contra; rewrite -FCR_ngt; apply: btBlockchain_btupd_geq;
        [apply: C_valid | apply: C_gb].
    (* largest chain *)
    + rewrite /largest_chain /holds /= => u' bc'.
      rewrite setfsNK; case: ifP => /eqP E; last by  apply: I_large.
      rewrite -H_useq /has_chain /= => /eqP <-.
        by move: T; rewrite -H_useq /=.
    (* valid block forest and having GenesisBlock *)
    + repeat split; [by apply: btupd_validP => // |  apply: btupd_gbP => // |  | ].
    (* canonical chain is still the main chain of the extended block forest *)
    + subst can_bc.
      move: (btBlockchain_btupd_geq new_b I_valid I_gb); case => // Gt.
      move: (I_sub u); rewrite /holds => Sub.
      move /andP: V => [Vnew Vall].
      have P : (prev_blk new_b = #b last_blk (btBlockchain (btree (user_state gs u)))) by subst new_b.
      contradict Gt; apply: btupd_within => //;
         [by apply: C_valid|by apply: C_gb|by subst new_b|by rewrite -H_useq /= in T|exact Sub].
    (* the extended block forest is still complete *)
    + exact Good.
    (* cliq property *)
    + rewrite /= => u'.
      rewrite setfsNK; case: ifP => /eqP E; last by apply: I_cliq.
        by rewrite -H_useq E /=; apply: I_cliq.
    (* eventual consensus *)
    + rewrite /holds /= => u'.
      rewrite setfsNK; case: ifP => /eqP E.
      * rewrite -H_useq E /blocks_for /=.
        rewrite filter_cat blocks_for_split foldl_undup_split.
        rewrite -H_peq irrelevant_broadcast' /=;
                       [|by apply: C_uiq
                        |by rewrite I_cliq mem_rem_uniqF //; apply: enum_uniq].
        move: (I_sub u); rewrite /holds /blocks_for => ->.
        change (bt_upd (foldl bt_upd (btree (user_state gs u))
                              (undup (blocks_for_rec [seq p <- inflight_msg gs | dst p == u]))) new_b
                = foldl bt_upd (btree (user_state gs u)).[#b new_b <- new_b]
                              (undup (blocks_for_rec [seq p <- inflight_msg gs | dst p == u]))).
          by rewrite bt_updE foldl_comm.
      * rewrite /blocks_for /=.
        rewrite filter_cat blocks_for_split foldl_undup_split.
        rewrite -H_peq relevant_broadcast /=;
                       [|by apply: C_uiq
                        |by rewrite I_cliq enumT; apply: rem_in_mem => //; apply: count1_impl_in; apply: enumP
                        |by move /andP: V => [V _]].
        move: (I_sub u'); rewrite /holds /blocks_for => ->.
        change (bt_upd (foldl bt_upd (btree (user_state gs u'))
                              (undup (blocks_for_rec [seq p <- inflight_msg gs | dst p == u']))) new_b
                = foldl bt_upd (bt_upd (btree (user_state gs u')) new_b)
                              (undup (blocks_for_rec [seq p <- inflight_msg gs | dst p == u']))).
          by rewrite bt_updE foldl_comm.
    (* Case 2: new block contributes to the canonical chain *)
    exists can_bt.[#b new_b <- new_b], (btBlockchain (btree us)), u; split => //.
    (* has chain *)
    + by rewrite /holds /= setfsNK eqxx -H_useq /has_chain /=.
    (* largest chain *)
    + rewrite /largest_chain /holds /= => u' bc'.
      rewrite setfsNK; case: ifP => /eqP E; first by rewrite /has_chain -H_useq /= => /eqP; left.
      rewrite /has_chain -H_useq /= => /eqP <-.
      move: (I_large u' (btBlockchain (btree (user_state gs u')))).
      rewrite /holds /has_chain /= => /(_ (eqxx _)) H.
        by apply: FCR_geq_trans H; right; rewrite -H_useq /= in T.
    (* valid block forest and having GenesisBlock *)
    + repeat split; [by apply: btupd_validP => // | apply: btupd_gbP => // | |].
    (* canonical chain is still the main chain of the extended block forest *)
    + move: (I_sub u); rewrite /holds -H_useq /= => Hbt; subst can_bc.
      rewrite -H_useq /= in T.
      rewrite (btupd_with_new I_valid I_gb _ _ _ _ T Hbt) //;
        [by apply: C_valid|by apply: C_gb].
    (* the extended block forest is still complete *)
    + exact Good.
    (* cliq property *)
    + rewrite /= => u'.
        by rewrite setfsNK; case: ifP => /eqP E; [rewrite E -H_useq | ]; rewrite I_cliq.
    (* eventual consensus *)
    + rewrite /holds /blocks_for /= => u'.
      rewrite setfsNK; case: ifP => /eqP E.
      rewrite -H_useq E /=.
      rewrite filter_cat blocks_for_split foldl_undup_split.
      rewrite -H_peq irrelevant_broadcast' /=;
                     [|apply: C_uiq | rewrite I_cliq mem_rem_uniqF //; apply: enum_uniq].
      move: (I_sub u); rewrite /holds /= => ->.
      change (bt_upd (foldl bt_upd (btree (user_state gs u))
                          (undup (blocks_for_rec [seq p <- inflight_msg gs | dst p == u]))) new_b
            = foldl bt_upd (btree (user_state gs u)).[#b new_b <- new_b]
                          (undup (blocks_for_rec [seq p <- inflight_msg gs | dst p == u]))).
        by rewrite bt_updE foldl_comm.
      rewrite filter_cat blocks_for_split foldl_undup_split.
      rewrite -H_peq relevant_broadcast /=;
                     [|by apply: C_uiq
                      |by rewrite I_cliq enumT; apply: rem_in_mem => //; apply: count1_impl_in; apply: enumP
                      |by move /andP: V => [V _]].
      move: (I_sub u'); rewrite /holds /blocks_for => ->.
      change (bt_upd (foldl bt_upd (btree (user_state gs u'))
                            (undup (blocks_for_rec [seq p <- inflight_msg gs | dst p == u']))) new_b
              = foldl bt_upd (bt_upd (btree (user_state gs u')) new_b)
                            (undup (blocks_for_rec [seq p <- inflight_msg gs | dst p == u']))).
        by rewrite bt_updE foldl_comm.
Qed.

Lemma sync_inv_reachable :
  forall (gs gs': GState),
    sync_inv gs -> reachable_state gs gs' -> sync_inv gs'.
Proof.
  move => gs gs' S R; elim: R S => //.
  - by move => gs1 gs2 s Step Sync; apply: (sync_inv_step Sync Step).
  - move => gs1 gs2 gs3 R12 S12 R23 H23 S1.
      by apply: (H23 (S12 S1)).
Qed.

Lemma final_consensus :
  forall (gs : GState),
    reachable_state initGState gs ->
    (forall (u : UserId), blocks_for u gs == [::]) ->
    exists (bc : Blockchain), largest_chain gs bc /\
                              (forall (u : UserId), holds u gs (has_chain bc)).
Proof.
  move => gs /(sync_inv_reachable sync_initial_state).
    by apply: sync_eventual_consensus.
Qed.


Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.SmartMap.
Require Import Crypto.Compilers.Wf.
Require Import Crypto.Compilers.WfInversion.
Require Import Crypto.Compilers.TypeInversion.
Require Import Crypto.Compilers.ExprInversion.
Require Import Crypto.Compilers.RewriterWf.
Require Import Crypto.Compilers.Z.Syntax.
Require Import Crypto.Compilers.Z.OpInversion.
Require Import Crypto.Compilers.Z.ArithmeticSimplifier.
Require Import Crypto.Compilers.Z.Syntax.Equality.
Require Import Crypto.Compilers.Z.Syntax.Util.
Require Import Crypto.Util.ZUtil.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.Sum.
Require Import Crypto.Util.Prod.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Crypto.Util.HProp.

Local Notation exprf := (@exprf base_type op).
Local Notation expr := (@expr base_type op).
Local Notation wff := (@wff base_type op).
Local Notation Wf := (@Wf base_type op).

Local Ltac fin_t :=
  first [ exact I
        | reflexivity
        | congruence
        | assumption
        | exfalso; assumption
        | match goal with
          | [ |- _ /\ False ] => exfalso
          | [ |- False /\ _ ] => exfalso
          | [ |- _ /\ _ /\ False ] => exfalso
          | [ |- _ /\ False /\ _ ] => exfalso
          | [ |- False /\ _ /\ _ ] => exfalso
          end ].
Local Ltac break_t_step :=
  first [ progress subst
        | progress inversion_option
        | progress inversion_sum
        | progress inversion_expr
        | progress inversion_prod
        | progress invert_op
        | progress inversion_flat_type
        | progress destruct_head'_and
        | progress destruct_head' iff
        | progress destruct_head'_prod
        | progress destruct_head'_sig
        | progress specialize_by reflexivity
        | progress eliminate_hprop_eq
        | progress break_innermost_match_hyps_step
        | progress break_innermost_match_step
        | progress break_match_hyps
        | progress inversion_wf_constr ].

Lemma interp_as_expr_or_const_None_iff {var1 var2 t} {G e1 e2}
      (Hwf : @wff var1 var2 G t e1 e2)
  : @interp_as_expr_or_const var1 t e1 = None
    <-> @interp_as_expr_or_const var2 t e2 = None.
Proof.
  induction Hwf;
    repeat first [ fin_t
                 | split; congruence
                 | progress simpl in *
                 | progress intros
                 | break_t_step ].
Qed.

Lemma interp_as_expr_or_const_None_Some {var1 var2 t} {G e1 e2 v}
      (Hwf : @wff var1 var2 G t e1 e2)
  : @interp_as_expr_or_const var1 t e1 = None
    -> @interp_as_expr_or_const var2 t e2 = Some v
    -> False.
Proof.
  erewrite interp_as_expr_or_const_None_iff by eassumption; congruence.
Qed.

Lemma interp_as_expr_or_const_Some_None {var1 var2 t} {G e1 e2 v}
      (Hwf : @wff var1 var2 G t e1 e2)
  : @interp_as_expr_or_const var1 t e1 = Some v
    -> @interp_as_expr_or_const var2 t e2 = None
    -> False.
Proof.
  erewrite <- interp_as_expr_or_const_None_iff by eassumption; congruence.
Qed.

Local Ltac pret_step :=
  first [ fin_t
        | progress subst
        | progress inversion_option
        | progress inversion_prod
        | progress simpl in *
        | progress inversion_wf
        | match goal with
          | [ H : match interp_as_expr_or_const ?e with _ => _ end = Some _ |- _ ]
            => is_var e; destruct (interp_as_expr_or_const e) eqn:?
          end ].

Fixpoint wff_as_expr_or_const {var1 var2} G {t}
  : interp_flat_type (@inverted_expr var1) t
    -> interp_flat_type (@inverted_expr var2) t
    -> Prop
  := match t with
     | Tbase T
       => fun z1 z2 => match z1, z2 return Prop with
                       | const_of z1, const_of z2 => z1 = z2
                       | gen_expr e1, gen_expr e2
                       | neg_expr e1, neg_expr e2
                         => wff G e1 e2
                       | const_of _, _
                       | gen_expr _, _
                       | neg_expr _, _
                         => False
                       end
     | Unit => fun _ _ => True
     | Prod A B => fun a b : interp_flat_type _ A * interp_flat_type _ B
                   => and (@wff_as_expr_or_const var1 var2 G A (fst a) (fst b))
                          (@wff_as_expr_or_const var1 var2 G B (snd a) (snd b))
     end.

Lemma wff_interp_as_expr_or_const {var1 var2 t} {G e1 e2 v1 v2}
      (Hwf : @wff var1 var2 G t e1 e2)
  : @interp_as_expr_or_const var1 t e1 = Some v1
    -> @interp_as_expr_or_const var2 t e2 = Some v2
    -> wff_as_expr_or_const G v1 v2.
Proof.
  induction Hwf;
    repeat first [ progress subst
                 | progress inversion_option
                 | progress simpl in *
                 | progress cbn [wff_as_expr_or_const]
                 | reflexivity
                 | break_innermost_match_hyps_step
                 | intro
                 | match goal with
                   | [ H : forall z, Some _ = Some z -> _ |- _ ] => specialize (H _ eq_refl)
                   | [ |- context[match ?e with _ => _ end] ]
                     => is_var e; invert_one_op e
                   end
                 | break_innermost_match_step
                 | solve [ auto with wf ] ].
Qed.

Local Ltac pose_wff _ :=
  match goal with
  | [ H1 : _ = Some _, H2 : _ = Some _, Hwf : wff _ _ _ |- _ ]
    => pose proof (wff_interp_as_expr_or_const Hwf H1 H2); clear H1 H2
  end.

Lemma Wf_SimplifyArith {convert_adc_to_sbb} {t} (e : Expr t)
      (Hwf : Wf e)
  : Wf (SimplifyArith convert_adc_to_sbb e).
Proof.
  apply Wf_RewriteOp; [ | assumption ].
  intros ???????? Hwf'; unfold simplify_op_expr.
  repeat match goal with
         | [ H : ?T |- ?T ] => exact H
         | [ H : False |- _ ] => exfalso; assumption
         | [ |- True ] => exact I
         | [ H : false = true |- _ ] => exfalso; clear -H; discriminate
         | [ H : true = false |- _ ] => exfalso; clear -H; discriminate
         | [ H : None = Some _ |- _ ] => exfalso; clear -H; discriminate
         | [ H : Some _ = None |- _ ] => exfalso; clear -H; discriminate
         | [ H : TT = Op _ _ |- _ ] => exfalso; clear -H; discriminate
         | [ H : invert_Op ?e = None, H' : wff _ (Op ?opc _) ?e |- _ ]
           => progress (exfalso; clear -H H'; generalize dependent opc; intros; try (is_var e; destruct e))
         | [ H : invert_Op ?e = None, H' : wff _ ?e (Op ?opc _) |- _ ]
           => progress (exfalso; clear -H H'; generalize dependent opc; intros; try (is_var e; destruct e))
         | _ => progress destruct_head'_and
         | _ => progress subst
         | _ => progress destruct_head'_prod
         | _ => progress destruct_head'_sig
         | _ => progress destruct_head'_sigT
         | _ => inversion_base_type_constr_step
         | _ => inversion_wf_step_constr
         | _ => progress invert_expr_subst
         | _ => progress rewrite_eta_match_base_type_impl
         | [ H : ?x = ?x |- _ ] => clear H || (progress eliminate_hprop_eq)
         | [ H : match ?e with @const_of _ _ _ => _ = _ | _ => _ end |- _ ]
           => is_var e; destruct e
         | [ H : match ?e with @const_of _ _ _ => False | _ => _ end |- _ ]
           => is_var e; destruct e
         | [ H1 : _ = Some _, H2 : _ = None, Hwf : wff _ _ _ |- _ ]
           => pose proof (interp_as_expr_or_const_Some_None Hwf H1 H2); clear H1 H2
         | [ H1 : _ = None, H2 : _ = Some _, Hwf : wff _ _ _ |- _ ]
           => pose proof (interp_as_expr_or_const_None_Some Hwf H1 H2); clear H1 H2
         | [ |- wff _ (Op _ _) (LetIn _ _) ] => exfalso
         | [ |- wff _ (LetIn _ _) (Op _ _) ] => exfalso
         | [ |- wff _ (Pair _ _) (LetIn _ _) ] => exfalso
         | [ |- wff _ (LetIn _ _) (Pair _ _) ] => exfalso
         | _ => pose_wff ()
         | _ => progress cbn [fst snd projT1 projT2 interp_flat_type wff_as_expr_or_const eq_rect invert_Op] in *
         | [ |- wff _ _ _ ] => constructor; intros
         | [ H : match ?e with @const_of _ _ _ => _ | _ => _ end |- _ ]
           => is_var e; destruct e
         | [ |- context[match @interp_as_expr_or_const ?var ?t ?e with _ => _ end] ]
           => destruct (@interp_as_expr_or_const var t e) eqn:?
         | [ |- context[match base_type_eq_semidec_transparent ?t1 ?t2 with _ => _ end] ]
           => destruct (base_type_eq_semidec_transparent t1 t2)
         | [ |- context[match @invert_Op ?base_type ?op ?var ?t ?e with _ => _ end] ]
           => destruct (@invert_Op base_type op var t e) eqn:?
         | [ |- context[if BinInt.Z.eqb ?x ?y then _ else _] ]
           => destruct (BinInt.Z.eqb x y) eqn:?
         | [ |- context[if BinInt.Z.ltb ?x ?y then _ else _] ]
           => destruct (BinInt.Z.ltb x y) eqn:?
         | [ |- context[match ?e with @OpConst _ _ => _ | _ => _ end] ]
           => is_var e; destruct e
         | [ |- context[match ?e with @OpConst _ _ => _ | _ => _ end] ]
           => is_var e; invert_one_op e; try exact I; break_innermost_match_step; intros
         | [ |- List.In _ _ ] => progress (simpl; auto)
         | _ => break_innermost_match_step
         end.
Qed.

Hint Resolve Wf_SimplifyArith : wf.


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import String.
Require Import List.
Require Import Arith.
Require Import EquivDec.
Require Import Utils.
Require Import DataRuntime.
Require Import OQL.

Section OQLSize.
  Context {fruntime:foreign_runtime}.

  Fixpoint oql_expr_size (e:oql_expr) : nat
    := match e with
         | OConst d => 1
         | OVar v => 1
         | OTable v => 1
         | OBinop op n₁ n₂ => S (oql_expr_size n₁ + oql_expr_size n₂)
         | OUnop op n₁ => S (oql_expr_size n₁)
         | OSFW se el we oe =>
           let from_size :=
               fold_left (fun x => fun e => x+oql_in_size e) el 0
           in
           S (oql_select_size se + from_size + oql_where_size we + oql_order_size oe)
       end
  with oql_select_size (se:oql_select_expr) :=
    match se with
    | OSelect e => oql_expr_size e
    | OSelectDistinct e => oql_expr_size e
    end
  with oql_in_size (ie:oql_in_expr) :=
    match ie with
    | OIn v e => oql_expr_size e
    | OInCast v brand_names e => oql_expr_size e
    end
  with oql_where_size (we:oql_where_expr) :=
    match we with
    | OTrue => 0
    | OWhere e => oql_expr_size e
    end
  with oql_order_size (oe:oql_order_by_expr) :=
    match oe with
    | ONoOrder => 0
    | OOrderBy e _ => oql_expr_size e
    end.

  Fixpoint oql_query_program_size (oq:oql_query_program) : nat
    := match oq with
      | ODefineQuery s e rest => S (oql_expr_size e + oql_query_program_size rest)
      | OUndefineQuery s rest => S (oql_query_program_size rest)
      | OQuery e => S (oql_expr_size e)
      end.

  Definition oql_size (q:oql) : nat
    := oql_query_program_size q.

End OQLSize.


From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Loc.

From PromisingLib Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.

Set Implicit Arguments.

Module MemoryMerge.
  Lemma add_lower_add
        mem0 loc from to msg1 msg2 mem1 mem2
        (ADD1: Memory.add mem0 loc from to msg1 mem1)
        (LOWER2: Memory.lower mem1 loc from to msg1 msg2 mem2):
    Memory.add mem0 loc from to msg2 mem2.
  Proof.
    inv ADD1. inv ADD. inv LOWER2. inv LOWER.
    rewrite LocFun.add_add_eq. econs; auto.
    unfold Cell.add in *.
    destruct r, r0. ss. subst.
    unfold LocFun.add. condtac; [|congr]. s.
    rewrite DOMap.add_add_eq. econs; auto.
  Qed.

  Lemma split_lower_split
        mem0 loc ts1 ts2 ts3 msg2 msg2' msg3 mem1 mem2
        (SPLIT1: Memory.split mem0 loc ts1 ts2 ts3 msg2 msg3 mem1)
        (LOWER2: Memory.lower mem1 loc ts1 ts2 msg2 msg2' mem2):
    Memory.split mem0 loc ts1 ts2 ts3 msg2' msg3 mem2.
  Proof.
    inv SPLIT1. inv SPLIT. inv LOWER2. inv LOWER.
    rewrite LocFun.add_add_eq. econs; auto.
    unfold Cell.split in *.
    destruct r, r0. ss. subst.
    unfold LocFun.add. condtac; [|congr]. s.
    rewrite DOMap.add_add_eq. econs; auto.
  Qed.

  Lemma lower_lower_lower
        mem0 loc from to msg0 msg1 msg2 mem1 mem2
        (LOWER1: Memory.lower mem0 loc from to msg0 msg1 mem1)
        (LOWER2: Memory.lower mem1 loc from to msg1 msg2 mem2):
    Memory.lower mem0 loc from to msg0 msg2 mem2.
  Proof.
    inv LOWER1. inv LOWER. inv LOWER2. inv LOWER.
    rewrite LocFun.add_add_eq. econs; auto.
    unfold Cell.lower in *.
    destruct r, r0. ss. subst.
    unfold LocFun.add. condtac; [|congr]. s.
    rewrite DOMap.add_add_eq. econs; auto.
    etrans; eauto.
  Qed.

  Lemma promise_promise_promise
        loc from to msg1 msg2 promises0 promises1 promises2 mem0 mem1 mem2 kind
        (PROMISE1: Memory.promise promises0 mem0 loc from to msg1 promises1 mem1 kind)
        (PROMISE2: Memory.promise promises1 mem1 loc from to msg2 promises2 mem2 (Memory.op_kind_lower msg1)):
    Memory.promise promises0 mem0 loc from to msg2 promises2 mem2 kind.
  Proof.
    inv PROMISE2. inv PROMISE1.
    - econs; eauto.
      + eapply add_lower_add; eauto.
      + eapply add_lower_add; eauto.
      + i. inv MEM. inv LOWER. inv MSG_LE; ss; eauto.
        eapply ATTACH; eauto. ss.
    - econs; eauto.
      + eapply split_lower_split; eauto.
      + eapply split_lower_split; eauto.
    - econs; eauto.
      + eapply lower_lower_lower; eauto.
      + eapply lower_lower_lower; eauto.
    - exploit Memory.remove_get0; try exact PROMISES0. i. des.
      exploit Memory.lower_get0; try exact PROMISES. i. des.
      congr.
  Qed.

  Lemma promise_write_write
        loc from to msg1 msg promises0 promises1 promises2 mem0 mem1 mem2 kind
        (PROMISE1: Memory.promise promises0 mem0 loc from to msg1 promises1 mem1 kind)
        (PROMISE2: Memory.write promises1 mem1 loc from to msg promises2 mem2 (Memory.op_kind_lower msg1)):
    Memory.write promises0 mem0 loc from to msg promises2 mem2 kind.
  Proof.
    inv PROMISE2.
    exploit promise_promise_promise; try exact PROMISE1; eauto.
  Qed.

  Lemma add_remove
        loc from to msg mem0 mem1 mem2
        (ADD1: Memory.add mem0 loc from to msg mem1)
        (REMOVE2: Memory.remove mem1 loc from to msg mem2):
    mem0 = mem2.
  Proof.
    apply Memory.ext. i. symmetry.
    exploit Memory.add_get0; eauto. i. des.
    erewrite Memory.remove_o; eauto. condtac; ss.
    - des. subst. rewrite GET. ss.
    - guardH o.
      erewrite Memory.add_o; eauto. condtac; ss; eauto.
  Qed.
End MemoryMerge.


Require Export EnvLibA.
Require Export RelLibA.
Require Export PRelLibA.

Require Export Coq.Program.Equality.
Require Import Coq.Init.Specif.
Require Import Coq.Arith.PeanoNat.
Require Import Omega.
Require Import Coq.Lists.List.
Require Import Bool.
Require Import Coq.Logic.ProofIrrelevance.

Require Import StaticSemA.
Require Import DynamicSemA.
Require Import TRInductA.
Require Import WeakenA.
Require Import TSoundnessA.
Require Import IdModTypeA.
Require Import IdModPip.
Require Import DetermA.
Require Import AbbrevA.
Require Import HoareA.
Require Import THoareA.
Require Import Lib.
Require Import Pip_state.
Require Import Pip_stateLib.
Require Import Pip_Prop.
Require Import Pip_DependentTypeLemmas.
Require Import Pip_InternalLemmas.
Require Import Pip_writeVirtualInv_Lemmas.
Require Import Hoare_getFstShadow.
Import ListNotations.

Module Hoare_Test_VirtualInv.

Module VirtualInv := Hoare_Test_FstShadow.
Export VirtualInv.

(**************************************************)

(******* Program *)

(** WriteVirtualInv -page -index -vaddress : writes the vaddress at key (page,index) in memory *)

Definition xf_writeVirtual (p: page) (i: index) (v: vaddr) : XFun unit unit := {|
   b_mod := fun s _ => (writeVirtualInternal p i v s,tt)
|}.

Instance VT_unit : ValTyp unit.

Definition WriteVirtual (p: page) (i: index) (v: vaddr) : Exp :=
  Modify unit unit VT_unit VT_unit (xf_writeVirtual p i v) (QV (cst unit tt)).

(******* Useful Lemmas *)

Lemma writeVirtualWp  table idx (addr : vaddr)  (P : Value -> state -> Prop) (fenv: funEnv) (env: valEnv) :
{{fun  s => P (cst unit tt) {| currentPartition := currentPartition s;
  memory := add table idx (VA addr) (memory s) beqPage beqIndex |} }}
fenv >> env >> WriteVirtual table idx addr  {{P}}.
Proof.
unfold THoareTriple_Eval.
intros.
inversion X;subst.
inversion X0;subst.
repeat apply inj_pair2 in H6.
repeat apply inj_pair2 in H8.
subst.
unfold xf_writeVirtual, b_eval, b_exec, b_mod in *.
simpl in *.
inversion X1;subst.
auto.
inversion X2.
inversion X2.
Qed.

(******* Hoare Triple *)

Lemma writeVirtualInvNewProp (p : page) (i:index) (v:vaddr) (fenv: funEnv) (env: valEnv) :
{{fun _ => True}}
fenv >> env >> WriteVirtual p i v
{{fun _ s => readVirtualInternal p i s.(memory) =  Some v}}.
Proof.
unfold THoareTriple_Eval.
intros.
clear H k3 t k2 k1 tenv ftenv.
inversion X;subst.
inversion X0;subst.
repeat apply inj_pair2 in H5.
apply inj_pair2 in H7.
subst.
unfold b_eval, b_exec, xf_writeVirtual, b_mod in *.
simpl in *.
inversion X1;subst.
unfold writeVirtualInternal.
simpl.
unfold add.
unfold readVirtualInternal.
simpl.
specialize beqPairsTrue with p i p i.
intros.
intuition.
rewrite H.
reflexivity.
inversion X2.
inversion X2.
Qed.

Lemma writeVirtualInv (vaInCurrentPartition vaChild: vaddr)  currentPart
currentShadow descChild idxDescChild ptDescChild ptVaInCurPart idxvaInCurPart
vainve isnotderiv currentPD ptVaInCurPartpd accessiblesrc presentmap ptDescChildpd idxDescChild1
presentDescPhy phyDescChild pdChildphy ptVaChildpd idxvaChild presentvaChild phyVaChild
sh2Childphy ptVaChildsh2 level (fenv: funEnv) (env: valEnv) :
isnotderiv && accessiblesrc && presentmap && negb presentvaChild = true ->
negb presentDescPhy = false ->
{{ fun s : state => propagatedPropertiesAddVaddr s vaInCurrentPartition vaChild currentPart
currentShadow descChild idxDescChild ptDescChild ptVaInCurPart idxvaInCurPart
vainve isnotderiv currentPD ptVaInCurPartpd accessiblesrc presentmap ptDescChildpd idxDescChild1
presentDescPhy phyDescChild pdChildphy ptVaChildpd idxvaChild presentvaChild phyVaChild
sh2Childphy ptVaChildsh2 level }}
  fenv >> env >> WriteVirtual ptVaChildsh2 idxvaChild vaInCurrentPartition
  {{ fun _ s => propagatedPropertiesAddVaddr s vaInCurrentPartition vaChild currentPart
currentShadow descChild idxDescChild ptDescChild ptVaInCurPart idxvaInCurPart
vainve isnotderiv currentPD ptVaInCurPartpd accessiblesrc presentmap ptDescChildpd idxDescChild1
presentDescPhy phyDescChild pdChildphy ptVaChildpd idxvaChild presentvaChild phyVaChild
sh2Childphy ptVaChildsh2 level /\
readVirtualInternal ptVaChildsh2 idxvaChild s.(memory) = Some vaInCurrentPartition }}.
Proof.
intros.
eapply weakenEval.
eapply writeVirtualWp.
simpl; intros.
split.
unfold propagatedPropertiesAddVaddr in *.
assert(Hlookup :exists entry,
 lookup ptVaChildsh2 idxvaChild (memory s) beqPage beqIndex = Some (VA entry)).
{ assert(Hva : isVA ptVaChildsh2 (getIndexOfAddr vaChild fstLevel) s) by intuition.
  unfold isVA in *.
  assert(Hidx :  getIndexOfAddr vaChild fstLevel = idxvaChild) by intuition.
 clear H.
 subst.
 destruct(lookup ptVaChildsh2 (getIndexOfAddr vaChild fstLevel)
          (memory s) beqPage beqIndex);intros; try now contradict Hva.
 destruct v; try now contradict Hva.
 do 2 f_equal.
 exists v;trivial. }
 destruct Hlookup as (entry & Hlookup).
intuition try assumption.
(** partitionsIsolation **)
+ apply partitionsIsolationUpdateSh2 with entry;trivial.
(** kernelDataIsolation **)
+ apply kernelDataIsolationUpdateSh2 with entry;trivial.
(** verticalSharing **)
+ apply verticalSharingUpdateSh2 with entry;trivial.
(** consistency **)
+ apply consistencyUpdateSh2 with
    entry vaChild
    currentPart currentShadow descChild idxDescChild ptDescChild
    ptVaInCurPart idxvaInCurPart vainve isnotderiv currentPD
    ptVaInCurPartpd accessiblesrc presentmap ptDescChildpd idxDescChild1 presentDescPhy
    phyDescChild pdChildphy ptVaChildpd presentvaChild phyVaChild
    sh2Childphy level;trivial.
  unfold propagatedPropertiesAddVaddr ;intuition.
(** Propagated properties **)
+ rewrite <- nextEntryIsPPUpdateSh2;trivial.
  exact Hlookup.
+ apply isVEUpdateSh2 with entry;trivial.
+ apply getTableAddrRootUpdateSh2 with entry;trivial.
+ apply entryPDFlagUpdateSh2 with entry;trivial.
+ apply isVEUpdateSh2 with entry;trivial.
+ apply getTableAddrRootUpdateSh2 with entry;trivial.
+ apply isEntryVAUpdateSh2 with entry;trivial.
+ rewrite <- nextEntryIsPPUpdateSh2;trivial.
  exact Hlookup.
+ apply isPEUpdateSh2 with entry;trivial.
+ apply getTableAddrRootUpdateSh2 with entry;trivial.
+ apply entryUserFlagUpdateSh2 with entry;trivial.
+ apply entryPresentFlagUpdateSh2 with entry;trivial.
+ apply isPEUpdateSh2 with entry;trivial.
+ apply getTableAddrRootUpdateSh2 with entry;trivial.
+ apply entryPresentFlagUpdateSh2 with entry;trivial.
+ apply isEntryPageUpdateSh2  with entry;trivial.
+ assert(Hchildren : forall part, getChildren part
     {|
     currentPartition := currentPartition s;
     memory := add ptVaChildsh2 idxvaChild(VA vaInCurrentPartition) (memory s) beqPage
                 beqIndex |} = getChildren part s).
  { intros; symmetry; apply getChildrenUpdateSh2 with entry;trivial. }
  rewrite Hchildren in *;trivial.
+ rewrite <- nextEntryIsPPUpdateSh2;trivial.
  exact Hlookup.
+ apply isPEUpdateSh2 with entry;trivial.
+ apply getTableAddrRootUpdateSh2 with entry;trivial.
+ apply entryPresentFlagUpdateSh2 with entry;trivial.
+ apply isEntryPageUpdateSh2  with entry;trivial.
+ rewrite <- nextEntryIsPPUpdateSh2;trivial.
  exact Hlookup.
+ apply isVAUpdateSh2 with entry;trivial.
+ apply getTableAddrRootUpdateSh2 with entry;trivial.
(** new property **)
+ unfold readVirtualInternal.
  cbn.
  assert (Htrue : beqPairs (ptVaChildsh2, idxvaChild) (ptVaChildsh2, idxvaChild) beqPage
      beqIndex = true).
  apply beqPairsTrue;split;trivial.
  rewrite Htrue.
  trivial.
Qed.

End Hoare_Test_VirtualInv.


(*

  Copyright 2016 Luxembourg University
  Copyright 2017 Luxembourg University

  This file is part of Velisarios.

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

  Velisarios 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 General Public License
  along with Velisarios.  If not, see <http://www.gnu.org/licenses/>.

  Authors: Vincent Rahli
           Ivana Vukotic

*)

Require Export EventOrdering.

Section correct.

  Context { pn  : @Node }.
  Context { pk  : @Key }.
  Context { m   : @Msg }.

  Local Open Scope eo.

  (* This defines what it means for a node [n] to be correct in a partial cut [L]
     of an event ordering [eo]: the keys of all events [e1] happening before [e]
     (an event of the partial cut [L]) at location [n], are different from the keys
     held at other locations at events [e2] prior to [e] *)
  Definition correct (eo : EventOrdering) (n : name) (L : list Event) :=
    forall e e1 e2,
      In e L
      -> e1 ≼ e
      -> e2 ≼ e
      -> loc e1 = n
      -> loc e2 <> n
      -> disjoint (lkm_sending_keys (keys e1)) (lkm_sending_keys (keys e2)).

  Definition correct_e {eo : EventOrdering} (e : Event) :=
    correct eo (loc e) [e].

End correct.