Require Import GhostSimulations.
Require Import Raft.

Require Import RaftRefinementInterface.

Section RaftMsgRefinementInterface.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition ghost_log : Type := list entry.

  Lemma ghost_log_eq_dec : forall x y : ghost_log, {x = y} + {x <> y}.
  Proof using.
    decide equality.
    apply entry_eq_dec.
  Qed.

  Definition write_ghost_log (h : name) (st : @data raft_refined_base_params) : ghost_log := log (snd st).

  Instance ghost_log_params : MsgGhostFailureParams raft_refined_failure_params :=
    {| ghost_msg := ghost_log ;
       ghost_msg_eq_dec := ghost_log_eq_dec ;
       ghost_msg_default := [] ;
       write_ghost_msg := write_ghost_log
    |}.

  Definition raft_msg_refined_base_params := mgv_refined_base_params.
  Definition raft_msg_refined_multi_params := mgv_refined_multi_params.
  Definition raft_msg_refined_failure_params := mgv_refined_failure_params.

  Hint Extern 3 (@BaseParams) => apply raft_msg_refined_base_params : typeclass_instances.
  Hint Extern 3 (@MultiParams _) => apply raft_msg_refined_multi_params : typeclass_instances.
  Hint Extern 3 (@FailureParams _ _) => apply raft_msg_refined_failure_params : typeclass_instances.

  Inductive msg_refined_raft_intermediate_reachable : network -> Prop :=
  | MRRIR_init : msg_refined_raft_intermediate_reachable step_m_init
  | MRRIR_step_f :
      forall failed net failed' net' out,
        msg_refined_raft_intermediate_reachable net ->
        step_f (failed, net) (failed', net') out ->
        msg_refined_raft_intermediate_reachable net'
  | MRRIR_handleInput :
      forall net h inp gd out d l ps' st',
        msg_refined_raft_intermediate_reachable net ->
        handleInput h inp (snd (nwState net h)) = (out, d, l) ->
        update_elections_data_input h inp (nwState net h) = gd ->
        (forall h', st' h' = update (nwState net) h (gd, d) h') ->
        (forall p', In p' ps' -> In p' (nwPackets net) \/
                           In p' (send_packets h (add_ghost_msg h (gd, d) l))) ->
        msg_refined_raft_intermediate_reachable (mkNetwork ps' st')
  | MRRIR_handleMessage :
      forall p net xs ys st' ps' gd d l,
        msg_refined_raft_intermediate_reachable net ->
        handleMessage (pSrc p) (pDst p) (snd (pBody p)) (snd (nwState net (pDst p))) = (d, l) ->
        update_elections_data_net (pDst p) (pSrc p) (snd (pBody p)) (nwState net (pDst p)) = gd ->
        nwPackets net = xs ++ p :: ys ->
        (forall h, st' h = update (nwState net) (pDst p) (gd, d) h) ->
        (forall p', In p' ps' -> In p' (xs ++ ys) \/
                           In p' (send_packets (pDst p) (@add_ghost_msg _ _ _ ghost_log_params (pDst p) (gd, d) l))) ->
        msg_refined_raft_intermediate_reachable (mkNetwork ps' st')
  | MRRIR_doLeader :
      forall net st' ps' h os gd d d' ms,
        msg_refined_raft_intermediate_reachable net ->
        doLeader d h = (os, d', ms) ->
        nwState net h = (gd, d) ->
        (forall h', st' h' = update (nwState net) h (gd, d') h') ->
        (forall p, In p ps' -> In p (nwPackets net) \/
                         In p (send_packets h (add_ghost_msg h (gd, d') ms))) ->
        msg_refined_raft_intermediate_reachable (mkNetwork ps' st')
  | MRRIR_doGenericServer :
      forall net st' ps' os gd d d' ms h,
        msg_refined_raft_intermediate_reachable net ->
        doGenericServer h d = (os, d', ms) ->
        nwState net h = (gd, d) ->
        (forall h', st' h' = update (nwState net) h (gd, d') h') ->
        (forall p, In p ps' -> In p (nwPackets net) \/
                         In p (send_packets h (add_ghost_msg h (gd, d') ms))) ->
        msg_refined_raft_intermediate_reachable (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_client_request (P : network -> Prop) :=
    forall h net st' ps' gd out d l client id c,
      handleClientRequest h (snd (nwState net h)) client id c = (out, d, l) ->
      gd = update_elections_data_client_request h (nwState net h) client id c ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      (forall h', st' h' = update (nwState net) h (gd, d) h') ->
      (forall p', In p' ps' -> In p' (nwPackets net) \/
                         In p' (send_packets h (add_ghost_msg h (gd, d) l))) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_timeout (P : network -> Prop) :=
    forall net h st' ps' gd out d l,
      handleTimeout h (snd (nwState net h)) = (out, d, l) ->
      gd = update_elections_data_timeout h (nwState net h) ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      (forall h', st' h' = update (nwState net) h (gd, d) h') ->
      (forall p', In p' ps' -> In p' (nwPackets net) \/
                               In p' (send_packets h (add_ghost_msg h (gd, d) l))) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_append_entries (P : network -> Prop) :=
    forall xs p ys net st' ps' gd d m t n pli plt es ci,
      handleAppendEntries (pDst p) (snd (nwState net (pDst p))) t n pli plt es ci = (d, m) ->
      gd = update_elections_data_appendEntries (pDst p) (nwState net (pDst p)) t n pli plt es ci ->
      snd (pBody p) = AppendEntries t n pli plt es ci ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      nwPackets net = xs ++ p :: ys ->
      (forall h, st' h = update (nwState net) (pDst p) (gd, d) h) ->
      (forall p', In p' ps' -> In p' (xs ++ ys) \/
                         p' = mkPacket (pDst p) (pSrc p) (write_ghost_log (pDst p) (gd, d), m)) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_append_entries_reply (P : network -> Prop) :=
    forall xs p ys net st' ps' gd d m t es res,
      handleAppendEntriesReply (pDst p) (snd (nwState net (pDst p))) (pSrc p) t es res = (d, m) ->
      gd = (fst (nwState net (pDst p))) ->
      snd (pBody p) = AppendEntriesReply t es res ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      nwPackets net = xs ++ p :: ys ->
      (forall h, st' h = update (nwState net) (pDst p) (gd, d) h) ->
      (forall p', In p' ps' -> In p' (xs ++ ys) \/
                         In p' (send_packets (pDst p) (@add_ghost_msg _ _ _ ghost_log_params (pDst p) (gd, d) m))) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_request_vote (P : network -> Prop) :=
    forall xs p ys net st' ps' gd d m t cid lli llt,
      handleRequestVote (pDst p) (snd (nwState net (pDst p))) t (pSrc p) lli llt  = (d, m) ->
      gd = update_elections_data_requestVote (pDst p) (pSrc p) t (pSrc p) lli llt (nwState net (pDst p)) ->
      snd (pBody p) = RequestVote t cid lli llt ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      nwPackets net = xs ++ p :: ys ->
      (forall h, st' h = update (nwState net) (pDst p) (gd, d) h) ->
      (forall p', In p' ps' -> In p' (xs ++ ys) \/
                         p' = mkPacket (pDst p) (pSrc p) (write_ghost_log (pDst p) (gd, d), m)) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_request_vote_reply (P : network -> Prop) :=
    forall xs p ys net st' ps' gd d t v,
      handleRequestVoteReply (pDst p) (snd (nwState net (pDst p))) (pSrc p) t v = d ->
      gd = update_elections_data_requestVoteReply (pDst p) (pSrc p) t v (nwState net (pDst p)) ->
      snd (pBody p) = RequestVoteReply t v ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      nwPackets net = xs ++ p :: ys ->
      (forall h, st' h = update (nwState net) (pDst p) (gd, d) h) ->
      (forall p', In p' ps' -> In p' (xs ++ ys)) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_do_leader (P : network -> Prop) :=
    forall net st' ps' gd d h os d' ms,
      doLeader d h = (os, d', ms) ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      nwState net h = (gd, d) ->
      (forall h', st' h' = update (nwState net) h (gd, d') h') ->
      (forall p, In p ps' -> In p (nwPackets net) \/
                             In p (send_packets h (add_ghost_msg h (gd, d') ms))) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_do_generic_server (P : network -> Prop) :=
    forall net st' ps' gd d os d' ms h,
      doGenericServer h d = (os, d', ms) ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      nwState net h = (gd, d) ->
      (forall h', st' h' = update (nwState net) h (gd, d') h') ->
      (forall p, In p ps' -> In p (nwPackets net) \/
                             In p (send_packets h (add_ghost_msg h (gd, d') ms))) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_state_same_packet_subset (P : network -> Prop) :=
    forall net net',
      (forall h, nwState net h = nwState net' h) ->
      (forall p, In p (nwPackets net') -> In p (nwPackets net)) ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      P net'.

  Definition msg_refined_raft_net_invariant_reboot (P : network -> Prop) :=
    forall net net' gd d h d',
      reboot d = d' ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      nwState net h = (gd, d) ->
      (forall h', nwState net' h' = update (nwState net) h (gd, d') h') ->
      nwPackets net = nwPackets net' ->
      P net'.

  Definition msg_refined_raft_net_invariant_init (P : network -> Prop) :=
    P step_m_init.

  Definition msg_refined_raft_net_invariant_client_request' (P : network -> Prop) :=
    forall h net st' ps' gd out d l client id c,
      handleClientRequest h (snd (nwState net h)) client id c = (out, d, l) ->
      gd = update_elections_data_client_request h (nwState net h) client id c ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      msg_refined_raft_intermediate_reachable (mkNetwork ps' st') ->
      (forall h', st' h' = update (nwState net) h (gd, d) h') ->
      (forall p', In p' ps' -> In p' (nwPackets net) \/
                         In p' (send_packets h (add_ghost_msg h (gd, d) l))) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_timeout' (P : network -> Prop) :=
    forall net h st' ps' gd out d l,
      handleTimeout h (snd (nwState net h)) = (out, d, l) ->
      gd = update_elections_data_timeout h (nwState net h) ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      msg_refined_raft_intermediate_reachable (mkNetwork ps' st') ->
      (forall h', st' h' = update (nwState net) h (gd, d) h') ->
      (forall p', In p' ps' -> In p' (nwPackets net) \/
                               In p' (send_packets h (add_ghost_msg h (gd, d) l))) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_append_entries' (P : network -> Prop) :=
    forall xs p ys net st' ps' gd d m t n pli plt es ci,
      handleAppendEntries (pDst p) (snd (nwState net (pDst p))) t n pli plt es ci = (d, m) ->
      gd = update_elections_data_appendEntries (pDst p) (nwState net (pDst p)) t n pli plt es ci ->
      snd (pBody p) = AppendEntries t n pli plt es ci ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      msg_refined_raft_intermediate_reachable (mkNetwork ps' st') ->
      nwPackets net = xs ++ p :: ys ->
      (forall h, st' h = update (nwState net) (pDst p) (gd, d) h) ->
      (forall p', In p' ps' -> In p' (xs ++ ys) \/
                         p' = mkPacket (pDst p) (pSrc p) (write_ghost_log (pDst p) (gd, d), m)) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_append_entries_reply' (P : network -> Prop) :=
    forall xs p ys net st' ps' gd d m t es res,
      handleAppendEntriesReply (pDst p) (snd (nwState net (pDst p))) (pSrc p) t es res = (d, m) ->
      gd = (fst (nwState net (pDst p))) ->
      snd (pBody p) = AppendEntriesReply t es res ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      msg_refined_raft_intermediate_reachable (mkNetwork ps' st') ->
      nwPackets net = xs ++ p :: ys ->
      (forall h, st' h = update (nwState net) (pDst p) (gd, d) h) ->
      (forall p', In p' ps' -> In p' (xs ++ ys) \/
                         In p' (send_packets (pDst p) (@add_ghost_msg _ _ _ ghost_log_params (pDst p) (gd, d) m))) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_request_vote' (P : network -> Prop) :=
    forall xs p ys net st' ps' gd d m t cid lli llt,
      handleRequestVote (pDst p) (snd (nwState net (pDst p))) t (pSrc p) lli llt  = (d, m) ->
      gd = update_elections_data_requestVote (pDst p) (pSrc p) t (pSrc p) lli llt (nwState net (pDst p)) ->
      snd (pBody p) = RequestVote t cid lli llt ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      msg_refined_raft_intermediate_reachable (mkNetwork ps' st') ->
      nwPackets net = xs ++ p :: ys ->
      (forall h, st' h = update (nwState net) (pDst p) (gd, d) h) ->
      (forall p', In p' ps' -> In p' (xs ++ ys) \/
                         p' = mkPacket (pDst p) (pSrc p) (write_ghost_log (pDst p) (gd, d), m)) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_request_vote_reply' (P : network -> Prop) :=
    forall xs p ys net st' ps' gd d t v,
      handleRequestVoteReply (pDst p) (snd (nwState net (pDst p))) (pSrc p) t v = d ->
      gd = update_elections_data_requestVoteReply (pDst p) (pSrc p) t v (nwState net (pDst p)) ->
      snd (pBody p) = RequestVoteReply t v ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      msg_refined_raft_intermediate_reachable (mkNetwork ps' st') ->
      nwPackets net = xs ++ p :: ys ->
      (forall h, st' h = update (nwState net) (pDst p) (gd, d) h) ->
      (forall p', In p' ps' -> In p' (xs ++ ys)) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_do_leader' (P : network -> Prop) :=
    forall net st' ps' gd d h os d' ms,
      doLeader d h = (os, d', ms) ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      msg_refined_raft_intermediate_reachable (mkNetwork ps' st') ->
      nwState net h = (gd, d) ->
      (forall h', st' h' = update (nwState net) h (gd, d') h') ->
      (forall p, In p ps' -> In p (nwPackets net) \/
                             In p (send_packets h (add_ghost_msg h (gd, d') ms))) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_do_generic_server' (P : network -> Prop) :=
    forall net st' ps' gd d os d' ms h,
      doGenericServer h d = (os, d', ms) ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      msg_refined_raft_intermediate_reachable (mkNetwork ps' st') ->
      nwState net h = (gd, d) ->
      (forall h', st' h' = update (nwState net) h (gd, d') h') ->
      (forall p, In p ps' -> In p (nwPackets net) \/
                             In p (send_packets h (add_ghost_msg h (gd, d') ms))) ->
      P (mkNetwork ps' st').

  Definition msg_refined_raft_net_invariant_state_same_packet_subset' (P : network -> Prop) :=
    forall net net',
      (forall h, nwState net h = nwState net' h) ->
      (forall p, In p (nwPackets net') -> In p (nwPackets net)) ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      P net'.

  Definition msg_refined_raft_net_invariant_reboot' (P : network -> Prop) :=
    forall net net' gd d h d',
      reboot d = d' ->
      P net ->
      msg_refined_raft_intermediate_reachable net ->
      msg_refined_raft_intermediate_reachable net' ->
      nwState net h = (gd, d) ->
      (forall h', nwState net' h' = update (nwState net) h (gd, d') h') ->
      nwPackets net = nwPackets net' ->
      P net'.

  Lemma msg_refined_raft_net_invariant_client_request'_weak :
    forall net,
      msg_refined_raft_net_invariant_client_request net ->
      msg_refined_raft_net_invariant_client_request' net.
  Proof using.
    unfold msg_refined_raft_net_invariant_client_request, msg_refined_raft_net_invariant_client_request'.
    intuition eauto.
  Qed.

  Lemma msg_refined_raft_net_invariant_timeout'_weak :
    forall net,
      msg_refined_raft_net_invariant_timeout net ->
      msg_refined_raft_net_invariant_timeout' net.
    Proof using.
      unfold msg_refined_raft_net_invariant_timeout, msg_refined_raft_net_invariant_timeout'.
      intuition eauto.
  Qed.

  Lemma msg_refined_raft_net_invariant_append_entries'_weak :
    forall net,
      msg_refined_raft_net_invariant_append_entries net ->
      msg_refined_raft_net_invariant_append_entries' net.
    Proof using.
      unfold msg_refined_raft_net_invariant_append_entries, msg_refined_raft_net_invariant_append_entries'.
      intuition eauto.
  Qed.

  Lemma msg_refined_raft_net_invariant_append_entries_reply'_weak :
    forall net,
      msg_refined_raft_net_invariant_append_entries_reply net ->
      msg_refined_raft_net_invariant_append_entries_reply' net.
    Proof using.
      unfold msg_refined_raft_net_invariant_append_entries_reply, msg_refined_raft_net_invariant_append_entries_reply'.
      intuition eauto.
  Qed.

  Lemma msg_refined_raft_net_invariant_request_vote'_weak :
    forall net,
      msg_refined_raft_net_invariant_request_vote net ->
      msg_refined_raft_net_invariant_request_vote' net.
    Proof using.
      unfold msg_refined_raft_net_invariant_request_vote, msg_refined_raft_net_invariant_request_vote'.
      intuition eauto.
  Qed.

  Lemma msg_refined_raft_net_invariant_request_vote_reply'_weak :
    forall net,
      msg_refined_raft_net_invariant_request_vote_reply net ->
      msg_refined_raft_net_invariant_request_vote_reply' net.
    Proof using.
      unfold msg_refined_raft_net_invariant_request_vote_reply, msg_refined_raft_net_invariant_request_vote_reply'.
      intuition eauto.
  Qed.

  Lemma msg_refined_raft_net_invariant_do_leader'_weak :
    forall net,
      msg_refined_raft_net_invariant_do_leader net ->
      msg_refined_raft_net_invariant_do_leader' net.
    Proof using.
      unfold msg_refined_raft_net_invariant_do_leader, msg_refined_raft_net_invariant_do_leader'.
      intuition eauto.
  Qed.

  Lemma msg_refined_raft_net_invariant_do_generic_server'_weak :
    forall net,
      msg_refined_raft_net_invariant_do_generic_server net ->
      msg_refined_raft_net_invariant_do_generic_server' net.
    Proof using.
      unfold msg_refined_raft_net_invariant_do_generic_server, msg_refined_raft_net_invariant_do_generic_server'.
      intuition eauto.
  Qed.

  Lemma msg_refined_raft_net_invariant_reboot'_weak :
    forall net,
      msg_refined_raft_net_invariant_reboot net ->
      msg_refined_raft_net_invariant_reboot' net.
    Proof using.
      unfold msg_refined_raft_net_invariant_reboot, msg_refined_raft_net_invariant_reboot'.
      intuition eauto.
  Qed.

  Lemma msg_refined_raft_net_invariant_subset'_weak :
    forall net,
      msg_refined_raft_net_invariant_state_same_packet_subset net ->
      msg_refined_raft_net_invariant_state_same_packet_subset' net.
  Proof using.
    unfold msg_refined_raft_net_invariant_state_same_packet_subset, msg_refined_raft_net_invariant_state_same_packet_subset'.
    intuition eauto.
  Qed.

  Class raft_msg_refinement_interface : Prop :=
    {
      msg_refined_raft_net_invariant :
        forall P net,
          msg_refined_raft_net_invariant_init P ->
          msg_refined_raft_net_invariant_client_request P ->
          msg_refined_raft_net_invariant_timeout P ->
          msg_refined_raft_net_invariant_append_entries P ->
          msg_refined_raft_net_invariant_append_entries_reply P ->
          msg_refined_raft_net_invariant_request_vote P ->
          msg_refined_raft_net_invariant_request_vote_reply P ->
          msg_refined_raft_net_invariant_do_leader P ->
          msg_refined_raft_net_invariant_do_generic_server P ->
          msg_refined_raft_net_invariant_state_same_packet_subset P ->
          msg_refined_raft_net_invariant_reboot P ->
          msg_refined_raft_intermediate_reachable net ->
          P net;
      msg_refined_raft_net_invariant' :
        forall P net,
          msg_refined_raft_net_invariant_init P ->
          msg_refined_raft_net_invariant_client_request' P ->
          msg_refined_raft_net_invariant_timeout' P ->
          msg_refined_raft_net_invariant_append_entries' P ->
          msg_refined_raft_net_invariant_append_entries_reply' P ->
          msg_refined_raft_net_invariant_request_vote' P ->
          msg_refined_raft_net_invariant_request_vote_reply' P ->
          msg_refined_raft_net_invariant_do_leader' P ->
          msg_refined_raft_net_invariant_do_generic_server' P ->
          msg_refined_raft_net_invariant_state_same_packet_subset' P ->
          msg_refined_raft_net_invariant_reboot' P ->
          msg_refined_raft_intermediate_reachable net ->
          P net;
      msg_lift_prop :
        forall (P : _ -> Prop),
          (forall net, refined_raft_intermediate_reachable net -> P net) ->
          (forall net, msg_refined_raft_intermediate_reachable net -> P (mgv_deghost net));
      msg_lift_prop_all_the_way :
        forall (P : _ -> Prop),
          (forall net, raft_intermediate_reachable net -> P net) ->
          (forall (net : @network _ raft_msg_refined_multi_params), msg_refined_raft_intermediate_reachable net -> P (deghost (mgv_deghost net)));
      msg_lower_prop :
        forall P : _ -> Prop,
          (forall net, msg_refined_raft_intermediate_reachable net -> P (mgv_deghost net)) ->
          (forall net, refined_raft_intermediate_reachable net -> P net);
      msg_lower_prop_all_the_way :
        forall P : _ -> Prop,
          (forall (net : @network _ raft_msg_refined_multi_params), msg_refined_raft_intermediate_reachable net -> P (deghost (mgv_deghost net))) ->
          (forall net, raft_intermediate_reachable net -> P net);
      msg_deghost_spec :
        forall (net : @network _ raft_msg_refined_multi_params) h,
          nwState (mgv_deghost net) h = nwState net h;
      msg_simulation_1 :
        forall net,
          msg_refined_raft_intermediate_reachable net ->
          refined_raft_intermediate_reachable (mgv_deghost net)
    }.

End RaftMsgRefinementInterface.

Hint Extern 3 (@BaseParams) => apply raft_msg_refined_base_params : typeclass_instances.
Hint Extern 3 (@MultiParams _) => apply raft_msg_refined_multi_params : typeclass_instances.
Hint Extern 3 (@FailureParams _ _) => apply raft_msg_refined_failure_params : typeclass_instances.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import Setoid.
Require Import ZArith.
Require Import Psatz.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.NewProofs.ProofHelpers.
Require Import depoolContract.DePoolFunc.

(* Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100. *)

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
Require Import depoolContract.Lib.CommonCommon.

(* Require Import MultiSigWallet.Proofs.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Require Import depoolContract.Lib.CommonStateProofs.

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Require Import depoolContract.DePoolConsts.
Module DePoolContract_Ф_sendAcceptAndReturnChange (dc : DePoolConstsTypesSig XTypesSig StateMonadSig).
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig dc.
Module ProofHelpers := ProofHelpers dc.

Import dc.
Import ProofHelpers.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Opaque Z.eqb Z.add Z.sub Z.div Z.mul hmapLookup hmapInsert Z.ltb Z.geb Z.leb Z.gtb Z.modulo deleteListPair.

(* function sendAcceptAndReturnChange() private {
  IParticipant(msg.sender).receiveAnswer{value: 0, bounce: false, flag: 64}(STATUS_SUCCESS, 0);
} *)

Lemma DePoolContract_Ф_sendAcceptAndReturnChange_exec : forall (l: Ledger) ,
let oldMessages := eval_state ( ↑16 ε VMState_ι_messages) l in
let newMessage  := {| contractAddress  := eval_state msg_sender l ;
                      contractFunction := IParticipant_И_receiveAnswerF DePool_ι_STATUS_SUCCESS 0 ;
                      contractMessage  := {$ default with (messageValue , 0) ;
                                                          (messageBounce , false) ;
                                                          (messageFlag , 64) $} |}  in
exec_state ( ↓ DePoolContract_Ф_sendAcceptAndReturnChange ) l =  {$ l With VMState_ι_messages := newMessage :: oldMessages $} .

Proof.
  intros. destruct l. auto.
Qed.

Lemma DePoolContract_Ф_sendAcceptAndReturnChange_eval : forall ( l: Ledger ) ,
eval_state ( ↓ DePoolContract_Ф_sendAcceptAndReturnChange ) l = I .
Proof.
  intros. destruct l. auto.
Qed.

End DePoolContract_Ф_sendAcceptAndReturnChange.


From ITree Require Import ITree.
From Paco Require Import paco.
From compcert Require Import Integers.

Require Import sflib.

Require Import StdlibExt.
Require Import IntegersExt.
Require Import ConvC2ITree.
Require Import SyncSysModel.

Require Import Executable.
Require Import PALSSystem.

Require master worker.

From Coq Require Extraction ExtrOcamlBasic ExtrOcamlString.

Require Import ZArith List Lia.

Definition resize_bytes: bytes -> bytes? :=
  (fun bs => Some (RTSysEnv.resize_bytes 2 bs)).

Definition max_num_tasks: nat := 16.
Definition msg_size_k: Z := 1.
Definition msg_size: Z := 2.

Definition oapp_mast: AppMod.t ? :=
  cprog2app master.prog max_num_tasks msg_size_k msg_size.
Definition oapp_work (tid: Z): AppMod.t ? :=
  cprog2app (worker.prog tid) max_num_tasks msg_size_k msg_size.

Definition JobDistr_period: Z := 1000000000.

Definition app_system : ExecutableSpec.t :=
  let apps :=
      match deopt_list
              [oapp_mast; oapp_work 1; oapp_work 2;
              oapp_work 3; oapp_work 4; oapp_work 5;
              oapp_work 6; oapp_work 7; oapp_work 8] with
      | None => []
      | Some apps => apps
      end
  in
  ExecutableSpec.mk _ _ JobDistr_period
                    apps [[0;1;2;3;4;5;6;7;8]]
                    resize_bytes.

Definition app_system_itree: Z -> option Z -> itree _ unit :=
  @ExecutableSpec.sys_itree _ _ app_system.

Cd "./extr/job_assn_c2itree".
Extraction "AppSystem.ml" app_system app_system_itree.
Cd "../..".


(* -------------------------------------------------------------------- *)
From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp Require Import word_ssrZ.
Require Import utils oseq strings word memory_model global Utf8 Relation_Operators sem_type syscall label.
Require Import
  flag_combination
  shift_kind.

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

(* -------------------------------------------------------------------- *)
(* String representation of architecture components.
 * ToString is a class for types that have a string representation and a
 * particular stype, such as registers (represented as "RAX", "RSP", etc.
 * with sword U64 being the associated stype) or flags (represented as "CF",
 * "ZF", with sbool the associated stype).
 *)
Class ToString (t: stype) (T: Type) :=
  { category      : string    (* Name of the "register" used to print errors. *)
  ; _finC         :> finTypeC T
  ; to_string     : T -> string
  ; strings       : list (string * T)
  ; inj_to_string : injective to_string
  ; stringsE      : strings = [seq (to_string x, x) | x <- enum cfinT_finType]
  }.

Definition rtype {t T} `{ToString t T} := t.

(* -------------------------------------------------------------------- *)
(* Basic architecture declaration.
 * Parameterized by types for registers, extra registers, flags, and conditions.
 *)
Class arch_decl (reg regx xreg rflag cond : Type) :=
  { reg_size : wsize     (* Register size. Also used as pointer size. *)
  ; xreg_size : wsize    (* Extended registers size. *)
  ; cond_eqC :> eqTypeC cond
  ; toS_r :> ToString (sword reg_size) reg
  ; toS_rx :> ToString (sword reg_size) regx
  ; toS_x :> ToString (sword xreg_size) xreg
  ; toS_f :> ToString sbool rflag
  ; reg_size_neq_xreg_size : reg_size != xreg_size
  ; ad_rsp : reg
  ; inj_toS_reg_regx : forall (r:reg) (rx:regx), to_string r <> to_string rx
  ; ad_fcp :> FlagCombinationParams
  }.

#[global]
Instance arch_pd `{arch_decl} : PointerData := { Uptr := reg_size }.

Definition mk_ptr `{arch_decl} name :=
  {| vtype := sword Uptr; vname := name; |}.

(* FIXME ARM : Try to not use this projection *)
Definition reg_t   {reg regx xreg rflag cond} `{arch : arch_decl reg regx xreg rflag cond} := reg.
Definition regx_t  {reg regx xreg rflag cond} `{arch : arch_decl reg regx xreg rflag cond} := regx.
Definition xreg_t  {reg regx xreg rflag cond} `{arch : arch_decl reg regx xreg rflag cond} := xreg.
Definition rflag_t {reg regx xreg rflag cond} `{arch : arch_decl reg regx xreg rflag cond} := rflag.
Definition cond_t  {reg regx xreg rflag cond} `{arch : arch_decl reg regx xreg rflag cond} := cond.

Section DECL.

Context {reg regx xreg rflag cond} `{arch : arch_decl reg regx xreg rflag cond}.

Definition sreg := sword reg_size.
Definition wreg := sem_t sreg.
Definition sxreg := sword xreg_size.
Definition wxreg := sem_t sxreg.

Lemma sword_reg_neq_xreg :
  sreg != sxreg.
Proof.
  apply/eqP. move=> []. apply/eqP. exact: reg_size_neq_xreg_size.
Qed.

(* -------------------------------------------------------------------- *)
(* Addresses.
 * An address consists of
 *   - A displacement (an immediate value).
 *   - A base (a register).
 *   - A scale.
 *   - An offset (a register).
 * The effective address is displacement + base + offset * scale.
 *)
Record reg_address : Type := mkAddress
  { ad_disp   : pointer
  ; ad_base   : option reg_t
  ; ad_scale  : nat
  ; ad_offset : option reg_t
  }.

Variant address :=
| Areg of reg_address (* Absolute address. *)
| Arip of pointer.    (* Address relative to instruction pointer. *)

Definition oeq_reg (x y:option reg_t) :=
  @eq_op (option_eqType ceqT_eqType) x y.

Definition reg_address_beq (addr1: reg_address) addr2 :=
  match addr1, addr2 with
  | mkAddress d1 b1 s1 o1, mkAddress d2 b2 s2 o2 =>
    [&& d1 == d2, oeq_reg b1 b2, s1 == s2 & oeq_reg o1 o2]
  end.

Lemma reg_address_eq_axiom : Equality.axiom reg_address_beq.
Proof.
case=> [d1 b1 s1 o1] [d2 b2 s2 o2]; apply: (iffP idP) => /=.
+ by case/and4P ; do 4! move/eqP=> ->.
by case; do 4! move=> ->; rewrite /oeq_reg !eqxx.
Qed.

Definition reg_address_eqMixin := Equality.Mixin reg_address_eq_axiom.
Canonical reg_address_eqType := EqType reg_address reg_address_eqMixin.

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

Definition address_beq (addr1: address) addr2 :=
  match addr1, addr2 with
  | Areg ra1, Areg ra2 => ra1 == ra2
  | Arip p1, Arip p2   => p1 == p2
  | _, _ => false
  end.

Lemma address_eq_axiom : Equality.axiom address_beq.
Proof.
  by case=> []? []? /=; (constructor || apply: reflect_inj eqP => ?? []).
Qed.

Definition address_eqMixin := Equality.Mixin address_eq_axiom.
Canonical address_eqType := EqType address address_eqMixin.

(* -------------------------------------------------------------------- *)
(* Arguments to assembly instructions. *)
Variant asm_arg : Type :=
| Condt  of cond_t
| Imm ws of word ws
| Reg    of reg_t
| Regx   of regx_t
| Addr   of address
| XReg   of xreg_t.

Definition asm_args := (seq asm_arg).

Definition is_Condt (a : asm_arg) : option cond_t :=
  if a is Condt c then Some c else None.

Definition asm_arg_beq (a1 a2:asm_arg) :=
  match a1, a2 with
  | Condt t1, Condt t2 => t1 == t2 ::>
  | Imm sz1 w1, Imm sz2 w2 => (sz1 == sz2) && (wunsigned w1 == wunsigned w2)
  | Reg r1, Reg r2     => r1 == r2 ::>
  | Regx r1, Regx r2   => r1 == r2 ::>
  | Addr a1, Addr a2   => a1 == a2
  | XReg r1, XReg r2   => r1 == r2 ::>
  | _, _ => false
  end.

Definition Imm_inj sz sz' w w' (e: @Imm sz w = @Imm sz' w') :
  ∃ e : sz = sz', eq_rect sz (λ s, (word s)) w sz' e = w' :=
  let 'Logic.eq_refl := e in (ex_intro _ erefl erefl).

Lemma asm_arg_eq_axiom : Equality.axiom asm_arg_beq.
Proof.
  case => [t1 | sz1 w1 | r1 | r1 | a1 | xr1] [t2 | sz2 w2 | r2 | r2 | a2 | xr2] /=;
    try by (constructor || apply: reflect_inj eqP => ?? []).
  apply: (iffP idP) => //=.
  + by move=> /andP [] /eqP ? /eqP; subst => /wunsigned_inj ->.
  by move=> /Imm_inj [? ];subst => /= ->;rewrite !eqxx.
Qed.

Definition asm_arg_eqMixin := Equality.Mixin asm_arg_eq_axiom.
Canonical asm_arg_eqType := EqType asm_arg asm_arg_eqMixin.

(* -------------------------------------------------------------------- *)
(* Writing a large word to register or memory
 * When writing to a register, depending on the instruction,
 * the most significant bits are either preserved or cleared.
 *)
Variant msb_flag : Type :=
| MSB_CLEAR
| MSB_MERGE.

Scheme Equality for msb_flag.

Lemma msb_flag_eq_axiom : Equality.axiom msb_flag_beq.
Proof.
  move=> x y;apply:(iffP idP).
  + by apply: internal_msb_flag_dec_bl.
  by apply: internal_msb_flag_dec_lb.
Qed.

Definition msb_flag_eqMixin := Equality.Mixin msb_flag_eq_axiom.
Canonical msb_flag_eqType := EqType msb_flag msb_flag_eqMixin.

(* -------------------------------------------------------------------- *)
(* Implicit arguments.
 * Assembly instructions may have implicit arguments, such as flags if
 * they are set by the instruction.
 *)
Variant implicit_arg : Type :=
| IArflag of rflag_t  (* Implicit flag. *)
| IAreg   of reg_t.   (* Implicit register. *)

Definition implicit_arg_beq (i1 i2 : implicit_arg) :=
  match i1, i2 with
  | IArflag f1, IArflag f2 => f1 == f2 ::>
  | IAreg r1, IAreg r2 => r1 == r2 ::>
  | _, _ => false
  end.

Lemma implicit_arg_eq_axiom : Equality.axiom implicit_arg_beq.
Proof.
  by case=> []? []? /=; (constructor || apply: reflect_inj eqP => ?? []).
Qed.

Definition implicit_arg_eqMixin := Equality.Mixin implicit_arg_eq_axiom.
Canonical implicit_arg_eqType := EqType _ implicit_arg_eqMixin.

(* -------------------------------------------------------------------- *)
(* Address kinds.
 * An address argument may be used in two ways:
 * - To compute the effective address (such as in LEA in x86, or ADR in ARMv7).
 * - To load data from memory.
 *)
Variant addr_kind : Type :=
| AK_compute (* Only compute the address. *)
| AK_mem.    (* Compute the address and load from memory. *)

Scheme Equality for addr_kind.

Lemma addr_kind_eq_axiom : Equality.axiom addr_kind_beq.
Proof.
  move=> x y;apply:(iffP idP).
  + by apply: internal_addr_kind_dec_bl.
  by apply: internal_addr_kind_dec_lb.
Qed.

Definition addr_kind_eqMixin := Equality.Mixin addr_kind_eq_axiom.
Canonical addr_kind_eqType := EqType _ addr_kind_eqMixin.

(* -------------------------------------------------------------------- *)
(* Argument description.
 * An argument may be either implicit or explicit.
 *)
Variant arg_desc :=
| ADImplicit of implicit_arg
| ADExplicit
    of addr_kind      (* If argument is an address, should it be loaded? *)
     & nat            (* Position of the argument in assembly syntax. *)
     & option reg_t.  (* Set if there is only one valid register. *)

Definition arg_desc_beq (d1 d2 : arg_desc) :=
  match d1, d2 with
  | ADImplicit i1, ADImplicit i2 => i1 == i2
  | ADExplicit k1 n1 or1, ADExplicit k2 n2 or2 =>
    (k1 == k2) && (n1 == n2) && (or1 == or2 :> option_eqType ceqT_eqType)
  | _, _ => false
  end.

Lemma arg_desc_eq_axiom : Equality.axiom arg_desc_beq.
Proof.
  case=> [i1|k1 n1 or1] [i2|k2 n2 or2] /=;
    try by (constructor || apply: reflect_inj eqP => ?? []).
  do! (case: eqP; try by constructor; congruence).
Qed.

Definition arg_desc_eqMixin := Equality.Mixin arg_desc_eq_axiom.
Canonical  arg_desc_eqType  := EqType arg_desc arg_desc_eqMixin.

Definition F  f   := ADImplicit (IArflag f).
Definition R  r   := ADImplicit (IAreg   r).
Definition E  n   := ADExplicit AK_mem n None.
Definition Ec n   := ADExplicit AK_compute n None.
Definition Ef n r := ADExplicit AK_mem n (Some  r).

Definition check_oreg or ai :=
  match or, ai with
  | Some r, Reg r'  => r == r' ::>
  | Some _, Imm _ _ => true
  | Some _, _       => false
  | None, _         => true
  end.

(* -------------------------------------------------------------------- *)
(* Argument kinds.
 * Types for arguments of assembly instructions.
 *)
Variant arg_kind :=
| CAcond
| CAreg
| CAregx
| CAxmm
| CAmem of bool (* true if Global is allowed *)
| CAimm of wsize.

Scheme Equality for arg_kind.

Lemma arg_kind_eq_axiom : Equality.axiom arg_kind_beq.
Proof.
  move=> x y;apply:(iffP idP).
  + by apply: internal_arg_kind_dec_bl.
  by apply: internal_arg_kind_dec_lb.
Qed.

Definition arg_kind_eqMixin := Equality.Mixin arg_kind_eq_axiom.
Canonical  arg_kind_eqType  := EqType _ arg_kind_eqMixin.

(* An argument position where different argument kinds are allowed is
 * represented by a list of these kinds.
 * For instance, a position taking a register or an immediate is represented
 * by [:: CAreg; CAimm ] : arg_kinds.
 * This is a disjunction of the possible kinds for a position.
*)
Definition arg_kinds := seq arg_kind.

(* Each argument position has a description.
 * For instance [:: a0; a1; a2 ] is a description where the first argument
 * is described by the arg_kind a0, the second by a1 and the third by a2.
 * This is a conjunction of argument descriptions.
 *)
Definition args_kinds := seq arg_kinds.

(* An assembly instruction may take different number of arguments.
 * For instance, an instruction may take two registers, add their values
 * and write to the first, or take three registers, add two and store the
 * result to the third.
 * This is a disjunction of these signatures.
 *)
Definition i_args_kinds := seq args_kinds.

Definition check_arg_kind (a:asm_arg) (cond: arg_kind) :=
  match a, cond with
  | Condt _, CAcond => true
  | Imm sz _, CAimm sz' => sz == sz'
  | Reg _ , CAreg => true
  | Regx _, CAregx => true
  | Addr _, CAmem _ => true
  | XReg _, CAxmm   => true
  | _, _ => false
  end.

Definition check_arg_kinds (a:asm_arg) (cond:arg_kinds) :=
  has (check_arg_kind a) cond.

Definition check_args_kinds (a:asm_args) (cond:args_kinds) :=
 all2 check_arg_kinds a cond.

Definition check_i_args_kinds (cond:i_args_kinds) (a:asm_args) :=
  has (check_args_kinds a) cond.

Definition check_arg_dest (ad:arg_desc) (ty:stype) :=
  match ad with
  | ADImplicit _ => true
  | ADExplicit _ _ _ => ty != sbool
  end.

(* -------------------------------------------------------------------- *)
Variant pp_asm_op_ext :=
  | PP_error
  | PP_name
  | PP_iname   of wsize
  | PP_iname2  of string & wsize & wsize
  | PP_viname  of velem & bool (* long *)
  | PP_viname2 of velem & velem (* source and target element sizes *)
  | PP_ct      of asm_arg.

Record pp_asm_op := mk_pp_asm_op {
  pp_aop_name : string;
  pp_aop_ext  : pp_asm_op_ext;
  pp_aop_args : seq (wsize * asm_arg);
}.

(* -------------------------------------------------------------------- *)
(* Instruction descriptions. *)
Record instr_desc_t := {
  (* Info for architecture semantics. *)
  (* When writing a smaller value to a register, keep or clear old bits? *)
  id_msb_flag   : msb_flag;
  (* Types of input arguments. *)
  id_tin        : seq stype;
  (* Description of input arguments. *)
  id_in         : seq arg_desc;
  (* Types of output arguments. *)
  id_tout       : seq stype;
  (* Description of output arguments. *)
  id_out        : seq arg_desc;
  (* Semantics (only deals with values). *)
  id_semi       : sem_prod id_tin (exec (sem_tuple id_tout));
  (* Possible signatures for an instruction. *)
  id_args_kinds : i_args_kinds;
  (* Number of explicit arguments in assembly syntax. *)
  id_nargs      : nat;
  (* Info for jasmin *)
  id_eq_size    : (size id_in == size id_tin) && (size id_out == size id_tout);
  id_tin_narr   : all is_not_sarr id_tin;
  id_tout_narr  : all is_not_sarr id_tout;
  id_str_jas    : unit -> string;
  id_check_dest : all2 check_arg_dest id_out id_tout;
  id_safe       : seq safe_cond;
  id_pp_asm     : asm_args -> pp_asm_op;
}.

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

Variant prim_constructor (asm_op:Type) :=
  | PrimP of wsize & (wsize -> asm_op)
  | PrimM of asm_op
  | PrimV of (velem -> wsize -> asm_op)
  | PrimSV of (signedness -> velem -> wsize -> asm_op)
  | PrimX of (wsize -> wsize -> asm_op)
  | PrimVV of (velem → wsize → velem → wsize → asm_op)
  | PrimARM of
    (bool                 (* set_flags *)
     -> bool              (* is_conditional *)
     -> option shift_kind (* has_shift *)
     -> asm_op).

(* -------------------------------------------------------------------- *)
(* Architecture operand declaration. *)
Class asm_op_decl (asm_op: Type) :=
  { _eqT          :> eqTypeC asm_op
  ; instr_desc_op : asm_op -> instr_desc_t
  ; prim_string   : list (string * prim_constructor asm_op)
  }.

Definition asm_op_t' {asm_op} {asm_op_d : asm_op_decl asm_op} := asm_op.
(* We extend [asm_op] in order to deal with msb flags *)
Definition asm_op_msb_t {asm_op} {asm_op_d : asm_op_decl asm_op} := (option wsize * asm_op)%type.

Context `{asm_op_d : asm_op_decl}.

Definition extend_size (ws: wsize) (t:stype) :=
  match t with
  | sword ws' => if (ws' <= ws)%CMP then sword ws else sword ws'
  | _ => t
  end.

Definition wextend_size (ws: wsize) (t:stype) : sem_ot t -> sem_ot (extend_size ws t) :=
  match t return sem_ot t -> sem_ot (extend_size ws t) with
  | sword ws' =>
    fun (w: word ws') =>
    match (ws' <= ws)%CMP as b return sem_ot (if b then sword ws else sword ws') with
    | true => zero_extend ws w
    | false => w
    end
  | _ => fun x => x
  end.

Fixpoint extend_tuple (ws:wsize) (id_tout : list stype) (t: sem_tuple id_tout) :
   sem_tuple (map (extend_size ws) id_tout) :=
 match id_tout return sem_tuple id_tout -> sem_tuple (map (extend_size ws) id_tout) with
 | [::] => fun _ => tt
 | t :: ts =>
   match ts return
     (sem_tuple ts -> sem_tuple (map (extend_size ws) ts)) ->
     sem_tuple (t::ts) -> sem_tuple (map (extend_size ws) (t::ts)) with
   | [::] => fun rec_ x => wextend_size ws x
   | t'::ts'    => fun rec_ p => (wextend_size ws p.1, rec_ p.2)
   end (@extend_tuple ws ts)
 end t.

Fixpoint apply_lprod (A B : Type) (f : A -> B) (ts:list Type) : lprod ts A -> lprod ts B :=
  match ts return lprod ts A -> lprod ts B with
  | [::] => fun a => f a
  | t :: ts' => fun g x => apply_lprod f (g x)
  end.

Lemma instr_desc_aux1 ws (id_in id_out : list arg_desc) (id_tin id_tout : list stype) :
  is_true ((size id_in == size id_tin) && (size id_out == size id_tout)) ->
  is_true ((size id_in == size id_tin) && (size id_out == size (map (extend_size ws) id_tout))).
Proof. by rewrite size_map. Qed.

Lemma instr_desc_aux2 ws (id_out : list arg_desc) (id_tout : list stype) :
  is_true (all2 check_arg_dest id_out id_tout) ->
  is_true (all2 check_arg_dest id_out (map (extend_size ws) id_tout)).
Proof.
  rewrite /is_true => <-.
  elim: id_out id_tout => [ | a id_out hrec] [ | t id_tout] //=.
  rewrite hrec; case: t => // ws'.
  by rewrite /extend_size /check_arg_dest; case: a => //; case: ifP.
Qed.

Definition is_not_CAmem (cond : arg_kind) :=
  match cond with
  | CAmem _ => false
  | _ => true
  end.

Definition exclude_mem_args_kinds (d : arg_desc) (cond : args_kinds) :=
  match d with
  | ADExplicit _ i _ =>
    mapi (fun k c => if k == i then filter is_not_CAmem c else c) cond
  | _ => cond
  end.

Definition exclude_mem_i_args_kinds (d : arg_desc) (cond : i_args_kinds) : i_args_kinds :=
  map (exclude_mem_args_kinds d) cond.

(* Remark: if the cast is explicit and do nothing then this code will reject store in memory
   while assembly accepts it.
   It is our choice... *)

Definition exclude_mem_aux (cond : i_args_kinds) (d : seq arg_desc) :=
  foldl (fun cond d => exclude_mem_i_args_kinds d cond) cond d.

Definition exclude_mem (cond : i_args_kinds) (d : seq arg_desc) : i_args_kinds :=
  filter (fun c => [::] \notin c) (exclude_mem_aux cond d).

Lemma instr_desc_tout_narr ws xs :
  all is_not_sarr xs -> all is_not_sarr (map (extend_size ws) xs).
Proof.
  move=> h.
  rewrite all_map.
  apply: (sub_all _ h).
  move=> [] //= ws'.
  by case: (ws' <= ws)%CMP.
Qed.

(* An extension of [instr_desc] that deals with msb flags *)
Definition instr_desc (o:asm_op_msb_t) : instr_desc_t :=
  let (ws, o) := o in
  let d := instr_desc_op o in
  if ws is Some ws then
    if d.(id_msb_flag) == MSB_CLEAR then
    {| id_msb_flag   := d.(id_msb_flag);
       id_tin        := d.(id_tin);
       id_in         := d.(id_in);
       id_tout       := map (extend_size ws) d.(id_tout);
       id_out        := d.(id_out);
       id_semi       :=
         apply_lprod (Result.map (@extend_tuple ws d.(id_tout))) d.(id_semi);
       id_args_kinds := exclude_mem d.(id_args_kinds) d.(id_out) ;
       id_nargs      := d.(id_nargs);
       id_eq_size    := instr_desc_aux1 ws d.(id_eq_size);
       id_tin_narr   := d.(id_tin_narr);
       id_tout_narr  := instr_desc_tout_narr _ d.(id_tout_narr);
       id_str_jas    := d.(id_str_jas);
       id_check_dest := instr_desc_aux2 ws d.(id_check_dest);
       id_safe       := d.(id_safe);
       id_pp_asm     := d.(id_pp_asm); |}
    else d (* FIXME do the case for MSB_KEEP *)
  else
    d.

(* -------------------------------------------------------------------- *)
(* Assembly language. *)
Variant asm_i : Type :=
  | ALIGN
  | LABEL of label_kind & label
  | STORELABEL of reg_t & label (* Store the address of a local label *)
  (* Jumps *)
  | JMP    of remote_label (* Direct jump *)
  | JMPI   of asm_arg (* Indirect jump, arm : BX *)
  | Jcc    of label & cond_t  (* Conditional jump *)
  (* Functions *)
  | JAL of reg_t & remote_label (* Direct jump; return address is saved in a register *)
  | CALL of remote_label (* Direct jump; return address is saved at the top of the stack *)
  | POPPC (* Pop a destination from the stack and jump there, arm : POP PC, x86 : RET *)
  (* Instructions exposed at source-level *)
  | AsmOp  of asm_op_t' & asm_args
  | SysCall of syscall_t.

Definition asm_code := seq asm_i.

(* Any register, used for function arguments and returned values. *)
Variant asm_typed_reg :=
  | ARReg of reg_t
  | ARegX of regx_t
  | AXReg of xreg_t
  | ABReg of rflag_t.
Notation asm_typed_regs := (seq asm_typed_reg).

Definition asm_typed_reg_beq r1 r2 :=
  match r1, r2 with
  | ARReg r1, ARReg r2 => r1 == r2 ::>
  | ARegX r1, ARegX r2 => r1 == r2 ::>
  | AXReg r1, AXReg r2 => r1 == r2 ::>
  | ABReg r1, ABReg r2 => r1 == r2 ::>
  | _       , _        => false
  end.

Lemma asm_typed_reg_eq_axiom : Equality.axiom asm_typed_reg_beq.
Proof. case => r1 [] r2 /=; try by (constructor || apply: reflect_inj eqP => ?? []). Qed.

Definition asm_typed_reg_eqMixin := Equality.Mixin asm_typed_reg_eq_axiom.
Canonical asm_typed_reg_eqType := EqType asm_typed_reg asm_typed_reg_eqMixin.

(* -------------------------------------------------------------------- *)
(* Function declaration                                                 *)

Record asm_fundef := XFundef
  { asm_fd_align : wsize
  ; asm_fd_arg   : asm_typed_regs
  ; asm_fd_body  : asm_code
  ; asm_fd_res   : asm_typed_regs
  ; asm_fd_export: bool
  ; asm_fd_total_stack: Z
  }.

Record asm_prog : Type :=
  { asm_globs : seq u8
  ; asm_funcs : seq (funname * asm_fundef)
  }.

(* -------------------------------------------------------------------- *)
(* Calling Convention                                                   *)

Definition is_ABReg r :=
  match r with
  | ABReg _ => true
  | _ => false
  end.

Class calling_convention :=
  { callee_saved   : seq asm_typed_reg
  ; callee_saved_not_bool : all (fun r => ~~is_ABReg r) callee_saved
  ; call_reg_args  : seq reg_t
  ; call_xreg_args : seq xreg_t
  ; call_reg_ret   : seq reg_t
  ; call_xreg_ret  : seq xreg_t
  ; call_reg_ret_uniq : uniq (T:= @ceqT_eqType _ _) call_reg_ret
  }.

Definition get_ARReg (a:asm_typed_reg) :=
  match a with
  | ARReg r => Some r
  | _ => None
  end.

Definition get_ARegX (a:asm_typed_reg) :=
  match a with
  | ARegX r => Some r
  | _ => None
  end.

Definition get_AXReg (a:asm_typed_reg) :=
  match a with
  | AXReg r => Some r
  | _ => None
  end.

Definition check_list {T} {eqc : eqTypeC T} (get : asm_typed_reg -> option T) (l:asm_typed_regs) (expected:seq T) :=
  let r := pmap get l in
  (r : seq (@ceqT_eqType T eqc)) == take (size r) expected.

Definition check_call_conv {call_conv:calling_convention} (fd:asm_fundef) :=
  implb fd.(asm_fd_export)
    [&& check_list get_ARReg fd.(asm_fd_arg) call_reg_args,
        check_list get_AXReg fd.(asm_fd_arg) call_xreg_args,
        check_list get_ARReg fd.(asm_fd_res) call_reg_ret &
        check_list get_AXReg fd.(asm_fd_res) call_xreg_ret].

End DECL.

Section ENUM.
  Context `{arch : arch_decl}.

  Definition registers : seq reg_t := cenum.

  Definition registerxs : seq regx_t := cenum.

  Definition xregisters : seq xreg_t := cenum.

  Definition rflags : seq rflag_t := cenum.
End ENUM.

(* -------------------------------------------------------------------- *)
(* Flag values. *)
Variant rflagv := Def of bool | Undef.
Scheme Equality for rflagv.

Lemma rflagv_eq_axiom : Equality.axiom rflagv_beq.
Proof.
  move=> x y;apply:(iffP idP).
  + by apply: internal_rflagv_dec_bl.
  by apply: internal_rflagv_dec_lb.
Qed.

Definition rflagv_eqMixin := Equality.Mixin rflagv_eq_axiom.
Canonical rflagv_eqType := EqType _ rflagv_eqMixin.

(* -------------------------------------------------------------------- *)
(* Assembly declaration. *)

Class asm (reg regx xreg rflag cond asm_op: Type) :=
  { _arch_decl   :> arch_decl reg regx xreg rflag cond
  ; _asm_op_decl :> asm_op_decl asm_op
  ; eval_cond   : (rflag_t -> exec bool) -> cond_t -> exec bool
  }.


(* This file is part of the LLIR Semantics project. *)
(* Licensing information is available in the LICENSE file. *)
(* (C) 2020 Nandor Licker. All rights reserved. *)

Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Init.Nat.

Require Import LLIR.LLIR.
Require Import LLIR.Maps.
Require Import LLIR.Typing.
Require Import LLIR.Dom.
Require Import LLIR.Frame.
Require Import LLIR.State.

Import ListNotations.

Definition set_frame (st: state) (fr: frame): state :=
  let stk := st.(st_stack) in
  {| st_stack :=
    {| stk_fr := stk.(stk_fr)
     ; stk_frs := stk.(stk_frs)
     ; stk_next := stk.(stk_next)
     ; stk_frames := PTrie.set stk.(stk_frames) stk.(stk_fr) fr
     ; stk_init := stk.(stk_init)
     |}
   ; st_heap := st.(st_heap)
   |}.

Axiom argext: ty -> value -> option value.

Definition step_inst (fr: frame) (st: state) (i: inst): option state :=
  match i with
  | LLArg (ty, dst) next idx =>
    match nth_error fr.(fr_args) idx  with
    | None => None
    | Some v =>
      match argext ty v with
      | None => None
      | Some v' =>
        let fr' := set_vreg_pc fr dst v' next in
        Some (set_frame st fr')
      end
    end

  | LLInt dst next val =>
    let fr' := set_vreg_pc fr dst (VInt val) next in
    Some (set_frame st fr')

  | LLUnop (ty, dst) next op arg =>
    match fr.(fr_regs) ! arg with
    | Some varg =>
      match step_unop op ty varg with
      | Some r =>
        let fr' := set_vreg_pc fr dst r next in
        Some (set_frame st fr')
      | None => None
      end
    | None => None
    end

  | LLBinop (ty, dst) next op lhs rhs =>
    match fr.(fr_regs) ! lhs with
    | Some vl =>
      match fr.(fr_regs) ! rhs with
      | Some vr =>
        match step_binop op ty vl vr with
        | None => None
        | Some r =>
          let fr' := set_vreg_pc fr dst r next in
          Some (set_frame st fr')
        end
      | None => None
      end
    | None => None
    end

  | LLJcc cond bt bf =>
    match fr.(fr_regs) ! cond with
    | Some vc =>
      match is_true vc with
      | true =>
        Some (set_frame st (set_pc fr bt))
      | false =>
        Some (set_frame st (set_pc fr bf))
      end
    | None => None
    end

  | LLJmp target =>
    Some (set_frame st (set_pc fr target))

  | LLRet val =>
    None

  (* TODO *)
  | _ => None
  end.

Definition step (p: prog) (st: state): option state :=
  match (st.(st_stack).(stk_frames)) ! (st.(st_stack).(stk_fr)) with
  | Some fr =>
    match p ! (fr.(fr_func)) with
    | Some fn =>
      match fn.(fn_insts) ! (fr.(fr_pc)) with
      | Some inst =>
        step_inst fr st inst
      | None =>
        None
      end
    | _ => None
    end
  | _ => None
  end.


Set Implicit Arguments.
Require Import LibLogic LibHeap.
Require Export JsSemanticsDefs JsSemanticsRules.
Implicit Type h : heap.
Implicit Type l : loc.
Implicit Type f : field.

(**************************************************************)
(**************************************************************)
(** * Auxiliary lemmas *)

(**************************************************************)
(** * Checking the type of fields *)

(** Express whether a field is a user field *)

Definition is_field_normal f :=
    exists y, f = field_normal y.

(**************************************************************)
(** * Comparison of references *)

Lemma ref_neq : forall l l' f f',
  (Ref l f <> Ref l' f') = (l <> l' \/ f <> f').
Proof.
  intros. extens. iff H.
  rewrite <- not_and. intros [? ?]. subst. apply~ H.
  intros M. inverts M. destruct H; congruence.
Qed.

Lemma ref_neq_inv : forall l l' f f',
  (Ref l f <> Ref l' f') -> (l <> l' \/ f <> f').
Proof. intros. rewrite~ <- ref_neq. Qed.

Lemma ref_neq_prove : forall l l' f f',
  (l <> l' \/ f <> f') -> (Ref l f <> Ref l' f').
Proof. intros. rewrite~ ref_neq. Qed.

(**************************************************)
(** * Induction principle for [red_expr], [red_stat] and [red_prog] *)

Section Red_induct.

Scheme red_expr_ind' := Induction for red_expr Sort Prop
  with red_expr_lazy_binary_op_ind' := Induction for red_expr_lazy_binary_op Sort Prop
  with red_stat_ind' := Induction for red_stat Sort Prop
  with red_prog_ind' := Induction for red_prog Sort Prop.

End Red_induct.

(**************************************************************)
(** ** Expressing properties of extended expressions. *)

Section ExpressPropertiesOfExtented.

Variable Pout_expr : heap -> out_expr -> Prop.
Variable Pout_prog : heap -> out_prog -> Prop.
Variable Pextends : heap -> heap -> Prop.

Variable Pscope : heap -> scope -> Prop.
Variable Pvalue : heap -> value -> Prop.
Variable Pref : heap -> ref -> Prop.
Variable Ploc : heap -> loc -> Prop.
Variable Pbody_or_primitive : heap -> body_or_primitive -> Prop.
Variable Punary_op : unary_op -> Prop.
Variable Pbinary_op : binary_op -> Prop.

Definition extract_heap_from_output_expr default o :=
  match o with
  | out_expr_div => default
  | out_expr_ter h _ => h
  end.

Definition extract_heap_from_output_prog default o :=
  match o with
  | out_prog_div => default
  | out_prog_ter h _ => h
  end.

Fixpoint correct_ext_prog (h : heap) (P : ext_prog) : Prop :=
  match P with
    | ext_prog_prog _ =>
      True
    | ext_prog_seq_1 o _ =>
      Pout_prog h o
  end.

Fixpoint correct_ext_expr (h : heap) (e : ext_expr) : Prop :=
  let Pvalue' o := Pvalue (extract_heap_from_output_expr h o) in
  let Ploc' o := Ploc (extract_heap_from_output_expr h o) in
  let Pref' o := Pref (extract_heap_from_output_expr h o) in
  let correct_ext_expr' o := correct_ext_expr (extract_heap_from_output_expr h o) in
  match e with
    | ext_expr_expr _ =>
      True
    | ext_res_prog_res_expr o =>
      Pout_prog h o
    | ext_expr_prog P =>
      correct_ext_prog h P
    | ext_list_then k _ => (* FIXME:  Do we need the fact that [lv] has the same length than the list of expression? *)
      forall h' lv, Pextends h h' -> Forall (Pvalue h') lv -> correct_ext_expr h' (k lv)
    | ext_list_then_1 k lv _ =>
      Forall (Pvalue h) lv /\ forall h' lv', Pextends h h' -> Forall (Pvalue h') lv' -> correct_ext_expr h' (k (lv ++ lv'))
    | ext_list_then_2 k lv o _ =>
      Pout_expr h o /\ Forall (Pvalue' o) lv /\ forall h' lv', Pextends h h' -> Forall (Pvalue h') lv' -> correct_ext_expr h' (k (lv ++ lv'))
    | ext_expr_object_1 l _ lv =>
      Ploc h l /\ Forall (Pvalue h) lv
    | ext_expr_access_1 o _ =>
      Pout_expr h o
    | ext_expr_access_2 l o =>
      Pvalue h l /\ Pout_expr h o
    | ext_expr_new_1 o _ =>
      Pout_expr h o
    | ext_expr_new_2 l bp lv =>
      Ploc h l /\ Pbody_or_primitive h bp /\ Forall (Pvalue h) lv
    | ext_expr_new_3 l o =>
      Ploc' o l /\ Pout_expr h o
    | ext_expr_call_1 o _ =>
      Pout_expr h o
    | ext_expr_call_2 l1 l2 _ =>
      Ploc h l1 /\ Ploc h l2
    | ext_expr_call_3 l bp lv =>
      Ploc h l /\ Pbody_or_primitive h bp /\ Forall (Pvalue h) lv
    | ext_expr_call_4 o =>
      Pout_expr h o
    | ext_expr_unary_op_1 op o =>
      Punary_op op /\ Pout_expr h o
    | ext_expr_binary_op_1 o op _ =>
      Pout_expr h o /\ Pbinary_op op
    | ext_expr_binary_op_2 (Some o) _ _ _ =>
      Pout_expr h o
    | ext_expr_binary_op_2 None v op _ =>
      Pvalue h v /\ Pbinary_op op
    | ext_expr_binary_op_3 v op o =>
      Pvalue' o v /\ Pbinary_op op /\ Pout_expr h o
    | ext_expr_assign_1 o (Some op) _ =>
      Pout_expr h o /\ Pbinary_op op
    | ext_expr_assign_1 o None _ =>
      Pout_expr h o
    | ext_expr_assign_2 r o =>
      Pref' o r /\ Pout_expr h o
    | ext_expr_assign_2_op r v op o =>
      Pref' o r /\ Pvalue' o v /\ Pbinary_op op /\ Pout_expr h o
  end.

Fixpoint correct_ext_stat (h : heap) (p : ext_stat) : Prop :=
  match p with
    | ext_stat_stat _ =>
      True
    | ext_res_expr_res_prog o =>
      Pout_expr h o
    | ext_stat_expr e =>
      correct_ext_expr h e
    | ext_stat_seq_1 o _ =>
      Pout_prog h o
    | ext_stat_var_decl_expr_1 o =>
      Pout_prog h o
    | ext_stat_if_1 o _ _ =>
      Pout_prog h o
    | ext_stat_while_1 _ o _ =>
      Pout_prog h o
    | ext_stat_while_2 _ _ o =>
      Pout_prog h o
    | ext_stat_with_1 o _ =>
      Pout_prog h o
    | ext_stat_throw_1 o =>
      Pout_prog h o
    | ext_stat_try_1 o _ _ =>
      Pout_prog h o
    | ext_stat_try_2 s _ _ =>
      Pscope h s
    | ext_stat_try_3 o _ =>
      Pout_prog h o
    | ext_stat_try_4 r o =>
      Pout_prog h o /\ Pout_prog h (out_prog_ter h r)
  end.

End ExpressPropertiesOfExtented.

(**************************************************************)
(** ** Corrolaries for [obj_of_value] *)

Definition value_not_loc v :=
  forall l, v <> value_loc l.

Lemma value_loc_or_not : forall v,
  (exists l, v = value_loc l) \/ (value_not_loc v).
Proof.
  intros. applys classic_right. introv M.
  rew_logic in M. auto.
Qed.

Lemma obj_of_value_not_loc : forall v l',
  value_not_loc v ->
  obj_of_value v l' = l'.
Proof. introv H. destruct* v. false* H. Qed.

(**************************************************************)
(** ** Corrolaries for [obj_or_glob_of_value_not_loc] *)

Definition not_scope_or_body f :=
  f <> field_scope /\ f <> field_body.

Hint Unfold not_scope_or_body.

Lemma obj_or_glob_of_value_not_loc : forall v,
  value_not_loc v ->
  obj_or_glob_of_value v = loc_obj_proto.
Proof. introv H. destruct* v. simpl. false* H. Qed.

(**************************************************************)
(**************************************************************)
(** * Properties of heaps *)

(**************************************************************)
(** * Properties of heaps (adapted from module [Heap]) *)

Section Properties.
Hint Resolve ref_neq_inv ref_neq_prove.

(** DO NOT REORDER THE LEMMAS *)

Lemma binds_equiv_read : forall h l f,
  indom h l f -> (forall v, (binds h l f v) = (read h l f = v)).
Proof. intros. apply* @Heap.binds_equiv_read. Qed.

Lemma indom_equiv_binds : forall h l f,
  indom h l f = (exists v, binds h l f v).
Proof. intros. apply Heap.indom_equiv_binds. Qed.

Lemma binds_write_eq : forall h l f v,
  binds (write h l f v) l f v.
Proof. intros. apply Heap.binds_write_eq. Qed.

Lemma binds_write_neq : forall h l f v l' f' v',
  binds h l f v -> (l <> l' \/ f <> f') ->
  binds (write h l' f' v') l f v.
Proof.
  introv B N. applys @Heap.binds_write_neq B.
  destruct N; congruence.
Qed.

Lemma binds_write_inv : forall h l f v l' f' v',
  binds (write h l' f' v') l f v ->
     (l = l' /\ f = f' /\ v = v')
  \/ ((l <> l' \/ f <> f') /\ binds h l f v).
Proof.
  introv B. forwards [[E ?]|[E ?]]: @Heap.binds_write_inv B.
  inverts E. left*.
  right*.
Qed.

Lemma binds_rem : forall h l f l' f' v,
  binds h l f v -> (l <> l' \/ f <> f') -> binds (rem h l' f') l f v.
Proof. introv B N. applys* @Heap.binds_rem B. Qed.

Lemma binds_rem_inv : forall h l f v l' f',
  binds (rem h l' f') l f v -> (l <> l' \/ f <> f') /\ binds h l f v.
Proof. introv B. forwards* [? ?]: @Heap.binds_rem_inv B. Qed.

Lemma not_indom_rem : forall h l f,
  ~ indom (rem h l f) l f.
Proof. intros. apply Heap.not_indom_rem. Qed.

Lemma indom_binds : forall h l f,
  indom h l f -> exists v, binds h l f v.
Proof. intros. apply* @LibHeap.indom_binds. Qed.

Lemma binds_indom : forall h l f v,
  binds h l f v -> indom h l f.
Proof. intros. apply* @LibHeap.binds_indom. Qed.

Lemma binds_func : forall h l f v v',
  binds h l f v -> binds h l f v' -> v = v'.
Proof. intros. applys* @LibHeap.binds_func; typeclass. Qed.

Lemma binds_read : forall h l f v,
  binds h l f v -> read h l f = v.
Proof. intros. apply* @LibHeap.binds_read. Qed.

Lemma read_binds : forall h l f v,
  read h l f = v -> indom h l f -> binds h l f v.
Proof. intros. apply* @LibHeap.read_binds. Qed.

Lemma read_write_eq : forall h l f v,
  read (write h l f v) l f = v.
Proof. intros. apply* @LibHeap.read_write_eq. Qed.

Lemma read_write_neq : forall h l f l' f' v',
  indom h l f -> (l <> l' \/ f <> f') -> read (write h l' f' v') l f = read h l f.
Proof. intros. apply* @LibHeap.read_write_neq. Qed.

Lemma indom_write_eq : forall h l f v,
  indom (write h l f v) l f.
Proof. intros. apply* @LibHeap.indom_write_eq. Qed.

Lemma indom_write : forall h l f l' f' v',
  indom h l f -> indom (write h l' f' v') l f.
Proof. intros. apply* @LibHeap.indom_write. Qed.

Lemma indom_write_inv : forall h l f l' f' v',
  indom (write h l' f' v') l f -> (l <> l' \/ f <> f') -> indom h l f.
Proof. intros. apply* @LibHeap.indom_write_inv. Qed.

Lemma binds_write_eq_inv : forall h l f v v',
  binds (write h l f v') l f v -> v = v'.
Proof. intros. apply* @LibHeap.binds_write_eq_inv. Qed.

Lemma binds_write_neq_inv : forall h l f v l' f' v',
  binds (write h l' f' v') l f v -> (l <> l' \/ f <> f') -> binds h l f v.
Proof. intros. apply* @LibHeap.binds_write_neq_inv. Qed.

Lemma indom_rem : forall h l f l' f',
  indom h l f -> (l <> l' \/ f <> f') -> indom (rem h l' f') l f.
Proof. intros. apply* @LibHeap.indom_rem. Qed.

Lemma indom_rem_inv : forall h l f l' f',
  indom (rem h l f) l' f' -> (l <> l' \/ f <> f') /\ indom h l' f'.
Proof. intros. forwards* [? ?]: @LibHeap.indom_rem_inv H. Qed.

Lemma read_rem_neq : forall h l f l' f',
  indom h l f -> (l <> l' \/ f <> f') -> read (rem h l' f') l f = read h l f.
Proof. intros. apply* @LibHeap.read_rem_neq. Qed.

Lemma not_indom_empty : forall l f,
  ~ indom empty_heap l f.
Proof. intros. apply* @LibHeap.not_indom_empty. Qed.

Lemma not_binds_empty : forall l f v,
  ~ binds empty_heap l f v.
Proof. intros. apply* @LibHeap.not_binds_empty. Qed.

End Properties.

(**************************************************************)
(** * Other results *)

(** [binds] on location is functional *)

Lemma binds_func_loc : forall h f l l1 l2,
  binds h l f (value_loc l1) ->
  binds h l f (value_loc l2) ->
  l1 = l2.
Proof. introv B1 B2. forwards E: binds_func B1 B2. inverts~ E. Qed.

(** [binds] on location is functional *)

Lemma binds_func_scope : forall h f l s1 s2,
  binds h l f (value_scope s1) ->
  binds h l f (value_scope s2) ->
  s1 = s2.
Proof. introv B1 B2. forwards E: binds_func B1 B2. inverts~ E. Qed.

(** Checking if a location l is bound to a given value in the heap
    is decidable. *)

Global Instance indom_decidable : forall h l f,
  Decidable (indom h l f).
Proof. intros. apply Heap.indom_decidable. Qed.

(**************************************************************)
(** * Properties of write_fields *)

Lemma write_fields_nil : forall h l,
  write_fields h l nil = h.
Proof. auto. Qed.

Lemma write_fields_cons : forall h l f v fvs,
  write_fields h l ((f,v)::fvs) = write_fields (write h l f v) l fvs.
Proof. auto. Qed.

Hint Rewrite write_fields_nil write_fields_cons : rew_write_fields.
Ltac rew_write_fields := autorewrite with rew_write_fields.

(** An induction principle for proving facts about [write_fields] *)

Lemma write_fields_ind : forall (P : list(field*value)->heap->heap->Prop), forall l h,
  (P nil h h) ->
  (forall f v fvs, P fvs h (write_fields h l fvs) -> P (fvs&(f,v)) h (write (write_fields h l fvs) l f v)) ->
  (forall fvs, P fvs h (write_fields h l fvs)).
Proof.
  introv MN MC. intros. unfold write_fields. induction fvs using list_ind_last; rew_list.
  auto. destruct a as [f' v']. apply~ MC.
Qed.

Lemma binds_write_fields_neq : forall h l f v l' fvs',
  binds h l f v -> l <> l' ->
  binds (write_fields h l' fvs') l f v.
Proof. intros. lets: binds_write_neq. apply* write_fields_ind. Qed.

Lemma binds_write_fields_neq_inv : forall h l l' fvs' f v,
  binds (write_fields h l' fvs') l f v -> l <> l' -> binds h l f v.
Proof. introv B N. gen B. lets: binds_write_neq_inv. apply* write_fields_ind. Qed.

Lemma indom_write_fields : forall h l f l' fvs',
  indom h l f -> indom (write_fields h l' fvs') l f.
Proof. introv D. lets: indom_write. apply* write_fields_ind. Qed.

(**************************************************************)
(** * Properties of bound *)

Lemma binds_bound : forall h l f v,
  binds h l f v -> bound h l.
Proof. intros. exists f. apply* binds_indom. Qed.

Lemma indom_bound : forall h l f,
  indom h l f -> bound h l.
Proof. intros. exists* f. Qed.

Lemma not_bound_indom : forall h l f,
  (~ bound h l) -> indom h l f -> False.
Proof. introv N D. apply N. apply* indom_bound. Qed.

Lemma not_bound_binds : forall h l f v,
  (~ bound h l) -> binds h l f v -> False.
Proof. introv N D. apply N. apply* binds_bound. Qed.

Lemma bound_binds : forall h l,
  bound h l -> exists f v, binds h l f v.
Proof. introv [f D]. rewrite* indom_equiv_binds in D. Qed.

(**************************************************************)
(** * Properties of freshness *)

Lemma fresh_not_null : forall h l,
  fresh h l -> l <> loc_null.
Proof. introv [N _]. auto. Qed.

Hint Resolve fresh_not_null.

(** Elimination of fresh *)

Lemma fresh_not_bound : forall h l,
  fresh h l -> bound h l -> False.
Proof. introv [_ N] D. false. Qed.

Lemma fresh_bound_neq : forall h l l',
  fresh h l' -> bound h l -> l <> l'.
Proof. introv B F E. subst. apply* fresh_not_bound. Qed.

Lemma fresh_not_indom : forall h l f,
  fresh h l -> indom h l f -> False.
Proof. intros. apply* fresh_not_bound. apply* indom_bound. Qed.

Lemma fresh_indom_neq : forall h l l' f,
  fresh h l' -> indom h l f -> l <> l'.
Proof. introv B F E. subst. apply* fresh_not_indom. Qed.

Lemma fresh_not_binds : forall h l f v,
  fresh h l -> binds h l f v -> False.
Proof. intros. apply* fresh_not_indom. applys* binds_indom. Qed.

Lemma fresh_binds_neq : forall h l l' f v,
  fresh h l' -> binds h l f v -> l <> l'.
Proof. introv B F E. subst. apply* fresh_not_binds. Qed.

(** Preservation of fresh *)

Lemma fresh_write : forall l' h l f v,
  fresh h l' -> l <> l' -> fresh (write h l f v) l'.
Proof.
  introv [L B] N. split. auto.
  intros B'. lets (f'&v'&R): bound_binds B'.
  lets [(?&?&?)|(?&?)]: binds_write_inv R.
    false.
    apply* not_bound_binds.
Qed.

Lemma fresh_write_weaken : forall l' h l f v,
  fresh (write h l f v) l' -> fresh h l'.
Proof.
  introv [L B]. split. auto.
  intros [f' B']. apply B. eapply indom_bound.
  apply* indom_write.
Qed.

(**************************************************************)
(** ** Hints for proving freshness goals *)

Hint Extern 1 (fresh _ ?l) =>
  match goal with H: fresh _ ?l |- _ =>
    apply (fresh_write_weaken H) end.

Hint Resolve fresh_binds_neq.

Hint Extern 1 (_ <> _ :> ref) => congruence.

(**************************************************************)
(** * Properties of abort *)

Lemma not_abort_prog_ret_expr : forall o,
  ~ abort_prog o ->
  exists h, exists r, o = out_prog_ter h r.
Proof.
  introv nA.
  cases* o.
   false nA. constructors.
(* LATER:cleanup
   cases* r; try (false nA; constructors).
*)
Qed.

Lemma not_abort_expr_ret_expr : forall o,
  ~ abort_expr o ->
  exists h, exists r, o = out_expr_ter h r.
Proof.
  introv nA.
  cases* o.
   false nA. constructors.
(* LATER: cleanup
   cases* r; try (false nA; constructors).
*)
Qed.

Lemma not_abort_prog_ter : forall h (r : ret_expr),
  ~ abort_prog (out_prog_ter h r).
Proof.
  introv A. inverts* A.
Qed.

Lemma not_abort_expr_ter : forall h (r : ret_expr),
  ~ abort_expr (out_expr_ter h r).
Proof.
  introv A. inverts* A.
Qed.

(**************************************************************)
(** ** Tactics *)

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

(** The following tactic strengthens [congruence] by making it
    able to bruteforce a goal that concludes on a disjunction *)

Ltac congruence_on_disjunction :=
  let rec go tt :=
    match goal with
    | |- _ \/ _ => first [ left; go tt | right; go tt ]
    | |- _ => congruence
    end in
  go tt.

Lemma congruence_on_disjunction_demo : forall (l l' : nat),
  l <> l' -> (l <> l' \/ l' <> l \/ l <> l').
Proof. intros. try congruence. congruence_on_disjunction. Qed.

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

(** The tactic [indom_simpl_step] simplifies a goal of the
    form [indom (write h l f v) l' f'] by handling the case
    where [l'] is syntactically [l] and [f'] is syntactically [f],
    and otherwise turning the goal into [indom h l' f'].
    It also handles the [write_fields]. Note that you might
    need to do a case analysis on [l = l'] and [f = f'] before
    calling this tactic. It also handles the empty heap.  *)

Ltac indom_simpl_step :=
  match goal with
  | |- indom (write ?h ?l ?f _) ?l ?f =>
     apply indom_write_eq
  | |- indom (write_fields _ _ nil) _ _ =>
     rewrite write_fields_nil; indom_simpl_step
  | |- indom (write_fields _ _ (_::_)) _ _ =>
     rewrite write_fields_cons; indom_simpl_step
  | |- indom (write ?h ?l' ?f' _) ?l ?f =>
     apply indom_write
  | |- indom ?h _ _ =>
     let P := get_head h in progress (unfold P); indom_simpl_step
  | |- _ =>
     progress (unfolds); indom_simpl_step
  end.

(** The tactic [indom_simpl] iterates [indom_simpl_step]. *)

Tactic Notation "indom_simpl" :=
  repeat indom_simpl_step.
Tactic Notation "indom_simpl" "~" :=
  indom_simpl; auto_tilde.
Tactic Notation "indom_simpl" "*" :=
  indom_simpl; auto_star.

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

(** The tactic [binds_simpl_step] simplifies goal of the form
    [binds (write h l f v) f' l' v'] by handling the case where
    [l'] is syntactically [l] and [f'] is syntactically [f],
    and otherwise discarding the write, producing [l <> l' \/ f <> f']
    as subgoal and trying to prove it using [congruence].
    The tactic also handles [write_fields] in the case where [l <> l']. *)

Ltac binds_simpl_step :=
  match goal with
  | |- binds (write ?h ?l ?f _) ?l ?f _ =>
     apply binds_write_eq
  | |- binds (write_fields ?h ?l' ?fvs') ?l _ _ =>
     let F := fresh in
     assert (F : l <> l');
       [ try congruence
       | apply binds_write_fields_neq; [ clear F | apply F ]]
  | |- binds (write ?h ?l' ?f' _) ?l ?f _ =>
     let F := fresh in
     assert (F : l <> l' \/ f <> f');
       [ try congruence_on_disjunction
       | apply binds_write_neq; [ clear F | apply F ]]
  | |- binds ?h _ _ _ =>
     let P := get_head h in progress (unfold P); binds_simpl_step
  | |- _ =>
     progress (unfolds); binds_simpl_step
  end.

(** The tactic [binds_simpl] iterates [binds_simpl_step]. *)

Tactic Notation "binds_simpl" :=
  repeat binds_simpl_step.
Tactic Notation "binds_simpl" "~" :=
  binds_simpl; auto_tilde.
Tactic Notation "binds_simpl" "*" :=
  binds_simpl; auto_star.

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

(** The tactic [binds_case H] helps extracting information from an
    assumption [H] of the form [binds (write h l' f' v') l f v].
    If [l'] is syntactically [l] and [f'] is syntactically [f],
    then the tactic simplifies [H] to [v' = v]. Otherwise, if
    [l' <> l] or [f' <> f] is provable using [congruence], then
    the tactic simplifies [H] to [binds h l f v]. Otherwise, the
    tactic performs the case analysis and generates two subgoals,
    one corresponding to each case.
    The tactic also handles [write_fields] by unfolding the head
    write in write_fields, if any. It also handles the empty heap. *)

Ltac binds_case_step H :=
  match type of H with
  | binds (write ?h ?l ?f _) ?l ?f _ =>
     apply binds_write_eq_inv in H (*; try solve [ congruence ] *)
  | binds (write ?h ?l' ?f' ?v') ?l ?f ?v =>
     first [
       let F := fresh in let H' := fresh in
       assert (F : l <> l' \/ f <> f');
         [ congruence_on_disjunction
         | rename H into H';
           lets H: (binds_write_neq_inv H' F); clear F H' ]
     | let H' := fresh in rename H into H';
       let N := fresh "N" in let E1 := fresh "E1" in
       let E2 := fresh "E2" in let E3 := fresh "E3" in
       destruct (binds_write_inv H') as [(E1&E2&E3)|(N&H)];
         [ clear H'; try solve [ false; congruence ];
           try subst_hyp E1; try subst_hyp E2; try subst_hyp E3
         | clear H' ]
     ]
  | binds (write_fields _ _ nil) _ _ _ =>
     rewrite write_fields_nil in H
  | binds (write_fields _ _ (_::_)) _ _ _ =>
     rewrite write_fields_cons in H; binds_case_step H
  | binds (write_fields _ _ _) _ _ _ =>
     fail 2 "list given to write_fields should not be abstract"
  | binds empty_heap _ _ _ =>
     false (not_binds_empty H)
  | binds ?h _ _ _ =>
     let P := get_head h in progress (unfold P in H); binds_case_step H
  end.

Tactic Notation "binds_case" hyp(H) :=
  binds_case_step H.
Tactic Notation "binds_case" "~" hyp(H) :=
  binds_case H; auto_tilde.
Tactic Notation "binds_case" "*" hyp(H) :=
  binds_case H; auto_star.

(** The tactic [binds_cases] iterates [binds_case] *)

Tactic Notation "binds_cases" hyp(H) :=
  repeat (binds_case H).
Tactic Notation "binds_cases" "~" hyp(H) :=
  binds_cases H; auto_tilde.
Tactic Notation "binds_cases" "*" hyp(H) :=
  binds_cases H; auto_star.