(*

  Copyright 2016 Luxembourg University
  Copyright 2017 Luxembourg University
  Copyright 2018 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 Simulator.
Require Export PBFT.
Require Export PBFTcollision_resistant.
Require Import Ascii String.
(*Require Import SHA256.*)

(*
    We'll define here an instance of PBFT so that we can simulate it.
 *)

(* ================== INSTANCE OF PBFT ================== *)

Section PBFTinstance.

(*  Class NumNodes := MkNumNodes { total_num_faults : nat; total_num_clients : nat }.
  Context { p_num_nodes : NumNodes }.*)

  (* ============================================ *)
  (* total_num_faults *)
  Definition F := 1.

  (* total_num_clients is C+1 *)
  Definition C := 0.

  (* max requests in progress *)
  Definition MIP := 2.

  (* water-mark range *)
  Definition WMR := 200.

  (* checkpoint period *)
  Definition CP := 100.
  (* ============================================ *)

  Definition pbft_digest : Set := list nat.

  Lemma pbft_digest_deq : Deq pbft_digest.
  Proof.
    introv; apply list_eq_dec.
    apply deq_nat.
  Defined.

  Inductive sending_key_stub : Set :=
  | pbft_sending_key_stub.

  Inductive receiving_key_stub : Set :=
  | pbft_receiving_key_stub.

  Definition pbft_sending_key   : Set := sending_key_stub.
  Definition pbft_receiving_key : Set := receiving_key_stub.

  (*Definition F : nat := 1.*)
  Definition nreps (F : nat) : nat := 3 * F + 1.

  Definition replica (F : nat) : Set := nat_n (nreps F).

  Lemma replica_deq (F : nat) : Deq (replica F).
  Proof.
    apply nat_n_deq.
  Defined.

  Definition reps2nat (F : nat) : replica F -> nat_n (nreps F) := fun n => n.

  Lemma bijective_reps2nat (F : nat) : bijective (reps2nat F).
  Proof.
    exists (fun n : nat_n (nreps F) => n); introv; unfold reps2nat; auto.
  Defined.

  Definition nclients (C : nat) : nat := S C.

  Definition client (C : nat) : Set := nat_n (nclients C).

  Definition client0 (C : nat) : client C.
  Proof.
    exists 0.
    apply leb_correct.
    unfold nclients.
    omega.
  Defined.

  Lemma client_deq (C : nat) : Deq (client C).
  Proof.
    apply nat_n_deq.
  Defined.

  Definition clients2nat (C : nat) : client C -> nat_n (nclients C) := fun n => n.

  Lemma bijective_clients2nat (C : nat) : bijective (clients2nat C).
  Proof.
    exists (fun n : nat_n (nclients C) => n); introv; unfold clients2nat; auto.
  Defined.

  Inductive operation :=
  | opr_add (n : nat)
  | opr_sub (n : nat).

  Lemma operation_deq : Deq operation.
  Proof.
    introv; destruct x as [n|n], y as [m|m]; prove_dec;
      destruct (deq_nat n m); subst; prove_dec.
  Defined.

  Definition smState : Set := nat.
  Definition result : Set := nat.

  Definition operation_upd (C : nat) (c : client C) (state : smState) (opr : operation) : result * smState :=
    match opr with
    | opr_add m => let k := state + m in (k,k)
    | opr_sub m => let k := state - m in (k,k)
    end.

  Inductive PBFTtoken_stub : Set :=
  | pbft_token_stub.

  Definition pbft_token : Set := PBFTtoken_stub.

  Lemma pbft_token_deq : Deq pbft_token.
  Proof.
    introv; destruct x, y; simpl; prove_dec.
  Defined.

  Global Instance PBFT_I_context : PBFTcontext :=
    MkPBFTcontext
      (* max in progress *)
      MIP

      (* water mark range *)
      WMR

      (* checkpoint period *)
      CP

      (* digest type *)
      pbft_digest

      (* digest decider *)
      pbft_digest_deq

      (* token type *)
      pbft_token

      (* token decider *)
      pbft_token_deq

      (* sending key type *)
      pbft_sending_key

      (* receiving key type *)
      pbft_receiving_key

      (* number of faults *)
      F

      (* replica type *)
      (replica F)

      (* Replica decider *)
      (replica_deq F)

      (* replica 2 nat *)
      (reps2nat F)

      (* proof that reps2nat is bijective *)
      (bijective_reps2nat F)

      (* number of clients *)
      (nclients C)

      (* client type *)
      (client C)

      (* client decider *)
      (client_deq C)

      (* client 2 nat *)
      (clients2nat C)

      (* proof that clients2nat is bijective *)
      (bijective_clients2nat C)

      (* operation type *)
      operation

      (* operation decider *)
      operation_deq

      (* result type *)
      result

      (* result decider *)
      deq_nat

      (* state type *)
      smState

      (* initial state *)
      0

      (* update function *)
      (operation_upd C)

      (* delay in ms *)
      1000.

  Definition pbft_create_signature
             (m  : PBFTBare_Msg)
             (ks : sending_keys) : PBFTtokens := [pbft_token_stub].

  Definition pbft_verify_signature
             (m : PBFTBare_Msg)
             (n : name)
             (k : receiving_key)
             (a : pbft_token) : bool := true.

  Global Instance PBFT_I_auth : PBFTauth :=
    MkPBFTauth pbft_create_signature pbft_verify_signature.

  Definition pbft_lookup_replica_sending_key   (src : Rep)    : pbft_sending_key   := pbft_sending_key_stub.
  Definition pbft_lookup_replica_receiving_key (dst : Rep)    : pbft_receiving_key := pbft_receiving_key_stub.
  Definition pbft_lookup_client_receiving_key  (c   : Client) : pbft_receiving_key := pbft_receiving_key_stub.

  Definition initial_pbft_local_key_map_replicas (src : name) : local_key_map :=
    match src with
    | PBFTreplica i =>
      MkLocalKeyMap
        [MkDSKey (map PBFTreplica reps) (pbft_lookup_replica_sending_key i)]
        (List.app
           (map (fun c => MkDRKey [PBFTclient  c] (pbft_lookup_client_receiving_key  c)) clients)
           (map (fun m => MkDRKey [PBFTreplica m] (pbft_lookup_replica_receiving_key m)) reps))
    | PBFTclient _ => MkLocalKeyMap [] []
    end.

  Global Instance PBFT_I_keys : PBFTinitial_keys :=
    MkPBFTinitial_keys initial_pbft_local_key_map_replicas.

  Definition pbft_simple_create_hash_messages (msgs : list PBFTmsg) : PBFTdigest := [].
  Definition pbft_simple_verify_hash_messages (msgs : list PBFTmsg) (d : PBFTdigest) := true.
  Definition pbft_simple_create_hash_state_last_reply (smst : PBFTsm_state) (lastr : LastReplyState) : PBFTdigest := [].
  Definition pbft_simple_verify_hash_state_last_reply (smst : PBFTsm_state) (lastr : LastReplyState) (d : PBFTdigest) := true.

  Global Instance PBFT_I_hash : PBFThash :=
    MkPBFThash
      pbft_simple_create_hash_messages
      pbft_simple_verify_hash_messages
      pbft_simple_create_hash_state_last_reply
      pbft_simple_verify_hash_state_last_reply.

  (*Lemma simple_create_hash_messages_collision_resistant :
  forall msgs1 msgs2,
    simple_create_hash_messages msgs1 = simple_create_hash_messages msgs2
    -> msgs1 = msgs2.
Proof.
  introv h.
  unfold simple_create_hash_messages in *.
Admitted.

Lemma simple_create_hash_state_last_reply_collision_resistant :
  forall sm1 sm2 last1 last2,
    simple_create_hash_state_last_reply sm1 last1 = simple_create_hash_state_last_reply sm2 last2
    -> sm1 = sm2 /\ last1 = last2.
Proof.
  introv h.
Admitted.

Global Instance PBFT_I_hash_axioms : PBFThash_axioms.
Proof.
  exact (Build_PBFThash_axioms
           (* create_hash_message is collision resistant *)
           simple_create_hash_messages_collision_resistant

           (* create_hash_state_last_reply is collision resistant *)
           simple_create_hash_state_last_reply_collision_resistant
        ).
Defined.
   *)

  (* ================== TIME ================== *)

  Definition time_I_type : Set := unit.

  Definition time_I_get_time : unit -> time_I_type := fun _ => tt.

  Definition time_I_sub : time_I_type -> time_I_type -> time_I_type := fun _ _ => tt.

  Definition time_I_2string : time_I_type -> string := fun _ => "".

  Global Instance TIME_I : Time.
  Proof.
    exists time_I_type.
    { exact time_I_get_time. }
    { exact time_I_sub. }
    { exact time_I_2string. }
  Defined.

  (* ================== PRETTY PRINTING ================== *)

  (* FIX: to replace when extracting *)
  Definition print_endline : string -> unit := fun _ => tt.
  Definition nat2string (n : nat) : string := "-".

  Definition CR : string := String (ascii_of_nat 13) "".

  (* Fix: to finish *)
  Definition tokens2string (toks : Tokens) : string := "-".

  (* Fix: to finish *)
  Definition digest2string (d : pbft_digest) : string := "-".

  (* Fix: to finish *)
  Definition result2string (r : result) : string := "-".

  (* Fix: there's only one client anyway *)
  Definition client2string (c : client C) : string := "-".

  Definition timestamp2string (ts : Timestamp) : string :=
    match ts with
    | time_stamp n => nat2string n
    end.

  Definition view2string (v : View) : string :=
    match v with
    | view n => nat2string n
    end.

  Definition seq2string (s : SeqNum) : string :=
    match s with
    | seq_num n => nat2string n
    end.

  Definition operation2string (opr : operation) : string :=
    match opr with
    | opr_add n => str_concat ["+", nat2string n]
    | opr_sub n => str_concat ["-", nat2string n]
    end.

  Definition nat_n2string {m} (n : nat_n m) : string := nat2string (proj1_sig n).

  Definition replica2string (r : replica F) : string := nat_n2string r.

  Definition bare_request2string (br : Bare_Request) : string :=
    match br with
    | null_req => str_concat [ "null_req"]
    | bare_req opr ts c => str_concat [operation2string opr, ",", timestamp2string ts, ",", client2string c]
    end.

  Definition request2string (r : Request) : string :=
    match r with
    | req br a => str_concat ["REQUEST(", bare_request2string br, ",", tokens2string a, ")"]
    end.

  Fixpoint requests2string (rs : list Request) : string :=
    match rs with
    | [] => ""
    | [r] => request2string r
    | r :: rs => str_concat [request2string r, ",", requests2string rs]
    end.

  Definition bare_pre_prepare2string (bpp : Bare_Pre_prepare) : string :=
    match bpp with
    | bare_pre_prepare v s reqs => str_concat [view2string v, ",", seq2string s, ",", requests2string reqs]
    end.

  Definition bare_prepare2string (bp : Bare_Prepare) : string :=
    match bp with
    | bare_prepare v s d i => str_concat [view2string v, ",", seq2string s, ",", digest2string d, ",", replica2string i]
    end.

  Definition bare_commit2string (bc : Bare_Commit) : string :=
    match bc with
    | bare_commit v s d i => str_concat [view2string v, ",", seq2string s, ",", digest2string d, ",", replica2string i]
    end.

  Definition bare_reply2string (br : Bare_Reply) : string :=
    match br with
    | bare_reply v ts c i res => str_concat [view2string v, ",", timestamp2string ts, ",", client2string c, ",", replica2string i, ",", result2string res]
    end.

  Definition pre_prepare2string (pp : Pre_prepare) : string :=
    match pp with
    | pre_prepare b a => str_concat ["PRE_PREPARE(",bare_pre_prepare2string b, ",", tokens2string a, ")"]
    end.

  Definition prepare2string (p : Prepare) : string :=
    match p with
    | prepare bp a => str_concat ["PREPARE(", bare_prepare2string bp, ",", tokens2string a, ")"]
    end.

  Definition commit2string (c : Commit) : string :=
    match c with
    | commit bc a => str_concat ["COMMIT(", bare_commit2string bc, ",", tokens2string a, ")"]
    end.

  Definition reply2string (r : Reply) : string :=
    match r with
    | reply br a => str_concat ["REPLY(", bare_reply2string br, ",", tokens2string a, ")"]
    end.

  Definition debug2string (d : Debug) : string :=
    match d with
    | debug r s => str_concat ["DEBUG(", replica2string r, ",", s, ")"]
    end.

  Definition bare_checkpoint2string (bc : Bare_Checkpoint) : string :=
    match bc with
    | bare_checkpoint v n d i => str_concat [view2string v, ",", seq2string n, ",", digest2string d, ",", replica2string i]
    end.

  Definition checkpoint2string (c : Checkpoint) : string :=
    match c with
    | checkpoint bc a => str_concat ["CHECKPOINT(", bare_checkpoint2string bc, ",", tokens2string a, ")"]
    end.

  Definition check_ready2string (c : CheckReady) : string := "CHECK-READY()".

  Definition check_stable2string (c : CheckStableChkPt) : string := "CHECK-STABLE()".

  Definition start_timer2string (t : StartTimer) : string :=
    match t with
    | start_timer r v => str_concat ["START-TIMER(", bare_request2string r, "," , view2string v, ")"]
    end.

  Definition expired_timer2string (t : ExpiredTimer) : string :=
    match t with
    | expired_timer r v => str_concat ["EXPIRED-TIMER(", bare_request2string r, "," , view2string v, ")"]
    end.

  (* FIX *)
  Definition stable_chkpt2string (stable : StableChkPt) : string := "-".

  (* FIX *)
  Definition checkpoint_cert2string (cert : CheckpointCert) : string := "-".

  (* FIX *)
  Definition prepared_infos2string (l : list PreparedInfo) : string := "-".

  Definition bare_view_change2string (bvc : Bare_ViewChange) : string :=
    match bvc with
    | bare_view_change v n stable cert preps i =>
      str_concat
        [view2string v,
         ",",
         seq2string n,
         ",",
         stable_chkpt2string stable,
         ",",
         checkpoint_cert2string cert,
         ",",
         prepared_infos2string preps,
         ",",
         replica2string i
        ]
    end.

  Definition view_change2string (vc : ViewChange) : string :=
    match vc with
    | view_change bvc a => str_concat ["VIEW-CHANGE(", bare_view_change2string bvc, ",", tokens2string a, ")"]
    end.

  (* FIX *)
  Definition view_change_cert2string (V : ViewChangeCert) : string := "-".

  Fixpoint pre_prepares2string (l : list Pre_prepare) : string :=
    match l with
    | [] => ""
    | [r] => pre_prepare2string r
    | r :: rs => str_concat [pre_prepare2string r, ",", pre_prepares2string rs]
    end.

  Definition bare_new_view2string (bnv : Bare_NewView) : string :=
    match bnv with
    | bare_new_view v V OP NP =>
      str_concat
        [
          view2string v,
          ",",
          view_change_cert2string V,
          ",",
          pre_prepares2string OP,
          ",",
          pre_prepares2string NP
        ]
    end.

  Definition new_view2string (nv : NewView) : string :=
    match nv with
    | new_view bnv a => str_concat ["NEW-VIEW(", bare_new_view2string bnv, ",", tokens2string a, ")"]
    end.

  Definition check_bcast_new_view2string (c : CheckBCastNewView) : string :=
    match c with
    | check_bcast_new_view i => str_concat ["CHECK-BCAST-NEW-VIEW(", nat2string i, ")"]
    end.

  Definition msg2string (m : PBFTmsg) : string :=
    match m with
    | PBFTrequest r              => request2string r
    | PBFTpre_prepare pp         => pre_prepare2string pp
    | PBFTprepare p              => prepare2string p
    | PBFTcommit c               => commit2string c
    | PBFTcheckpoint c           => checkpoint2string c
    | PBFTcheck_ready c          => check_ready2string c
    | PBFTcheck_stable c         => check_stable2string c
    | PBFTcheck_bcast_new_view c => check_bcast_new_view2string c
    | PBFTstart_timer t          => start_timer2string t
    | PBFTexpired_timer t        => expired_timer2string t
    | PBFTview_change v          => view_change2string v
    | PBFTnew_view v             => new_view2string v
    | PBFTdebug d                => debug2string d
    | PBFTreply r                => reply2string r
    end.

  Definition name2string (n : name) : string :=
    match n with
    | PBFTreplica r => replica2string r
    | PBFTclient c => client2string c
    end.

  Fixpoint names2string (l : list name) : string :=
    match l with
    | [] => ""
    | [n] => name2string n
    | n :: ns => str_concat [name2string n, ",", names2string ns]
    end.

  Definition delay2string (delay : PosDTime) : string := "-".

  Definition DirectedMsg2string (dm : DirectedMsg) : string :=
    match dm with
    | MkDMsg msg dst delay =>
      str_concat [msg2string msg, ":", "[", names2string dst, "]", ":", delay2string delay]
    end.

  Fixpoint DirectedMsgs2string (l : DirectedMsgs) : string :=
    match l with
    | [] => ""
    | [dm] => DirectedMsg2string dm
    | dm :: dmsgs => str_concat [DirectedMsg2string dm, CR, DirectedMsgs2string dmsgs]
    end.

  Definition TimedDirectedMsg2string (m : TimedDirectedMsg) : string :=
    match m with
    | MkTimedDMsg dm time => str_concat [DirectedMsg2string dm, ":", time_I_2string time]
    end.

  Fixpoint TimedDirectedMsgs2string (l : TimedDirectedMsgs) : string :=
    match l with
    | [] => ""
    | [dm] => TimedDirectedMsg2string dm
    | dm :: dmsgs => str_concat [TimedDirectedMsg2string dm, CR, TimedDirectedMsgs2string dmsgs]
    end.

  Definition MonoSimulationState2string (s : MonoSimulationState) : string :=
    match s with
    | MkMonoSimState ty sys step out_inflight in_inflight delivered =>
      str_concat
        [CR,
         "====== STEP ======",
         CR,
         nat2string step,
         CR,
         "====== IN FLIGHT (from outside the system) ======",
         CR,
         DirectedMsgs2string out_inflight,
         CR,
         "====== IN FLIGHT (from inside the system) ======",
         CR,
         DirectedMsgs2string in_inflight,
         CR,
         "====== DELIVERED ======",
         CR,
         TimedDirectedMsgs2string delivered,
         CR]
    end.

  Definition pbft_state2string (s : PBFTstate) :=
      str_concat
        ["(checkpoint state size:"
         , nat2string (List.length (chk_state_others (cp_state s)))
         ,")"
         ,"(ready size:"
         , nat2string (List.length (ready s))
         ,")"
         ,"(buffered requests:"
         , nat2string (List.length (request_buffer (primary_state s)))
         ,")"
         ,"(log size:"
         , nat2string (List.length (log s))
         ,")"
        ].

  (* ================== SYSTEM ================== *)

  Definition dummy_initial_state : PBFTstate :=
    Build_State
      (MkLocalKeyMap [] [])
      initial_view
      []
      initial_checkpoint_state
      PBFTsm_initial_state
      initial_next_to_execute
      initial_ready
      initial_last_reply
      initial_view_change_state
      initial_primary_state.

  Definition PBFTdummySM : MStateMachine PBFTstate :=
    MhaltedSM dummy_initial_state.

  Definition PBFTmono_sys : NMStateMachine PBFTstate := PBFTreplicaSM.

  Definition mk_request_to (rep : Rep) (ts : nat) (opr : nat) : DirectedMsg :=
    let ts   := time_stamp ts in
    let breq := bare_req (opr_add opr) ts (client0 C) in
    let dst  := PBFTreplica rep in (* the leader *)
    let toks := [ pbft_token_stub ] : Tokens in (* we just send empty lists here to authenticate messages *)
    let req  := req breq toks in
    let msg  := PBFTrequest req in
    MkDMsg msg [dst] ('0).

  Definition mk_request (ts : nat) (opr : nat) : DirectedMsg :=
    mk_request_to (PBFTprimary initial_view) ts opr.

  (* n request starting with number start *)
  Fixpoint mk_requests_start (n start opr : nat) : DirectedMsgs :=
    match n with
    | 0 => []
    | S m => List.app (mk_requests_start m start opr) [mk_request (n + start) opr]
    end.

  Definition mk_requests (n opr : nat) : DirectedMsgs :=
    mk_requests_start n 0 opr.

  Record InitRequests :=
    MkInitRequests
      {
        num_requests     : nat;
        starting_seq_num : nat;
        req_operation    : nat;
      }.

  Definition PBFTinit_msgs (msgs : DirectedMsgs) : MonoSimulationState :=
    MkInitMonoSimState PBFTmono_sys msgs.

  Definition PBFTinit (init : InitRequests) : MonoSimulationState :=
    PBFTinit_msgs
      (mk_requests_start
         (num_requests init)
         (starting_seq_num init)
         (req_operation init)).

  Definition PBFTsimul_list (init : InitRequests) (L : list nat) : MonoSimulationState :=
    mono_run_n_steps L (PBFTinit init).

  Definition PBFTsimul_list_msgs (msgs : DirectedMsgs) (L : list nat) : MonoSimulationState :=
    mono_run_n_steps L (PBFTinit_msgs msgs).

  (* [switch] is the list of steps at which we want to switch to sending messages
   coming from the outside (from clients) instead of keeping on sending messages
   coming from the inside (from replicas). *)
  Definition PBFTsimul_n
             (init     : InitRequests) (* This is to generate an initial list of requests *)
             (rounds   : Rounds)
             (switches : Switches) : MonoSimulationState :=
    mono_iterate_n_steps rounds switches (PBFTinit init).

  Definition PBFTsimul_n_msgs
             (msgs     : DirectedMsgs)
             (rounds   : Rounds)
             (switches : Switches) : MonoSimulationState :=
    mono_iterate_n_steps rounds switches (PBFTinit_msgs msgs).

End PBFTinstance.

(* ================== EXTRACTION ================== *)

Extraction Language Ocaml.

(* printing stuff *)
Extract Inlined Constant print_endline => "Prelude.print_coq_endline".
Extract Inlined Constant nat2string    => "Prelude.char_list_of_int".
Extract Inlined Constant CR            => "['\n']".

(* numbers *)
Extract Inlined Constant Nat.modulo    => "(mod)".

(* lists *)
Extract Inlined Constant forallb => "List.for_all".
Extract Inlined Constant existsb => "List.exists".
Extract Inlined Constant length  => "List.length".
Extract Inlined Constant app     => "List.append".
Extract Inlined Constant map     => "List.map".
Extract Inlined Constant filter  => "List.filter".

(* timing stuff *)
Extract Inlined Constant time_I_type     => "float".
Extract Inlined Constant time_I_get_time => "Prelude.Time.get_time".
Extract Inlined Constant time_I_sub      => "Prelude.Time.sub_time".
Extract Inlined Constant time_I_2string  => "Prelude.Time.time2string".

(* == crypto stuff == *)
(* === COMMENT OUT THIS PART IF YOU DON'T WANT TO USE KEYS === *)
Extract Inlined Constant pbft_sending_key   => "Nocrypto.Rsa.priv".
Extract Inlined Constant pbft_receiving_key => "Nocrypto.Rsa.pub".
Extract Inlined Constant pbft_lookup_replica_sending_key   => "RsaKeyFun.lookup_replica_sending_key".
Extract Inlined Constant pbft_lookup_replica_receiving_key => "RsaKeyFun.lookup_replica_receiving_key".
Extract Inlined Constant pbft_lookup_client_receiving_key  => "RsaKeyFun.lookup_client_receiving_key".

Extract Inlined Constant pbft_create_signature => "RsaKeyFun.sign_list".
Extract Inlined Constant pbft_verify_signature => "RsaKeyFun.verify_one".
Extract Inlined Constant pbft_token => "Cstruct.t".
Extract Inlined Constant pbft_token_deq => "(=)".
(* === --- === *)

(* == hashing stuff == *)
Extract Inlined Constant pbft_digest => "Cstruct.t".
Extract Inlined Constant pbft_digest_deq => "(=)".
Extract Inlined Constant pbft_simple_create_hash_messages => "Obj.magic (Hash.create_hash_objects)".
Extract Inlined Constant pbft_simple_verify_hash_messages => "Obj.magic (Hash.verify_hash_objects)".
Extract Inlined Constant pbft_simple_create_hash_state_last_reply => "Obj.magic (Hash.create_hash_pair)".
Extract Inlined Constant pbft_simple_verify_hash_state_last_reply => "Obj.magic (Hash.verify_hash_pair)".
(* === --- === *)

Require Export ExtrOcamlBasic.
Require Export ExtrOcamlNatInt.
Require Export ExtrOcamlString.

Definition local_replica (*(F C : nat)*) :=
  @PBFTreplicaSM
    (@PBFT_I_context (*(MkNumNodes F C)*))
    PBFT_I_auth
    PBFT_I_keys
    PBFT_I_hash.

Extraction "PbftReplica.ml" pbft_state2string lrun_sm MonoSimulationState2string PBFTdummySM local_replica.


Require Import Reals Psatz.
From iris.program_logic Require Export weakestpre.
From iris.base_logic.lib Require Export invariants sts.
From iris.heap_lang Require Export lang.
From iris.proofmode Require Import tactics.
From iris.heap_lang Require Import proofmode notation spawn.
From iris.algebra Require Import excl agree csum frac.
From discprob.idxval Require Import pival
     pival_dist ival_dist irrel_equiv idist_pidist_pair extrema.

Program Definition flip_half := pidist_plus (1/2)%R _ (mret true) (mret false).
Next Obligation.
  abstract (nra).
Qed.

Definition one_shotR := csumR (fracR) (agreeR boolC).
Class one_shotG Σ := { one_shot_inG :> inG Σ one_shotR }.

Section proof.
Context `{!heapG Σ, !spawnG Σ, !probG Σ, !one_shotG Σ}.

Definition Pending q : one_shotR := (Cinl q : one_shotR).
Definition Shot (b: bool) : one_shotR := (Cinr (to_agree b) : one_shotR).

Global Instance shot_persistent γ b : Persistent (own γ (Shot b)).
Proof. apply _. Qed.

(* TODO: there's no need to have the starting thread wrap up their ownership into
   this one shot inv; and the flip_inv should not hold "one_shot_inv" but rather
   just the status of the shot. *)
Definition one_shot_inv (γ : gname) (l : loc) : iProp Σ :=
  (l ↦ NONEV ∨ ∃ b : bool, (l ↦  NONEV ∨ l ↦ SOMEV #b ∗ own γ (Shot b)))%I.

Definition mapsto_shot l (ob : option bool) : iProp Σ :=
  match ob with
    | None => (∃ N γ, inv N (one_shot_inv γ l))%I
    | Some b => (∃ N γ, inv N (one_shot_inv γ l) ∗ own γ (Shot b))%I
  end.

Definition flip_inv (γ : gname) (γ1 γ2: gname) : iProp Σ :=
  ((ownProb flip_half ∗ own γ1 (Pending (1/2)%Qp) ∗ own γ2 (Pending (1/2)%Qp)) ∨
   (∃ b, ownProb flip_half ∗ own γ1 (Shot b) ∗ own γ2 (Pending (1/2)%Qp)) ∨
   (∃ b, ownProb flip_half ∗ own γ1 (Pending (1/2)%Qp) ∗ own γ2 (Shot b)) ∨
   (∃ b1 b2, (own γ (Excl ()) ∨ ownProb (mret (eqb b1 b2)))
                     ∗ own γ1 (Shot b1) ∗ own γ2 (Shot b2)))%I.

Lemma mapsto_shot_load N γ l:
  {{{ inv N (one_shot_inv γ l) }}} Load (Lit (LitLoc l))
  {{{ v, RET v;
      match v with
      | NONEV => True
      | SOMEV #b => ∃ b', ⌜ (LitBool b') = b ⌝ ∗ own γ (Shot b')
      | _  => False
      end}}}.
Proof.
  iIntros (Φ) "#Hinv Hwand".
  iInv N as ">[Hnone|Hsome]" "Hclose".
  - wp_load. iApply "Hwand". iMod ("Hclose" with "[Hnone]").
    { iNext. iRight. iExists true. iLeft. iFrame. }
    done.
  - iDestruct "Hsome" as (b') "[Hnone|(Hsome&#Hshot')]".
    * wp_load. iApply "Hwand". iMod ("Hclose" with "[Hnone]").
      { iNext. iRight. iExists true. iLeft. iFrame. }
      iModIntro. done.
    * wp_load. iApply "Hwand".
      iMod ("Hclose" with "[Hsome]").
      { iNext. iRight. iExists b'. iRight. iFrame. done. }
      iModIntro; iExists b'; iSplitR; done.
Qed.

Lemma mapsto_shot_load_some N γ l b:
  {{{ inv N (one_shot_inv γ l) ∗ own γ (Shot b) }}} Load (Lit (LitLoc l))
  {{{ v, RET v;
      match v with
      | NONEV => own γ (Shot b)
      | SOMEV #b' => ⌜ (LitBool b) = b' ⌝ ∗ own γ (Shot b)
      | _  => False
      end}}}.
Proof.
  iIntros (Φ) "(#Hinv&Hshot) Hwand".
  iInv N as ">[Hnone|Hsome]" "Hclose".
  - wp_load. iApply "Hwand". iMod ("Hclose" with "[Hnone]").
    { iNext. iRight. iExists true. iLeft. iFrame. }
    done.
  - iDestruct "Hsome" as (b') "[Hnone|(Hsome&Hshot')]".
    * wp_load. iApply "Hwand". iMod ("Hclose" with "[Hnone]").
      { iNext. iRight. iExists true. iLeft. iFrame. }
      iModIntro. done.
    * wp_load. iApply "Hwand".
      iDestruct (own_valid_2 with "Hshot Hshot'") as %?%agree_op_invL'; subst.
      iMod ("Hclose" with "[Hshot' Hsome]").
      { iNext. iRight. iExists b'. iRight. iFrame. }
      iModIntro; iSplitR; done.
Qed.

Lemma mapsto_shot_store_some N γ l b:
  {{{ inv N (one_shot_inv γ l) ∗ own γ (Shot b) }}}
    Store (Lit (LitLoc l)) (SOMEV (LitV $ LitBool b))
  {{{ RET #(); own γ (Shot b) }}}.
Proof.
  iIntros (Φ) "(#Hinv&Hshot) Hwand".
  iInv N as ">[Hnone|Hsome]" "Hclose".
  - wp_store. iApply "Hwand".
      iAssert (own γ (Shot b) ∗ own γ (Shot b))%I with "[Hshot]" as "(Hshot1&Hshot2)".
      { rewrite -own_op Cinr_op //=
        -(proj1 (agree_included (to_agree b) (to_agree b))); last reflexivity.
        iFrame. }
      iMod ("Hclose" with "[Hshot1 Hnone]").
      { iNext. iRight. iExists b. iRight. iFrame. }
      iModIntro. done.
  - iDestruct "Hsome" as (b') "[Hnone|(Hsome&Hshot')]".
    * wp_store. iApply "Hwand".
      iAssert (own γ (Shot b) ∗ own γ (Shot b))%I with "[Hshot]" as "(Hshot1&Hshot2)".
      { rewrite -own_op Cinr_op //=
        -(proj1 (agree_included (to_agree b) (to_agree b))); last reflexivity.
        iFrame. }
      iMod ("Hclose" with "[Hshot1 Hnone]").
      { iNext. iRight. iExists b. iRight. iFrame. }
      iModIntro. done.
    * wp_store. iApply "Hwand".
      iDestruct (own_valid_2 with "Hshot Hshot'") as %?%agree_op_invL'; subst.
      iMod ("Hclose" with "[Hshot' Hsome]").
      { iNext. iRight. iExists b'. iRight. iFrame. }
      iModIntro. done.
Qed.

Lemma flip_inv_commit N γ γ1 γ2 γ':
  γ' = γ1 ∨ γ' = γ2 →
  {{{ inv N (flip_inv γ γ1 γ2) ∗ own γ' (Pending (1/2)%Qp) }}}
    flip #1 #2
  {{{ b, RET (LitV $ LitBool b); own γ' (Shot b) }}}.
Proof.
  intros Heq.
  iIntros (Φ) "(#Hinv&Hγ') Hwand".
  iInv N as ">[Hprob|[Hprob|[Hprob|Hprob]]]" "Hclose".
  * iDestruct "Hprob" as "(Hprob&Hγ1&Hγ2)".
    setoid_rewrite <-(pidist_left_id tt (λ x, flip_half)) at 1.
    unshelve (wp_flip (mret tt) (λ x y, True) b t HR); first by abstract (nra).
    { apply irrel_coupling_trivial. }
    destruct Heq as [Heq|Heq]; subst.
    ** iMod (own_update γ1 (Pending 1%Qp) with "[Hγ' Hγ1]") as "#Hγ'".
       { by apply cmra_update_exclusive with (y:=Shot b). }
       { iCombine "Hγ'" "Hγ1" as "H".
         rewrite //=. rewrite Cinl_op frac_op'. rewrite /Pending.
         by rewrite Qp_div_2. }
       iMod ("Hclose" with "[Hprob Hγ2]").
       { iNext. iRight. iLeft. iExists b. iFrame. done. }
       iModIntro.
       iApply "Hwand"; done.
    ** iMod (own_update γ2 (Pending 1%Qp) with "[Hγ' Hγ2]") as "#Hγ'".
       { by apply cmra_update_exclusive with (y:=Shot b). }
       { iCombine "Hγ'" "Hγ2" as "H".
         rewrite //=. rewrite Cinl_op frac_op'. rewrite /Pending.
         by rewrite Qp_div_2. }
       iMod ("Hclose" with "[Hprob Hγ1]").
       { iNext. iRight. iRight. iLeft. iExists b. iFrame. done. }
       iModIntro.
       iApply "Hwand"; done.
  * destruct Heq as [Heq1|Heq2]; subst.
    { iDestruct "Hprob" as (b) "(Hprob&Hshot&?)".
      iDestruct (own_valid_2 with "Hγ' Hshot") as "%".
      exfalso; auto. }

    iDestruct "Hprob" as (b) "(Hprob&Hshot1&Hshot2)".
    setoid_rewrite <-pidist_right_id.
    unshelve (wp_flip flip_half (λ x y, match b, x with
                                               | true, true => y = true
                                               | false, false => y = true
                                               | _, _ => y = false
                                               end) c c' HRc); first by abstract (nra).
    { apply ip_irrel_coupling.
      destruct b.
      * eapply ip_coupling_plus; first (by reflexivity);
          apply ip_coupling_mret; auto.
      * assert (0 <= 1 - (IZR 1 /IZR 2) <= 1)%R by nra.
        eapply (ip_coupling_proper (ivdplus _ H (mret false) (mret true))).
        { symmetry. eapply ivdplus_comm. }
        { reflexivity.  }
        assert (1 - (IZR 1 / IZR 2) = IZR 1 / IZR 2)%R as Hzeq.
        { nra.  }
        generalize H.
        rewrite Hzeq => ?.
        eapply ip_coupling_plus; first (by reflexivity);
          apply ip_coupling_mret; auto.
    }
    iMod (own_update _ (Pending 1%Qp) with "[Hγ' Hshot2]") as "#Hγ'".
    { by apply cmra_update_exclusive with (y:=Shot c). }
    { iCombine "Hγ'" "Hshot2" as "H".
         rewrite //=. rewrite Cinl_op frac_op'. rewrite /Pending.
         by rewrite Qp_div_2. }
    iMod ("Hclose" with "[Hprob Hshot1]").
    { iNext. iRight. iRight. iRight.
      iExists b, c. iFrame. iFrame "Hγ'".
      iRight. iFrame.
      destruct b, c, c' => //=.
    }
    iModIntro.
    iApply "Hwand". done.
  * destruct Heq as [Heq1|Heq2]; subst; last first.
    { iDestruct "Hprob" as (b) "(Hprob&_&Hshot)".
      iDestruct (own_valid_2 with "Hγ' Hshot") as "%".
      exfalso; auto. }
    iDestruct "Hprob" as (b) "(Hprob&Hshot1&Hshot2)".
    setoid_rewrite <-pidist_right_id.
    unshelve (wp_flip flip_half (λ x y, match b, x with
                                               | true, true => y = true
                                               | false, false => y = true
                                               | _, _ => y = false
                                               end) c c' HRc); first by abstract (nra).
    { apply ip_irrel_coupling.
      destruct b.
      * eapply ip_coupling_plus; first (by reflexivity);
          apply ip_coupling_mret; auto.
      * assert (0 <= 1 - (IZR 1 /IZR 2) <= 1)%R by nra.
        eapply (ip_coupling_proper (ivdplus _ H (mret false) (mret true))).
        { symmetry. eapply ivdplus_comm. }
        { reflexivity.  }
        assert (1 - (IZR 1 / IZR 2) = IZR 1 / IZR 2)%R as Hzeq.
        { nra.  }
        generalize H.
        rewrite Hzeq => ?.
        eapply ip_coupling_plus; first (by reflexivity);
          apply ip_coupling_mret; auto.
    }
    iMod (own_update _ (Pending 1%Qp) with "[Hγ' Hshot1]") as "#Hγ'".
    { by apply cmra_update_exclusive with (y:=Shot c). }
    { iCombine "Hγ'" "Hshot1" as "H".
         rewrite //=. rewrite Cinl_op frac_op'. rewrite /Pending.
         by rewrite Qp_div_2. }
    iMod ("Hclose" with "[Hprob Hshot2]").
    { iNext. iRight. iRight. iRight.
      iExists c, b. iFrame. iFrame "Hγ'".
      iRight. iFrame.
      destruct b, c, c' => //=.
    }
    iModIntro.
    iApply "Hwand". done.
  * iDestruct "Hprob" as (b1 b2) "(Hprob&Hshot1&Hshot2)".
    destruct Heq as [Heq1|Heq2]; subst.
    ** iDestruct (own_valid_2 with "Hγ' Hshot1") as "%".
       exfalso; auto.
    ** iDestruct (own_valid_2 with "Hγ' Hshot2") as "%".
       exfalso; auto.
Qed.

Lemma join_spec N γ l :
  {{{ inv N (one_shot_inv γ l) }}} join #l {{{ b, RET (LitV $ LitBool b); own γ (Shot b) }}}.
Proof.
  iIntros (Φ) "#Hinv Hwand".
  iLöb as "IH". wp_rec. wp_bind (! _)%E.
  wp_apply mapsto_shot_load; eauto.
  iIntros (v) "Hret". destruct v; eauto.
  * wp_match. wp_apply "IH"; auto.
  * wp_match. destruct v; eauto.
    iDestruct "Hret" as (b) "(%&Hshot)"; subst.
    iApply "Hwand". done.
Qed.

Definition join : val :=
  rec: "join" "c" :=
    match: !"c" with
      SOME "x" => "x"
    | NONE => "join" "c"
    end.

Definition concurrent_flip : expr :=
  let: "l" := ref NONE in
  Fork ("l" <- SOME (flip #1 #2)) ;;
  let: "b" := flip #1 #2 in
  let: "ret" := App join "l" in
  "b" = "ret".

Lemma cflip_spec  :
  ownProb flip_half ⊢
          WP concurrent_flip {{ v, ∃ v', ownProb (mret v') ∗
                                                 ⌜ v = LitV $ LitBool v' ⌝ }}%I.
Proof.
  iIntros "Hprob". rewrite /concurrent_flip.
  wp_alloc l2 as "Hl2". wp_let.
  iMod (own_alloc (Pending 1%Qp)) as (γ1) "Hγ1"; first done.
  rewrite -[a in Pending a](Qp_div_2 1). rewrite /Pending -frac_op' -Cinl_op.
  iDestruct "Hγ1" as "(Hγ1a&Hγ1b)".

  iMod (own_alloc (Pending 1%Qp)) as (γ2) "Hγ2"; first done.
  rewrite -[a in Pending a](Qp_div_2 1). rewrite /Pending -frac_op' -Cinl_op.
  iDestruct "Hγ2" as "(Hγ2a&Hγ2b)".

  pose proof (nroot .@ "N1") as N1.
  pose proof (nroot .@ "N2") as N2.
  iMod (inv_alloc N1 _ (one_shot_inv γ2 l2) with "[Hl2]") as "#HN1".
  { iNext. rewrite /one_shot_inv. iLeft. iFrame. }

  iMod (own_alloc (Excl ())) as (γ) "Hγ"; first done.
  iMod (inv_alloc N2 _ (flip_inv γ γ1 γ2) with "[Hprob Hγ1b Hγ2b]") as "#HN2".
  { iNext. rewrite /flip_inv. iLeft. iFrame. }

  wp_apply wp_fork.
  iSplitR "Hγ2a"; last first.
  - wp_bind (flip #1 #2).
    wp_apply (flip_inv_commit N2 γ γ1 γ2 γ2 with "[Hγ2a]"); auto.
    iIntros (b) "#Hγ2".
    wp_apply (mapsto_shot_store_some with "[Hγ2]"); eauto.
  - wp_let. wp_bind (flip #1 #2).
    wp_apply (flip_inv_commit N2 γ γ1 γ2 γ1 with "[Hγ1a]"); auto.
    iIntros (b) "#Hγ1".
    wp_let. wp_apply join_spec; eauto.
    iIntros (b') "#Hγ2".
    wp_let.
    iInv N2 as ">[(_&Hγ1'&_)|[Hprob|[Hprob|Hprob]]]" "Hclose".
    { iDestruct (own_valid_2 with "Hγ1 Hγ1'") as "%".
      exfalso; auto. }
    { iDestruct "Hprob" as (?) "(_&_&Hγ2')".
      iDestruct (own_valid_2 with "Hγ2 Hγ2'") as "%".
      exfalso; auto. }
    { iDestruct "Hprob" as (?) "(_&Hγ1'&_)".
      iDestruct (own_valid_2 with "Hγ1 Hγ1'") as "%".
      exfalso; auto. }
    iDestruct "Hprob" as (b1 b2) "(Hprob&Hγ1'&Hγ2')".
    iDestruct (own_valid_2 with "Hγ1 Hγ1'") as %?%agree_op_invL'; subst.
    iDestruct (own_valid_2 with "Hγ2 Hγ2'") as %?%agree_op_invL'; subst.
    iDestruct "Hprob" as "[Htok|Hprob]".
    { iDestruct (own_valid_2 with "Hγ Htok") as "%".
      exfalso; auto. }
    wp_op.
    iMod ("Hclose" with "[Hγ]").
    { iNext.  iRight. iRight. iRight. iExists b1, b2. iFrame "Hγ1 Hγ2".
      iLeft. done. }
    iModIntro. iExists (eqb b1 b2). iFrame.
    iPureIntro. destruct b1, b2 => //=.
Qed.
End proof.


From Perennial.program_proof.lockservice Require Import lockservice_nocrash.
From Perennial.program_logic Require Export weakestpre.
From Perennial.goose_lang Require Import prelude.
From Perennial.goose_lang Require Import ffi.disk_prelude.
From Perennial.goose_lang Require Import notation.
From Perennial.program_proof Require Import disk_prelude.
From stdpp Require Import gmap.
From RecordUpdate Require Import RecordUpdate.
From Perennial.algebra Require Import auth_map.
From Perennial.goose_lang.lib Require Import lock.
From Perennial.Helpers Require Import NamedProps.
From iris.algebra Require Import numbers.

Section lockservice_proof.
Context `{!heapGS Σ}.
Context `{!mapG Σ u64 bool}.
Context `{!mapG Σ u64 unit}.
Context `{!ghost_varG Σ bool}.

Definition Nclient := nroot .@ "client".
Definition Nserver := nroot .@ "server".
Parameter (P : iProp Σ).
Instance tp : Timeless P. Admitted.

Definition server_inner γi γp γc : iProp Σ :=
  ∃ (issued : gmap u64 unit) (processed : gmap u64 bool) (claimed : gmap u64 bool) (locked : bool),
    "Hissued" ∷ ([∗ map] _ ↦ _; _ ∈ issued; processed, True) ∗
    "Hprocessed" ∷ ([∗ map] _ ↦ proc; claim ∈ processed; claimed, ⌜proc = false \/ claim = true⌝ ∨ P) ∗
    "Hctxi" ∷ map_ctx γi 1 issued ∗
    "Hctxp" ∷ map_ctx γp 1 processed ∗
    "Hctxc" ∷ map_ctx γc 1 claimed ∗
    "Hprocro" ∷ ([∗ map] reqid ↦ proc ∈ processed, reqid [[γp]]↦ false ∨ reqid [[γp]]↦ro true) ∗
    "Havail" ∷ (⌜locked=true⌝ ∨ P).

Definition client_req_inner γi γc returned reqid : iProp Σ :=
  "#Hissue" ∷ reqid [[γi]]↦ro () ∗
  "Hreply" ∷ ( ghost_var returned (1/2) false ∗ reqid [[γc]]↦ false ∨
               ghost_var returned (1/2) false ∗ reqid [[γc]]↦ro true ∗ P ∨
               ghost_var returned (1/2) true ∗ reqid [[γc]]↦ro true ).

Definition request_token γi reqid : iProp Σ :=
  "Hreq_tok" ∷ reqid [[γi]]↦ro ().

Definition response_token γp reqid acquired : iProp Σ :=
  "Hresp_tok" ∷ ⌜acquired=false⌝ ∨ reqid [[γp]]↦ro true.

Theorem client_allocates_reqid γi γp γc reqid :
  inv Nserver (server_inner γi γp γc)
  ={⊤}=∗
  ∃ returned,
    inv Nclient (client_req_inner γi γc returned reqid) ∗
    ghost_var returned (1/2) false.
Proof.
  iIntros "#H".
  iInv "H" as ">Hinner" "Hclose".
  iNamed "Hinner".
  destruct (issued !! reqid) eqn:Hissue.
  { (* Need some kind of assumption that this reqid has not been used yet. *)
    admit.
  }

  iDestruct (big_sepM2_lookup_l_none with "Hissued") as %Hproc; eauto.
  iDestruct (big_sepM2_lookup_l_none with "Hprocessed") as %Hclaim; eauto.

  iMod (map_alloc_ro _ tt with "Hctxi") as "[Hctxi #Hissue]"; eauto.
  iMod (map_alloc _ false with "Hctxp") as "[Hctxp Hproc]"; eauto.
  iMod (map_alloc _ false with "Hctxc") as "[Hctxc Hclaim]"; eauto.

  iDestruct (big_sepM2_insert _ _ _ _ tt false with "[$Hissued]") as "Hissued"; eauto.
  iDestruct (big_sepM2_insert _ _ _ _ false false with "[$Hprocessed]") as "Hprocessed"; eauto.
  iDestruct (big_sepM_insert with "[$Hprocro $Hproc]") as "Hprocro"; eauto.

  iMod (ghost_var_alloc false) as (returned) "[Hret1 Hret2]".

  iMod ("Hclose" with "[-Hclaim Hret1 Hret2]") as "_".
  { iExists _, _, _, _. iFrame. }

  iMod (inv_alloc with "[Hclaim Hret1]") as "Hc".
  2: { iModIntro. iExists returned. iFrame. }

  iFrame "#".
  iLeft. iFrame.
Admitted.

Theorem client_generates_request γi γc returned reqid :
  inv Nclient (client_req_inner γi γc returned reqid)
  ={⊤}=∗
  request_token γi reqid.
Proof.
  iIntros "#H".
  iInv "H" as ">Hinner" "Hclose".
  iNamed "Hinner".
  iFrame "Hissue".
  iApply "Hclose".
  iFrame. iFrame "#".
Qed.

Theorem server_processes_request γi γp γc reqid :
  inv Nserver (server_inner γi γp γc) -∗
  request_token γi reqid
  ={⊤}=∗
  ∃ acquired, response_token γp reqid acquired.
Proof.
  iIntros "#H #Hreq".
  iInv "H" as ">Hinner" "Hclose".
  iNamed "Hinner".
  iDestruct (map_valid with "Hctxi Hreq") as %Hreq.
  iDestruct (big_sepM2_lookup_l_some with "Hissued") as (proc) "%"; eauto.
  destruct proc.
  - iDestruct (big_sepM_lookup_acc with "Hprocro") as "[Hdupreply Hprocro]"; eauto.
    iDestruct "Hdupreply" as "[Hdupreply|#Hdupreply]".
    { iDestruct (map_valid with "Hctxp Hdupreply") as "%". congruence. }
    iFrame "Hdupreply".
    iDestruct ("Hprocro" with "[$Hdupreply]") as "Hprocro".
    iExists true.
    iApply "Hclose". iExists _, _, _, _. iFrame.
  - destruct locked.
    + iExists false.
      iMod ("Hclose" with "[-]") as "_".
      { iExists _, _, _, _. iFrame. }
      iModIntro. iLeft. done.
    + iDestruct (big_sepM2_delete with "Hissued") as "[_ Hissued]"; eauto.
      iDestruct (big_sepM2_insert_delete with "[$Hissued]") as "Hissued".
      iDestruct (big_sepM2_lookup_l_some with "Hprocessed") as (claim) "%"; eauto.
      iDestruct (big_sepM2_delete with "Hprocessed") as "[_ Hprocessed]"; eauto.
      iDestruct (big_sepM2_insert_delete with "[$Hprocessed Havail]") as "Hprocessed".
      { iDestruct "Havail" as "[%|Havail]"; first by congruence. iFrame. }
      iDestruct (big_sepM_insert_acc with "Hprocro") as "[Hproc Hprocro]"; eauto.
      iDestruct "Hproc" as "[Hproc|Hproc]".
      2: { iDestruct (map_valid with "Hctxp Hproc") as "%". congruence. }
      iMod (map_update _ _ true with "Hctxp Hproc") as "[Hctxp Hproc]".
      iMod (map_freeze with "Hctxp Hproc") as "[Hctxp #Hproc]".
      iDestruct ("Hprocro" with "[$Hproc]") as "Hprocro".
      iExists true. iFrame "Hproc".
      iApply "Hclose". iExists _, _, _, true. iFrame.
      rewrite insert_id; eauto. rewrite insert_id; eauto. iFrame.
      iLeft. done.
Qed.

Theorem client_accepts_reply γi γp γc returned reqid :
  ghost_var returned (1/2) false -∗
  inv Nserver (server_inner γi γp γc) -∗
  inv Nclient (client_req_inner γi γc returned reqid) -∗
  response_token γp reqid true
  ={⊤}=∗
  P.
Proof.
  iIntros "Hret #Hs #Hc #Htok".
  iInv "Hc" as ">Hinner_c" "Hclose_c".
  iNamed "Hinner_c".
  iDestruct "Hreply" as "[Hnotclaimed|Hclaimed]".
  2: {
    iDestruct "Hclaimed" as "[(Hret2 & Hclaim & HP)|(Hret2 & HP)]".
    2: { iDestruct (ghost_var_agree with "Hret Hret2") as %Heq. congruence. }
    iCombine "Hret Hret2" as "Hret".
    iMod (ghost_var_update true with "Hret") as "[Hret1 Hret2]".
    iFrame.
    iApply "Hclose_c". iFrame "#". iRight. iRight. iFrame.
  }

  iDestruct "Hnotclaimed" as "[Hret2 Hnotclaimed]".

  iInv "Hs" as ">Hinner_s" "Hclose_s".
  iNamed "Hinner_s".
  iDestruct (map_valid with "Hctxc Hnotclaimed") as %Hnotclaimed.

  iMod (map_update _ _ true with "Hctxc Hnotclaimed") as "[Hctxc Hclaimed]".
  iMod (map_freeze with "Hctxc Hclaimed") as "[Hctxc #Hclaimed]".

  iDestruct (map_ro_valid with "Hctxp [Htok]") as %Hproc.
  { iDestruct "Htok" as "[%|Htok]"; first by congruence. iFrame "Htok". }

  iDestruct (big_sepM2_delete with "Hprocessed") as "[Hproc Hprocessed]"; eauto.
  iDestruct "Hproc" as "[%|Hproc]"; first by intuition congruence.

  iDestruct (big_sepM2_insert_delete _ _ _ _ true true with "[$Hprocessed]") as "Hprocessed".
  { iLeft. iRight. done. }

  iCombine "Hret Hret2" as "Hret".
  iMod (ghost_var_update true with "Hret") as "[Hret Hret2]".

  iMod ("Hclose_s" with "[-Hclose_c Hproc Hret Hret2]") as "_".
  { iExists _, _, _, _. iFrame.
    rewrite insert_id; eauto. iFrame. }

  iFrame.
  iMod ("Hclose_c" with "[-]") as "_".
  { iFrame "#". iFrame. }

  done.
Qed.

End lockservice_proof.


(*===========================================================================
    Predicates over system state: actually predicates over a subset of
    processor state, in order to define separating conjunction nicely.
  ===========================================================================*)
Require Import Ssreflect.ssreflect Ssreflect.ssrfun Ssreflect.ssrbool Ssreflect.eqtype Ssreflect.fintype Ssreflect.finfun Ssreflect.seq Ssreflect.tuple.
Require Import x86proved.bitsrep x86proved.pfun x86proved.x86.reg x86proved.x86.mem x86proved.x86.flags.
Require Import x86proved.pmap x86proved.pmapprops.
Require Import Coq.Setoids.Setoid x86proved.charge.csetoid Coq.Classes.Morphisms.

(* Importing this file really only makes sense if you also import ilogic, so we
   force that. *)
Require Export x86proved.charge.ilogic x86proved.charge.bilogic x86proved.ilogicss x86proved.charge.sepalg.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Require Import Coq.Logic.FunctionalExtensionality.

(*---------------------------------------------------------------------------
    Define partial states and lift definitions and lemmas from partial functions

    A partial state consists of
    - a partial register file
    - a partial memory map
    - a partial flag file
  ---------------------------------------------------------------------------*)

Inductive Frag := Registers | Memory | Flags.
Definition fragDom d :=
  match d with
  | Registers => RegPiece
  | Memory => PTR
  | Flags => Flag
  end.

Definition fragTgt d :=
  match d with
  | Registers => BYTE
    (* None = "memory not mapped" or "memory inaccessible".
       Access to such memory should cause a trap handler to be executed *)
  | Memory => option BYTE

    (* FlagUnspecified = "unspecified", and might not even be stable
       (e.g. two reads of the flag won't necessarily be consistent) *)
  | Flags => FlagVal
  end.

(* None = "not described" for the purposes of separation logic *)
Definition PState := forall f: Frag, fragDom f -> option (fragTgt f).

Structure StateFrag : Type := {frag:Frag; carrier:>Type}.
Canonical Structure AnyRegStateFrag := @Build_StateFrag Registers AnyReg.
Canonical Structure RegStateFrag := @Build_StateFrag Registers Reg.
Canonical Structure NonSPRegStateFrag := @Build_StateFrag Registers NonSPReg.
Canonical Structure FlagStateFrag := Build_StateFrag Flags Flag.

Definition fragOf {sf: StateFrag} (x: carrier sf) := frag sf.

Definition emptyPState : PState := fun _ => empFun _.

Definition addRegPieceToPState (s:PState) (rp:RegPiece) (v:BYTE) : PState :=
  fun (f:Frag) =>
  match f as f in Frag return fragDom f -> option (fragTgt f) with
  | Registers => fun rp' => if rp == rp' then Some v else s Registers rp'
  | Flags => s Flags
  | Memory => s Memory
  end.

Definition addFlagToPState (s:PState) f v : PState :=
  fun (fr:Frag) =>
  match fr as fr in Frag return fragDom fr -> option (fragTgt fr) with
  | Registers => s Registers
  | Flags => fun f' => if f == f' then Some v else s Flags f'
  | Memory => s Memory
  end.

Definition addBYTEToPState (s:PState) (p:PTR) b : PState :=
  fun (fr:Frag) =>
  match fr as fr in Frag return fragDom fr -> option (fragTgt fr) with
  | Memory => fun p' => if p == p' then Some (Some b) else s Memory p'
  | Registers => s Registers
  | Flags => s Flags
  end.

(*
Definition addToPState (f:Frag) (s: PState) : fragDom f -> fragTgt f -> PState :=
  match f with (* as f in Frag return fragDom f -> option (fragTgt f) with *)
  | Registers => fun r v => addRegToPState s r v
  | Flags => fun f v => addFlagToPState s f v
  | Memory => fun p v => addBYTEToPState s p v
  end.

Definition genericAddToPState (f:StateFrag) (s: PState) (x: carrier f) (v: fragTgt (frag f)) := @addToPState (frag f) s x v.

Check (fun s => genericAddToPState s EAX #0).
Definition undefRegToPState s r :=
  mkPState (fun r' => if r==r' then None else pregisters s r') (pmemory s) (pflags s) (ptrace s).
*)

(*
Definition addGenRegToPState s r v :=
  mkPState (fun r' => if r==r' then v else pregisters s r') (pmemory s) (pflags s) (ptrace s).
*)

Definition extendState (s1 s2: PState) : PState := fun f => extend (s1 f) (s2 f).
Definition stateIncludedIn (s1 s2: PState) := forall f, includedIn (s1 f) (s2 f).

Lemma stateIncludedIn_trans (s1 s2 s3:PState) :
  stateIncludedIn s1 s2 -> stateIncludedIn s2 s3 -> stateIncludedIn s1 s3.
Proof. move => H1 H2 f. by apply: includedIn_trans. Qed.

(*
Lemma stateIncludedIn_modReg : forall (s1 s2:PState) (r:AnyReg) x, stateIncludedIn s1 s2 ->
stateIncludedIn (addRegToPState s1 r x) (addRegToPState s2 r x).
Proof.
rewrite /stateIncludedIn /addRegToPState /includedIn; simpl; move => s1 s2 r v Hincl.
destruct Hincl.
split. move => r0 y.
assert (r === r0 \/ r != r0).
destruct r; destruct r0; auto.
destruct r; destruct r0; auto.
destruct n; destruct n0; auto.
destruct H1 as [H1 | H1].
rewrite H1; auto.
rewrite (negPf H1). auto.
auto.
Qed.

Lemma stateIncludedIn_modGenReg : forall (s1 s2:PState) (r:AnyReg) v, stateIncludedIn s1 s2 ->
stateIncludedIn (addGenRegToPState s1 r v) (addGenRegToPState s2 r v).
Proof.
rewrite /stateIncludedIn /addGenRegToPState /includedIn; simpl; move => s1 s2 r v Hincl.
destruct Hincl.
split. move => r0.
assert (r === r0 \/ r != r0).
destruct r; destruct r0; auto.
destruct r; destruct r0; auto.
destruct n; destruct n0; auto.
destruct H1 as [H1 | H1].
rewrite H1; auto.
rewrite (negPf H1). auto.
auto.
Qed.
*)

Definition stateSplitsAs (s s1 s2: PState) := forall f, splitsAs (s f) (s1 f) (s2 f).

Lemma stateSplitsAsIncludes s s1 s2 :
  stateSplitsAs s s1 s2 -> stateIncludedIn s1 s /\ stateIncludedIn s2 s.
Proof. move => H.
split => f. apply (proj1 (splitsAsIncludes (H f))). apply (proj2 (splitsAsIncludes (H f))).
Qed.

Lemma stateSplitsAsExtendL s s1 s2 s3 s4 : stateSplitsAs s s1 s2 -> stateSplitsAs s2 s3 s4 ->
  stateSplitsAs s (extendState s1 s3) s4.
Proof. move => H1 H2 f. by apply: splitsAsExtendL. Qed.

Lemma stateSplitsAsExtends s s1 s2 : stateSplitsAs s s1 s2 -> s = extendState s1 s2.
Proof.
  move => H.
  extensionality f.
  extensionality x.
  exact: splitsAsExtend.
Qed.

Lemma stateSplitsAs_s_emp_s s : stateSplitsAs s emptyPState s.
Proof. move => f. apply: splitsAs_f_emp_f. Qed.

Lemma stateSplitsAs_s_s_emp s : stateSplitsAs s s emptyPState.
Proof. move => f. apply: splitsAs_f_f_emp. Qed.

Lemma stateSplitsAs_s_emp_t s t : stateSplitsAs s emptyPState t -> s = t.
Proof. move => H. extensionality f.
apply: functional_extensionality. apply: splitsAs_f_emp_g. apply: H.
Qed.

Lemma stateSplitsAs_s_t_emp s t : stateSplitsAs s t emptyPState -> s = t.
Proof. move => H. extensionality f.
apply: functional_extensionality. apply: splitsAs_f_g_emp. apply: H.
Qed.

Lemma stateSplitsAs_s_t_s s t: stateSplitsAs s t s -> t = emptyPState.
Proof. move => H. extensionality f.
apply: functional_extensionality. apply: splitsAs_f_g_f. apply H.
Qed.

Lemma stateSplitsAs_s_s_t s t: stateSplitsAs s s t -> t = emptyPState.
Proof. move => H. extensionality f.
apply: functional_extensionality. apply: splitsAs_f_f_g. apply H.
Qed.

Lemma stateSplitsAsIncludedInSplitsAs f f1 f2 g :
    stateSplitsAs f f1 f2 -> stateIncludedIn f g -> exists g1, exists g2,
    stateSplitsAs g g1 g2 /\ stateIncludedIn f1 g1 /\ stateIncludedIn f2 g2.
Proof. move => H1 H2.
exists f1.
set g2 := fun fr => fun x => if f1 fr x is Some _ then None else if f2 fr x is Some y then Some y else g fr x.
exists g2.
split => //.
move => fr. apply (splitsAsIncludedInSplitsAs (H1 fr) (H2 fr)).
split => //.
move => fr. apply (splitsAsIncludedInSplitsAs (H1 fr) (H2 fr)).
Qed.

(* a version more faithful to [splitsAsIncludedInSplitsAs] *)
Lemma stateSplitsAsIncludedInSplitsAs' (f f1 f2 g: PState) :
  stateSplitsAs f f1 f2 -> stateIncludedIn f g ->
  exists g2,
  stateSplitsAs g f1 g2 /\ stateIncludedIn f2 g2.
Proof.
  move=> Hsplit Hinc.
  exists (fun fr => fun x => if f1 fr x is Some _ then None else if f2 fr x is Some y then Some y else g fr x).
  split => fr; by have [? ?] := splitsAsIncludedInSplitsAs (Hsplit fr) (Hinc fr).
Qed.

Lemma stateSplitsAs_functional s1 s2 h i : stateSplitsAs h s1 s2 -> stateSplitsAs i s1 s2 -> h = i.
Proof. move => H1 H2.
extensionality f.
specialize (H1 f). specialize (H2 f).
have H:= splitsAs_functional H1 H2.
apply: functional_extensionality.
move => x. by specialize (H x).
Qed.

Lemma stateSplitsAs_functionalArg s s1 s2 s3 : stateSplitsAs s s2 s1 -> stateSplitsAs s s3 s1 -> s2 = s3.
Proof. move => H1 H2.
extensionality f.
specialize (H1 f). specialize (H2 f).
have H := splitsAs_functionalArg H1 H2.
apply: functional_extensionality.
move => x. by specialize (H x).
Qed.

Lemma stateSplitsAs_commutative s s1 s2 :
  stateSplitsAs s s1 s2 -> stateSplitsAs s s2 s1.
Proof. move => H f. by apply: splitsAs_commutative. Qed.

Lemma stateSplitsAs_associative s s1 s2 s3 s4 :
  stateSplitsAs s s1 s2 ->
  stateSplitsAs s2 s3 s4 ->
  exists s5,
  stateSplitsAs s s3 s5 /\
  stateSplitsAs s5 s1 s4.
Proof. move => H1 H2.
set s5 := fun fr => fun x => if s4 fr x is Some y then Some y else s1 fr x.
exists s5.
split; move => fr; apply (splitsAs_associative (H1 fr) (H2 fr)).
Qed.

Definition restrictState (s: PState) (p: forall f:Frag, fragDom f -> bool) : PState :=
  fun f => fun x => if p f x then s f x else None.

Lemma stateSplitsOn (s: PState) p :
stateSplitsAs s (restrictState s p)
                (restrictState s (fun f => fun x => ~~p f x)).
Proof. move => f x.
case E: (s f x) => [a |] => //. rewrite /restrictState.
case E': (p f x). rewrite E. left; done. right. by rewrite E.
rewrite /restrictState.  rewrite E.
by case (p f x).
Qed.

(* Builds a total memory with the same mappings as the partial memory s.
   Locations that are not in s will be unmapped in the result. *)
Definition memComplete (s: PState) : Mem :=
  pmap_of (fun p =>
    match s Memory p with
    | Some (Some v) => Some v
    | _ => None
    end).

Lemma memComplete_inverse (s: PState) p v:
  s Memory p = Some v -> (memComplete s) p = v.
Proof.
  move=> Hsp. rewrite /memComplete. rewrite pmap_of_lookup.
  rewrite Hsp. by destruct v.
Qed.

(*---------------------------------------------------------------------------
    State predicates, and logical connectives
    We start without restrictions on predicates, roughly the "assertions" of
    Reynolds' "Introduction to Separation Logic", 2009.
  ---------------------------------------------------------------------------*)

Instance PStateEquiv : Equiv PState := {
   equiv s1 s2 := forall f, s1 f =1 s2 f
}.

Instance PStateType : type PState.
Proof.
  split.
  move => s f x; reflexivity.
  move => s1 s2 Hs f x; specialize (Hs f x); symmetry; assumption.
  move => s1 s2 s3 H12 H23 f x; specialize (H12 f x); specialize (H23 f x).
  transitivity (s2 f x); assumption.
Qed.

Instance addRegPieceToPStateEquiv_m :
  Proper (equiv ==> eq ==> eq ==> equiv) addRegPieceToPState.
Proof.
  move => p q Hpeq r1 r2 Hr1eqr2 w1 w2 Hw1eqw2 f x; subst.
  destruct f; simpl; rewrite Hpeq; reflexivity.
Qed.

Instance addFlagToPStateEquiv_m :
  Proper (equiv ==> eq ==> eq ==> equiv) addFlagToPState.
Proof.
  move => p q Hpeq r1 r2 Hr1eqr2 w1 w2 Hw1eqw2 f x; subst.
  destruct f; simpl; rewrite Hpeq; reflexivity.
Qed.

Instance addBYTEToPStateEquiv_m :
  Proper (equiv ==> eq ==> eq ==> equiv) addBYTEToPState.
Proof.
  move => p q Hpeq r1 r2 Hr1eqr2 w1 w2 Hw1eqw2 f x; subst.
  destruct f; simpl; rewrite Hpeq; reflexivity.
Qed.

Instance extendStateEquiv_m :
  Proper (equiv ==> equiv ==> equiv) extendState.
Proof.
  move => p q Hpeqq r1 r2 Hr1eqr2 f d.
  unfold extendState, extend.
  rewrite Hr1eqr2. destruct (r2 f d); [|rewrite Hpeqq]; reflexivity.
Qed.

Instance stateIncludeInEquiv_m :
  Proper (equiv ==> equiv ==> iff) stateIncludedIn.
Proof.
  move => p q Hpeqq r1 r2 Hr1eqr2.
  split; move => H f d y Heq; specialize (H f d y);
  [rewrite <- Hpeqq in Heq | rewrite Hpeqq in Heq];
  specialize (H Heq); [rewrite <- Hr1eqr2| rewrite Hr1eqr2];
  assumption.
Qed.

Lemma state_extensional (s1 s2: PState) : (forall f, s1 f =1 s2 f) -> s1 === s2.
Proof. unfold equiv, PStateEquiv; move => H f; apply H. Qed.

Program Definition my_sa_mul : (PState -s> PState -s> PState -s> Prop) :=
  lift3s (fun s1 s2 s => forall f, splitsAs (s f) (s1 f) (s2 f)) _ _ _.
Next Obligation.
  intros t1 t2 HEqt; unfold equiv, PStateEquiv in HEqt.
  split; intros; [rewrite <- HEqt | rewrite HEqt]; apply H.
Qed.
Next Obligation.
  intros t1 t2 HEqt; unfold equiv, PStateEquiv in HEqt;
  split; simpl; intros; [rewrite <- HEqt | rewrite HEqt]; apply H.
Qed.
Next Obligation.
  intros t1 t2 HEqt; unfold equiv, PStateEquiv in HEqt.
  split; simpl; intros; [rewrite <- HEqt | rewrite HEqt]; apply H.
Qed.

Instance PStateSepAlgOps: SepAlgOps PState := {
  sa_unit := emptyPState;
  sa_mul s1 s2 s := stateSplitsAs s s1 s2
}.

Instance PStateSepAlg : SepAlg PState.
Proof.
  split.
  + move => a b c d Habc Hceqd f; specialize (Hceqd f); rewrite <- Hceqd.
    apply Habc.
  + move => a b c d Habc Habd f.
    eapply splitsAs_functional; [apply Habc | apply Habd].
  + move => a b c Hbc d. split.
    - move => Habd f; specialize (Hbc f); rewrite <- Hbc; apply Habd.
    - move => Hacd f; specialize (Hbc f); rewrite Hbc; apply Hacd.
  + split; intros; by apply stateSplitsAs_commutative.
  + move => a b c bc abc H1 H2. eapply stateSplitsAs_associative. apply H1. apply H2.
  + intros; apply stateSplitsAs_s_s_emp.
Qed.

Definition SPred := ILFunFrm PState Prop.

Local Existing Instance ILFun_Ops.
Local Existing Instance ILFun_ILogic.
Local Existing Instance SABIOps.
Local Existing Instance SABILogic.

(* Giving these cost 1 ensures that they are preferred over spec/Prop instances *)
Instance sepILogicOps : ILogicOps SPred | 1 := _.
Instance sepLogicOps : BILOperators SPred | 1 := _.
Instance sepLogic : BILogic SPred | 1 := _.
Global Opaque sepILogicOps sepLogicOps sepLogic.

Implicit Arguments mkILFunFrm [[e] [ILOps]].

Definition mkSPred (P : PState -> Prop)
        (f : forall t t' : PState, t === t' -> P t |-- P t') : SPred :=
  mkILFunFrm PState Prop P f.

Implicit Arguments mkSPred [].

Local Transparent lentails sepILogicOps.
Program Definition eq_pred s := mkSPred (fun s' => s === s') _.
Next Obligation.
  rewrite <- H; assumption.
Qed.

Local Transparent ILFun_Ops.
Instance eq_pred_equiv_lentails :
  Proper (equiv ==> lentails) eq_pred.
Proof.
  move => s t Hseqt u Hsequ; simpl in *.
  rewrite <- Hseqt. assumption.
Qed.

Instance eq_pred_equiv_lequiv :
  Proper (equiv ==> lequiv) eq_pred.
Proof.
  split; apply eq_pred_equiv_lentails; [|symmetry]; assumption.
Qed.

Instance eq_pred_eq_pred_lentails :
  Proper (eq_pred ==> lentails) eq_pred.
Proof.
  move => s t Hseqt u Hsequ; simpl in *.
  rewrite <- Hseqt. assumption.
Qed.

Instance eq_pred_eq_pred_lequiv :
  Proper (eq_pred ==> lequiv) eq_pred.
Proof.
  split; apply eq_pred_equiv_lentails; [|symmetry]; assumption.
Qed.

Lemma lentails_eq (P : SPred) t :
  P t <-> eq_pred t |-- P.
Proof.
  split.
  - simpl. intros H x H1.
    assert (P t |-- P x) as H2 by (eapply ILFunFrm_closed; assumption).
    apply H2; assumption.
  - simpl; intros; firstorder.
Qed.

(* Need lemma about splitting involving a total (e.g. toPState) "partial" store.
   e.g. sa_mul (toPState s) s0 s1 -> s1 = s /\ s0 = emptyPState *)
Definition isTotal T U (f: T -> option U) := forall x, f x <> None.
Definition isTotalPState (s: PState) := forall f:Frag, isTotal (s f).

Lemma splitsTotal T U (s s0 s1: T -> option U) : isTotal s0 -> splitsAs s s0 s1 -> s =1 s0.
Proof. move => TOT SPLITS. rewrite /splitsAs in SPLITS.
move => x. unfold isTotal in TOT.
specialize (SPLITS x). specialize (TOT x).
destruct (s0 x) => //. destruct (s x) => //.
elim SPLITS => [[H1 H2] | [H1 H2]]. done. done. by destruct SPLITS.
Qed.

Lemma stateSplitsTotal (s s0 s1: PState) : isTotalPState s0 -> stateSplitsAs s s0 s1 -> s === s0.
Proof. move => TOT SPLITS. unfold stateSplitsAs in SPLITS. unfold isTotalPState in TOT.
move => f. apply: splitsTotal => //. Qed.

Instance stateSplitsAs_m :
  Proper (csetoid.equiv ==> csetoid.equiv ==> csetoid.equiv ==> iff) stateSplitsAs.
Proof. move => s1 s2 EQ s1' s2' EQ' s1'' s2'' EQ''.
split => SPLIT f x.
specialize (SPLIT f x). specialize (EQ f x). specialize (EQ' f x). specialize (EQ'' f x).
destruct (s1 f x); destruct (s2 f x); congruence.
specialize (SPLIT f x). specialize (EQ f x). specialize (EQ' f x). specialize (EQ'' f x).
destruct (s1 f x); destruct (s2 f x); congruence.
Qed.

Local Transparent ILFun_Ops SABIOps ltrue.

Lemma emp_unit : empSP -|- eq_pred sa_unit.
  split; simpl; move => x H.
  + destruct H as [H _]; assumption.
  + exists H; constructor.
Qed.

Lemma eqPredTotal_sepSP_trueR s :
  isTotalPState s ->
  eq_pred s -|- eq_pred s ** ltrue.
Proof.
move => TOT.
split => s'.
- apply lentails_eq. exists s, emptyPState. split => //; first apply stateSplitsAs_s_s_emp.
- move => /= [s1 [s2 [H1 [H2 H3]]]]. hnf in H2, H1. setoid_rewrite <- H2 in H1.
  apply (stateSplitsTotal TOT) in H1. by rewrite H1.
Qed.

Lemma eqPredTotal_sepSP s1 s2 R:
  isTotalPState s2 ->
  eq_pred s1 |-- eq_pred s2 ** R ->
  empSP |-- R.
Proof. move => TOT H.
apply lentails_eq in H. destruct H as [s3 [s4 [H1 [H2 H3]]]].
simpl in H2. rewrite <-H2 in H1.
simpl in H1.
rewrite -> (stateSplitsTotal TOT H1) in H1.
apply stateSplitsAs_s_s_t in H1.
subst. rewrite emp_unit. by apply lentails_eq.
Qed.

Local Opaque SABIOps.

Global Coercion lbool (b:bool) := lpropand b ltrue.

(*===========================================================================
    "is" predicates on registers and flags
  ===========================================================================*)

Definition regPieceIs r v : SPred := eq_pred (addRegPieceToPState emptyPState r v).
Definition flagIs f b : SPred := eq_pred (addFlagToPState emptyPState f b).
Definition BYTEregIs (r:VRegAny OpSize1) v : SPred := regPieceIs (BYTERegToRegPiece r) v.

Definition regIs (r:AnyReg) (v:DWORD) : SPred :=
   regPieceIs (AnyRegPiece r RegIx0) (getRegPiece v RegIx0)
** regPieceIs (AnyRegPiece r RegIx1) (getRegPiece v RegIx1)
** regPieceIs (AnyRegPiece r RegIx2) (getRegPiece v RegIx2)
** regPieceIs (AnyRegPiece r RegIx3) (getRegPiece v RegIx3).

Definition WORDregIs (r:VRegAny OpSize2) (v:WORD) : SPred :=
   regPieceIs (AnyRegPiece (WORDRegToReg r) RegIx0) (slice 0 8 8 v)
** regPieceIs (AnyRegPiece (WORDRegToReg r) RegIx1) (slice 8 8 0 v).

Inductive RegOrFlag :=
| RegOrFlagR s :> VRegAny s -> RegOrFlag
| RegOrFlagF :> Flag -> RegOrFlag.

Definition RegOrFlag_target rf :=
match rf with
| RegOrFlagR s _   => VWORD s
| RegOrFlagF _     => FlagVal
end.

Definition stateIs (x: RegOrFlag) : RegOrFlag_target x -> SPred :=
match x with
| RegOrFlagR OpSize4 r => regIs r
| RegOrFlagR OpSize2 r => WORDregIs r
| RegOrFlagR OpSize1 r => BYTEregIs r
| RegOrFlagF f => flagIs f
end.

Implicit Arguments stateIs [].

Definition stateIsAny x := lexists (stateIs x).

Notation "x '~=' v" := (stateIs x v) (at level 70, no associativity, format "x '~=' v") : spred_scope.
Notation "x '?'" := (stateIsAny x) (at level 2, format "x '?'"): spred_scope.

Hint Unfold VWORD RegOrFlag_target : spred.
(** When dealing with logic, we want to reduce [stateIsAny] and similar to basic building blocks. *)
Hint Unfold stateIsAny : finish_logic_unfolder.

(*---------------------------------------------------------------------------
     Byte-is predicate
  ---------------------------------------------------------------------------*)
Program Definition byteIs p b : SPred := eq_pred (addBYTEToPState emptyPState p b).

Definition byteAny p : SPred := lexists (byteIs p).

Instance flagIsEquiv_m :
  Proper (eq ==> eq ==> csetoid.equiv ==> iff) flagIs.
Proof.
  intros n m Hneqm f g Hbeqc p q Hpeqq; subst.
  split; simpl; rewrite <- Hpeqq; tauto.
Qed.

Instance byteIsEquiv_m :
  Proper (eq ==> eq ==> csetoid.equiv ==> iff) byteIs.
Proof.
  intros n m Hneqm b c Hbeqc p q Hpeqq; subst.
  split; simpl; rewrite <- Hpeqq; tauto.
Qed.

(*---------------------------------------------------------------------------
    Iterated separating conjunction
  ---------------------------------------------------------------------------*)
Fixpoint isc {A} (I: seq A) (F: A -> SPred) :=
  match I with
  | nil => empSP
  | i :: I' => F i ** isc I' F
  end.

Lemma isc_cat {A} (I J: seq A) F :
  isc (I ++ J) F -|- isc I F ** isc J F.
Proof.
  elim: I.
  - simpl; rewrite sepSPC. rewrite empSPR. reflexivity.
  - move=> i I IH /=. by rewrite IH sepSPA.
Qed.

Lemma isc_snoc {A} (I: seq A) i F :
  isc (I ++ [:: i]) F -|- isc I F ** F i.
Proof. rewrite isc_cat /=. by rewrite empSPR. Qed.

(*---------------------------------------------------------------------------
    Strictly exact assertions

    See Section 2.3.2 In Reynolds's "Introduction to Separation Logic" online
    lecture notes.
    http://www.cs.cmu.edu/afs/cs.cmu.edu/project/fox-19/member/jcr/www15818As2011/cs818A3-11.html
  ---------------------------------------------------------------------------*)

Class StrictlyExact (P: SPred) := strictly_exact:
  forall s s', P s -> P s' -> s === s'.

Instance StrictlyExactRegPieceIs r v: StrictlyExact (regPieceIs r v).
Proof. move => s s'. simpl. by move ->. Qed.

Instance StrictlyExactFlagIs f v: StrictlyExact (flagIs f v).
Proof. move => s s'. simpl. by move ->. Qed.

Instance StrictlyExactByteIs p v: StrictlyExact (byteIs p v).
Proof. move => s s'. simpl. by move ->. Qed.

Instance StrictlyExactSep P Q `{PH: StrictlyExact P} `{QH: StrictlyExact Q}
  : StrictlyExact (P**Q).
Proof. move => s s' [s1 [s2 [H1 [H2 H3]]]] [s1' [s2' [H1' [H2' H3']]]].
specialize (PH s1 s1' H2 H2').
specialize (QH s2 s2' H3 H3').
rewrite -> PH, QH in H1.
by rewrite (stateSplitsAsExtends H1) (stateSplitsAsExtends H1').
Qed.

Instance StrictlyExactRegIs r v: StrictlyExact (regIs r v).
Proof. rewrite /regIs. do 3 (apply StrictlyExactSep; first apply StrictlyExactRegPieceIs).
apply StrictlyExactRegPieceIs. Qed.

Instance StrictlyExactEmpSP : StrictlyExact empSP.
Proof. move => s s' H H'.
destruct H as [H _]. destruct H' as [H' _].
by rewrite -H -H'.
Qed.

Instance StrictlyExactConj P Q `{PH: StrictlyExact P} `{QH: StrictlyExact Q}
  : StrictlyExact (P //\\ Q).
Proof. move => s s' [H1 H2] [H1' H2'].
by apply (PH s s' H1 H1').
Qed.

Class Precise (P: SPred) := precise:
  forall s s1 s2, stateIncludedIn s1 s -> stateIncludedIn s2 s -> P s1 -> P s2 -> s1 === s2.

Instance PreciseStrictlyExact P `{PH: StrictlyExact P} : Precise P.
Proof. move => s s1 s2 H1 H2. intuition. Qed.

Corollary Distributive P0 P1 Q `{QH: Precise Q} :
  (P0 ** Q) //\\ (P1 ** Q) |-- (P0 //\\ P1) ** Q.
Proof.
unfold "|--". rewrite /sepILogicOps/ILFun_Ops. move => s [H0 H1].
destruct H0 as [s0 [s0' [H0a [H0b H0c]]]].
destruct H1 as [s1 [s1' [H1a [H1b H1c]]]].
have SSI0 := stateSplitsAsIncludes H0a.
have SSI1 := stateSplitsAsIncludes H1a.
destruct SSI0 as [SSI0a SSI0b].
destruct SSI1 as [SSI1a SSI1b].
have QH1 := (QH _ _ _ SSI0b SSI1b H0c H1c).
exists s0. exists s1'.
split. rewrite -> QH1 in H0a.

exact H0a.
split. split. exact H0b. rewrite -> QH1 in SSI0b.
rewrite -> QH1 in H0a.
rewrite <- (stateSplitsAs_functionalArg H1a H0a). exact H1b.
exact H1c.
Qed.

(*---------------------------------------------------------------------------
    A partial application of [eq] is a predicate
  ---------------------------------------------------------------------------*)

Lemma stateSplitsAs_eq s s1 s2:
  sa_mul s1 s2 s ->
  eq_pred s1 ** eq_pred s2 -|- eq_pred s.
Proof.
  split.
  - move=> s' [s1' [s2' [Hs' [Hs1' Hs2']]]].
    Opaque sa_mul.
    simpl in *.
    rewrite <- Hs1', <- Hs2' in Hs'.
    eapply sa_mul_eqR; eassumption.
  - simpl. move=> s' H1.
    rewrite -> H1 in H.
    exists s1; exists s2; done.
Qed.

Lemma ILFun_exists_eq (P : SPred) :
  P -|- Exists s, P s /\\ eq_pred s.
Proof.
  split; intros s Hs.
  - exists s. constructor; simpl; intuition.
  - simpl in *; destruct Hs as [x [Hp Hs]].
    assert (P x |-- P s) as H by (eapply ILFunFrm_closed; assumption).
    by apply H.
Qed.

Global Opaque PStateSepAlgOps.

(*---------------------------------------------------------------------------
    Some lemmas about the domains of primitive points-to-like predicates
  ---------------------------------------------------------------------------*)
Open Scope spred_scope.

Lemma regPieceIs_same (r:RegPiece) v1 v2 : regPieceIs r v1 ** regPieceIs r v2 |-- lfalse.
Proof.  move => s [s1 [s2 [H1 [H1a H1b]]]].
simpl in H1a, H1b. rewrite <-H1a in H1. rewrite <-H1b in H1.
rewrite /sa_mul/PStateSepAlgOps/= in H1.
specialize (H1 Registers r). simpl in H1.
destruct (s Registers r); rewrite eq_refl in H1.
destruct H1; by destruct H.
by destruct H1.
Qed.

Lemma sepRev4 P Q R S : P ** Q ** R ** S -|- S ** R ** Q ** P.
Proof. rewrite (sepSPC P). rewrite (sepSPC Q). rewrite (sepSPC R).
by rewrite !sepSPA. Qed.

Lemma regIs_same s (r:VRegAny s) (v1 v2:VWORD s) : r ~= v1 ** r ~= v2 |-- lfalse.
Proof. destruct s.
- apply regPieceIs_same.
- destruct r. admit.
- rewrite /stateIs/regIs.
  rewrite sepRev4. rewrite sepSPA.
  rewrite sepRev4. rewrite -!sepSPA. rewrite -> (@regPieceIs_same (AnyRegPiece r RegIx0)).
  by rewrite !sepSP_falseL.
Qed.

Lemma flagIs_same (f:Flag) v1 v2 : f ~= v1 ** f ~= v2 |-- lfalse.
Proof.  move => s [s1 [s2 [H1 [H1a H1b]]]].
simpl in H1a, H1b. rewrite <-H1a in H1. rewrite <-H1b in H1.
rewrite /sa_mul/PStateSepAlgOps/= in H1.
specialize (H1 Flags f). simpl in H1.
destruct (s Flags f); rewrite eq_refl in H1.
destruct H1; by destruct H.
by destruct H1.
Qed.

Lemma byteIs_same p v1 v2 : byteIs p v1 ** byteIs p v2 |-- lfalse.
Proof.  move => s [s1 [s2 [H1 [H1a H1b]]]].
simpl in H1a, H1b. rewrite <-H1a in H1. rewrite <-H1b in H1.
rewrite /sa_mul/PStateSepAlgOps/= in H1.
specialize (H1 Memory p). simpl in H1.
destruct (s Memory p); rewrite eq_refl in H1.
destruct H1; by destruct H.
by destruct H1.
Qed.

(* We don't want simpl to unfold this *)
Global Opaque stateIs.


(* This file defines a simple escrow contract based on the "safe remote
purchase" example in Solidity's docs. This contract allows a seller to sell an
item in a trustless setting assuming economically rational actors. With the
premise that the seller wants to sell an item for 1 ETH, the contract works in
the following way:

1. The seller deploys the contract and commits 2 ETH.
2. The buyer commits 2 ETH before the deadline.
3. The seller hands over the item (outside of the smart contract).
4. The buyer confirms he has received the item. He gets 1 ETH back
while the seller gets 3 ETH back.

If the buyer does not commit the funds, the seller gets his money back after the
deadline. The economic rationality shows up in our assumption that the seller
will confirm he has received the item to get his own funds back. *)

From Coq Require Import List.
From Coq Require Import Morphisms.
From Coq Require Import ZArith.
From Coq Require Import Permutation.
From Coq Require Import Psatz.
Require Import Automation.
Require Import Blockchain.
Require Import Extras.
Require Import Monads.
Require Import Serializable.
From RecordUpdate Require Import RecordUpdate.

Import ListNotations.
Import RecordSetNotations.

Section Escrow.
Context `{Base : ChainBase}.

Set Nonrecursive Elimination Schemes.

Record Setup :=
  build_setup {
      setup_buyer : Address;
    }.

Inductive NextStep :=
(* Waiting for buyer to commit itemvalue * 2 *)
| buyer_commit
(* Waiting for buyer to confirm item received *)
| buyer_confirm
(* Waiting for buyer and seller to withdraw their funds. *)
| withdrawals
(* No next step, sale is done. *)
| none.

Record State :=
  build_state {
      last_action : nat;
      next_step : NextStep;
      seller : Address;
      buyer : Address;
      seller_withdrawable : Amount;
      buyer_withdrawable : Amount;
    }.

Inductive Msg :=
| commit_money
| confirm_item_received
| withdraw.

Global Instance State_settable : Settable _ :=
  settable! build_state <last_action; next_step; seller; buyer;
                         seller_withdrawable; buyer_withdrawable>.

Global Instance Setup_serializable : Serializable Setup :=
  Derive Serializable Setup_rect<build_setup>.

Global Instance NextStep_serializable : Serializable NextStep :=
  Derive Serializable NextStep_rect<buyer_commit, buyer_confirm, withdrawals, none>.

Global Instance State_serializable : Serializable State :=
  Derive Serializable State_rect<build_state>.

Global Instance Msg_serializable : Serializable Msg :=
  Derive Serializable Msg_rect<commit_money, confirm_item_received, withdraw>.

Open Scope Z.
Definition init (chain : Chain) (ctx : ContractCallContext) (setup : Setup)
  : option State :=
  let seller := ctx_from ctx in
  let buyer := setup_buyer setup in
  do if (buyer =? seller)%address then None else Some tt;
  do if ctx_amount ctx =? 0 then None else Some tt;
  do if Z.even (ctx_amount ctx) then Some tt else None;
  Some (build_state (current_slot chain) buyer_commit seller buyer 0 0).

Definition receive
           (chain : Chain) (ctx : ContractCallContext)
           (state : State) (msg : option Msg)
  : option (State * list ActionBody) :=
  match msg, next_step state with
  | Some commit_money, buyer_commit =>
    let item_price := (account_balance chain (ctx_contract_address ctx)
                       - ctx_amount ctx) / 2 in
    let expected := item_price * 2 in
    do if (ctx_from ctx =? buyer state)%address then Some tt else None;
    do if ctx_amount ctx =? expected then Some tt else None;
    Some (state<|next_step := buyer_confirm|>
               <|last_action := current_slot chain|>, [])

  | Some confirm_item_received, buyer_confirm =>
    let item_price := account_balance chain (ctx_contract_address ctx) / 4 in
    do if (ctx_from ctx =? buyer state)%address then Some tt else None;
    do if ctx_amount ctx =? 0 then Some tt else None;
    let new_state :=
        state<|next_step := withdrawals|>
             <|buyer_withdrawable := item_price|>
             <|seller_withdrawable := item_price * 3|> in
    Some (new_state, [])

  | Some withdraw, withdrawals =>
    do if ctx_amount ctx =? 0 then Some tt else None;
    let from := ctx_from ctx in
    do '(to_pay, new_state) <-
       match from =? buyer state, from =? seller state with
       | true, _ => Some (buyer_withdrawable state, state<|buyer_withdrawable := 0|>)
       | _, true => Some (seller_withdrawable state, state<|seller_withdrawable := 0|>)
       | _, _ => None
       end%address;
    do if to_pay >? 0 then Some tt else None;
    let new_state :=
        match buyer_withdrawable new_state, seller_withdrawable new_state with
        | 0, 0 => new_state<|next_step := none|>
        | _, _ => new_state
        end in
    Some (new_state, [act_transfer (ctx_from ctx) to_pay])

  | Some withdraw, buyer_commit =>
    do if ctx_amount ctx =? 0 then Some tt else None;
    do if (last_action state + 50 <? current_slot chain)%nat then None else Some tt;
    do if (ctx_from ctx =? seller state)%address then Some tt else None;
    let balance := account_balance chain (ctx_contract_address ctx) in
    Some (state<|next_step := none|>, [act_transfer (seller state) balance])

  | _, _ => None
  end.

Ltac solve_contract_proper :=
  repeat
    match goal with
    | [|- @bind _ ?m _ _ _ _ = @bind _ ?m _ _ _ _] => unfold bind, m
    | [|- ?x _  = ?x _] => unfold x
    | [|- ?x _ _ = ?x _ _] => unfold x
    | [|- ?x _ _ _ = ?x _ _ _] => unfold x
    | [|- ?x _ _ _ _ = ?x _ _ _ _] => unfold x
    | [|- ?x _ _ _ _ = ?x _ _ _ _] => unfold x
    | [|- ?x _ _ _ _ _ = ?x _ _ _ _ _] => unfold x
    | [|- Some _ = Some _] => f_equal
    | [|- pair _ _ = pair _ _] => f_equal
    | [|- (if ?x then _ else _) = (if ?x then _ else _)] => destruct x
    | [|- match ?x with | _ => _ end = match ?x with | _ => _ end ] => destruct x
    | [H: ChainEquiv _ _ |- _] => rewrite H in *
    | _ => subst; auto
    end.

Program Definition contract : Contract Setup Msg State :=
  build_contract init _ receive _.
Next Obligation. repeat intro; solve_contract_proper. Qed.
Next Obligation. repeat intro; solve_contract_proper. Qed.

Section Theories.
  Lemma no_self_calls bstate caddr :
    reachable bstate ->
    env_contracts bstate caddr = Some (Escrow.contract : WeakContract) ->
    Forall (fun abody => match abody with
                         | act_transfer to _ => (to =? caddr)%address = false
                         | _ => False
                         end) (outgoing_acts bstate caddr).
  Proof.
    contract_induction; intros; cbn in *; auto.
    - now inversion IH.
    - apply Forall_app; split; try tauto.
      clear IH.
      unfold receive in receive_some.
      destruct_match as [[]|] in receive_some; try congruence.
      + destruct_match in receive_some; try congruence.
        destruct_match in receive_some; cbn in *; try congruence.
        destruct_match in receive_some; cbn in *; try congruence.
        inversion_clear receive_some; auto.
      + destruct_match in receive_some; try congruence.
        destruct_match in receive_some; cbn in *; try congruence.
        destruct_match in receive_some; cbn in *; try congruence.
        inversion_clear receive_some; auto.
      + destruct_match in receive_some; try congruence.
        * destruct_match in receive_some; cbn in *; try congruence.
          destruct_match in receive_some; cbn in *; try congruence.
          destruct (address_eqb_spec (ctx_from ctx) (seller prev_state)) as
              [<-|]; cbn in *; try congruence.
          inversion_clear receive_some.
          constructor; try constructor.
          apply address_eq_ne; auto.
        * destruct_match in receive_some; cbn in *; try congruence.
          destruct_match in receive_some; cbn in *; try congruence.
          destruct_match in receive_some.
          destruct_match in receive_some; cbn in *; try congruence.
          inversion_clear receive_some.
          constructor; try constructor.
          apply address_eq_ne; auto.
    - inversion_clear IH as [|? ? head_not_me tail_not_me].
      apply Forall_app; split; auto; clear tail_not_me.
      destruct head; try contradiction.
      destruct action_facts as [? [? ?]].
      destruct_address_eq; congruence.
    - now rewrite <- perm.
    - instantiate (DeployFacts := fun _ _ => True).
      instantiate (CallFacts := fun _ _ _ => True).
      instantiate (AddBlockFacts := fun _ _ _ _ _ _ => True).
      unset_all; subst; cbn in *.
      destruct_chain_step; auto.
      destruct_action_eval; auto.
  Qed.

  Definition txs_to (to : Address) (txs : list Tx) : list Tx :=
    filter (fun tx => (tx_to tx =? to)%address) txs.

  Arguments txs_to : simpl never.

  Lemma txs_to_cons addr tx txs :
    txs_to addr (tx :: txs) =
    if (tx_to tx =? addr)%address then
      tx :: txs_to addr txs
    else
      txs_to addr txs.
  Proof. reflexivity. Qed.

  Definition txs_from (from : Address) (txs : list Tx) : list Tx :=
    filter (fun tx => (tx_from tx =? from)%address) txs.

  Arguments txs_from : simpl never.

  Lemma txs_from_cons addr tx txs :
    txs_from addr (tx :: txs) =
    if (tx_from tx =? addr)%address then
      tx :: txs_from addr txs
    else
      txs_from addr txs.
  Proof. reflexivity. Qed.

  Local Open Scope bool.
  Definition buyer_confirmed (inc_calls : list (ContractCallInfo Msg)) buyer :=
    existsb (fun call => (call_from call =? buyer)%address &&
                         match call_msg call with
                         | Some confirm_item_received => true
                         | _ => false
                         end) inc_calls.

  Definition transfer_acts_to addr acts :=
    filter (fun a => match a with
                     | act_transfer to _ => (to =? addr)%address
                     | _ => false
                     end) acts.

  Arguments transfer_acts_to : simpl never.

  Lemma transfer_acts_to_cons addr act acts :
    transfer_acts_to addr (act :: acts) =
    if match act with
       | act_transfer to _ => (to =? addr)%address
       | _ => false
       end
    then
      act :: transfer_acts_to addr acts
    else
      transfer_acts_to addr acts.
  Proof. reflexivity. Qed.

  Definition money_to
             {bstate_from bstate_to}
             (trace : ChainTrace bstate_from bstate_to)
             caddr addr :=
    sumZ tx_amount (txs_to addr (outgoing_txs trace caddr)) +
    sumZ act_body_amount (transfer_acts_to addr (outgoing_acts bstate_to caddr)).

  Lemma escrow_correct_strong bstate caddr (trace : ChainTrace empty_state bstate) :
    env_contracts bstate caddr = Some (Escrow.contract : WeakContract) ->
    exists (cstate : State)
           (depinfo : DeploymentInfo Setup)
           (inc_calls : list (ContractCallInfo Msg)),
      deployment_info Setup trace caddr = Some depinfo /\
      contract_state bstate caddr = Some cstate /\
      incoming_calls Msg trace caddr = Some inc_calls /\
      let item_worth := deployment_amount depinfo / 2 in
      let seller_addr := deployment_from depinfo in
      let buyer_addr := setup_buyer (deployment_setup depinfo) in
      deployment_amount depinfo = 2 * item_worth /\
      item_worth > 0 /\
      seller cstate = seller_addr /\
      buyer cstate = buyer_addr /\
      buyer_addr <> seller_addr /\
      forallb (fun act => match act with
                         | act_transfer _ _ => true
                         | _ => false
                         end) (outgoing_acts bstate caddr) = true /\
      match next_step cstate with
      | buyer_commit =>
        account_balance bstate caddr = 2 * item_worth /\
        outgoing_acts bstate caddr = [] /\
        outgoing_txs trace caddr = [] /\
        inc_calls = []

      | buyer_confirm =>
        account_balance bstate caddr = 4 * item_worth /\
        outgoing_acts bstate caddr = [] /\
        outgoing_txs trace caddr = [] /\
        inc_calls = [build_call_info buyer_addr (2 * item_worth) (Some commit_money)]

      | withdrawals =>
        buyer_confirmed inc_calls buyer_addr = true /\
        filter (fun c => negb (call_amount c =? 0)%Z ) inc_calls =
        [build_call_info buyer_addr (2 * item_worth) (Some commit_money)] /\
        money_to trace caddr seller_addr + seller_withdrawable cstate = 3 * item_worth /\
        money_to trace caddr buyer_addr + buyer_withdrawable cstate = 1 * item_worth

      | none =>
        buyer_confirmed inc_calls buyer_addr = true /\
        filter (fun c => negb (call_amount c =? 0)%Z) inc_calls =
        [build_call_info buyer_addr (2 * item_worth) (Some commit_money)] /\
        money_to trace caddr seller_addr = 3 * item_worth /\
        money_to trace caddr buyer_addr = 1 * item_worth \/

        inc_calls = [build_call_info seller_addr 0 (Some withdraw)] /\
        money_to trace caddr seller_addr = 2 * item_worth /\
        money_to trace caddr buyer_addr = 0
      end.
  Proof.
    unfold money_to.
    contract_induction; cbn in *; intros.
    - (* New block *)
      auto.
    - (* Deployment *)
      unfold Escrow.init in *.
      destruct (address_eqb_spec (setup_buyer setup) (ctx_from ctx));
        cbn in *; try congruence.
      destruct (ctx_amount ctx =? 0) eqn:amount_some; cbn in *; try congruence.
      destruct (Z.even (ctx_amount ctx)) eqn:amount_even; cbn in *; try congruence.
      inversion init_some; subst; clear init_some.
      cbn.
      assert (2 * (ctx_amount ctx / 2) > 0 -> ctx_amount ctx / 2 > 0) by lia.
      enough (2 * (ctx_amount ctx / 2) > 0 /\
              ctx_amount ctx = 2 * (ctx_amount ctx / 2)) by tauto.
      assert (ctx_amount ctx mod 2 = 0).
      {
        rewrite Zeven_mod in amount_even.
        unfold Zeq_bool in *.
        destruct_match eqn:amount_mod_2 in amount_even; try congruence; auto.
        destruct (Z.compare_spec (ctx_amount ctx mod 2) 0); auto; try congruence.
      }
      rewrite <- (Z_div_exact_2 (ctx_amount ctx) 2) by (auto; lia).
      split; auto.
      instantiate (DeployFacts := fun _ ctx => ctx_amount ctx >= 0);
        subst DeployFacts; cbn in *.
      apply Z.eqb_neq in amount_some.
      lia.
    - (* Transfer from contract to someone *)
      repeat rewrite txs_to_cons.
      do 5 (split; try tauto).
      destruct IH as [_ [_ [_ [<- [_ [only_transfers IH]]]]]].
      apply andb_prop in only_transfers.
      split; try tauto.
      destruct only_transfers as [is_transfer _].
      destruct out_act; try congruence.
      destruct tx_act_match as [<- [<- _]].
      repeat rewrite transfer_acts_to_cons in *.
      destruct (next_step cstate).
      + intuition congruence.
      + intuition congruence.
      + (* Transfer while next_step is withdraw; so seller or buyer withdrew *)
        do 2 (split; try tauto).
        destruct IH as [_ [_ [? ?]]].
        destruct_address_eq; cbn in *; lia.
      + (* Transfer while next_step is none; action moved from queue to txs *)
        destruct IH as [IH | IH]; [left|right].
        * do 2 (split; try tauto).
          destruct IH as [_ [? ?]].
          destruct_address_eq; cbn in *; lia.
        * split; try tauto.
          destruct IH as [_ ?].
          destruct_address_eq; cbn in *; lia.
    - (* Call from someone else *)
      do 2 (split; try tauto).
      unfold Escrow.receive in *.
      set (item_worth := deployment_amount dep_info / 2) in *.
      destruct msg as [[| |]|].
      + (* Some commit_money *)
        destruct (next_step prev_state); try congruence.
        destruct (address_eqb_spec (ctx_from ctx) (buyer prev_state)) as [->|];
          cbn in *; try congruence.
        destruct (ctx_amount ctx =? _) eqn:proper_amount in receive_some;
          cbn in *; try congruence.
        inversion_clear receive_some.
        cbn.
        do 4 (split; try tauto).
        destruct IH as [deployed_even [_ [_ [-> [_ [_ [balance_eq [-> [-> ->]]]]]]]]].
        apply Z.eqb_eq in proper_amount.
        rewrite balance_eq in proper_amount.
        rewrite proper_amount.
        replace (account_balance _ _) with (2 * item_worth + 2 * item_worth / 2 * 2) by lia.
        rewrite <- Z.mul_comm.
        rewrite Z.div_mul by lia.
        repeat split; auto.
        lia.
      + (* Some confirm_item_received *)
        destruct_match in receive_some; cbn in *; try congruence.
        destruct (address_eqb_spec (ctx_from ctx) (buyer prev_state)) as [->|];
          cbn in *; try congruence.
        destruct (ctx_amount ctx =? 0) eqn:zero_amount in receive_some;
          cbn in *; try congruence.
        inversion_clear receive_some.
        cbn.
        do 4 (split; try tauto).
        destruct IH as [deployed_even [? [<- [<- [_ [_ [balance_eq [-> [-> ->]]]]]]]]].
        rewrite address_eq_refl.
        cbn.
        split; auto.
        unfold txs_to, transfer_acts_to; cbn.
        apply Z.eqb_eq in zero_amount.
        rewrite zero_amount in *.
        replace (account_balance _ _) with (4 * item_worth) in * by lia.
        rewrite (Z.mul_comm 4).
        rewrite Z.div_mul by lia.
        destruct (Z.eqb_spec (2 * item_worth) 0); cbn in *; try lia.
        repeat split; lia.
      + (* Some withdraw. Can be sent while next_step is either
           commit_money or withdrawals. *)
        destruct_match eqn:prev_next_step in receive_some;
          cbn -[Nat.ltb] in *; try congruence.
        * (* next_step was commit_money, so seller is withdrawing money
          because buyer did not commit anything. *)
          destruct (ctx_amount ctx =? 0) eqn:zero_amount in receive_some;
            cbn -[Nat.ltb] in *; try congruence.
          apply Z.eqb_eq in zero_amount.
          rewrite zero_amount in *.
          destruct_match in receive_some; cbn in *; try congruence.
          destruct (address_eqb_spec (ctx_from ctx) (seller prev_state))
            as [->|]; cbn in *; try congruence.
          inversion_clear receive_some; cbn.
          do 4 (split; try tauto).
          (* In this case we go to none state without buyer having confirmed anything *)
          right.
          destruct IH as [_ [_ [<- [_ [? [_ [? [-> [-> ->]]]]]]]]].
          unfold txs_to, transfer_acts_to.
          cbn.
          rewrite address_eq_refl, address_eq_ne by auto.
          cbn.
          split; auto; lia.
        * (* next_step was withdrawals, so either seller or buyer is withdrawing money.
             This might put us into next_step = none. *)
          destruct (ctx_amount ctx =? 0) eqn:zero_amount in receive_some;
            cbn -[Nat.ltb] in *; try congruence.
          apply Z.eqb_eq in zero_amount.
          rewrite zero_amount in *.
          destruct (address_eqb_spec (ctx_from ctx) (buyer prev_state))
            as [->|]; [|destruct (address_eqb_spec (ctx_from ctx) (seller prev_state))
                         as [->|]; cbn in *; try congruence].
          -- (* Buyer withdrawing *)
            cbn in *.
            destruct_match in receive_some; cbn in *; try congruence.
            inversion_clear receive_some; cbn.
            apply and_assoc; split; [destruct_match; tauto|].
            do 2 (split; try tauto).
            destruct (Z.eqb_spec (seller_withdrawable prev_state) 0) as [seller_done|].
            ++ (* No one has more to withdrew, next_step is none now, so establish
                  final IH. Since we got here from withdrawal we will be in left case. *)
              rewrite seller_done in *.
              left.
              repeat rewrite transfer_acts_to_cons.
              fold (buyer_confirmed prev_inc_calls
                                    (setup_buyer (deployment_setup dep_info))).
              destruct IH as [_ [_ [<- [-> [? [_ [-> [-> [? ?]]]]]]]]].
              rewrite address_eq_refl.
              rewrite address_eq_ne by assumption.
              cbn.
              do 2 (split; [tauto|]).
              lia.
            ++ (* Seller still has more to withdraw, next_step is still withdrawals *)
              replace (match seller_withdrawable prev_state with _ => _ end)
                with (prev_state <| buyer_withdrawable := 0 |>)
                by (destruct_match; cbn in *; try congruence).
              cbn.
              rewrite prev_next_step.
              repeat rewrite transfer_acts_to_cons.
              fold (buyer_confirmed prev_inc_calls
                                    (setup_buyer (deployment_setup dep_info))).
              destruct IH as [_ [_ [<- [-> [? [_ [-> [-> [? ?]]]]]]]]].
              rewrite address_eq_refl.
              rewrite address_eq_ne by assumption.
              cbn.
              do 2 (split; try tauto).
              lia.
          -- (* Seller withdrawing. Todo: generalize and clean up. *)
            cbn in *.
            destruct_match in receive_some; cbn in *; try congruence.
            inversion_clear receive_some; cbn.
            apply and_assoc; split; [destruct_match; tauto|].
            do 2 (split; try tauto).
            destruct (Z.eqb_spec (buyer_withdrawable prev_state) 0) as [buyer_done|].
            ++ (* No one has more to withdrew, next_step is none now, so establish
                  final IH. Since we got here from withdrawal we will be in left case. *)
              rewrite buyer_done in *.
              left.
              repeat rewrite transfer_acts_to_cons.
              fold (buyer_confirmed prev_inc_calls
                                    (setup_buyer (deployment_setup dep_info))).
              destruct IH as [_ [_ [<- [<- [? [_ [-> [-> [? ?]]]]]]]]].
              rewrite address_eq_refl.
              rewrite address_eq_ne by auto.
              cbn.
              do 2 (split; [tauto|]).
              lia.
            ++ (* Buyer still has more to withdraw, next_step is still withdrawals *)
              replace (match buyer_withdrawable prev_state with _ => _ end)
                with (prev_state <| seller_withdrawable := 0 |>)
                by (destruct_match; cbn in *; try congruence).
              cbn.
              rewrite prev_next_step.
              repeat rewrite transfer_acts_to_cons.
              fold (buyer_confirmed prev_inc_calls
                                    (setup_buyer (deployment_setup dep_info))).
              destruct IH as [_ [_ [<- [<- [? [_ [-> [-> [? ?]]]]]]]]].
              rewrite address_eq_refl.
              rewrite address_eq_ne by auto.
              cbn.
              do 2 (split; [tauto|]).
              lia.
      + (* None *)
        congruence.
    - (* Self call *)
      instantiate (CallFacts := fun _ ctx _ => ctx_from ctx <> ctx_contract_address ctx);
        subst CallFacts; cbn in *; congruence.
    - (* Permuting queue *)
      do 5 (split; try tauto).
      split.
      + now rewrite <- perm.
      + assert (out_queue = [] -> out_queue' = [])
          by (intros ->; now apply Permutation_nil).
        unfold transfer_acts_to in *.
        repeat rewrite sumZ_filter in *.
        destruct (next_step cstate); try tauto.
        * now rewrite <- perm.
        * destruct IH as [_ [_ [_ [_ [_ [_ [IH | IH]]]]]]];
            [left|right]; rewrite <- perm; auto.
    - instantiate (AddBlockFacts := fun _ _ _ _ _ _ => True).
      unset_all; subst; cbn in *.
      destruct_chain_step; auto.
      destruct_action_eval; auto.
      intros.
      pose proof (no_self_calls bstate_from to_addr ltac:(assumption) ltac:(assumption))
           as all.
      unfold outgoing_acts in *.
      rewrite queue_prev in *.
      subst act; cbn in all.
      destruct_address_eq; cbn in *; auto.
      inversion_clear all as [|? ? hd _].
      destruct msg.
      + contradiction.
      + rewrite address_eq_refl in hd.
        congruence.
  Qed.

  Definition net_balance_effect
             {bstate_from bstate_to : ChainState}
             (trace : ChainTrace bstate_from bstate_to)
             (caddr addr : Address) : Amount :=
    sumZ tx_amount (txs_to addr (outgoing_txs trace caddr))
    - sumZ tx_amount (txs_from addr (incoming_txs trace caddr)).

  (* Our main assumption is that the escrow will always finish due to
  economically rational actors. We do not formalize this. *)
  Definition is_escrow_finished cstate :=
    match next_step cstate with
    | none => true
    | _ => false
    end.

  (* The functional correctness of the Escrow, under the assumption that the
  escrow finishes due to rational actors. *)
  Corollary escrow_correct
            {ChainBuilder : ChainBuilderType}
            prev new header acts :
    builder_add_block prev header acts = Some new ->
    let trace := builder_trace new in
    forall caddr,
      env_contracts new caddr = Some (Escrow.contract : WeakContract) ->
      exists (depinfo : DeploymentInfo Setup)
             (cstate : State)
             (inc_calls : list (ContractCallInfo Msg)),
        deployment_info Setup trace caddr = Some depinfo /\
        contract_state new caddr = Some cstate /\
        incoming_calls Msg trace caddr = Some inc_calls /\
        let item_worth := deployment_amount depinfo / 2 in
        let seller := deployment_from depinfo in
        let buyer := setup_buyer (deployment_setup depinfo) in
        is_escrow_finished cstate = true ->
        (buyer_confirmed inc_calls buyer = true /\
         net_balance_effect trace caddr seller = item_worth /\
         net_balance_effect trace caddr buyer = -item_worth \/

         buyer_confirmed inc_calls buyer = false /\
         net_balance_effect trace caddr seller = 0 /\
         net_balance_effect trace caddr buyer = 0).
  Proof.
    intros after_add trace caddr escrow_at_caddr.
    cbn in *.
    pose proof (escrow_correct_strong _ caddr trace escrow_at_caddr) as general.
    cbn in general.
    destruct general as
        [cstate [depinfo [inc_calls [? [? [? [? [? [? [? [? [_ IH]]]]]]]]]]]].
    exists depinfo, cstate, inc_calls.
    do 3 (split; [tauto|]).
    intros is_finished.
    unfold is_escrow_finished in *.
    destruct (next_step cstate); try congruence; clear is_finished.
    unfold net_balance_effect, money_to.
    assert (inc_txs:
              forall addr,
                sumZ tx_amount (txs_from addr (incoming_txs trace caddr)) =
                sumZ (fun '(a, b, c) => c)
                     (filter (fun '(from, _, _) => (from =? addr)%address)
                             (map (fun tx => (tx_from tx, tx_to tx, tx_amount tx))
                                  (incoming_txs trace caddr)))).
    {
      intros addr.
      induction (incoming_txs trace caddr) as [|hd tl IH'].
      - reflexivity.
      - rewrite txs_from_cons.
        cbn.
        destruct_address_eq; cbn in *; rewrite IH'; reflexivity.
    }

    repeat rewrite inc_txs; clear inc_txs.
    rewrite (incoming_txs_contract caddr _ trace _ depinfo _ inc_calls) by assumption.
    repeat rewrite filter_app, sumZ_app.
    cbn.
    rewrite address_eq_refl.
    rewrite address_eq_ne by auto.
    cbn.
    rewrite 2!filter_map, 2!sumZ_map.

    set (buyer_addr := setup_buyer (deployment_setup depinfo)) in *.
    set (seller_addr := deployment_from depinfo) in *.

    unfold money_to, transfer_acts_to in IH.
    cbn in IH.

    change (fun a => call_amount a) with (@call_amount _ Msg).

    destruct IH as [IH | IH]; [left|right].
    - split; [tauto|].
      remember (build_call_info _ _ (Some commit_money)) as commitment.
      assert (Hsum :
                forall f,
                  sumZ call_amount (filter f inc_calls) =
                  sumZ call_amount (filter f [commitment])).
      {
        intros f.
        destruct IH as [_ [<- ?]].
        clear -inc_calls.
        induction inc_calls as [|hd tl IH']; auto.
        cbn.
        destruct (Z.eqb_spec (call_amount hd) 0) as [zero_amount|].
        - cbn.
          destruct (f hd); cbn; try rewrite zero_amount; rewrite IH'; auto.
        - cbn.
          destruct (f hd); cbn; rewrite IH'; auto.
      }

      rewrite 2!Hsum; clear Hsum; subst commitment; cbn in *.
      rewrite address_eq_refl, address_eq_ne by auto.
      cbn.
      destruct IH as [_ [_ [? ?]]].
      split; lia.
    - destruct IH as [-> IH].
      cbn.
      rewrite address_eq_refl, address_eq_ne by auto.
      cbn.
      split; [auto|].
      split; lia.
  Qed.

End Theories.

End Escrow.