(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*                                                                      *)
(* Micromega: A reflexive tactic using the Positivstellensatz           *)
(*                                                                      *)
(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
(*                                                                      *)
(************************************************************************)

(* Used to generate micromega.ml *)

Require Import ZMicromega.
Require Import QMicromega.
Require Import RMicromega.
Require Import VarMap.
Require Import RingMicromega.
Require Import NArith.
Require Import QArith.

Extract Inductive prod => "( * )" [ "(,)" ].
Extract Inductive List.list => list [ "[]" "(::)" ].
Extract Inductive bool => bool [ true false ].
Extract Inductive sumbool => bool [ true false ].
Extract Inductive option => option [ Some None ].
Extract Inductive sumor => option [ Some None ].
(** Then, in a ternary alternative { }+{ }+{ },
   -  leftmost choice (Inleft Left) is (Some true),
   -  middle choice (Inleft Right) is (Some false),
   -  rightmost choice (Inright) is (None) *)

(** To preserve its laziness, andb is normally expansed.
    Let's rather use the ocaml && *)
Extract Inlined Constant andb => "(&&)".

Extraction "micromega.ml"
  List.map simpl_cone (*map_cone  indexes*)
  denorm Qpower
  n_of_Z Nnat.N_of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find.

(* Local Variables: *)
(* coding: utf-8 *)
(* End: *)


(*

  Copyright 2016 Luxembourg University
  Copyright 2017 Luxembourg University
  Copyright 2018 Luxembourg University
  Copyright 2019 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 Quorum.
Require Export Process.

Section SM.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { dtc : @DTimeContext }.
  Context { pt  : @TimeConstraint dtc }.

  Class SMcontext :=
    MkSMcontext
      {
        (* number of faults *)
        F : nat;

        (* ++++++++ Nodes ++++++++ *)
        num_generals : nat;
        num_generals_non_empty : 0 < num_generals;
        num_generals_constraint : F <= num_generals;

        Gen : Set; (* same as in paper, replica 0 is commander *)
        gen_deq : Deq Gen;
        gens2nat : Gen -> nat_n num_generals;
        gens_bij : bijective gens2nat;

        SMtoken    : Set;
        SMtokendeq : Deq SMtoken;

        sm_value : Set;
        sm_default_value : sm_value;
        sm_value_deq : Deq sm_value;
        sm_choice : list sm_value -> sm_value;
        sm_choice_cond1 : forall v, sm_choice [v] = v;
        sm_choice_cond2 : sm_choice [] = sm_default_value;
        sm_choice_cond3 : forall l1 l2, eqset l1 l2 -> sm_choice l1 = sm_choice l2;

        sm_initial_values : Gen -> sm_value;

        SMsending_key   : Set;
        SMreceiving_key : Set;
      }.

  Context { sm_context : SMcontext }.

  Lemma sm_choice_diff :
    forall l1 l2,
      sm_choice l1 <> sm_choice l2
      ->
      exists v,
        (In v l1 /\ ~ In v l2)
        \/
        (In v l2 /\ ~ In v l1).
  Proof.
    introv h.
    destruct (eqset_dec l1 l2 sm_value_deq) as [d|d].
    { apply sm_choice_cond3 in d; rewrite d in *; tcsp. }
    apply not_eqset_implies; auto.
    apply sm_value_deq.
  Qed.

  (* ===============================================================
     No trusted component
     =============================================================== *)

  Global Instance SM_I_IOTrustedFun : IOTrustedFun := MkIOTrustedFun (fun _ => MkIOTrusted unit unit tt).

  Inductive General :=
  | general (n : Gen).

  Coercion general : Gen >-> General.

  Definition General2Gen (g : General) : Gen :=
    match g with
    | general n => n
    end.

  Coercion General2Gen : General >-> Gen.

  Lemma GeneralDeq : Deq General.
  Proof.
    introv; destruct x as [g1], y as [g2].
    destruct (gen_deq g1 g2);[left|right]; subst; auto.
    intro xx; inversion xx; subst; tcsp.
  Defined.

  Global Instance SM_I_Node : Node := MkNode General GeneralDeq.

  Lemma general_inj : injective general.
  Proof.
    introv h; ginv; auto.
  Qed.

  Definition General2GenOp (g : General) : option Gen :=
    Some (General2Gen g).

  Lemma Gen2General_cond : forall n, General2GenOp (general n) = Some n.
  Proof.
    tcsp.
  Qed.

  Lemma General2Gen_cond : forall n m, General2GenOp m = Some n -> general n = m.
  Proof.
    introv h.
    unfold General2GenOp in h; ginv; simpl; destruct m; auto.
  Qed.

  Global Instance SM_I_Quorum : Quorum_context :=
    MkQuorumContext
      Gen
      num_generals
      gen_deq
      gens2nat
      gens_bij
      _
      _
      Gen2General_cond
      General2Gen_cond
      general_inj.

  Definition SMtokens := list SMtoken.

  Global Instance SM_I_AuthTok : AuthTok :=
    MkAuthTok
      SMtoken
      SMtokendeq.

  (* 0 is less than F+2 *)
  Definition nat_n_Fp2_0 : nat_n num_generals.
  Proof.
    exists 0.
    apply leb_correct.
    apply num_generals_non_empty.
  Defined.

  Definition general0 : Gen := bij_inv gens_bij nat_n_Fp2_0.

  Definition nat2gen (n : nat) : Gen.
  Proof.
    destruct gens_bij as [f a b].
    destruct (lt_dec n num_generals) as [d|d].
    - exact (f (mk_nat_n d)).
    - exact general0.
  Defined.

  Definition SMcommander : Gen := nat2gen 0.

  Definition is_commander (g : Gen) : bool :=
    if gen_deq g SMcommander then true else false.

  Definition is_lieutenant (g : Gen) : bool := negb (is_commander g).

  Lemma is_commander_false :
    forall n, is_commander n = false <-> n <> SMcommander.
  Proof.
    introv.
    unfold is_commander.
    dest_cases w; split; intro h; tcsp.
  Qed.

  Lemma is_commander_true :
    forall n, is_commander n = true <-> n = SMcommander.
  Proof.
    introv.
    unfold is_commander.
    dest_cases w; split; intro h; tcsp.
  Qed.

(*  Record sm_sign :=
    MkSmSign
      {
        sm_sign_id : General;
        sm_sign_sign : SMtokens;
      }.*)

  Definition sm_signs := list Sign.

  Inductive sm_signed_msg :=
  (* FIX: should we also add timestamps here so that we can make difference
       between different values that commanders proposed *)
  (* V: [sm_order] is abstract.  Is it enough to instantiate it with pairs
       of values and a timestamp? *)
  | sm_signed_msg_sing (v : sm_value) (a : Sign)
  | sm_signed_msg_cons (m : sm_signed_msg) (a : Sign).

  Inductive SMmsg : Type :=
  | sm_msg_init
  | sm_msg_alarm
  | sm_msg_signed (v : sm_signed_msg)
  | sm_msg_result (v : sm_value).

  Global Instance SM_I_Msg : Msg := MkMsg SMmsg.

  (* FIX : Is this correct? *)
  Definition SMmsg2status (m : SMmsg) : msg_status :=
    match m with
    | sm_msg_init     => MSG_STATUS_INTERNAL
    | sm_msg_alarm    => MSG_STATUS_INTERNAL
    | sm_msg_signed _ => MSG_STATUS_PROTOCOL
    | sm_msg_result _ => MSG_STATUS_INTERNAL (* sent to itself *)
    end.

  Global Instance SM_I_get_msg_status : MsgStatus := MkMsgStatus SMmsg2status.

  Inductive sm_bare_signed_msg :=
  | sm_bare_signed_msg_sing (v : sm_value) (a : General)
  | sm_bare_signed_msg_cons (m : sm_signed_msg) (a : General).

  Inductive SMbare_msg : Type :=
  | sm_bare_msg_signed (v : sm_bare_signed_msg)
  | sm_bare_msg_result (v : sm_value).

  Global Instance SM_I_Data : Data := MkData SMbare_msg.

  (* extraxt value and auth *)

  Fixpoint sm_signed_msg2value (m : sm_signed_msg) : sm_value :=
    match m with
    | sm_signed_msg_sing v _ => v
    | sm_signed_msg_cons v _ => sm_signed_msg2value v
    end.

  Definition SMmsg2value (m : SMmsg) : option sm_value :=
    match m with
    | sm_msg_init     => None
    | sm_msg_alarm    => None
    | sm_msg_signed v => Some (sm_signed_msg2value v)
    | sm_msg_result v => Some v
    end.

  Definition sm_signed_msg2sign (m : sm_signed_msg) : Sign :=
    match m with
    | sm_signed_msg_sing _ a => a
    | sm_signed_msg_cons _ a => a
    end.

  Definition sm_signed_msg2auth (m : sm_signed_msg) : SMtokens :=
    sign_token (sm_signed_msg2sign m).

  Definition sm_signed_msg2sender (m : sm_signed_msg) : Gen :=
    sign_name (sm_signed_msg2sign m).

  Fixpoint sm_signed_msg2signs (m : sm_signed_msg) : list Sign :=
    match m with
    | sm_signed_msg_sing _ a => [a]
    | sm_signed_msg_cons v a => snoc (sm_signed_msg2signs v) a
    end.

  (* only the last sender *)
  Definition SMmsg2sender (m : SMmsg) : option Gen :=
    match m with
    | sm_msg_init     => None
    | sm_msg_alarm    => None
    | sm_msg_signed v => Some (sm_signed_msg2sender v)
    | sm_msg_result v => None
    end.

  Fixpoint sm_signed_msg2senders (m : sm_signed_msg) : list Gen :=
    match m with
    | sm_signed_msg_sing _ a => [(sign_name a)]
    | sm_signed_msg_cons v a => snoc (sm_signed_msg2senders v) (sign_name a)
    end.

  (* all senders; correct order *)
  Definition SMmsg2senders (m : SMmsg) : list Gen :=
    match m with
    | sm_msg_init     => []
    | sm_msg_alarm    => []
    | sm_msg_signed v => sm_signed_msg2senders v
    | sm_msg_result v => []
    end.

  Fixpoint sm_signed_msg2msgs (m : sm_signed_msg) : list sm_signed_msg :=
    match m with
    | sm_signed_msg_sing v a => [m]
    | sm_signed_msg_cons v a => snoc (sm_signed_msg2msgs v) m
    end.

  (* all signed messages; correct order *)
  Fixpoint SMmsg2signed_messages (m : SMmsg) : list SMmsg :=
    match m with
    | sm_msg_init     => []
    | sm_msg_alarm    => []
    | sm_msg_signed v => map sm_msg_signed (sm_signed_msg2msgs v)
    | sm_msg_result v => []
    end.

  (* only the last signature *)
  Definition SMmsg2sign (m : SMmsg) : option SMtokens :=
    match m with
    | sm_msg_init     => None
    | sm_msg_alarm    => None
    | sm_msg_signed v => Some (sign_token (sm_signed_msg2sign v))
    | sm_msg_result v => None
    end.

  (* all signatures; correct order *)
  Fixpoint SMmsg2signs (m : SMmsg) : list SMtokens :=
    match m with
    | sm_msg_init     => []
    | sm_msg_alarm    => []
    | sm_msg_signed v => map sign_token (sm_signed_msg2signs v)
    | sm_msg_result v => []
    end.

  Definition gens : list Gen := nodes.
  Definition ngens : list name := map general gens.

  Lemma gens_prop : forall (x : Gen), In x gens.
  Proof.
    exact nodes_prop.
  Qed.
  Hint Resolve gens_prop : sm.

  Global Instance SM_I_Key : Key := MkKey SMsending_key SMreceiving_key.

  Class SMauth :=
    MkSMauth
      {
        SMcreate : data -> sending_keys -> SMtokens;
        SMverify : data -> name -> receiving_key -> SMtoken -> bool
      }.
  Context { sm_auth : SMauth }.

  Global Instance SM_I_AuthFun : AuthFun :=
    MkAuthFun
      SMcreate
      SMverify.

  Class SMinitial_keys :=
    MkSMinitial_keys {
        initial_keys : key_map;
      }.

  Context { sm_initial_keys : SMinitial_keys }.

  (*Record value_and_senders :=
    Build_ValueAndSenders
      {
        (* None means that we have no messages so far, and sm_value_default means that we received message with empty value *)
        v         : option sm_value;
        senders   : list Gen;
      }.*)

  Definition sm_values := list sm_value.

  Record SMstate :=
    Build_SMstate
      {
        (* some initial value *)
        init          : sm_value;

        (* the values we received *)
        V             : sm_values;

        (* The keys that we're holding to communicate with the other replicas *)
        local_keys    : local_key_map;
      }.

  Definition SMinitial_state (g : Gen) (init : sm_value) : SMstate :=
    Build_SMstate
      init
      []
      (initial_keys (general g)).

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

  Definition sm_bare_signed_msg2general (m : sm_bare_signed_msg) : General :=
    match m with
    | sm_bare_signed_msg_sing _ a => a
    | sm_bare_signed_msg_cons _ a => a
    end.

  Definition SMdata_auth (n : name) (m : data) : option name :=
    match m with
    | sm_bare_msg_signed v => Some (sm_bare_signed_msg2general v)
    | sm_bare_msg_result v => Some n
    end.

  Global Instance SM_I_DataAuth : DataAuth := MkDataAuth SMdata_auth.

  Definition sm_signed_msg2bare (m : sm_signed_msg) : sm_bare_signed_msg :=
    match m with
    | sm_signed_msg_sing v a => sm_bare_signed_msg_sing v (node2name (sign_name a))
    | sm_signed_msg_cons v a => sm_bare_signed_msg_cons v (node2name (sign_name a))
    end.

  Definition sm_signed_msg2main_auth_data (m : sm_signed_msg) : AuthenticatedData :=
    MkAuthData (sm_bare_msg_signed (sm_signed_msg2bare m)) (sm_signed_msg2auth m).

  Fixpoint sm_signed_msg2list_auth_data (m : sm_signed_msg) : list AuthenticatedData :=
    match m with
    | sm_signed_msg_sing _ _ => [sm_signed_msg2main_auth_data m]
    | sm_signed_msg_cons v _ =>
      snoc (sm_signed_msg2list_auth_data v)
           (sm_signed_msg2main_auth_data m)
    end.

  Definition SMget_contained_auth_data (m : SMmsg) : list AuthenticatedData :=
    match m with
    | sm_msg_init     => []
    | sm_msg_alarm    => []
    | sm_msg_signed v => sm_signed_msg2list_auth_data v
    | sm_msg_result v => [] (* these are not signed *)
    end.

  Global Instance SM_I_ContainedAuthData : ContainedAuthData :=
    MkContainedAuthData SMget_contained_auth_data.

  (* Here, we check that all signatures are correct *)
  Definition verify_signed_msg_sign (slf : Gen) (lkm : local_key_map) (m : sm_signed_msg) : bool :=
    forallb
      (fun a => verify_authenticated_data (general slf) a lkm)
      (sm_signed_msg2list_auth_data m).

  (*(* Here, we check that all signatures are correct *)
  Definition verify_msg_sign (slf : Gen) (lkm : local_key_map) (m : SMmsg) : bool :=
    forallb
      (fun a => verify_authenticated_data (general slf) a lkm)
      (SMget_contained_auth_data m).*)

  Fixpoint sm_signed_msg2sing (m : sm_signed_msg) : sm_value * Sign :=
    match m with
    | sm_signed_msg_sing v a => (v, a)
    | sm_signed_msg_cons v _ => sm_signed_msg2sing v
    end.

  (* Here, we check that the first one to sign was the commander *)
  Definition verify_msg_commander (m : SMmsg) : bool :=
    match m with
    | sm_msg_init  => false
    | sm_msg_alarm => false
    | sm_msg_signed v =>
      let (_,a) := sm_signed_msg2sing v in
      is_commander (sign_name a)
    | sm_msg_result _ => false
    end.

  (* Here, we check that the first one to sign was the commander *)
  Definition verify_signed_msg_commander (m : sm_signed_msg) : bool :=
    is_commander (sign_name (snd (sm_signed_msg2sing m))).

  Definition is_sm_signed_msg2directly_from_commander (m : sm_signed_msg) : bool :=
    match m with
    | sm_signed_msg_sing v a => is_commander (sign_name a)
    | sm_signed_msg_cons v _ => false
    end.

  Definition verify_signed_msg (slf : Gen) (lkm : local_key_map) (m : sm_signed_msg) : bool :=
    (* all signatures have to be correct *)
    (verify_signed_msg_sign slf lkm m)
      (* the first signer has to be the commander *)
      && (verify_signed_msg_commander m)
      (* the senders have to be different from each other *)
      && (norepeatsb gen_deq (sm_signed_msg2senders m))
      (* the receiver should not be in the list of signers *)
      && (not_inb gen_deq slf (sm_signed_msg2senders m)).

  (*Definition verify_msg (slf : Gen) (lkm : local_key_map) (m : SMmsg) : bool :=
    verify_msg_sign slf lkm m && verify_msg_commander m.*)

(* Fixpoint verify_msg_form_list_senders_signatures
             (signed_messages  : list SMmsg)
             (senders          : list Gen)
             (signatures       : list SMtokens)
             (lkm              : local_key_map) : bool :=
    (* here we take care of only properly structure messages *)
    match signed_messages, senders, signatures with
    | [] , [], [] => true
    | m :: l_signed_messages, g :: l_senders, a :: l_signatures =>
      if verify_authenticated_data (general g) (sm_msg_lieutenant2auth_data m g a) lkm then
        verify_msg_form_list_senders_signatures l_signed_messages l_senders l_signatures lkm
      else false
    | _ , _ , _ => false (* this should never happened *)
    end.

  Definition remove_first_element {A} (l : list A) : list A :=
    match l with
    | [] => []
    | h :: t => t
    end.

    Definition first_element {A} (l : list A) :  option A :=
    match l with
    | [] => None
    | h :: t =>  Some h
    end.

  Definition verify_msg (lkm : local_key_map) (m : SMmsg) : bool :=
    let value                := SMmsg2value m in
    let list_senders         := SMmsg2senders m in
    let list_signatures      := SMmsg2signs m in
    let list_signed_messages := app (SMmsg2signed_messages m) [m] in

  (* here we check only if the message that commander signed was correct,
   and forward the rest to the verify_msg_form_list_senders_signatures *)
    let c := first_element list_senders in
    let a := first_element list_signatures in

    match c, a with
    | Some c, Some a =>
      if verify_authenticated_data (general c) (sm_msg_commander2auth_data value c a) lkm then

        (* check if all other messages are signed properly *)
        let list_senders'    := remove_first_element list_senders in
        let list_signatures' := remove_first_element list_signatures in

        verify_msg_form_list_senders_signatures list_signed_messages list_senders' list_signatures' lkm

      else false

    |_,_ => false (* this should never happened *)
    end.*)

  Definition check_new_value
             (V : sm_values (*value_and_senders*))
             (m : sm_signed_msg) : bool :=
    if in_dec sm_value_deq (sm_signed_msg2value m) V then false
    else true.

(*  Fixpoint check_new_value
           (slf : Gen)
           (V   : list value_and_senders)
           (m   : SMmsg) : bool :=
    match V with
    | [] => true
    | entry :: entries =>
      match entry with
      | Build_ValueAndSenders v senders =>
        match v with
        | None => false (* this means that message was missing the value! *)
        | Some value => if sm_value_deq (SMmsg2value m) value then false
                        else check_new_value slf entries m
        end
      end
    end.*)

(*  Fixpoint occurrences (e : sm_value) (l : list sm_value) : nat :=
    match l with
    | [] => 0
    | entry :: entries =>
      if sm_value_deq e entry then 1 + occurrences e entries
      else occurrences e entries
    end.*)

  (* median value is return -- see pg. 391
  Fixpoint choice_V_ (l : list value_and_senders) : (option sm_value * nat) :=
    match l with
    | [] => (None, 0)
    | entry :: entries => match entry with
                          | Build_ValueAndSenders val senders =>
                            match val with
                            | None => (Some sm_value_default,0) (* pg. 391 retreat is default value *)
                            | Some v =>
                              let (sum_val, num) := choice_V entries in
                               , num + 1)

                              (Some v, 1)
                              (* we should have a median value here *)
(*                              let med :=  choice_V entries *)
                            end
                          end
                              end.
   *)

(*  Fixpoint all_sm_values (l : list value_and_senders) : list sm_value :=
    match l with
    | [] => []
    | entry :: entries =>
      match entry with
      | Build_ValueAndSenders val senders =>
        match val with
        | None => [sm_default_value] (* pg. 391 retreat is default value *)
        | Some v =>
          let l' := all_sm_values entries in
          match l' with
          | [] => [v]
          | _ => v :: l'
          end
        end
      end
    end.

  Fixpoint number_of_diff_values (l : list value_and_senders) : nat :=
    match l with
    | [] => 0
    | entry :: entries => match entry with
                          | Build_ValueAndSenders val senders =>
                            match val with
                            | None => 1 (* pg. 391 retreat is default value *)
                            | Some v => (number_of_diff_values entries) + 1
                            end
                          end
    end.

  (* median value is return -- see pg. 391 *)
  Definition choice_V (l : list value_and_senders) : sm_value :=
    let nb_val  := number_of_diff_values l in
    let all_val := all_sm_values l in
    sm_choice all_val (*nb_val*).*)

  (* message has the form (v:0) *)
  Definition commander_message (m : SMmsg) : bool := verify_msg_commander m.

  (* message has the form (v:0:j1:...jk) *)
  Definition commander_lieutenant (m : SMmsg) : bool := negb (verify_msg_commander m).

  (* general have not received any order yet *)
  Definition no_order_yet (V : sm_values (*value_and_senders*)) : bool := nullb V.

(*  (* add value v to the V; no order received so far *)
  Definition add_value_to_V_no_order_yet (v : sm_value) (V : sm_values) :=
    match V with
    | [] => [v]
    | l => l (* this should never happened!!! *)
    end.*)

  (*Definition update_state_V (s : SMstate) (V : sm_values) : SMstate :=
    Build_SMstate
      (init       s)
      V
      (local_keys s)
      (bp         s).*)

  Definition add_to_V (s : SMstate) (v : sm_value) : SMstate :=
    Build_SMstate
      (init          s)
      (v ::        V s)
      (local_keys    s).

  Definition extend_signed_msg
             (m    : sm_signed_msg)
             (g    : General)
             (keys : local_key_map) : sm_signed_msg :=
    let a := authenticate (sm_bare_msg_signed (sm_bare_signed_msg_cons m g)) keys in
    sm_signed_msg_cons m (MkSign (General2Gen g) a).

  Definition extend_msg
             (m    : SMmsg)
             (g    : General)
             (keys : local_key_map) : SMmsg :=
    match m with
    | sm_msg_init     => m
    | sm_msg_alarm    => m
    | sm_msg_signed v => sm_msg_signed (extend_signed_msg v g keys)
    | sm_msg_result v => m
    end.

  Definition send_sm_msg_commander (m : SMmsg) (n : list name) : DirectedMsg :=
    MkDMsg m n ('0).

  Definition send_sm_msg_lieutenant (m : SMmsg) (n : list name) : DirectedMsg :=
    MkDMsg m n ('0).

  Definition gens_not_in_list (l : list Gen) : list Gen :=
    diff gen_deq l gens.

  Definition names_not_in_list (l : list Gen) : list name :=
    map general (gens_not_in_list l).

  Definition broadcast2not_in_list (l : list Gen) F : DirectedMsg :=
    F (names_not_in_list l).

  Definition create_new_sm_signed_msg
             (v    : sm_value)
             (keys : local_key_map) : sm_signed_msg :=
    let b := sm_bare_signed_msg_sing v (general SMcommander) in
    let a := authenticate (sm_bare_msg_signed b) keys in
    sm_signed_msg_sing v (MkSign (SMcommander) a).

  Definition create_new_msg_commander
             (v    : sm_value)
             (keys : local_key_map) : SMmsg :=
    sm_msg_signed (create_new_sm_signed_msg v keys).

  Definition create_new_msg_result (v : sm_value) : SMmsg:=
    let b := sm_bare_msg_result v in
    sm_msg_result v.

  (* FIX: the paper is not clear what lieutenants do with their decision at the end.
      We send the final decision to ourselves. *)
  Definition send_sm_msg_result (slf : Gen) (m : sm_value) : DirectedMsg :=
    MkDMsg (sm_msg_result m) [general slf] ('0).

  (* FIX: correct delay?  [F] or [F+1]? *)
  Definition send_alarm (slf : Gen) : DirectedMsg :=
    MkDMsg sm_msg_alarm [general slf] (pdt_mult ('(S F)) (pdt_plus mu tau)).

  (* handler of initial message sent to commander to start it *)
  Definition SMhandler_initial (slf : Gen) : Update SMstate unit DirectedMsgs :=
    fun state v t =>
      let keys   := local_keys state in
      let V_list := V state in

      if dt_eq_dec t (nat2pdt 0) then

        if is_commander slf then
          let new_msg := create_new_msg_commander (init state) keys in
          let new_state1 := add_to_V state (init state) in

          (* commander broadcasts new message to all replicas *)
          (Some new_state1, [broadcast2not_in_list [SMcommander] (send_sm_msg_commander new_msg)])

        else
          (Some state, [send_alarm slf])

      else (* initial messages are supposed to be received at time 0 *)
        (Some state, []).

  Definition message_is_on_time (m : sm_signed_msg) (t : PosDTime) : bool :=
    let signs := sm_signed_msg2signs m in
    if dt_le_lt_dec t (nat2pdt (length signs) * (mu + tau))%dtime then
      (* We don't care about messages with more than F+1 signatures,
         we're not supposed to send any: *)
      if le_dec (length signs) (S F) then true else false
    else false.

  Definition SMhandler_lieutenant (slf : Gen) : Update SMstate sm_signed_msg DirectedMsgs :=
    fun state m time =>
      let keys := local_keys state in
      let Vs   := V state in

      if is_lieutenant slf then

        if verify_signed_msg slf keys m then

          if message_is_on_time m time then

            (* is message of the form (v:0), i.e., commander message *)
            if is_sm_signed_msg2directly_from_commander m then

              (* lieutenant have not received any order yet *)
              if no_order_yet Vs then

                (* add value (received with msg m) to the V, assuming that general have not received any order yet *)
                let new_state1 := add_to_V state (sm_signed_msg2value m) in

                if 1 <=? F then

                  (* create new message v:0:i *)
                  let new_signed_msg := extend_signed_msg m (general slf) keys in
                  let new_msg := sm_msg_signed new_signed_msg in

                  (* we broadcast new message to all replicas that are not in the message i.e. commander in this case *)
                  (Some new_state1, [broadcast2not_in_list [slf,SMcommander] (send_sm_msg_lieutenant new_msg)])

                else
                  (Some new_state1, [])

              else (* message has the form (v:0), but lieutenant has some order already received *)
                (Some state, [])

            else (* message is not of the form (v:0), i.e., commander message
              i.e., message has the form (v:0:j1:..:jk *)

              (* if this is the value that was not received before *)
              if check_new_value Vs m then

                (* add value (received with msg m) to the V, assuming that general already received some value *)
                let new_state1 := add_to_V state (sm_signed_msg2value m) in

                (* if k < m , i.e., (if number of senders is less than number of faults) then broadcast the message *)
                (* NOTE : F + 1 because commander is one of the senders *)
                if length (sm_signed_msg2senders m) <=? F then

                  (* create new message v:0:j1:...:jk:i *)
                  let new_signed_msg := extend_signed_msg m (general slf) keys in
                  let new_msg := sm_msg_signed new_signed_msg in

                  let ls := sm_signed_msg2senders m in

                  (* we broadcast new message to all replicas that were not in the message *)
                  (Some new_state1, [broadcast2not_in_list (slf :: ls) (send_sm_msg_lieutenant new_msg)])

                else (* number of senders is not less than number of faults,
                  i.e., in this case lieutenant obeys the order determined with choice(V) *)
                  (Some new_state1, [])

              else (* this value was received before *)
                (Some state, [])

          else (* message is not on time *)
            (Some state, [])

        else (* message is not signed properly *)
          (Some state, [])

      else (* not a lieutenant *)
        (Some state, []).

  Definition SMhandler_result (slf : Gen) : Update SMstate sm_value DirectedMsgs :=
    fun state _ _ => (Some state, []).

  Definition SMhandler_alarm (slf : Gen) : Update SMstate unit DirectedMsgs :=
    fun state _ t =>
      if is_lieutenant slf then
        if dt_le_lt_dec t (pdt_mult ('(S F)) (pdt_plus mu tau))
        then (Some state, []) (* this shouldn't happen because the alarm was set to [(F+1)*(mu+tau)] *)
        else
          let choice := sm_choice (V state) in
          (* we send the signed msg that contains choice to all other replicas *)
(*          let new_msg := create_new_msg_result choice in *)
          (Some state, [send_sm_msg_result slf choice])
      else (Some state, []).

  (*
     NOTE:

     - The init message has to be sent to the commander at time T0
     - Alarms have to be sent to the lieutenants at time T0, and have to be
       set as in [send_alarm].
   *)
  Definition SMupdate (slf : Gen) : MUpdate SMstate :=
    fun state m =>
      match m with
      | sm_msg_init     => SMhandler_initial    slf state tt
      | sm_msg_alarm    => SMhandler_alarm      slf state tt
      | sm_msg_signed v => SMhandler_lieutenant slf state v
      | sm_msg_result v => SMhandler_result     slf state v
      end.

  Definition SMreplicaSM (slf : Gen) : MStateMachine _ :=
    mkSM
      (SMupdate slf)
      (SMinitial_state slf (sm_initial_values slf)).

  Definition SMsys : MUSystem (fun n => SMstate) := SMreplicaSM.

  (*Definition initial_conditions (eo : EventOrdering) :=
    forall (e : Event) g,
      has_correct_trace_before e (loc e)
      -> loc e = general g
      -> isFirst e
      -> (time e = 0 /\ trigger e = Some sm_msg_init).*)

End SM.

Hint Resolve gens_prop : sm.


(*
Alternative ("big-step") definition of run_vm + proof that it corresponds to the one in VmSemantics.v.

Author:  Adam Petz, ampetz@ku.edu
*)

Require Import Preamble GenStMonad MonadVM Instr VmSemantics MyStack ConcreteEvidence MonadLaws.
Require Import Event_system More_lists LTS Term Term_system.
Require Import StructTactics.

Require Import List.
Import ListNotations.
Require Import Coq.Program.Tactics.

Lemma hfhf : forall (act1 act2:VM unit) st il,
    (act1;;
     (fold_left (fun (a0 : VM unit) (b : AnnoInstr) => a0;; build_comp b) il
                act2)) st =
    (act1;; (act2 ;;
            (fold_left (fun (a0 : VM unit) (b : AnnoInstr) => a0;; build_comp b) il
                       (ret tt)))) st.
Proof.
  intros.
  generalize dependent act1.
  generalize dependent act2.
  generalize dependent st.
  induction il; intros.
  - simpl.
    rewrite monad_comp.
    rewrite <- monad_right_id'.
    reflexivity.
  -
    simpl.
    rewrite IHil.
    repeat rewrite monad_comp.

    rewrite IHil.
    rewrite IHil.

    repeat rewrite monad_comp.
    rewrite fafa.

    Check gasd.

    assert (
      (((act1;; act2;; build_comp a);; ret tt);;
       fold_left (fun (a0 : VM unit) (b : AnnoInstr) => a0;; build_comp b) il (ret tt)) st =
      ((act1;; act2;; build_comp a);; ret tt;; fold_left (fun (a0 : VM unit) (b : AnnoInstr) => a0;; build_comp b) il (ret tt)) st).
    {
    rewrite hghg.
    reflexivity.
    }
    rewrite H.
    rewrite gasd.

    rewrite hlhl.
    reflexivity.
Defined.

Lemma gfds: forall (act:VM unit) (st:vm_st) il,
    (fold_left (fun (a0 : VM unit) (b : AnnoInstr) => a0;; build_comp b) il
               (act)) st =
    (act ;;
     (fold_left (fun (a0 : VM unit) (b : AnnoInstr) => a0;; build_comp b) il
                (ret tt))) st.
Proof.
  intros.
  generalize dependent act.
  generalize dependent st.
  induction il; intros.
  - simpl. rewrite monad_right_id'. reflexivity.

  - simpl.
    erewrite IHil.
    rewrite <- monad_comp.

    rewrite hfhf.
    rewrite monad_comp.
    rewrite monad_comp.

    rewrite fafa.
    reflexivity.
Defined.

(* Not provable, act1 could fail *)
(*
Lemma fads : forall (act1:VM unit) act2 il st v o,
    act1 st = (o, v) ->
    fold_left (fun (a0 : VM unit) (b : AnnoInstr) => a0;; build_comp b) il
              (act1 ;; act2) st =
    fold_left (fun (a0 : VM unit) (b : AnnoInstr) => a0;; build_comp b) il
              (act2) v.
Proof.
  intros.
  rewrite gfds.
  rewrite <- monad_comp.
  unfold ret.
  unfold bind.
  rewrite H.
  break_let.
  break_match.
  destruct o0.
  - simpl in *.
    break_let.
    invc Heqp.
    rewrite gfds.
    unfold ret.
    unfold bind.
    destruct o0.
    + simpl.
      break_let.
      repeat find_inversion.
      rewrite <- Heqp.
      rewrite gfds.
      destruct v1.
      simpl.
      cbn.
      break_let.
      destruct v.
      cbn.
      rewrite gfds.
      unfold bind.
      rewrite Heqp0.
      break_let.
      unfold bind in Heqp1.
      congruence.
    + congruence.
  - repeat find_inversion.
    break_match.
    break_match.
    repeat break_let.
    repeat find_inversion.
    rewrite gfds.
    unfold bind.
    rewrite Heqp0.
    repeat break_let.
    unfold ret in Heqp.
    congruence.
    + repeat find_inversion.
      rewrite gfds.
      unfold bind.
      rewrite Heqp0.
      reflexivity.
  - break_match.
    break_match.
    repeat break_let.
    repeat find_inversion.
    rewrite gfds.
    unfold bind.
    rewrite Heqp0.
    repeat break_let.
    unfold ret in *.
    rewrite gfds in Heqp.
    unfold bind in Heqp.
    repeat break_let.
    repeat find_inversion.
    congruence.

      rewrite <- Heqp0.

    rewrite Heqp0.
    break_let.
    congruence.
  - invc Heqp.
    rewrite <- Heqp0.
    rewrite gfds.
    unfold ret.
    unfold bind.
    rewrite Heqp0.
    reflexivity.
Defined.
*)

Lemma fads : forall (act1:VM unit) act2 il st v z,
    act1 st = (Some z, v) ->
    fold_left (fun (a0 : VM unit) (b : AnnoInstr) => a0;; build_comp b) il
              (act1 ;; act2) st =
    fold_left (fun (a0 : VM unit) (b : AnnoInstr) => a0;; build_comp b) il
              (act2) v.
Proof.
  intros.
  rewrite gfds.
  rewrite <- monad_comp.
  unfold ret.
  unfold bind.
  rewrite H.
  break_let.
  break_match.
  destruct o0.
  - simpl in *.
    break_let.
    invc Heqp.
    rewrite gfds.
    unfold ret.
    unfold bind.
    rewrite Heqp0.
    break_let.
    congruence.
  - invc Heqp.
    rewrite <- Heqp0.
    rewrite gfds.
    unfold ret.
    unfold bind.
    rewrite Heqp0.
    reflexivity.
Defined.

Definition run_vm_fold (il:list AnnoInstr) : VM unit :=
  fold_left (fun (a:VM unit) (b:AnnoInstr) => a ;; (build_comp b)) il (GenStMonad.ret tt).

Definition run_vm' (il:list AnnoInstr) st : vm_st :=
  let c := run_vm_fold il in
  execSt st c.

Lemma vm_fold_step : forall a il st z v,
    run_vm_fold (a :: il) st = (Some z, v) ->
    run_vm_fold il (run_vm_step st a) = (Some z, v).
Proof.
  intros.
  simpl in *.
  cbn in *.
  rewrite gfds in H.
  rewrite <- monad_comp in H.
  rewrite monad_left_id in H.
  cbn in H.
  unfold ret in H.
  unfold bind in H.
  remember (build_comp a st) as ooo.
  destruct ooo.
  destruct o.
  - break_let.
    invc H.

    unfold run_vm_fold in *.
    unfold run_vm_step in *.
    unfold execSt in *.
    rewrite <- Heqooo.
    simpl.
    rewrite <- Heqp.
    reflexivity.
  - inv H.
Defined.

Lemma newLem : forall il a st z v,
    build_comp a st = (Some z, v) ->
    (fold_left (fun (a0 : VM unit) (b : AnnoInstr) => a0;; build_comp b) il
               (GenStMonad.ret tt) (snd (build_comp a st))) =
    (fold_left (fun (a0 : VM unit) (b : AnnoInstr) => a0;; build_comp b) il
               (GenStMonad.ret tt;; build_comp a) st).
Proof.
  intros.
  remember (build_comp a st) as aaa.
  destruct aaa.
  destruct o.
  + simpl.
    cbn.
    assert (
        fold_left (fun (a0 : VM unit) (b : AnnoInstr) => a0;; build_comp b) il
                  (ret tt;; build_comp a) st =
        fold_left (fun (a0 : VM unit) (b : AnnoInstr) => a0;; build_comp b) il
                  (build_comp a) st
      ) as H0.
    {
      Check bind.
      Print bind.
      Check tt.

      erewrite gfds.
      rewrite <- monad_comp.
      rewrite monad_left_id.
      erewrite gfds.
      reflexivity.
    }

    rewrite H0. clear H0.
    simpl.
    assert (
        fold_left (fun (a0 : VM unit) (b : AnnoInstr) => a0;; build_comp b) il
                  (build_comp a) st =
        fold_left (fun (a0 : VM unit) (b : AnnoInstr) => a0;; build_comp b) il
                  (build_comp a ;; ret tt) st
      ) as H0.
    {
      erewrite gfds.
      erewrite gfds.
      rewrite <- monad_comp.
      Check build_comp.

      rewrite gasd.
      reflexivity.
    }

    rewrite H0.
    clear H0.

    (*
    assert (build_comp a st = (None, v0)).
    admit.
    clear Heqaaa.
    unfold bind.
    unfold ret.
    rewrite gfds.
    cbn.
    break_let.
    simpl.

    destruct st.
    simpl.

    assert (
        (fun s : vm_st =>
     match build_comp a s with
     | (Some _, s') => (Some tt, s')
     | (None, s') => (None, s')
     end)
    {|
    st_ev := st_ev;
    st_stack := st_stack;
    st_trace := st_trace;
    st_pl := st_pl;
    st_store := st_store |}

        =
    match build_comp  a {|
    st_ev := st_ev;
    st_stack := st_stack;
    st_trace := st_trace;
    st_pl := st_pl;
    st_store := st_store |}  with
     | (Some _, s') => (Some tt, s')
     | (None, s') => (None, s')
    end) as HH by auto.
    repeat break_let.
    destruct o1; destruct o0; find_inversion.
    find_inversion.

    clear Heqp0.
    simpl.
    rewrite <- Heqp.
    rewrite gfds.
    unfold ret.
    unfold bind.
    repeat break_let.
    repeat find_inversion.
    rewrite gfds.
    simpl.
    cbn.
    unfold bind.
    rewrite Heqp1.
    unfold bind in Heqp.
    unfold ret in Heqp.
    rewrite Heqp in Heqp0.
    repeat find_inversion.
    rewrite <- HH.
     *)

    erewrite fads.
    reflexivity.
    symmetry.
    eassumption.
  +
    assert (
        fold_left (fun (a0 : VM unit) (b : AnnoInstr) => a0;; build_comp b) il
                  (ret tt;; build_comp a) st =
        fold_left (fun (a0 : VM unit) (b : AnnoInstr) => a0;; build_comp b) il
                  (build_comp a) st
      ) as H0.
    {

      erewrite gfds.
      rewrite <- monad_comp.
      rewrite monad_left_id.
      erewrite gfds.
      reflexivity.
    }

    rewrite H0. clear H0.

    assert (
        fold_left (fun (a0 : VM unit) (b : AnnoInstr) => a0;; build_comp b) il
                  (build_comp a) st =
        fold_left (fun (a0 : VM unit) (b : AnnoInstr) => a0;; build_comp b) il
                  (build_comp a ;; ret tt) st
      ) as H0.
    {
      erewrite gfds.
      erewrite gfds.
      rewrite <- monad_comp.
      Check build_comp.

      rewrite gasd.
      reflexivity.
    }
    rewrite H0.
    clear H0.

    simpl.
    congruence.
Defined.

Lemma runa : forall a il st z v,
    run_vm_fold (a :: il) st = (Some z, v) ->
    exists z' v',
    build_comp a st = (Some z', v').
Proof.
  intros.
  simpl in *.
  cbn in *.
  erewrite gfds in H.
  rewrite <- monad_comp in H.
  rewrite monad_left_id in H.
  cbn in H.
  unfold ret in H.
  unfold bind in H.
  remember (build_comp a st) as ooo.
  destruct ooo.
  destruct o.
  - break_let.
    invc H.

    destruct u.
    exists tt.
    exists v0.
    reflexivity.
  - inv H.
Defined.

Lemma fold_destruct : forall il1 il2 st st' st'' x x',
    run_vm_fold il1 st = (Some x, st') ->
    run_vm_fold il2 st' = (Some x', st'') ->
    run_vm_fold (il1 ++ il2) st = (Some x', st'').
Proof.
  induction il1; intros.
  - simpl.
    rewrite <- H0.
    simpl in *.
    unfold run_vm_fold in H.
    cbn in H.
    unfold ret in H.
    invc H.
    reflexivity.
  -
    cbn in *.
    unfold run_vm_fold in IHil1.
    rewrite gfds.
    cbn.
    simpl.
    monad_unfold.
    break_let.
    break_match.
    break_let.
    break_let.
    rewrite <- Heqp1.
    erewrite IHil1.
    reflexivity.
    rewrite <- H.
    repeat rewrite gfds in *.
    monad_unfold.
    break_let.
    simpl.
    cbn.
    (* rewrite gfds. *)
    monad_unfold.
    break_let.
    break_match.
    break_let.
    break_let.
    repeat find_inversion.
    congruence.
    repeat find_inversion.
    eauto.
    (*
    break_let.
    congruence.
    repeat find_inversion.
    eauto. *)

    break_let.
    repeat find_inversion.
    rewrite gfds in H.
    monad_unfold.
    repeat break_let.
    find_inversion.
    destruct o.
    inv Heqp.
    inv H.
Defined.

Lemma run_vm_iff : forall il st z v,
    (run_vm_fold il) st = (Some z, v) ->
    run_vm il st = run_vm' il st.
Proof.
  intros.
  generalize dependent st.
  generalize dependent z.
  generalize dependent v.
  induction il; intros.
  - simpl.
    unfold run_vm'. simpl.
    unfold execSt.
    unfold run_vm_fold. simpl. reflexivity.
  - simpl.
    destruct runa with (a:=a) (il:=il) (st:=st) (z:=z) (v:=v).
    apply H.
    destruct_conjs.
    erewrite IHil.
    unfold run_vm'. simpl.
    unfold execSt.
    unfold snd.
    simpl.
    unfold run_vm_fold.
    simpl.
    cbn.
    unfold run_vm_step.
    simpl.
    cbn.
    unfold execSt.
    unfold snd.
    simpl.
    cbn.
    expand_let_pairs.
    expand_let_pairs.
    expand_let_pairs.
    unfold snd at 2.
    cbn.
    (*unfold GenStMonad.ret.*)
    simpl.
    cbn.
    expand_let_pairs.
    unfold snd at 1.
    unfold snd at 2.
    (*unfold fold_left.*)
    unfold snd.
    cbn.
    simpl.
    repeat expand_let_pairs.
    fold (GenStMonad.ret (S:=vm_st) (A:=unit)).
    assert (
    (fold_left (fun (a0 : VM unit) (b : AnnoInstr) => a0;; build_comp b) il
                   (GenStMonad.ret tt) (snd (build_comp a st))) =
        (fold_left (fun (a0 : VM unit) (b : AnnoInstr) => a0;; build_comp b) il
                   (GenStMonad.ret tt;; build_comp a) st)) as H00.
    eapply newLem.

    apply H1.

    congruence.

    apply vm_fold_step. eassumption.
Defined.

Require Import MonadVMFacts.

Set Nested Proofs Allowed.

Lemma run_vm_iff_helper : forall t t' il st n,
    t = snd (anno t' n) ->
    il = (instr_compiler t) ->
    exists z v,
      (run_vm_fold il) st = (Some z, v).
Proof.
  intros.
  generalize dependent H.
  generalize dependent t'.
  generalize dependent st.
  generalize dependent il.
  generalize dependent n.

  induction t; intros.
  - simpl in *.
    destruct a;
      try (boom; allss; simpl in *; cbn; boom; allss).
  -
    cbn in *.
    simpl in *.
    break_let.
    simpl in *.
    boom; allss.
    boom; allss.
    simpl.
    cbn.
    repeat break_let.
    monad_unfold.
    unfold get_store_at in *.
    monad_unfold.
    rewrite PeanoNat.Nat.eqb_refl in *.
    allss.
  -
    unfold annotated in *.
    cbn in *.

    simpl in *.
    destruct t'; inv H;
      try (
          repeat break_let;
          simpl in *;
          inv H2).
    edestruct IHt1 with (st:=st) (il:=instr_compiler a).
    reflexivity.
    symmetry.
    rewrite Heqp.
    simpl.
    reflexivity.
    destruct_conjs.
    edestruct IHt2 with (st:=H0) (il:=instr_compiler a0).
    reflexivity.
    rewrite Heqp0.
    simpl. reflexivity.
    destruct_conjs.

    repeat eexists.

    eapply fold_destruct.
    eauto.
    vmsts.
    eauto.
  -
    simpl in *.
    destruct r; destruct s.
    subst.
    cbn.
    Print fold_destruct.
    Check fold_destruct.

    rewrite gfds.
    monad_unfold.
    cbn.
    break_let.
    rewrite <- Heqp.
    clear Heqp.
    simpl in *.
    vmsts.
    simpl in *.

    rewrite gfds.

    assert (
        fold_left (fun (a0 : VM unit) (b : AnnoInstr) => a0;; build_comp b)
     (instr_compiler t1 ++
      abesr :: instr_compiler t2 ++ [ajoins (Nat.pred n1)])
     (ret tt) =
        run_vm_fold
          (instr_compiler t1 ++
                          abesr :: instr_compiler t2 ++ [ajoins (Nat.pred n1)])
      ) as HH.
    {
      reflexivity.
    }

    rewrite HH.
    clear HH.
    assert (
        (instr_compiler t1 ++
                        abesr :: instr_compiler t2 ++ [ajoins (Nat.pred n1)]) =
         (instr_compiler t1 ++
                        [abesr] ++ instr_compiler t2 ++ [ajoins (Nat.pred n1)])
      ) as HH.
    {
      reflexivity.
    }
    rewrite HH. clear HH.
    unfold bind.
    unfold ret.
    repeat break_let.
    rewrite app_assoc in Heqp.
    rewrite app_assoc in Heqp.
    assert (
        (((instr_compiler t1 ++ [abesr]) ++ instr_compiler t2) ++
            [ajoins (Nat.pred n1)]) =
        (instr_compiler t1 ++ ([abesr] ++ (instr_compiler t2 ++
                                                          ([ajoins (Nat.pred n1)]))))
      ) as HH.
    {
      simpl.
      repeat rewrite <- app_assoc.

      reflexivity.
    }

    rewrite HH in Heqp. clear HH.
    destruct t'; inv H;

      try (
          simpl in *;
          repeat break_let;
          simpl in *;
          inv H).

    edestruct IHt1 with (st:={|
           st_ev := splitEv s st_ev0;
           st_stack := push_stack EvidenceC (splitEv s0 st_ev0) st_stack0;
           st_trace := st_trace0 ++ [Term.split n st_pl0];
           st_pl := st_pl0;
           st_store := st_store0 |}) (il:=instr_compiler a).
    reflexivity.

    symmetry.
    rewrite Heqp0.
    simpl.
    reflexivity.
    destruct_conjs.

    vmsts.

    assert (
        push_stack EvidenceC (splitEv s0 st_ev0) st_stack0 =
        st_stack1) as HH.
    {
      Print do_stack1.
      Print run_vm'.
      assert (run_vm' (instr_compiler a) {|
         st_ev := splitEv s st_ev0;
         st_stack := push_stack EvidenceC (splitEv s0 st_ev0) st_stack0;
         st_trace := st_trace0 ++ [Term.split n st_pl0];
         st_pl := st_pl0;
         st_store := st_store0 |} =
              {| st_ev := st_ev1; st_stack := st_stack1; st_trace := st_trace1; st_pl := st_pl1; st_store := st_store1 |}).
      {
        simpl.
        cbn.
        unfold run_vm'.
        unfold execSt.
        rewrite H2.
        reflexivity.
      }

      erewrite <- run_vm_iff in H0.
      do_stack1 a.
      assumption.
      eassumption.
    }
    subst.

    unfold run_vm_fold in Heqp.
    rewrite fold_left_app in Heqp.
    rewrite gfds in Heqp.
    cbn in *.
    monad_unfold.
    simpl in *.

    vmsts.
    simpl in *.
    assert (
        fold_left
             (fun (a : VM unit) (b : AnnoInstr) (s : vm_st) =>
              match a s with
              | (Some _, s') => let '(b0, s'') := build_comp b s' in (b0, s'')
              | (None, s') => (None, s')
              end) (instr_compiler a) (fun s : vm_st => (Some tt, s))
             {|
             st_ev := splitEv s st_ev0;
             st_stack := push_stack EvidenceC (splitEv s0 st_ev0) st_stack0;
             st_trace := st_trace0 ++ [Term.split n st_pl0];
             st_pl := st_pl0;
             st_store := st_store0 |} =
        run_vm_fold (instr_compiler a)
         {|
             st_ev := splitEv s st_ev0;
             st_stack := push_stack EvidenceC (splitEv s0 st_ev0) st_stack0;
             st_trace := st_trace0 ++ [Term.split n st_pl0];
             st_pl := st_pl0;
             st_store := st_store0 |}) as HHH.
    {
      reflexivity.
    }
    rewrite HHH in Heqp. clear HHH.
    rewrite H2 in Heqp. clear H2.
    repeat break_let.
    repeat find_inversion.

    rewrite fold_left_app in Heqp2.
    cbn in *.
    repeat break_let.
    monad_unfold.
    vmsts.
    rewrite gfds in Heqp.
    cbn in *.
    monad_unfold.
    repeat break_let.

    repeat find_inversion.
    vmsts.

    edestruct IHt2 with
        (il:= instr_compiler a0)

        (st:= {|
            st_ev := splitEv s0 st_ev0;
            st_stack := push_stack EvidenceC st_ev1 st_stack0;
            st_trace := st_trace1;
            st_pl := st_pl1;
            st_store := st_store1 |}).
    reflexivity.
    symmetry.
    rewrite Heqp1.
    simpl.
    reflexivity.
    destruct_conjs.

    vmsts.
    assert (
        run_vm_fold (instr_compiler a0)
                    {|
            st_ev := splitEv s0 st_ev0;
            st_stack := push_stack EvidenceC st_ev1 st_stack0;
            st_trace := st_trace1;
            st_pl := st_pl1;
            st_store := st_store1 |} =
        fold_left
            (fun (a0 : VM unit) (b : AnnoInstr) (s : vm_st) =>
             match a0 s with
             | (Some _, s') => let '(b0, s'') := build_comp b s' in (b0, s'')
             | (None, s') => (None, s')
             end) (instr_compiler a0) (fun s : vm_st => (Some tt, s))
            {|
            st_ev := splitEv s0 st_ev0;
            st_stack := push_stack EvidenceC st_ev1 st_stack0;
            st_trace := st_trace1;
            st_pl := st_pl1;
            st_store := st_store1 |}) as HH.
    {
      reflexivity.
    }

    rewrite <- HH in Heqp8. clear HH.
    rewrite H0 in Heqp8.
    assert (push_stack EvidenceC st_ev1 st_stack0 = st_stack3).
    {
      Print do_stack1.
      Print run_vm'.
      assert (run_vm' (instr_compiler a0) {|
         st_ev := splitEv s0 st_ev0;
         st_stack := push_stack EvidenceC st_ev1 st_stack0;
         st_trace := st_trace1;
         st_pl := st_pl1;
         st_store := st_store1 |} =
              {| st_ev := st_ev4; st_stack := st_stack3; st_trace := st_trace4; st_pl := st_pl4; st_store := st_store4 |}).
      {
        simpl.
        cbn.
        unfold run_vm'.
        unfold execSt.

        rewrite H0.
        reflexivity.
      }

      erewrite <- run_vm_iff in H.
      do_stack1 a0.
      assumption.
      eassumption.
    }
    subst.
    clear H0.
    repeat find_inversion.
    repeat break_match;
      repeat find_inversion.
    eauto.

    unfold push_stack in *.
    unfold pop_stack in *.
    congruence.

  - (* abpar case *)
    subst.
    unfold run_vm_fold.
    cbn.
    monad_unfold.
    destruct s; destruct r.
    rewrite gfds.
    monad_unfold.
    repeat break_let.
    subst.
    monad_unfold.
    break_let.
    monad_unfold.
    simpl in *.
    vmsts.
    simpl in *.
    unfold Maps.map_set in *.

    unfold get_store_at in *.
    unfold get in *.
    simpl in *.
    assert (

        (st <- (fun s : vm_st => (Some s, s));;
         match Maps.map_get (StVM.st_store st) (fst (range t1)) with
         | Some e => ret e
         | None => failm
         end)
          {|
            st_ev := ppc (parallel_att_vm_thread (instr_compiler t1) (splitEv s st_ev2))
                         (parallel_att_vm_thread (instr_compiler t2) (splitEv s0 st_ev2));
            st_stack := st_stack2;
            st_trace := (st_trace2 ++ [Term.split n0 st_pl2]) ++
              shuffled_events (parallel_vm_events (instr_compiler t1) st_pl2)
                (parallel_vm_events (instr_compiler t2) st_pl2);
            st_pl := st_pl2;
            st_store := (fst (range t2), parallel_att_vm_thread (instr_compiler t2) (splitEv s0 st_ev2))
                          :: (fst (range t1), parallel_att_vm_thread (instr_compiler t1) (splitEv s st_ev2)) :: st_store2 |} =
        (Some (parallel_att_vm_thread (instr_compiler t1) (splitEv s st_ev2)), {|
            st_ev := ppc (parallel_att_vm_thread (instr_compiler t1) (splitEv s st_ev2))
                         (parallel_att_vm_thread (instr_compiler t2) (splitEv s0 st_ev2));
            st_stack := st_stack2;
            st_trace := (st_trace2 ++ [Term.split n0 st_pl2]) ++
              shuffled_events (parallel_vm_events (instr_compiler t1) st_pl2)
                (parallel_vm_events (instr_compiler t2) st_pl2);
            st_pl := st_pl2;
            st_store := (fst (range t2), parallel_att_vm_thread (instr_compiler t2) (splitEv s0 st_ev2))
                          :: (fst (range t1), parallel_att_vm_thread (instr_compiler t1) (splitEv s st_ev2)) :: st_store2 |})) as HH.
    {
      simpl.
      unfold bind.
      repeat break_let.
      unfold StVM.st_store in Heqp5.

      assert (
          Maps.map_get
              ((fst (range t2), parallel_att_vm_thread (instr_compiler t2) (splitEv s0 st_ev2))
                 :: (fst (range t1), parallel_att_vm_thread (instr_compiler t1) (splitEv s st_ev2)) :: st_store2) (fst (range t1)) =
          Some (parallel_att_vm_thread (instr_compiler t1) (splitEv s st_ev2))) as HH.
      {
        apply map_get_get_2.
        invc H.
        simpl in *.
        clear Heqp2.
        clear Heqp4.
        clear Heqp3.
        clear Heqp1.
        clear Heqp0.
        clear Heqp5.
        clear Heqp.

        eapply afaf.
        eassumption.
      }

      rewrite HH in Heqp5.
      simpl in Heqp5.
      unfold ret in Heqp5.
      repeat find_inversion.
      eauto.
    }
    rewrite HH in Heqp1. clear HH.
    break_let.

    assert (
        (st <- (fun s : vm_st => (Some s, s));;
             match Maps.map_get (StVM.st_store st) (fst (range t2)) with
             | Some e => ret e
             | None => failm
             end)
              {|
              st_ev := ppc (parallel_att_vm_thread (instr_compiler t1) (splitEv s st_ev2))
                         (parallel_att_vm_thread (instr_compiler t2) (splitEv s0 st_ev2));
              st_stack := st_stack2;
              st_trace := (st_trace2 ++ [Term.split n0 st_pl2]) ++
                          shuffled_events (parallel_vm_events (instr_compiler t1) st_pl2)
                            (parallel_vm_events (instr_compiler t2) st_pl2);
              st_pl := st_pl2;
              st_store := (fst (range t2), parallel_att_vm_thread (instr_compiler t2) (splitEv s0 st_ev2))
                            :: (fst (range t1), parallel_att_vm_thread (instr_compiler t1) (splitEv s st_ev2)) :: st_store2 |} =

        (Some (parallel_att_vm_thread (instr_compiler t2) (splitEv s0 st_ev2)),
          {|
              st_ev := ppc (parallel_att_vm_thread (instr_compiler t1) (splitEv s st_ev2))
                         (parallel_att_vm_thread (instr_compiler t2) (splitEv s0 st_ev2));
              st_stack := st_stack2;
              st_trace := (st_trace2 ++ [Term.split n0 st_pl2]) ++
                          shuffled_events (parallel_vm_events (instr_compiler t1) st_pl2)
                            (parallel_vm_events (instr_compiler t2) st_pl2);
              st_pl := st_pl2;
              st_store := (fst (range t2), parallel_att_vm_thread (instr_compiler t2) (splitEv s0 st_ev2))
                            :: (fst (range t1), parallel_att_vm_thread (instr_compiler t1) (splitEv s st_ev2)) :: st_store2 |})) as HH.
    {
      simpl.
      unfold bind.
      repeat break_let.
      unfold StVM.st_store in Heqp4.

      assert (
          Maps.map_get
              ((fst (range t2), parallel_att_vm_thread (instr_compiler t2) (splitEv s0 st_ev2))
                 :: (fst (range t1), parallel_att_vm_thread (instr_compiler t1) (splitEv s st_ev2)) :: st_store2) (fst (range t2)) =
          Some (parallel_att_vm_thread (instr_compiler t2) (splitEv s0 st_ev2))) as HH.
      {
        simpl.
        Search PeanoNat.Nat.eqb.
        rewrite PeanoNat.Nat.eqb_refl.
        reflexivity.
      }
      rewrite HH in Heqp4.
      simpl in Heqp4.
      unfold ret in Heqp4.
      repeat find_inversion.
      eauto.
    }
    rewrite HH in Heqp2. clear HH.
    repeat find_inversion.
    eauto.
Defined.

(*
Lemma run_vm_iff : forall il st z v,
    (run_vm_fold il) st = (Some z, v) ->
    run_vm il st = run_vm' il st.
 *)

(*
Lemma run_vm_iff_helper : forall t il st,
    il = (instr_compiler t) ->
    exists z v,
      (run_vm_fold il) st = (Some z, v).
*)

Lemma run_vm_iff_compiled : forall il st t t' n,
    il = instr_compiler t ->
    t = snd (anno t' n) ->
    run_vm il st = run_vm' il st.
Proof.
  intros.
  edestruct run_vm_iff_helper.
  eassumption.
  eassumption.
  destruct_conjs.
  eapply run_vm_iff.
  eassumption.
Defined.

Lemma run_vm_iff_compiled_corrolary : forall il st t t',
    il = instr_compiler t ->
    t = annotated t' ->
    run_vm il st = run_vm' il st.
Proof.
  intros.
  eapply run_vm_iff_compiled; eauto.
Defined.

Lemma corr_corr : forall il st t,
  il = instr_compiler (annotated t) ->
  run_vm il st = run_vm' il st.
Proof.
  intros.
  eapply run_vm_iff_compiled_corrolary; eauto.
Defined.

Theorem vm_ordered_alt : forall t tr ev0 ev1 e e' s s' o o' t',
    t = annotated t' ->
    run_vm'
      (instr_compiler t)
      (mk_st e s [] 0 o) =
      (mk_st e' s' tr 0 o') ->
    prec (ev_sys t 0) ev0 ev1 ->
    earlier tr ev0 ev1.
Proof.
  intros.
  eapply vm_ordered; eauto.
  erewrite corr_corr; eauto.
  rewrite H.
  auto.
Defined.


(* Test yet another way of importing heap_lang modules that used to break
printing *)
From iris.heap_lang Require Export lifting notation.
From iris.proofmode Require Import tactics.
From iris.heap_lang Require Import proofmode notation.
Set Default Proof Using "Type".

Section printing_tests.
  Context `{heapG Σ}.

  Lemma wp_print_long_expr (fun1 fun2 fun3 : expr) :
    True -∗ WP let: "val1" := fun1 #() in
       let: "val2" := fun2 "val1" in
       let: "val3" := fun3 "val2" in
       if: "val1" = "val2" then "val" else "val3"  {{ _, True }}.
  Proof.
    iIntros "_". Show.
  Abort.

End printing_tests.


Require Import PerformanceExperiments.Harness.
Require PerformanceExperiments.quadratic_cbv_lazy_PHOAS.
(** https://github.com/coq/coq/issues/11964 *)

Local Infix "/" := Nat.div : nat_scope.

Definition args_of_size (s : size) : list nat
  := match s with
     | Sanity => seq 0 3
     | SuperFast => List.map (fun x => x * 5) (seq 0 (35 / 5))
     | Fast => List.map (fun x => x * 5) (seq 0 (65 / 5))
     | Medium => seq 0 61
     | Slow => []
     | VerySlow => []
     end.

Ltac mkgoal n := quadratic_cbv_lazy_PHOAS.mkgoal n.
Ltac describe_goal n := quadratic_cbv_lazy_PHOAS.describe_goal n.
Ltac redgoal _ := vm_compute.
Ltac time_solve_goal0 n :=
  let term := quadratic_cbv_lazy_PHOAS.get_term () in
  try (once (time "native_compute" (idtac; let res := (eval native_compute in term) in idtac)); fail).
Ltac run0 sz := Harness.runtests args_of_size describe_goal mkgoal redgoal time_solve_goal0 sz.
Set NativeCompute Timing.
(*
Goal True. run0 Fast.
*)


Require Import List.
Import ListNotations.
Require Import StructTact.StructTactics.
Require Import StructTact.Update.

Require Import Chord.Chord.

Require Import Chord.SystemReachable.
Require Import Chord.HandlerLemmas.
Require Import Chord.SystemLemmas.

Set Bullet Behavior "Strict Subproofs".

Definition joined_for_query (q : query) :=
  match q with
  | Join p => false
  | Join2 p => false
  | _ => true
  end.

Theorem cur_request_matches_joined :
  forall gst,
    reachable_st gst ->
    forall h st p q m,
      sigma gst h = Some st ->
      cur_request st = Some (p, q, m) ->
      joined st = joined_for_query q.
Proof.
  induction 1; intros.
  - unfold initial_st in *.
    find_apply_lem_hyp sigma_initial_st_start_handler; eauto.
    subst.
    unfold start_handler in *.
    repeat break_match; simpl in *; try congruence.
    find_inversion. reflexivity.
  - invcs H0; simpl in *; eauto.
    + update_destruct; subst; rewrite_update; simpl in *; eauto.
      find_inversion. simpl in *. find_inversion. reflexivity.
    + update_destruct; subst; rewrite_update; simpl in *; eauto.
      find_inversion.
      repeat (handler_def || handler_simpl).
    + update_destruct; subst; rewrite_update; simpl in *; eauto.
      find_inversion.
      repeat (handler_def || handler_simpl).
Qed.

Theorem cur_request_join_not_joined :
  forall gst,
    reachable_st gst ->
    forall h st p q m,
      sigma gst h = Some st ->
      cur_request st = Some (p, Join q, m) ->
      joined st = false.
Proof.
  eauto using cur_request_matches_joined.
Qed.

Theorem cur_request_join2_not_joined :
  forall gst,
    reachable_st gst ->
    forall h st p q m,
      sigma gst h = Some st ->
      cur_request st = Some (p, Join2 q, m) ->
      joined st = false.
Proof.
  eauto using cur_request_matches_joined.
Qed.

Theorem nodes_not_joined_have_no_successors :
  forall gst,
    reachable_st gst ->
    forall h st,
      sigma gst h = Some st ->
      joined st = false ->
      succ_list st = [].
Proof.
  induction 1; intros.
  - unfold initial_st in *.
    find_apply_lem_hyp sigma_initial_st_start_handler; eauto.
    subst.
    unfold start_handler in *.
    repeat break_match; simpl in *; congruence.
  - invcs H0; simpl in *; eauto.
    + update_destruct; subst; rewrite_update; simpl in *; eauto.
      find_inversion. reflexivity.
    + update_destruct; subst; rewrite_update; simpl in *; eauto.
      find_inversion.
      repeat (handler_def || handler_simpl);
        find_eapply_lem_hyp cur_request_matches_joined; eauto;
          simpl in *; congruence.
    + update_destruct; subst; rewrite_update; simpl in *; eauto.
      find_inversion.
      repeat (handler_def || handler_simpl);
        find_eapply_lem_hyp cur_request_matches_joined; eauto;
          simpl in *; congruence.
(*
Nodes do not set their successor lists until they finish joining. I don't really
know what invariants are needed here but they shouldn't be too complicated?

DIFFICULTY: 2
USED: In phase one
*)
Qed.


Require Import VST.floyd.proofauto.
Require Import VST.progs.libglob.

#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Local Open Scope logic.

(*  The LG module has two global variables of its own:
<<
int LG_n = 3;
struct foo {  int initialized;  int m; } LG_foo = {0};
>>
From the client's point of view, these variables are hidden
away in a separating conjuct of the form [LG.data n gv],
where [LG.data] is the name of the abstraction,
[n] is a client-visible parameter, and [gv] is the
global-variables table.

In Coq, the LG module defines three things:
 - [LG.data], of type [globals -> mpred] (possibly with some other parameters, in this case [n:Z])
 - [initialized_globals : globals -> mpred]
     This definition is supposed to match the extern initialized
     global variables, as processed by CompCert clightgen,
     for the initial state of LG's variables  [LG_n] and [LG_foo].
 - [initial],  which is a lemma showing that the extern
      initialized global variables of the C-language LG module do
      indeed form a legitimate initial state of the [LG.data _ gv]
      abstraction.
*)

Module Type LG_TYPE.
  Parameter data: Z -> globals -> mpred.
  Parameter initialized_globals: globals -> mpred.
  Axiom initial: forall gv,
     initialized_globals gv |-- data 3 gv.
End LG_TYPE.

(* And here is an implementation of the LG module, satisfying
   this module type. *)

Module LG <: LG_TYPE.

(* This is an _internal_ definition, not meant to be mentioned
    in proofs about _clients_ of the LG module.  It describes
    "known to be initialized" global LG data. *)
  Definition data_ok (n: Z) (gv: globals) : mpred :=
  !! (0 <= n <= Int.max_signed) &&
  data_at Ews tint (Vint (Int.repr n)) (gv _LG_n) *
  data_at Ews (Tstruct _foo noattr) (Vint Int.one, Vint (Int.repr n)) (gv _LG_foo).

(* This is an externally visible definition, describing global
    LG data whether initialized or not. *)
Definition data (n: Z) (gv: globals) : mpred :=
  data_ok n gv ||
   (!! (n=3) &&
    data_at Ews tint (Vint (Int.repr n)) (gv _LG_n) *
    data_at Ews (Tstruct _foo noattr) (Vint Int.zero, Vundef) (gv _LG_foo)).

(*  This describes the extern global variables of the LG.c file,
    as they would appear as processed by CompCert and Floyd. *)
Definition initialized_globals (gv: globals) :=
   !! (headptr (gv _LG_n)) &&
   !! (headptr (gv _LG_foo)) &&
   mapsto Ews tuint (offset_val 4 (gv _LG_foo))
          (Vint (Int.repr 0)) *
   data_at Ews tuint (Vint (Int.repr 0)) (gv _LG_foo) *
   data_at Ews tint (Vint (Int.repr 3)) (gv _LG_n).

(*  This lemma packages up the extern global variables of LG.c
   into the client-visible [data] abstraction.  It's a bit clumsy
   and verbose; it would be better to have better proof automation
   support for this kind of thing. *)
Lemma initial:
  forall gv, initialized_globals gv |-- data 3 gv.
Proof.
intros.
unfold initialized_globals, data.
rewrite !data_at_tuint_tint.
entailer!.
apply orp_right2.
cancel.
unfold_data_at (data_at _ (Tstruct _foo _) _ _).
rewrite sepcon_comm.
apply sepcon_derives.
rewrite field_at_data_at.
simpl.
rewrite field_compatible_field_address
  by auto with field_compatible.
simpl.  autorewrite with norm. cancel.
pose (x :=
field_at Ews (Tstruct _foo noattr) [
      StructField _m] (Vint (Int.repr 0)) (gv _LG_foo)).
apply derives_trans with x; subst x.
erewrite <- mapsto_field_at
  by auto with field_compatible.
simpl.
rewrite field_compatible_field_address
  by auto with field_compatible.
simpl. cancel.
cancel.
Qed.

End LG.

(* The [init] function is not meant to be called from clients directly.
    Thus it can use an _internal_ abstraction, LG.data_ok,
    in its specification. *)
Definition init_spec :=
 DECLARE _LG_init
  WITH n: Z, gv: globals
  PRE  []
        PROP ()
        PARAMS () GLOBALS (gv)
        SEP(LG.data n gv)
  POST [ tvoid ]
         PROP()
         RETURN ()
         SEP (LG.data_ok n gv).

(* The [bump] and [get] functions are meant to be called from
    client modules.  *)
Definition bump_spec :=
 DECLARE _LG_bump
  WITH n: Z, gv: globals
  PRE  []
        PROP (n < Int.max_signed)
        PARAMS () GLOBALS (gv)
        SEP(LG.data n gv)
  POST [ tvoid ]
         PROP()
         RETURN ()
         SEP (LG.data (n+1) gv).

Definition get_spec :=
 DECLARE _LG_get
  WITH n: Z, gv: globals
  PRE  []
        PROP ()
        PARAMS () GLOBALS (gv)
        SEP(LG.data n gv)
  POST [ tint ]
         PROP()
         RETURN (Vint (Int.repr n))
         SEP (LG.data n gv).

Definition client_spec :=
 DECLARE _client
  WITH n: Z, gv: globals
  PRE  []
        PROP (n < 1000000000)
        PARAMS () GLOBALS (gv)
        SEP(LG.data n gv)
  POST [ tint ]
         PROP()
         RETURN (Vint (Int.repr (n+2)))
         SEP (LG.data (n+2) gv).

Definition main_spec :=
  DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog tt gv
  POST [ tint ]
     PROP()
     RETURN (Vint (Int.repr 5))
     SEP(TT).

Definition Gprog : funspecs :=
    ltac:(with_library prog [
    init_spec; bump_spec; get_spec; client_spec; main_spec]).

Lemma orp_if_bool:
 forall {A} {NA: NatDed A} (P Q: A),
   orp P Q = EX b: bool, if b then P else Q.
Proof.
intros.
apply pred_ext.
apply orp_left.
Exists true; auto.
Exists false; auto.
Intros b.
destruct b.
apply orp_right1; auto.
apply orp_right2; auto.
Qed.

Lemma body_init:  semax_body Vprog Gprog f_LG_init init_spec.
Proof.
start_function.
unfold LG.data.
unfold LG.data_ok.
rewrite orp_if_bool.
Intros b; destruct b.
*
Intros.
forward.
forward_if (PROP() LOCAL() SEP(LG.data_ok n gv)).
inv H0.
forward.
unfold LG.data_ok.
entailer!.
*
Intros.
forward.
forward_if (PROP() LOCAL() SEP(LG.data_ok n gv)).
forward.
forward.
unfold LG.data_ok.
entailer!!.
forward.
unfold LG.data_ok.
entailer!!.
Qed.

Lemma body_bump:  semax_body Vprog Gprog f_LG_bump bump_spec.
Proof.
start_function.
forward_call (n,gv).
unfold LG.data_ok.
Intros.
forward.
forward.
forward.
forward.
entailer!!.
unfold LG.data.
apply orp_right1.
unfold LG.data_ok.
entailer!.
Qed.

Lemma body_get:  semax_body Vprog Gprog f_LG_get get_spec.
Proof.
start_function.
forward_call (n,gv).
unfold LG.data_ok.
Intros.
forward.
forward_if False.
*
forward.
unfold LG.data.
apply orp_right1.
unfold LG.data_ok.
entailer!!.
*
forward.
forward.
unfold LG.data.
apply orp_right1.
unfold LG.data_ok.
entailer!!.
*
Intros. contradiction.
Qed.

Lemma body_client: semax_body Vprog Gprog f_client client_spec.
Proof.
start_function.
forward_call (n,gv).
forward_call (n+1,gv).
replace (n+1+1) with (n+2) by lia.
forward_call (n+2,gv).
forward.
Qed.

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
start_function.
sep_apply (LG.initial gv); auto.
forward_call (3,gv).
forward.
Qed.


(**
       determinism & progress
       also includes lemmas about Casting & Consistency
*)
Require Import LibTactics.
Require Import Arith Lia.
Require Export KeyProperties.

(***************************** casting ************************************)

#[export] Hint Immediate casting_prv_value : core.

Lemma casting_top_normal : forall (v v': exp),
    casting v t_top v' -> v' = e_top.
Proof.
  intros v v' H.
  inductions H; solve_false; auto.
Qed.

Lemma casting_toplike : forall A v1 v2 v1' v2',
    topLike nil A -> value v1 -> value v2 -> casting v1 A v1' -> casting v2 A v2' -> v1' = v2'.
Proof with (split_unify; solve_false; auto).
  assert (HH: forall v v', value v -> casting v t_top v' -> v' = e_top). {
    intros.
    inductions H0; solve_false; eauto;
    inverts H; forwards*: IHcasting.
  }
  assert (HHarrow: forall v v' A1 A2, value v -> ord (t_arrow A1 A2) ->
                   topLike nil (t_arrow A1 A2) ->
                   casting v (t_arrow A1 A2) v' ->
          v' = (e_anno (e_abs t_top e_top) (t_arrow A1 A2))). {
    intros.
    inductions H2; solve_false; eauto.
  }
  assert (HHforall: forall v v' A1 A2, value v -> ord (t_forall A1 A2) ->
                   topLike nil (t_forall A1 A2) ->
                   casting v (t_forall A1 A2) v' ->
          v' = (e_anno (e_tabs e_top) (t_forall A1 A2))). {
    intros.
    inductions H2; solve_false; eauto.
  }
  assert (HHrcd: forall v v' l A, value v -> ord (t_rcd l A) ->
                   topLike nil (t_rcd l A) ->
                   casting v (t_rcd l A) v' ->
          v' = (e_anno (e_rcd l e_top) (t_rcd l A))). {
    intros.
    inductions H2; solve_false; eauto.
  }
  intros A v1 v2 v1' v2' TL Val1 Val2 Red1 Red2.
  gen v1' v2'.
  proper_ind A; intros;
  try solve [ inverts TL ].
  - inverts TL. inverts H1.
  - forwards*: HH Red1; forwards*: HH Val2 Red2; subst*.
  - forwards*: HHarrow TL Red1.
    forwards*: HHarrow TL Red2.
    congruence.
  - forwards*: HHforall TL Red1.
    forwards*: HHforall TL Red2.
    congruence.
  - forwards*: HHrcd TL Red1.
    forwards*: HHrcd TL Red2.
    congruence.
  - inverts Red1; solve_false; try solve [inverts H1; solve_false].
    inverts Red2; solve_false; try solve [inverts H1; solve_false].
    split_unify.
    forwards*: IHr1 H1 H4.
    forwards*: IHr2 H2 H5.
    congruence.
Qed.

Lemma casting_sub: forall v v' A B,
    value v -> casting v A v' -> pType v B -> TWell nil B -> algo_sub nil B A.
Proof with eauto with common.
  introv Val Red Typ Wf. gen B.
  induction Red; intros; try solve [ inverts Val; inverts Typ; auto_sub; eauto].
Qed.

(**************************** consistency ************************************)

Lemma consistent_symm: forall v1 v2,
    consistent v1 v2 -> consistent v2 v1.
Proof.
  intros. induction H; auto.
  applys* C_disjoint.
Qed.

Lemma consistent_refl: forall v A,
    value v -> Typing nil nil v Inf A -> consistent v v.
Proof with auto.
  intros v A Val Typ. gen A. induction Val;intros;auto.
  -(* top top *)
    apply C_disjoint with t_top t_top...
  - inverts~ Typ.
  - inverts~ Typ.
  - inverts~ Typ.
  - (*merge merge*)
    inverts~ Typ.
    + assert(consistent v1 v1). eauto.
      assert(consistent v2 v2). eauto.
      forwards:typ_value_ptype H1 Val1.
      forwards:typ_value_ptype H4 Val2.
      assert(consistent v1 v2). eauto.
      assert(consistent v2 v1). eauto. auto.
    + assert(consistent v1 v1). eauto.
      assert(consistent v2 v2). eauto.
      forwards: consistent_symm H8. auto.
Qed.

Lemma consistent_mergel: forall v1 v2 v,
    lc_exp v1 -> lc_exp v2 -> consistent (e_merge v1 v2) v -> consistent v1 v /\ consistent v2 v.
Proof.
  intros v1 v2 v Lc1 Lc2 H.
  inductions H.
  -
    inverts H.
    lets* (?&?): disjoint_andl_inv H1.
  - split; eauto.
  - forwards (?&?): IHconsistent1; try reflexivity; auto.
    forwards (?&?): IHconsistent2; try reflexivity; auto.
Qed.

Lemma consistent_merger: forall v1 v2 v,
    lc_exp v1 -> lc_exp v2 -> consistent v (e_merge v1 v2) -> consistent v v1 /\ consistent v v2.
Proof.
  intros v1 v2 v Lc1 Lc2 H.
  inductions H.
  -
    inverts H0.
    lets* (?&?): disjoint_andr_inv H1.
  - forwards (?&?): IHconsistent1; try reflexivity; auto.
    forwards (?&?): IHconsistent2; try reflexivity; auto.
  - split; eauto.
Qed.

(***************************** determinism ************************************)

Lemma consistent_casting_no_ambiguity: forall (v1 v2 v1' v2': exp) (C: typ),
    value v1 -> value v2 ->
    casting v1 C v1' -> casting v2 C v2' ->
    consistent v1 v2 -> v1' = v2'.
Proof with (solve_false; auto).
  introv Val1 Val2 R1 R2 Cons.
  gen v1 v2 v1' v2'. indTypSize (size_typ C).
  lets~ [?|(?&?&?)]: ord_or_split C.
  - inductions Cons.
    + inverts R1; inverts R2...
    + inverts R1; inverts R2...
    + forwards~ S1: casting_sub R1 H.
      forwards~ S2: casting_sub R2 H0.
      apply disjoint_soundness in H1.
      forwards~: H1 S1 S2.
      forwards*: casting_toplike R1 R2.
    + inverts Val1.
      inverts keep R1; try solve [forwards~: casting_toplike R1 R2]; solve_false; auto.
    + inverts Val2.
      inverts keep R2; try solve [forwards~: casting_toplike R1 R2]; solve_false; auto.
  - intros.
  inverts keep R1; try solve [forwards~: casting_toplike R1 R2]; solve_false; auto.
      inverts keep R2; try solve [forwards*: casting_toplike R1 R2]; solve_false; auto.
        split_unify.
        assert (HS: forall A B C, spl A B C -> size_typ B < size_typ A /\ size_typ C < size_typ A). {
          intros. induction H0; simpl; try lia.
          pick fresh x. forwards~: H6 x.
          forwards: size_typ_open_typ_wrt_typ_var C0 x.
          forwards: size_typ_open_typ_wrt_typ_var C2 x.
          forwards: size_typ_open_typ_wrt_typ_var B x.
          elia.
        }
        lets~ (?&?): HS H.
        forwards~: IH H1 H4. lia.
        forwards~: IH H2 H5. lia.
        congruence.
Qed.

Lemma casting_unique: forall v A B v1' v2',
    Typing nil nil v Inf B ->
    value v -> prevalue v -> casting v A v1' -> casting v A v2' -> v1' = v2'.
Proof with (solve_false; auto).
  intros.
  applys* consistent_casting_no_ambiguity.
  applys* consistent_refl.
Qed.

Lemma wrapping_prevalue : forall e A u,
    TWell nil A ->
    wrapping e A u ->
    prevalue u /\
    exists B, pType u B /\
    TWell nil B.
Proof.
  intros. induction* H0.
  forwards*: TWell_spl H0.
  forwards*: IHwrapping1.
  forwards*: IHwrapping2.
Qed.

Lemma wrapping_consistent : forall e A B C u1 u2,
    Typing nil nil e Chk C ->
    TWell nil A ->
    TWell nil B ->
    wrapping e A u1 ->
    wrapping e B u2 ->
    consistent u1 u2.
Proof with eauto 4.
  introv Typ TW1 TW2 cast1 cast2.
  forwards~ (PV1&B1&PT1&?): wrapping_prevalue cast1.
  forwards~ (PV2&B2&PT2&?): wrapping_prevalue cast2.
  inductions cast1.
  - applys C_disjoint t_top...
  - inverts PT1. inductions cast2; applys* C_disjoint.
  - inverts PT1. inductions cast2; applys* C_disjoint.
  - inverts PT1. inductions cast2; applys* C_disjoint.
  - inductions cast2.
    + applys C_disjoint B1 t_top...
    + applys C_disjoint B1 (t_arrow A1 A2)...
    + applys C_disjoint B1 (t_forall A1 A2)...
    + applys C_disjoint B1 (t_rcd l A0)...
    + applys C_anno...
    + forwards: prevalue_merge_l_inv PV2.
      forwards: prevalue_merge_r_inv PV2.
      inverts PT2.
      forwards~: IHcast2_1 H9.
      forwards~: IHcast2_2 H11.
  - forwards: prevalue_merge_l_inv PV1.
    forwards: prevalue_merge_r_inv PV1.
    inverts PT1.
    forwards*: IHcast1_1.
Qed.

Lemma wrapping_unique : forall e A C u1 u2,
    Typing nil nil e Chk C ->
    wrapping e A u1 ->
    wrapping e A u2 ->
    u1 = u2.
Proof with eauto; solve_false.
  introv Typ cast1 cast2. gen e u1 u2.
  indTypSize (size_typ A).
  inverts cast1; inverts cast2...
  - split_unify.
    forwards*: IH H0 H3; elia.
    forwards*: IH H1 H4; elia.
    congruence.
Qed.

Ltac papp_unify :=
  repeat match goal with
  | H: papp (e_anno (e_rcd _ _) _) (arg_la _) _ |- _ => inverts H
  | H: papp (e_anno (e_abs _ _) _) (arg_exp _) _ |- _ => inverts H
  | H: papp (e_anno (e_tabs _ _) _) (arg_typ _) _ |- _ => inverts H
         end; subst.

Ltac auto_unify := try binds_unify; typing_unify; split_unify; appdist_unify; papp_unify; ptype_unify.

Lemma papp_unique: forall v e e1 e2 A,
    value v -> Typing nil nil (e_app v e) Inf A ->
    papp v (arg_exp e) e1 ->
    papp v (arg_exp e) e2 ->
    e1 = e2.
Proof with eauto.
  intros v e e1 e2 A Val Typ P1 P2.
  gen e2 A.
  inductions P1; intros; inverts* P2.
  - inverts Val.
    inverts Typ.
    forwards*: wrapping_unique H1 H9.
    forwards* (_&?): appDist_arrow_unique H0 H8.
    substs~.
  - inverts Typ.
    inverts H2.
    + inverts H6.
      forwards*: Typing_chk_inter_inv H7.
      forwards*: IHP1_1.
      forwards*: IHP1_2.
      congruence.
    + inverts H6.
      forwards*: Typing_chk_inter_inv H7.
      forwards*: IHP1_1.
      forwards*: IHP1_2.
      congruence.
Qed.

Lemma papp_unique2: forall v1 la e1 e2 A,
    value v1 -> Typing nil nil (e_proj v1 la) Inf A -> papp v1 (arg_la la) e1 -> papp v1 (arg_la la) e2 -> e1 = e2.
Proof with eauto.
  intros v1 la e1 e2 A Val1 Typ P1 P2. gen e2 A.
  inductions P1; intros; inverts* P2.
  - inverts Val1.
    inverts Typ.
    inverts H10.
      inverts H9.
      forwards*: appDist_rcd_unique H0 H6.
      congruence.
      forwards*: appDist_rcd_unique H0 H6.
      congruence.
  - inverts Typ.
    inverts H5.
      inversion H6;subst.
      inverts H6.
      forwards*: Typ_proj H5.
      forwards*: IHP1_1 H1.
      forwards*: Typ_proj H10.
      forwards*: IHP1_2 H4.
      subst*.

      inversion H6;subst.
      inverts H6.
      forwards*: Typ_proj H9.
      forwards*: IHP1_1 H1.
      forwards*: Typ_proj H13.
      forwards*: IHP1_2 H4.
      subst*.
Qed.

Lemma papp_unique3: forall v1 e1 e2 A T,
    value v1 -> Typing nil nil (e_tapp v1 T) Inf A -> papp v1 (arg_typ T) e1 -> papp v1 (arg_typ T) e2 -> e1 = e2.
Proof with eauto.
  introv Val1 Typ P1 P2. gen e2 A.
  inductions P1; intros; inverts* P2.
  inverts Val1.
  inverts Typ.
  inverts H9.
    forwards* (_&?): appDist_forall_unique H1 H8.
    congruence.

  inverts Typ.
  inverts H6.

    inverts H2.
    forwards*: IHP1_1.
    forwards*: IHP1_2.
    congruence.
    forwards*: IHP1_1.
    forwards*: IHP1_2.
    congruence.

  inverts H2.
Qed.

Theorem step_unique: forall A (e e1 e2 : exp),
    Typing nil nil e Inf A -> step e e1 -> step e e2 -> e1 = e2.
Proof with intuition eauto.
  introv Typ Red1.
  gen A e2.
  lets Red1' : Red1.
  induction Red1;
    introv Typ Red2.
  - (* papp*)
    inverts* Red2.
    + forwards*: papp_unique H0 H5.
    + forwards*: step_not_value H5...
  - (* proj*)
    inverts* Red2.
    + forwards*: papp_unique2 H0 H5.
    + forwards*: step_not_value H4...
  - (* tapp*)
    inverts* Red2.
    + forwards*: papp_unique3 H0 H5.
    + forwards*: step_not_value H5...
  - (* annov*)
    inverts* Red2.
    + (* annov*)
      inverts* Typ.
      forwards* (N&Ty&S): Typing_chk2inf H8.
      forwards*: casting_unique H1 H7.
    + (* anno*)
      forwards*: step_not_value H6...
  - (* appl*)
    inverts Red2;
      try solve [forwards*: step_not_value Red1; intuition eauto].
    + (* appl*)
      inverts Typ.
      forwards: IHRed1...
      congruence.
  - (* merge*)
    inverts Typ;
      inverts* Red2;
      try solve [forwards*: step_not_value Red1_2; intuition eauto];
      try solve [forwards*: step_not_value Red1_1; intuition eauto];
      forwards*: IHRed1_1;
      forwards*: IHRed1_2;
      subst*...
  - (* mergel*)
    inverts* Red2;
      try solve [forwards*: step_not_value H4; intuition eauto].
    + (* mergel*)
      inverts* Typ;
        forwards*: IHRed1; intuition eauto;
        congruence.
  - (* merger*)
    inverts* Red2;
      try solve [forwards*: step_not_value H2; intuition eauto].
    + (* mergel*)
      forwards*: step_not_value H4...
    + (* merger*)
      inverts* Typ;
        forwards*: IHRed1; intuition eauto;
        congruence.
  - (* anno*)
    inverts* Red2;
      inverts* Typ;
      try solve [inverts* Red1; intuition eauto];
      try solve [lets*: step_not_value Red1; intuition eauto].

      inductions H5; solve_false.
      forwards*: IHTyping1. congruence.
    forwards*: IHRed1.
    congruence.
  - (* fix*)
    inverts* Red2.
  - (* rcd*)
    inverts* Typ. inverts* Red2.
    forwards*: step_not_value H1 Red1...
    forwards*: IHRed1... congruence.
  - (* proj*)
    inverts* Typ. inverts* Red2; try solve [forwards*: step_not_value Red1; intuition eauto]. forwards*: IHRed1. congruence.
  Unshelve.
  1,3,5: apply nil. 1,2,3: pick_fresh x; apply x.
Qed.

(***************************** progress ***************************************)

Lemma casting_progress: forall v A,
    value v -> prevalue v -> Typing nil nil v Chk A -> exists v', casting v A v'.
Proof with eauto 4.
  intros v A Val PV TypC.
  lets* (B&Typ&Sub): Typing_chk2inf TypC. clear TypC. gen v.
  inductions Sub; intros;
    try solve [inverts Typ; inverts Val; exists~].
  - inverts H0. inverts H3.
  - inverts Typ; solve_false...
    inverts Val; inverts H0; inverts H1.
  - inductions Typ; inverts Val...
    + inverts* H1; solve_false.
    + inverts* H1; solve_false.
    + inverts* H1; solve_false.
    + inverts H1; eauto 4; solve_false; exists*.
    + inverts H1; eauto 4; solve_false; exists*.
    + inverts H1; eauto 4; solve_false; exists*.
    + forwards* (?&?): IHTyp1.
  - inverts Typ; inverts~ Val; inverts H2; inverts H3.
  - inverts Typ; inverts Val...
    + forwards* (?&?): IHSub H3.
    + assert (topLike nil C \/ ~topLike nil C).
      applys toplike_decidable.
      destruct H2.
      inverts H2; try solve [ solve_false | exists* ].
      exists*.
    + assert (topLike nil C \/ ~topLike nil C).
      applys toplike_decidable.
      destruct H2.
      inverts H2; try solve [ solve_false | exists* ].
      exists*.
    + assert (topLike nil C \/ ~topLike nil C).
      applys toplike_decidable.
      destruct H2.
      inverts H2; try solve [ solve_false | exists* ].
      exists*.
    + forwards*: IHSub H6.
  - inverts Typ; inverts Val...
    + forwards* (?&?): IHSub H7.
    + assert (topLike nil C \/ ~topLike nil C).
      applys toplike_decidable.
      destruct H2.
      inverts H2; try solve [ solve_false | exists* ].
      exists*.
    + assert (topLike nil C \/ ~topLike nil C).
      applys toplike_decidable.
      destruct H2.
      inverts H2; try solve [ solve_false | exists* ].
      exists*.
    + assert (topLike nil C \/ ~topLike nil C).
      applys toplike_decidable.
      destruct H2.
      inverts H2; try solve [ solve_false | exists* ].
      exists*.
    + forwards*: IHSub H10.
  - assert(topLike nil (t_arrow A2 B2)\/~topLike nil (t_arrow A2 B2)).
    apply toplike_decidable. destruct H0.
    exists*. inverts Typ; solve_false.
    exists (e_anno e (t_arrow A2 B2)).
    assert (nil ||- (t_arrow A1 B1) <: (t_arrow A2 B2)) by eauto.
    applys Cast_anno...
    forwards~: Typing_regular_1 H1.
  - assert(topLike nil (t_forall B1 B2)\/~topLike nil (t_forall B1 B2)).
    apply toplike_decidable. destruct H2.
    exists*. inverts Typ; solve_false.
    exists (e_anno e (t_forall B1 B2)).
    assert (nil ||- (t_forall A1 A2) <: (t_forall B1 B2)) by eauto.
    applys Cast_anno...
    forwards~: Typing_regular_1 H3.
  - assert(topLike nil (t_rcd l B)\/~topLike nil (t_rcd l B)).
    apply toplike_decidable. destruct H0.
    exists*. inverts Typ; solve_false.
    exists (e_anno e (t_rcd l B)).
    assert (nil ||- (t_rcd l A) <: (t_rcd l B)) by eauto.
    applys Cast_anno...
    forwards~: Typing_regular_1 H1.
  - forwards* (?&?): IHSub1 Typ.
    forwards* (?&?): IHSub2 Typ.
Qed.

Lemma casting_progress_1: forall v A' A,
    value v ->
    Typing nil nil v Inf A' ->
    Typing nil nil v Chk A ->
    exists v', casting v A v'.
Proof.
  intros. forwards*: value_inf_prevalue.
  applys~ casting_progress.
Qed.

Lemma wrapping_progress: forall e A B,
    Typing nil nil e Chk A ->
    TWell nil B ->
    exists e', wrapping e B e'.
Proof with eauto 4 using Typing_regular_1, TWell_lc_typ.
  intros.
  forwards: Typing_regular_1 H.
  forwards: TWell_lc_typ H0.
  proper_ind B;
  eauto 4 using Typing_regular_1;
                try solve [ exists;
                            constructor*;
                            constructor*;
                            intros contra; solve_false].
  + inverts H0. inverts H5.
  + assert (TL: topLike nil (t_arrow A0 B) \/ ~topLike nil (t_arrow A0 B))
        by applys toplike_decidable.
      destruct TL.
      * exists. applys EW_topArrow...
      * exists. applys EW_anno...
  + assert (TL: topLike nil (t_forall A0 B) \/ ~topLike nil (t_forall A0 B))
      by applys toplike_decidable.
    destruct TL.
    * exists. applys EW_topAll...
    * exists. applys EW_anno...
  + assert (TL: topLike nil (t_rcd l A0) \/ ~topLike nil (t_rcd l A0))
      by applys toplike_decidable.
    destruct TL.
    * exists. applys EW_topRcd...
    * exists. applys EW_anno...
  + forwards~ (?&?): IHr1.
    forwards~ (?&?): IHr2.
    exists. applys EW_and...
Qed.

Lemma TWell_checked_abs : forall D G A e T,
    Typing D G (e_abs A e) Chk T ->
    TWell D A.
Proof.
  intros. inductions H; eauto.
Qed.

Lemma papp_progress: forall v e A,
    value v -> Typing nil nil (e_app v e) Inf A -> exists e', papp v (arg_exp e) e'.
Proof with eauto using Typing_regular_1.
  intros v e A Val Typ. gen A.
  induction Val; intros.
  - inverts Typ. inverts H1. inverts H4.
  - inverts Typ. inverts H1. inverts H4.
  - inverts Typ. inverts H4.
    inverts H7.
    inverts H6.
    forwards: TWell_checked_abs H11.
    forwards (e'&CE): wrapping_progress A H8...
    forwards (e'&CE): wrapping_progress A H8...
    forwards (e'&CE): wrapping_progress A H8...
    forwards~: TWell_checked_abs H6.
  - inverts Typ. inverts H3.
  - inverts Typ. inverts H3.
    forwards: Typing_chk_appDist H5 H6.
    inverts H1; solve_false.
  - inverts Typ. inverts H2.
  - inverts Typ. inverts H3.
    forwards: Typing_chk_appDist H5 H6.
    inverts H1; solve_false.
  - inverts Typ. inverts H2.
  - inverts Typ.
    inverts H1.
    + inverts H4.
      forwards: Typing_chk_inter_inv H5.
      forwards*: IHVal1.
      forwards*: IHVal2.
    + inverts H4.
      forwards: Typing_chk_inter_inv H5.
      forwards*: IHVal1.
      forwards*: IHVal2.
Qed.

Lemma papp_progress2: forall v1 la A,
    value v1 -> Typing nil nil (e_proj v1 la) Inf A -> exists e, papp v1 (arg_la la) e.
Proof with eauto.
  intros v1 la A Val1 Typ. gen A.
  induction Val1; intros;
    try solve [exists*].
  - inverts Typ. inverts H3. inverts H4.
  - inverts Typ. inverts H3. inverts H4.
  - inverts Typ.
    inverts H6.
    forwards: Typing_chk_appDist H5 H7.
    inverts H2; solve_false.
  - inverts Typ.
    inverts H5.
  - inverts Typ. inverts H5.
    forwards: Typing_chk_appDist H4 H6.
    inverts H1; solve_false.
  - inverts Typ. inverts H4.
  - inverts Typ. inverts H5.
    forwards: Typing_chk_appDist H4 H6.
    inverts H1; solve_false.
    exists*.
  - inverts Typ. inverts H4.
  - inverts Typ.
    inverts H3; inverts H4...
    + lets*: Typ_proj v1 la H3.
      lets*: Typ_proj v2 la H8.
      forwards* (?&?): IHVal1_1.
      forwards* (?&?): IHVal1_2.
    + lets*: Typ_proj v1 la H7.
      lets*: Typ_proj v2 la H11.
      forwards* (?&?): IHVal1_1.
      forwards* (?&?): IHVal1_2.
Qed.

Lemma papp_progress3: forall v1 A B,
    value v1 -> Typing nil nil (e_tapp v1 A) Inf B -> exists e, papp v1 (arg_typ A) e.
Proof with eauto.
  introv Val1 Typ. gen B.
  induction Val1; intros;
  forwards Lc : Typing_regular_1 Typ;
  inverts Lc.
  - inverts Typ. inverts H3. inverts H6.
  - inverts Typ. inverts H3. inverts H6.
  - inverts Typ. inverts H6.
    forwards: Typing_chk_appDist H8 H9.
    inverts H2; solve_false.
  - inverts Typ. inverts H5.
  - inverts Typ. inverts H5.
    exists*.
  - inverts Typ. inverts H4.
  - inverts Typ. inverts H5.
    forwards: Typing_chk_appDist H7 H8.
    inverts H1; solve_false.
  - inverts Typ. inverts H4.
  - inverts Typ.
    forwards (_&?): disjoint_regular H7.
    inverts H3; inverts H6...
    + inversion H;subst.
      forwards (?&?): disjoint_andr_inv B1 B2 H7.
      constructor; inverts H...
      forwards: Typ_tapp v1 A...
      forwards: Typ_tapp v2 A...
      forwards (?&?): IHVal1_1...
      forwards (?&?): IHVal1_2...
    + inversion H;subst.
      forwards (?&?): disjoint_andr_inv B1 B2 H7.
      constructor; inverts H...
      forwards: Typ_tapp v1 A...
      forwards: Typ_tapp v2 A...
      forwards (?&?): IHVal1_1...
      forwards (?&?): IHVal1_2...
Qed.

Theorem progress : forall dir e A,
    Typing nil nil e dir A ->
    value e \/ exists e', step e e'.
Proof with auto.
  introv Typ. lets Typ': Typ.
  inductions Typ; eauto;
    lets Lc: Typing_regular_1 Typ'.
  - (* var *)
    invert H1.
  - left...
  - (* app *)
    inverts Lc.
    right.
    destruct~ IHTyp1 as [Val1 | [e1' Red1] ]...
    elia.
    + (* v1 v2 *)
      forwards (?&?): papp_progress Val1 Typ'.
      exists. applys Step_papp H0...
    + exists*.
  - left...
  - (* tabs *)
    inverts Lc.
    right.
    destruct~ IHTyp as [Val1 | [e1' Red1] ].
    elia.
    + forwards* (?&?): papp_progress3 Val1 Typ'.
    + exists*.
  - (* proj *)
    inverts Lc.
    right.
    destruct~ IHTyp as [ Val1 | [t1' Red1] ].
    elia.
    + forwards* (?&?): papp_progress2 Val1 Typ'.
    + exists*.
  - left...
  - (* merge *)
    inverts Lc.
    destruct~ IHTyp1 as [ Val1 | [t1' Red1] ];
      destruct~ IHTyp2 as [ Val2 | [t2' Red2] ];
      subst; elia.
    + (* e_merge v1 e2 *)
      inverts* Typ1.
    + (* e_merge e1 v2 *)
      inverts* Typ2.
    + (* e_merge e1 e2 *)
      inverts* Typ2.
  - (* anno *)
    inductions Typ.
    + left...
    + left...
    + left...
    + forwards~: IHTyp1.
      forwards~: IHTyp2.
      destruct H. inverts H; left...
      destruct H0. inverts H0; left...
      destruct_conj.
      right...
      inverts keep H; inverts keep H0; exists*.
    + inverts Typ'.
      forwards*: IHTyp0.
      destruct H0.
      forwards*: value_inf_prevalue.
        forwards*: casting_progress H3.
        right. destruct H0. exists (e_anno x B)...
  - (* fixpoint *)
    right. eauto.
  - (* mergev *)
    destruct~ IHTyp1 as [ Val1 | [t1' Red1] ];
      destruct~ IHTyp2 as [ Val2 | [t2' Red2] ];
      subst; elia.
    + (* e_merge v1 e2 *)
      inverts* Typ1.
    + (* e_merge e1 v2 *)
      inverts* Typ2.
    + (* e_merge e1 e2 *)
      inverts* Typ2.
Qed.


Require Import ConcreteEvidence. (* Term GenStMonad MonadVM MonadAM. *)

Require Import Appraisal_Defs.  (* Require Import Impl_vm StAM. *)

Require Import List.
Import ListNotations.

Fixpoint build_app_comp_evC (e:EvidenceC) : EvidenceC :=
  match e with
  | mtc => mtc

  | uuc params p bs e' =>
    uuc params p (checkASPF params bs)
        (build_app_comp_evC e')
  | ggc p bs e' =>
    ggc p (checkSigF e' p bs)
        (build_app_comp_evC e')
  | hhc p bs et =>
    hhc p (checkHashF et p bs)(*(fromSome 0 (checkHash et p bs))*) et
  | nnc nid bs =>
    nnc nid (checkNonceF nid bs)
  | ssc e1 e2 =>
    ssc (build_app_comp_evC e1) (build_app_comp_evC e2)
  | ppc e1 e2 =>
    ppc (build_app_comp_evC e1) (build_app_comp_evC e2)
  end.

(*
(* *** Extra AM Monad defs *** *)

Definition am_add_trace (tr':list Ev) : AM_St -> AM_St :=
  fun '{| am_nonceMap := nm;
        am_nonceId := ni;
        st_aspmap := amap;
        st_sigmap := smap;
        st_hshmap := hmap;
        am_st_trace := tr;
        checked := cs |} =>
    mkAM_St nm ni amap smap hmap (tr ++ tr') cs.

Definition am_add_tracem (tr:list Ev) : AM unit :=
  modify (am_add_trace tr).

Definition am_run_cvm (annt:AnnoTerm) (e:EvidenceC) (et:Evidence) : AM EvidenceC :=
  let start_st := (mk_st e et [] 0) in
  let end_st := (run_cvm annt start_st) in
  am_add_tracem (st_trace end_st) ;;
  ret (st_ev end_st).

Definition am_run_cvm_comp{A:Type} (comp:CVM A) : AM A :=
  let '(cvm_res, vmst') := (runSt comp empty_vmst) in
  match cvm_res with
  | Some v =>
    am_add_tracem (st_trace vmst') ;;
    ret v
  | _ => failm
  end.

Require Import Maps.

Definition am_get_hsh_gv (p:Plc) (i:ASP_ID) : AM BS :=
  m <- gets st_hshmap ;;
  let maybeId := map_get m (p,i) in
  match maybeId with
  | Some i' => ret i'
  | None => failm
  end.

Definition am_get_hsh_golden_val (p:Plc) (et:Evidence): AM BS :=
  (*
    m <- gets st_aspmap ;;
    let maybeId := map_get m (p,i) in
    match maybeId with
    | Some i' => ret i'
    | None => failm
    end.
   *)
  ret 0.

Definition am_check_hsh_eq (gv:BS) (actual:BS) : AM BS :=
  ret 1.
*)