(*

  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.


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.