(* an abstract structured pools contract *)

From PhD.Specifications.FA2Spec Require FA2Spec.
From ConCert.Execution Require Import Blockchain.
From ConCert.Execution Require Import BuildUtils.
From ConCert.Execution Require Import Containers.
From ConCert.Execution Require Import ContractCommon.
From ConCert.Execution Require Import Monad.
From ConCert.Execution Require Import ResultMonad.
From ConCert.Execution Require Import Serializable.
From ConCert.Utils Require Import RecordUpdate.
From ConCert.Utils Require Import Extras.
From Coq Require Import Ensembles.
From Coq Require Import ZArith_base.
From Coq Require Import QArith_base.
From Coq Require Import String.
From Coq Require Import List.
From Coq Require Import Fin.
From Coq.Init Require Import Byte.

Import ListNotations.
Open Scope N_scope.
Open Scope string.

(* =============================================================================
 * Defintions:
      We begin with some type and auxiliary definitions which we use for the
      contract specification.
 * ============================================================================= *)

Section Definitions.
Context {Base : ChainBase}.

(* ConCert specific types *)
Definition error : Type := N.

    Section ErrorCodes.

    Definition error_PERMISSIONS_DENIED : error := 1.
    Definition error_CONTRACT_NOT_FOUND : error := 2.
    Definition error_TOKEN_NOT_FOUND : error := 3.
    Definition error_INSUFFICIENT_BALANCE : error := 4.
    Definition error_CALL_VIEW_FAILED : error := 5.
    Definition error_FAILED_ASSERTION : error := 6.
    Definition error_FAILED_DIVISION : error := 7.
    Definition error_FAILED_TO_INITIALIZE : error := 8.

    End ErrorCodes.

Definition token : Type := FA2Spec.token. (* token_address and token_id fields *)
Definition exchange_rate := N. (* always divided by 1_000_000n in the code  *)

Definition transfer_to := FA2Spec.transfer_to.
Definition transfer_data := FA2Spec.transfer_data.

Definition mint_data := FA2Spec.mint_data.
Definition mint := FA2Spec.mint.

Record pool_data := {
    token_pooled : token ;
    qty_pooled : N ; (* the qty of tokens to be pooled *)
}.

Record unpool_data := {
    token_unpooled : token ;
    qty_unpooled : N ; (* the qty of pool tokens being turned in *)
}.

Record trade_data := {
    token_in_trade : token ;
    token_out_trade : token ;
    qty_trade : N ; (* the qty of token_in going in *)
}.

Inductive entrypoint :=
(* pooling and trading *)
| Pool : pool_data -> entrypoint
| Unpool : unpool_data -> entrypoint
| Trade : trade_data -> entrypoint.

Definition calc_delta_y (rate_in : N) (rate_out : N) (qty_trade : N) (k : N) (x : N) : N :=
    (* calculate ell *)
    let l := N.sqrt (k * (1_000_000 * 1_000_000) / (rate_in * rate_out)) in
    (* calculate the exchange rate *)
    l * rate_in / 1_000_000 - k / ((l * rate_out) / 1_000_000 + qty_trade).

Definition calc_rate_in (rate_in : N) (rate_out : N) (qty_trade : N) (k : N) (x : N) : N :=
    let delta_y := calc_delta_y rate_in rate_out qty_trade k x in
    (rate_in * x / 1_000_000 + rate_out * delta_y / 1_000_000) / (x + qty_trade).

(* a function to get a balance from an FMap *)
Definition get_bal (t : token) (tokens_held : FMap token N) :=
    match FMap.find t tokens_held with | Some b => b | None => 0 end.

(* the same function, but named differently for the sake of clarity *)
Definition get_rate (t : token) (rates : FMap token N) : N :=
    match FMap.find t rates with | Some r => r | None => 0 end.

End Definitions.

(* the abstract specification *)
Section AbstractSpecification.
Context {Base : ChainBase}

(* =============================================================================
 * The Contract Specification:
      We detail a list of propositions of a contract's behavior which can be
      proven true of a given contract.
 * ============================================================================= *)

    { Setup Msg State Error : Type }
    `{Serializable Msg}  `{Serializable Setup}  `{Serializable State} `{Serializable Error}.

(* Specification of the Msg type:
  - A Pool entrypoint, whose interface is defined by the pool_data type
  - An Unpool entrypoint, whose interface is defined by the unpool_data type
  - A Trade entrypoint, whose interface is defined by the trade_data type
*)
Class Msg_Spec (T : Type) :=
  build_msg_spec {
    pool : pool_data -> T ;
    unpool : unpool_data -> T ;
    trade : trade_data -> T ;
}.

(* specification of the State type:
  - keeps track of:
    - the exchange rates
    - tokens held
    - pool token address
    - number of outstanding pool tokens
*)
Class State_Spec (T : Type) :=
  build_state_spec {
    stor_rates : T -> FMap token exchange_rate ;
    stor_tokens_held : T -> FMap token N ;
    stor_pool_token : T -> token ;
    stor_outstanding_tokens : T -> N ;
}.

(* specification of the Setup type
  to initialize the contract, we need:
    - the initial rates
    - the pool token
*)
Class Setup_Spec (T : Type) :=
  build_setup_spec {
    init_rates : T -> FMap token exchange_rate ;
    init_pool_token : T -> token ;
}.

(* specification of the Error type *)
Class Error_Spec (T : Type) :=
  build_error_type {
    error_to_Error : error -> T ;
}.

(* we assume that our contract types satisfy the type specifications *)
Context `{Msg_Spec Msg}  `{Setup_Spec Setup}  `{State_Spec State} `{Error_Spec Error}.

(* Specification of the POOL entrypoint *)
(* When the POOL entrypoint is called, the contract call fails if
    the token to be pooled is not in the family of semi-fungible tokens. *)
Definition pool_entrypoint_check (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate chain ctx msg msg_payload,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* forall calls to the Pool entrypoint *)
    msg = pool (msg_payload) ->
    (* the receive function returns an error if the token to be pooled is not in the
       rates map held in the storage (=> is not in the semi-fungible family) *)
    FMap.find msg_payload.(token_pooled) (stor_rates cstate) = None ->
    receive contract chain ctx cstate (Some msg) =
      Err(error_to_Error error_TOKEN_NOT_FOUND).

Definition pool_entrypoint_check_2 (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate cstate' chain ctx msg msg_payload acts,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* forall calls to the Pool entrypoint *)
    msg = pool (msg_payload) ->
    (* the receive function returns an error if the token to be pooled is not in the
       rates map held in the storage (=> is not in the semi-fungible family) *)
    receive contract chain ctx cstate (Some msg) = Ok(cstate', acts) ->
    exists r_x,
    FMap.find msg_payload.(token_pooled) (stor_rates cstate) = Some r_x.

(* When the POOL entrypoint is successfully called, it emits a TRANSFER call to the
    token in storage, with q tokens in the payload of the call *)
Definition pool_emits_transfer (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate chain ctx msg msg_payload cstate' acts,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* the call to POOL was successful *)
    msg = pool (msg_payload) ->
    receive contract chain ctx cstate (Some msg) = Ok(cstate', acts) ->
    (* in the acts list there is a transfer call with q tokens as the payload *)
    exists transfer_to transfer_data transfer_payload,
    (* there is a transfer call *)
    In
    (act_call
        (msg_payload.(token_pooled).(FA2Spec.token_address)) (* call to the token address *)
        0 (* with amount = 0 *)
        (serialize (FA2Spec.Transfer transfer_payload)))
    acts /\
    (* with a transfer in it *)
    In transfer_data transfer_payload /\
    (* which itself has transfer data *)
    In transfer_to transfer_data.(FA2Spec.txs) /\
    (* whose quantity is the quantity pooled *)
    transfer_to.(FA2Spec.amount) = msg_payload.(qty_pooled).

(* When the POOL entrypoint is successfully called, it emits a MINT call to the
    pool_token, with q * r_x / 1_000_000 in the payload *)
Definition pool_emits_mint (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate chain ctx msg msg_payload cstate' acts,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* the call to POOL was successful *)
    msg = pool msg_payload ->
    receive contract chain ctx cstate (Some msg) = Ok(cstate', acts) ->
    (* in the acts list there is a MINT call with q * r_x / 1_000_000 in the payload *)
    exists mint_data mint_payload,
    (* there is a mint call in acts *)
    In
    (act_call
        (stor_pool_token cstate).(FA2Spec.token_address) (* calls the pool token address *)
        0 (* with amount 0 *)
        (serialize (FA2Spec.Mint mint_payload)))
    acts /\
    (* with has mint_data in the payload *)
    In mint_data mint_payload /\
    (* and the mint data has these properties: *)
    let r_x := get_rate msg_payload.(token_pooled) (stor_rates cstate) in
    mint_data.(FA2Spec.qty) = msg_payload.(qty_pooled) * r_x / 1_000_000 /\
    (* TODO perhaps also specify that the minted tokens go to pooler *)
    mint_data.(FA2Spec.mint_owner) = ctx.(ctx_from).

(* When the POOL entrypoint is successfully called, the TRANSFER and MINT transactions
    are the only transactions emitted by the contract *)
Definition pool_atomic (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate chain ctx msg msg_payload cstate' acts,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* the call to POOL was successful *)
    msg = pool msg_payload ->
    receive contract chain ctx cstate (Some msg) = Ok(cstate', acts) ->
    (* we have a MINT call in acts and a TRANSFER call *)
    length acts = 2%nat.

(* When the POOL entrypoint is successfully called, tokens_held goes up appropriately *)
Definition pool_increases_tokens_held (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate chain ctx msg msg_payload qty token cstate' acts,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* the call to POOL was successful *)
    msg = pool msg_payload ->
    qty = msg_payload.(qty_pooled) ->
    token = msg_payload.(token_pooled) ->
    receive contract chain ctx cstate (Some msg) = Ok(cstate', acts) ->
    (* in cstate', tokens_held has increased at token *)
    let old_bal := get_bal token (stor_tokens_held cstate) in
    let new_bal := get_bal token (stor_tokens_held cstate') in
    new_bal = old_bal + qty.

(* Specification of the UNPOOL entrypoint *)
(* When the UNPOOL entrypoint is called, the contract call fails if
    the token to be pooled is not in the family of semi-fungible tokens. *)
Definition unpool_entrypoint_check (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate chain ctx msg msg_payload,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* forall calls to the Pool entrypoint *)
    msg = unpool (msg_payload) ->
    (* the receive function returns an error if the token to be pooled is not in the
       rates map held in the storage (=> is not in the semi-fungible family) *)
    FMap.find msg_payload.(token_unpooled) (stor_rates cstate) = None ->
    receive contract chain ctx cstate (Some msg) =
      Err(error_to_Error error_TOKEN_NOT_FOUND).

Definition unpool_entrypoint_check_2 (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate cstate' chain ctx msg msg_payload acts,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* forall calls to the Pool entrypoint *)
    msg = unpool (msg_payload) ->
    (* the receive function returns an error if the token to be pooled is not in the
       rates map held in the storage (=> is not in the semi-fungible family) *)
    receive contract chain ctx cstate (Some msg) = Ok(cstate', acts) ->
    exists r_x,
    FMap.find msg_payload.(token_unpooled) (stor_rates cstate) = Some r_x.

(* When the UNPOOL entrypoint is successfully called, it emits a BURN call to the
    pool_token, with q in the payload *)
Definition unpool_emits_burn (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate chain ctx msg msg_payload cstate' acts,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* the call to UNPOOL was successful *)
    msg = unpool msg_payload ->
    receive contract chain ctx cstate (Some msg) = Ok(cstate', acts) ->
    (* in the acts list there is a BURN call with q in the payload *)
    exists burn_data burn_payload,
    (* there is a mint call in acts *)
    In
    (act_call
        (stor_pool_token cstate).(FA2Spec.token_address) (* calls the pool token address *)
        0 (* with amount 0 *)
        (serialize (FA2Spec.Retire burn_payload)))
    acts /\
    (* with has burn_data in the payload *)
    In burn_data burn_payload /\
    (* and burn_data has these properties: *)
    burn_data.(FA2Spec.retire_amount) = msg_payload.(qty_unpooled) /\
    (* the burned tokens go from the unpooler *)
    burn_data.(FA2Spec.retiring_party) = ctx.(ctx_from).

(* When the UNPOOL entrypoint is successfully called, it emits a TRANSFER call to the
    token in storage, with q * 1_000_000 / r_x tokens in the payload of the call *)
Definition unpool_emits_transfer (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate chain ctx msg msg_payload cstate' acts,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* the call to UNPOOL was successful *)
    msg = unpool (msg_payload) ->
    receive contract chain ctx cstate (Some msg) = Ok(cstate', acts) ->
    (* in the acts list there is a transfer call with q tokens as the payload *)
    exists transfer_to transfer_data transfer_payload,
    (* there is a transfer call *)
    In
    (act_call
        (msg_payload.(token_unpooled).(FA2Spec.token_address)) (* call to the token address *)
        0 (* with amount = 0 *)
        (serialize (FA2Spec.Transfer transfer_payload)))
    acts /\
    (* with a transfer in it *)
    In transfer_data transfer_payload /\
    (* which itself has transfer data *)
    In transfer_to transfer_data.(FA2Spec.txs) /\
    (* whose quantity is the quantity pooled *)
    let r_x := get_rate msg_payload.(token_unpooled) (stor_rates cstate) in
    transfer_to.(FA2Spec.amount) = msg_payload.(qty_unpooled) * 1_000_000 / r_x.

(* When the UNPOOL entrypoint is successfully called, tokens_held goes down appropriately *)
Definition unpool_decreases_tokens_held (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate chain ctx msg msg_payload qty token cstate' acts,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* the call to UNPOOL was successful *)
    msg = unpool msg_payload ->
    qty = msg_payload.(qty_unpooled) ->
    token = msg_payload.(token_unpooled) ->
    receive contract chain ctx cstate (Some msg) =
      Ok(cstate', acts) ->
    (* in cstate', tokens_held has increased at token *)
    let old_bal := get_bal token (stor_tokens_held cstate) in
    let new_bal := get_bal token (stor_tokens_held cstate') in
    new_bal = old_bal - qty.

(* If the TRADE entrypoint is called, token_in_trade and token_out_trade must both be
    part of the semi-fungible family for the trade to succeed. *)
Definition trade_entrypoint_check (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate chain ctx msg msg_payload,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* forall calls to the Pool entrypoint *)
    msg = trade (msg_payload) ->
    (* the receive function returns an error if the token to be pooled is not in the
       rates map held in the storage (=> is not in the semi-fungible family) *)
    ((FMap.find msg_payload.(token_in_trade) (stor_rates cstate) = None) \/
    (FMap.find msg_payload.(token_out_trade) (stor_rates cstate) = None)) ->
    receive contract chain ctx cstate (Some msg) =
      Err(error_to_Error error_TOKEN_NOT_FOUND).

Definition trade_entrypoint_check_2 (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate chain ctx msg msg_payload cstate' acts,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* forall calls to the Pool entrypoint *)
    msg = trade (msg_payload) ->
    (* the receive function returns an error if the token to be pooled is not in the
       rates map held in the storage (=> is not in the semi-fungible family) *)
    receive contract chain ctx cstate (Some msg) = Ok(cstate', acts) ->
    exists x r_x r_y,
    ((FMap.find msg_payload.(token_in_trade) (stor_tokens_held cstate) = Some x) /\
    (FMap.find msg_payload.(token_in_trade) (stor_rates cstate) = Some r_x) /\
    (FMap.find msg_payload.(token_out_trade) (stor_rates cstate) = Some r_y)).

(* Specification of the TRADE entrypoint *)
(* When TRADE is successfully called, the trade is priced using the correct formula
    given by calculate_trade. The updated rate is also priced using the formula from
    calculate_trade. *)
Definition trade_pricing_formula (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate chain ctx msg msg_payload t_x t_y q cstate' acts,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* the TRADE entrypoint was called succesfully *)
    msg = trade msg_payload ->
    t_x = msg_payload.(token_in_trade) ->
    t_y = msg_payload.(token_out_trade) ->
    t_x <> t_y ->
    q = msg_payload.(qty_trade) ->
    receive contract chain ctx cstate (Some msg) =
      Ok(cstate', acts) ->
    (* calculate the diffs delta_x and delta_y *)
    let delta_x :=
        (get_bal t_x (stor_tokens_held cstate')) - (get_bal t_x (stor_tokens_held cstate)) in
    let delta_y :=
        (get_bal t_y (stor_tokens_held cstate)) - (get_bal t_y (stor_tokens_held cstate')) in
    let rate_in := (get_rate t_x (stor_rates cstate)) in
    let rate_out := (get_rate t_y (stor_rates cstate)) in
    let k := (stor_outstanding_tokens cstate) in
    let x := get_bal t_x (stor_tokens_held cstate) in
    (* the diff delta_x and delta_y are correct *)
    delta_x = q /\
    delta_y = calc_delta_y rate_in rate_out q k x.

Definition trade_update_rates_formula (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate chain ctx msg msg_payload t_x t_y q cstate' acts,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* the TRADE entrypoint was called succesfully *)
    msg = trade msg_payload ->
    t_x = msg_payload.(token_in_trade) ->
    t_y = msg_payload.(token_out_trade) ->
    t_x <> t_y ->
    q = msg_payload.(qty_trade) ->
    receive contract chain ctx cstate (Some msg) =
      Ok(cstate', acts) ->
    (* calculate the diffs delta_x and delta_y *)
    let rate_in := (get_rate t_x (stor_rates cstate)) in
    let rate_out := (get_rate t_y (stor_rates cstate)) in
    let k := (stor_outstanding_tokens cstate) in
    let x := get_bal t_x (stor_tokens_held cstate) in
    (* the new rate of t_x is correct *)
    let r_x' := calc_rate_in rate_in rate_out q k x in
    FMap.find t_x (stor_rates cstate') = Some r_x' /\
    (forall t, t <> t_x ->
        FMap.find t (stor_rates cstate') =
        FMap.find t (stor_rates cstate)).

(* When TRADE is successfully called, it emits a TRANSFER action of t_x in quantity q *)
Definition trade_emits_transfer_tx (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate cstate' chain ctx msg msg_payload acts,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* the call to TRADE was successful *)
    msg = trade (msg_payload) ->
    receive contract chain ctx cstate (Some msg) = Ok(cstate', acts) ->
    (* in the acts list there is a transfer call with q tokens as the payload *)
    exists transfer_to transfer_data transfer_payload,
    (* there is a transfer call *)
    In
    (act_call
        (msg_payload.(token_in_trade).(FA2Spec.token_address)) (* call to the correct token address *)
        0 (* with amount = 0 *)
        (serialize (FA2Spec.Transfer transfer_payload)))
    acts /\
    (* with a transfer in it *)
    In transfer_data transfer_payload /\
    (* which itself has transfer data *)
    In transfer_to transfer_data.(FA2Spec.txs) /\
    (* whose quantity is the quantity traded, transferred to the contract *)
    transfer_to.(FA2Spec.amount) = msg_payload.(qty_trade) /\
    transfer_to.(FA2Spec.to_) = ctx.(ctx_contract_address).

(* transfers with delta_y given by calculate_trade function *)
Definition trade_emits_transfer_ty (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate chain ctx msg msg_payload cstate' acts,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* the call to TRADE was successful *)
    msg = trade (msg_payload) ->
    receive contract chain ctx cstate (Some msg) =
      Ok(cstate', acts) ->
    (* in the acts list there is a transfer call with q tokens as the payload *)
    exists transfer_to transfer_data transfer_payload,
    (* there is a transfer call *)
    In
    (act_call
        (msg_payload.(token_out_trade).(FA2Spec.token_address)) (* call to the correct token address *)
        0 (* with amount = 0 *)
        (serialize (FA2Spec.Transfer transfer_payload)))
    acts /\
    (* with a transfer in it *)
    In transfer_data transfer_payload /\
    (* which itself has transfer data *)
    In transfer_to transfer_data.(FA2Spec.txs) /\
    (* whose quantity is the quantity traded, transferred to the contract *)
    let t_x := msg_payload.(token_in_trade) in
    let t_y := msg_payload.(token_out_trade) in
    let rate_in := (get_rate t_x (stor_rates cstate)) in
    let rate_out := (get_rate t_y (stor_rates cstate)) in
    let k := (stor_outstanding_tokens cstate) in
    let x := get_bal t_x (stor_tokens_held cstate) in
    let q := msg_payload.(qty_trade) in
    transfer_to.(FA2Spec.amount) = calc_delta_y rate_in rate_out q k x  /\
    transfer_to.(FA2Spec.to_) = ctx.(ctx_from).

(* Initialization specification *)
(* TODO HOW IS THE CONTRACT INITIALIZED *)
Definition initialized_with_nonzero_rates (contract : Contract Setup Msg State Error) : Prop :=
    forall chain bstate ctx setup cstate,
    (* bstate is reachable *)
    reachable bstate ->
    (* we call init successfully *)
    init contract chain ctx setup = Ok cstate ->
    (* then all rates are nonzero *)
    forall t r,
    FMap.find t (stor_rates cstate) = Some r ->
    r > 0.

(* we amalgamate each proposition in the specification into a single proposition *)
Definition is_structured_pool
    (C : Contract Setup Msg State Error) : Prop :=
    pool_entrypoint_check C /\
    pool_entrypoint_check_2 C /\
    pool_emits_transfer C /\
    pool_emits_mint C /\
    pool_atomic C /\
    pool_increases_tokens_held C /\
    unpool_entrypoint_check C /\
    unpool_entrypoint_check_2 C /\
    unpool_emits_burn C /\
    unpool_emits_transfer C /\
    unpool_decreases_tokens_held C /\
    trade_entrypoint_check C /\
    trade_entrypoint_check_2 C /\
    trade_pricing_formula C /\
    trade_update_rates_formula C /\
    trade_emits_transfer_tx C /\
    trade_emits_transfer_ty C /\
    initialized_with_nonzero_rates C.

(* A tactic to destruct is_sp if it's in the context of a proof *)
Tactic Notation "is_sp_destruct" :=
match goal with
    | is_sp : is_structured_pool _ |- _ =>
        unfold is_structured_pool in is_sp;
        destruct is_sp  as [pool_entrypoint_check_pf is_sp'];
        destruct is_sp' as [pool_entrypoint_check_2_pf is_sp'];
        destruct is_sp' as [pool_emits_transfer_pf is_sp'];
        destruct is_sp' as [pool_emits_mint_pf is_sp'];
        destruct is_sp' as [pool_atomic_pf is_sp'];
        destruct is_sp' as [pool_increases_tokens_held_pf is_sp'];
        destruct is_sp' as [unpool_entrypoint_check_pf is_sp'];
        destruct is_sp' as [unpool_entrypoint_check_2_pf is_sp'];
        destruct is_sp' as [unpool_emits_burn_pf is_sp'];
        destruct is_sp' as [unpool_emits_transfer_pf is_sp'];
        destruct is_sp' as [unpool_decreases_tokens_held_pf is_sp'];
        destruct is_sp' as [trade_entrypoint_check_pf is_sp'];
        destruct is_sp' as [trade_entrypoint_check_2_pf is_sp'];
        destruct is_sp' as [trade_pricing_formula_pf is_sp'];
        destruct is_sp' as [trade_update_rates_formula_pf is_sp'];
        destruct is_sp' as [trade_emits_transfer_tx_pf is_sp'];
        destruct is_sp' as [trade_emits_transfer_ty_pf initialized_with_nonzero_rates_pf]
end.

(* =============================================================================
 * The contract Metaspecification:
      We reason about a contract which satisfies the properties of the specification
      given here, showing that a contract which satisfies the specification also satisfies
      the properties here.
 * ============================================================================= *)

 Context {contract : Contract Setup Msg State Error}
 { is_sp : is_structured_pool contract }.

(* Demand Sensitivity :
    A trade for a given token increases its price relative to other constituent tokens,
    so that higher relative demand corresponds to a higher relative price.
    Likewise, trading one token in for another decreases the first's relative price in
    the pool, corresponding to slackened demand. This enforces the classical notion of
    supply and demand

    We prove that r_x' > r_x and forall t_z, r_z' = r_z.
*)
Lemma rate_decrease : forall r_x r_y delta_x k x,
    calc_rate_in r_x r_y delta_x k x < r_x.
Proof. Admitted.

Theorem demand_sensitivity :
    forall bstate caddr cstate t_x r_x,
    (* state is reachable *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* r_x is the rate of token t_x *)
    0 < r_x ->
    (FMap.find t_x (stor_rates cstate)) = Some r_x ->
    (* a trade of t_x for some t_y happens *)
    forall chain ctx msg msg_payload acts cstate',
        receive contract chain ctx cstate (Some msg) = Ok(cstate', acts) ->
        msg = trade msg_payload ->
        msg_payload.(token_in_trade) = t_x ->
        t_x <> msg_payload.(token_out_trade) ->
    (* new cstate induced by *)
    let r_x' := get_rate t_x (stor_rates cstate') in
    (* r_x' goes down while all other rates stay constant *)
    r_x' < r_x /\
    forall t,
    t <> t_x ->
    get_rate t (stor_rates cstate') = get_rate t (stor_rates cstate).
Proof.
    intros.
    is_sp_destruct.
    pose proof (trade_entrypoint_check_2_pf bstate caddr cstate chain ctx msg msg_payload
            cstate' acts H7 H8 H9 H13 H12).
    do 4 destruct H16. destruct H17.
    (* get the new rates *)
    pose proof (trade_update_rates_formula_pf bstate caddr cstate chain ctx msg msg_payload t_x (msg_payload.(token_out_trade)) (msg_payload.(qty_trade)) cstate' acts H7 H8 H9 H13 (eq_sym H14) (reflexivity (token_out_trade msg_payload)) H15 (reflexivity (qty_trade msg_payload)) H12).
    destruct H19.
    (*  *)
    split.
    -   unfold r_x'. unfold get_rate.
        replace (FMap.find t_x (stor_rates cstate'))
        with (Some
            (calc_rate_in
                (get_rate t_x (stor_rates cstate))
                (get_rate (token_out_trade msg_payload) (stor_rates cstate))
                (qty_trade msg_payload)
                (stor_outstanding_tokens cstate)
                (get_bal t_x (stor_tokens_held cstate)))).
        assert (r_x = (get_rate t_x (stor_rates cstate))).
        +   unfold get_rate.
            replace (FMap.find t_x (stor_rates cstate))
            with (Some r_x).
            reflexivity.
        +   rewrite H21.
            exact (rate_decrease
                (get_rate t_x (stor_rates cstate))
                (get_rate (token_out_trade msg_payload) (stor_rates cstate))
                (qty_trade msg_payload)
                (stor_outstanding_tokens cstate)
                (get_bal t_x (stor_tokens_held cstate))).
    -   intros. unfold get_rate.
        replace (FMap.find t (stor_rates cstate')) with (FMap.find t (stor_rates cstate));
        try exact (eq_sym (H20 t H21)).
        auto.
Qed.

(* Nonpathological prices
    As relative prices shift over time, a price that starts out nonzero never goes to
    zero or to a negative value.

    This is to avoid pathological behavior of zero or negative prices.

    Note, however, that prices can still get arbitrarily close to zero, like in the case
    of CPMMs.
*) (*
Theorem nonpathological_prices :
    forall bstate caddr cstate n,
    (* the state is reachable *)
    reachable bstate ->
    (* get the address *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* the statement *)
    forall t,
    (* token in the ledger => rate neq zero *)
    FMap.find t (stor_rates cstate) = Some n /\ n > 0 ->
    (* any state reachable through cstate has the same property *)
    forall bstate' cstate',
    reachable_through bstate bstate' ->
    contract_state bstate' caddr = Some cstate' ->
    (* the token still has an exchange rate greater than zero in the new state cstate' *)
    exists n',
    FMap.find t (stor_rates cstate) = Some n' /\ n' > 0.
Proof.
    intros.
    (* contract induction over the trace *)

*)

(* Functional non-depletion :
    No trade can empty the entire pool of tokens. This mimics properties of CPMMs
    currently, for which no trade can deplete any constituent token of any pool. The
    difference here is that we are willing to let individual, constituent tokens deplete,
    but do not allow the entire pool to deplete.

    This is because tokenized carbon credits can be consumed by being retired as offsets,
    so while we don't want the entire class of carbon credits to deplete from the pool by
    trading, we should enable individual credits to deplete.
*)
Theorem functional_non_depletion :
    forall bstate caddr cstate,
    (* state is reachable *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* there is liquidity *)
    (stor_outstanding_tokens cstate) > 0 ->
    (* a trade occurs *)
    forall chain ctx msg msg_payload acts cstate',
        receive contract chain ctx cstate (Some msg) = Ok(cstate', acts) ->
        msg = trade msg_payload ->
    (* there is liquidity *)
    (stor_outstanding_tokens cstate') > 0.
Proof. (*
    intros.
    pose proof (trade_entrypoint_check_2_pf bstate caddr cstate chain ctx msg msg_payload
            cstate' acts H7 H8 H9 H12 H11).
    do 4 destruct H13. destruct H14.
    rewrite H12 in H11. *)
    (* open up the receive function
    cbn in H7.
    destruct
        (FMap.find (token_in_trade msg_payload) (tokens_held cstate)),
        (FMap.find (token_in_trade msg_payload) (rates cstate)),
        (FMap.find (token_out_trade msg_payload) (rates cstate)) in H7;
    cbn in H7; inversion H7.
    destruct (RPMM.get_bal (token_out_trade msg_payload) (tokens_held cstate) <?
           calc_delta_y e n0 (qty_trade msg_payload) (outstanding_tokens cstate) n)%N in H7;
    cbn in H7; inversion H7.
    clear H7 H13 H15.*)
    (*  *)
    Admitted.

(* Swap rate consistency :
    For tokens tau_x, tau_y and tau_z, the exchange rate from tau_x to tau_y, and then to
    tau_z, must not be greater than the exchange rate from tau_x to token tau_z.

    As we will see, structured pools always price trades consistently, but because of how
    prices update over time it is nontrivial to show that this is true in practice.

    In particular, price consistency means that it is never profitable to trade in a loop,
    e.g. tau_x to tau_y, and back to tau_x, which is important so that there are no
    arbitrage oportunities internal to the pool.
*)
Theorem swap_rate_consistency :
    forall bstate caddr cstate,
    (* state is reachable *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* a trade from t_x to t_z *)
    forall t_x t_z qty_trade
        chain ctx msg_xz msg_payload_xz acts_xz cstate_xz,
        receive contract chain ctx cstate msg_xz = Ok (cstate_xz, acts_xz) ->
        msg_xz = Some (trade msg_payload_xz) ->
        msg_payload_xz = Build_trade_data t_x t_z qty_trade ->
    (* a trade from t_x to t_y *)
    forall t_y msg_xy msg_payload_xy acts_xy cstate_xy,
        receive contract chain ctx cstate msg_xy = Ok (cstate_xy, acts_xy) ->
        msg_xy = Some (trade msg_payload_xy) ->
        msg_payload_xy = Build_trade_data t_x t_y qty_trade ->
    (* which yields delta_y tokens in t_y *)
    let delta_y :=
        (get_bal t_y (stor_tokens_held cstate)) -
        (get_bal t_y (stor_tokens_held cstate_xy)) in
    (* followed by a trade of delta_y from t_y to t_z *)
    forall msg_yz msg_payload_yz acts_yz cstate_yz chain' ctx',
        receive contract chain' ctx' cstate_xy msg_yz = Ok (cstate_yz, acts_yz) ->
        msg_yz = Some (trade msg_payload_yz) ->
        msg_payload_yz = Build_trade_data t_y t_z delta_y ->
    (* the output delta_z *)
    let delta_z_direct :=
        (get_bal t_z (stor_tokens_held cstate)) -
        (get_bal t_z (stor_tokens_held cstate_xz)) in
    let delta_z_indirect :=
        (get_bal t_z (stor_tokens_held cstate)) -
        (get_bal t_z (stor_tokens_held cstate_yz)) in
    (* the direct trade yielded more t_z than the indirect trade *)
    delta_z_direct > delta_z_indirect.
Proof. Admitted.

(* Arbitrage sensitivity :
    If an opportunity for arbitrage exists due to some external market pricing a
    constituent token differently from the structured pool, the arbitrage loop can be
    closed with one sufficiently large transaction.

    In our case, this happens because prices adapt through trades due to demand
    sensitivity or the pool depletes in that particular token.
*)
Theorem arbitrage_sensitivity :
    forall bstate caddr cstate t_x,
    (* state is reachable *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (*  *)
    forall external_price
    chain ctx msg msg_payload cstate' acts,
    receive contract chain ctx cstate msg = Ok(cstate', acts) ->
    msg = Some(trade msg_payload) ->
    exists trade_qty,
    msg_payload.(qty_trade) = trade_qty ->
    (* price stabilizes or liquidity depletes *)
    FMap.find t_x (stor_rates cstate') = Some(external_price) \/
    FMap.find t_x (stor_tokens_held cstate') = None.
Proof. Admitted.

(* Pooled consistency
    The sum of all the constituent, pooled tokens, multiplied by their value in terms of
    pooled tokens, always equals the total number of outstanding pool tokens. That is,
    pool tokens are never under- or over-collateralized.
*)
Definition fold_fn (rates : FMap token exchange_rate) (tokens_held : FMap token N)
    (n : N) (k : token) : N :=
    let rate :=
        match FMap.find k rates with
        | Some r => r
        | None => 0
        end in
    let qty_held :=
        match FMap.find k tokens_held with
        | Some r => r
        | None => 0
        end in
    rate * qty_held / 1_000_000.

Definition sum_over_tokens
    (rates : FMap token exchange_rate) (tokens_held : FMap token N) : N :=
    (* get the list of keys *)
    let token_family := (FMap.keys rates) in
    (* fold over the list *)
    List.fold_left
        (fold_fn rates tokens_held)
        token_family
        0.

Theorem pooled_consistency :
    forall bstate caddr cstate,
    (* state is reachable *)
    reachable bstate ->
    (* the contract address is caddr *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    (* the contract state is cstate *)
    contract_state bstate caddr = Some cstate ->
    (* The sum of all the constituent, pooled tokens, multiplied by their value in terms
    of pooled tokens, always equals the total number of outstanding pool tokens. *)
    sum_over_tokens (stor_rates cstate) (stor_tokens_held cstate) =
        (stor_outstanding_tokens cstate).
Proof. Admitted.

End AbstractSpecification.


Require Import Util LengthEq IL RenamedApart LabelsDefined OptionR.
Require Import Keep Drop Take Restrict SetOperations OUnion.
Require Import Annotation Liveness.Liveness Coherence Delocation.
Require Import AddParam AddAdd MoreListSet DelocationAlgo DelocationAlgoIsCalled.
Require Import PartialOrder.

Set Implicit Arguments.

Local Hint Extern 10 (forall _ _, get (snd ⊝ computeParametersF ?DL ?ZL ?AP ?F ?als) _ _ -> ❬?LVb❭ = ❬_❭)
=> eapply computeParametersF_length : len.

Local Hint Extern 1 =>
match goal with
  [ |- context [ ❬snd (computeParameters _ _ _ _ )❭ ] ] =>
  rewrite computeParameters_length; eauto with len
end : len.

Lemma computeParameters_trs b ZL Lv AP s lv
: live_sound Imperative ZL Lv s lv
  -> noUnreachableCode (isCalled b) s
  -> poLe AP (Lv \\ ZL)
  -> length Lv = length ZL
  -> length ZL = length AP
  -> trs (restr (getAnn lv) ⊝ (zip ominus' (Lv \\ ZL)
                                  (snd (computeParameters (Lv \\ ZL) AP s lv))))
        s lv
        (fst (computeParameters (Lv \\ ZL) AP s lv)).
Proof.
  intros LIVE NOUR P LEN1 LEN2.
  revert_except LIVE.
  induction LIVE; simpl in *; intros; repeat let_case_eq;
    repeat let_pair_case_eq; inv NOUR; simpl in *.
  - eapply trsExp, trs_monotone_DL.
    + eapply IHLIVE; eauto 10 using addParam_Subset with len.
    + rewrite restrict_comp_meet.
      assert (SEQ:lv ∩ (getAnn al \ singleton x) [=] getAnn al \ singleton x) by
          (clear - H0; cset_tac).
      rewrite SEQ. eapply restrict_zip_ominus'; eauto with len.
      eapply PIR2_not_in; [ eapply computeParameters_AP_LV; eauto with len
                          | eauto with len].
  - econstructor.
    + eapply trs_monotone_DL; eauto.
      eapply restrict_subset2; eauto.
      eapply zip_ominus_contra; eauto using PIR2_zip_ounion with len.
    + eapply trs_monotone_DL; eauto using PIR2_zip_ounion' with len.
      eapply restrict_subset2; eauto with len.
      eapply zip_ominus_contra; eauto using PIR2_zip_ounion' with len.
  - inv_get.
    econstructor.
    + eapply restrict_get_Some.
      eapply zip_get_eq. eapply zip_get; eauto.
      eapply keep_Some; eauto. simpl. reflexivity.
      rewrite <- H1. eauto with cset.
  - econstructor.
  - len_simpl.
    assert (LenHelp1:❬(getAnn ⊝ als ++ Lv) \\ (fst ⊝ F ++ ZL)❭ =
                     ❬snd
                        (computeParameters ((getAnn ⊝ als ++ Lv) \\ (fst ⊝ F ++ ZL))
                                           (tab {} ‖F‖ ++ AP) t alb)❭). {
      rewrite computeParameters_length; eauto; revert LEN1 LEN2 H; clear_all;
        eauto with len.
    }
    assert (LenHelp2:
              forall (n : nat) (aa : 〔؟ ⦃var⦄〕),
                get (snd ⊝ computeParametersF F als Lv ZL AP) n aa ->
                ❬aa❭ =
                ❬snd
                   (computeParameters ((getAnn ⊝ als ++ Lv) \\ (fst ⊝ F ++ ZL))
                                      (tab {} ‖F‖ ++ AP) t alb)❭). {
      eapply computeParametersF_length; eauto.
      rewrite <- LenHelp1. eauto with len. eauto with len.
    }
    lnorm. econstructor.
    + eauto with len.
    + eauto with len.
    + rewrite map_length. rewrite take_length_le; eauto.
      rewrite zip_length2; [eauto 20 with len|].
      rewrite fold_zip_ounion_length; eauto.
    + intros. inv_get. simpl.
      eapply trs_monotone_DL.
      * eapply H1; eauto using PIR2_Subset_tab_extend with len.
      * { rewrite (take_eta (length F) (zip ominus' _ _)).
          do 2 rewrite List.map_app.
          eapply PIR2_app.
          - rewrite restrict_disj.
            + eapply restrict_subset2; eauto.
              do 2 rewrite take_zip.
              rewrite take_app_eq; [|eauto with len].
              rewrite take_app_eq; [|eauto with len].
              eapply ominus'_Some_oto_list.
              eapply PIR2_take. eapply PIR2_addAdds3.
              eauto with len.
              eapply PIR2_combineParams_get;
                [ eapply computeParametersF_length_pair; eauto with len
                | eauto with len
                | eapply zip_get; eauto
                | reflexivity ].
            + intros.
              inv_get.
              Opaque to_list.

              pose proof (H10 _ H12).
              edestruct computeParameters_isCalledFrom_get_Some; try eapply H6;
                try eassumption;
                [ intros; edestruct H2; eauto
                | eauto with len
                | dcr; subst ].
              pose proof (H10 _ H15).
              edestruct computeParameters_isCalledFrom_get_Some; try eapply H7;
                try eassumption;
                [ intros; edestruct H2; eauto
                | eauto with len
                | dcr; subst ].
              simpl.
              repeat rewrite of_list_app.
              repeat rewrite of_list_3.
              eapply disj_minus.
              rewrite (meet_comm _ (getAnn lvs)) at 1.
              rewrite union_meet_distr_r. rewrite union_meet_distr_r.
              eapply union_incl_split.
              eapply incl_union_incl_minus. eapply incl_union_left.
              eapply incl_meet_split. eapply incl_union_right.
              eapply incl_list_union; [ eapply map_get_1; try eapply H5 | ].
              clear_all; cset_tac.
              clear_all; cset_tac.
              eapply incl_union_incl_minus. eapply incl_union_left.
              assert (x0 ⊆ list_union (oget ⊝ take ❬F❭ (olu F als Lv ZL AP t alb))). {
                eapply incl_list_union.
                eapply map_get_1; eauto.
                eapply get_take; try eapply H6; eauto. reflexivity.
              }
              clear - H17.
              cset_tac.
          - rewrite restrict_comp_meet.
            pose proof (H10 _ H12).
            edestruct computeParameters_isCalledFrom_get_Some; try eapply H6;
              eauto with len; dcr; subst.
            intros; edestruct H2; eauto.
            simpl.

            repeat rewrite of_list_app. repeat rewrite of_list_3.
            set (XX:=(list_union (oget
                                ⊝ take ❬F❭
                                    (olist_union (snd ⊝ computeParametersF F als Lv ZL AP)
                                     (snd
                                        (computeParameters ((getAnn ⊝ als ++ Lv) \\ (fst ⊝ F ++ ZL))
                                                           (tab {} ‖F‖ ++ AP) t alb))))
                                 ∪ list_union (fst ∘ of_list ⊝ F))).

            assert (lvsEQ:
                      lv ∩ (getAnn lvs \ (of_list (fst Zs) ∪
                                                  (XX ∩ (getAnn lvs \ of_list (fst Zs)) ∪ x)))
                         [=]
                         (getAnn lvs \ (of_list (fst Zs) ∪
                                                (XX ∩ (getAnn lvs \ of_list (fst Zs)) ∪ x)))). {
              rewrite meet_comm. symmetry. eapply incl_meet.
              rewrite <- H3. subst XX.
              rewrite <- H14.
              clear_all; cset_tac.
            }
            rewrite lvsEQ.
            rewrite restrict_disj.
            + eapply restrict_subset2; eauto.
              do 2 rewrite drop_zip.
              repeat rewrite drop_length_ass; eauto with len.
              eapply zip_ominus_contra; eauto with len.
              eapply PIR2_drop; eauto.
              eapply PIR2_addAdds3; eauto with len.
              eapply PIR2_combineParams_get;
                [ | eauto with len | eauto using zip_get_eq | reflexivity].
              eapply computeParametersF_length_pair; eauto with len.
            + intros. inv_get.
              unfold ominus', lminus in H15.
              destruct x3; invc H15. simpl in *.
              subst XX.
              revert H5 H6. clear_all.
              intros; hnf; intros. cset_tac'.
              * eapply H8; eauto.
                eapply incl_list_union. eapply map_get_1; eauto. reflexivity.
                eauto.
              * eapply H0; eauto.
                eapply incl_list_union.
                eapply map_get_1.
                eapply get_take; eauto using get_range. reflexivity.
                eauto.
        }
    + eapply trs_monotone_DL.
      eapply IHLIVE; eauto using PIR2_Subset_tab_extend with len.
      * { rewrite (take_eta (length F) (zip ominus' _ _)).
          rewrite List.map_app.
          eapply PIR2_app.
          - eapply PIR2_restrict.
            do 2 rewrite take_zip.
            rewrite take_app_eq; [|eauto with len].
            rewrite take_app_eq; [|eauto with len].
            eapply ominus'_Some_oto_list.
            eapply PIR2_take. eapply PIR2_addAdds3.
            eauto with len.
            eapply PIR2_combineParams; [| reflexivity].
            eapply computeParametersF_length_pair; eauto with len.
          - eapply restrict_subset2; eauto.
            do 2 rewrite drop_zip.
            repeat (rewrite drop_length_ass; [| eauto with len]).
            eapply zip_ominus_contra.
            eapply PIR2_drop; eauto.
            eapply PIR2_addAdds3. eauto with len.
            eapply PIR2_combineParams; [| reflexivity].
            eapply computeParametersF_length_pair; eauto with len.
        }
Qed.

Lemma is_trs b s lv
: live_sound Imperative nil nil s lv
  -> noUnreachableCode (isCalled b) s
  -> trs nil s lv (fst (computeParameters nil nil s lv)).
Proof.
  intros.
  assert (snd (computeParameters nil nil s lv) = nil). {
    exploit computeParameters_AP_LV; eauto.
    inv H1; eauto.
  }
  exploit computeParameters_trs; eauto; try reflexivity.
Qed.


From machine_program_logic.program_logic Require Import weakestpre.
From HypVeri Require Import lifting rules.rules_base stdpp_extra.
From HypVeri.algebra Require Import base reg mem pagetable trans mailbox base_extra.
From HypVeri.lang Require Import lang_extra mem_extra reg_extra pagetable_extra trans_extra.

Section mem_relinquish.

Context `{hypparams: HypervisorParameters}.
Context `{vmG: !gen_VMG Σ}.

Lemma p_relinquish_inv_consist σ h i j ps tt:
  inv_trans_pgt_consistent σ ->
  inv_trans_ps_disj σ ->
  σ.2 !! h = Some (Some (j, i, ps, tt, true)) ->
  j ≠ i ->
  inv_trans_pgt_consistent (update_page_table_global revoke_access (update_transaction σ h (j, i, ps, tt, false)) i ps).
Proof.
  intros Hinv_con Hinv_disj Hlk Hneq_i.
  rewrite /inv_trans_pgt_consistent /inv_trans_pgt_consistent' /=.
  rewrite map_Forall_lookup.
  intros h' meta Hlookup'.
  rewrite lookup_insert_Some in Hlookup'.
  destruct Hlookup' as [[<- <-]|[Hneq Hlookup']].
  {
    intros p Hin.
    specialize (Hinv_con h _ Hlk p Hin).
    simpl in Hinv_con.
    generalize dependent σ.1.1.1.2.
    generalize dependent σ.2.
    induction ps using set_ind_L .
    - set_solver + Hin.
    - intros tran Htran pgt Hpgt.
      simpl.
      rewrite set_fold_disj_union_strong.
      {
        rewrite set_fold_singleton.
        destruct (decide (x = p)).
        {
          subst.
          destruct tt;first done.
          rewrite Hpgt.
          apply p_upd_pgt_pgt_not_elem.
          done.
          rewrite lookup_insert_Some.
          left. split;auto.
          assert (Hrw: {[j;i]} ∖ {[i]} = ({[j]} : gset _)).
          set_solver + Hneq_i.
          rewrite /revoke_access Hrw //.
          rewrite Hpgt.
          apply p_upd_pgt_pgt_not_elem.
          done.
          rewrite lookup_insert_Some.
          left. split;auto.
          assert (Hrw: {[i]} ∖ {[i]} = (∅ : gset _)).
          set_solver +.
          rewrite /revoke_access Hrw //.
        }
        {
          destruct (pgt !! x).
          {
            feed specialize IHps.
            set_solver + Hin n.
            apply (IHps (<[h := Some (j, i, X, tt, true)]>tran));eauto.
            rewrite lookup_insert //.
            rewrite lookup_insert_ne //.
          }
          {
            feed specialize IHps.
            set_solver + Hin n.
            apply (IHps (<[h := Some (j, i, X, tt, true)]>tran));eauto.
            rewrite lookup_insert //.
          }
        }
      }
      apply upd_is_strong_assoc_comm.
      set_solver + H0.
  }
  {
    rewrite /inv_trans_pgt_consistent /inv_trans_pgt_consistent' /= in Hinv_con.
    specialize (Hinv_con h' meta Hlookup').
    simpl in Hinv_con.
    destruct meta as [[[[[sv rv] ps'] tt'] b]|];last done.
    simpl in *.
    intros p Hin.
    specialize (Hinv_con p Hin).
    assert (p ∉ ps).
    {
      intro.
      specialize (Hinv_disj h' _ Hlookup').
      simpl in Hinv_disj.
      pose proof (elem_of_pages_in_trans' p (delete h' σ.2)) as [_ Hin'].
      feed specialize Hin'.
      exists h.
      eexists.
      split.
      rewrite lookup_delete_ne //.
      done.
      set_solver + Hin H0 Hin' Hinv_disj.
    }
    destruct tt',b;auto;try apply p_upd_pgt_pgt_not_elem;auto.
  }
Qed.

Lemma mem_relinquish {tt wi sacc i j q p_tx} {ps: gset PID}
      ai r0 wh:
  (* has access to the page which the instruction is in *)
  tpa ai ≠ p_tx ->
  tpa ai ∈ sacc ->
  (* current instruction is hvc *)
  decode_instruction wi = Some(Hvc) ->
  (* the hvc call to invoke is relinquish *)
  decode_hvc_func r0 = Some(Relinquish) ->
  {SS{{(* the encoding of instruction wi is stored in location ai *)
       ▷(PC @@ i ->r ai) ∗  ▷ ai ->a wi ∗
       ▷ (R0 @@ i ->r r0) ∗
       ▷ (R1 @@ i ->r wh) ∗
       (* the pagetable, the owership ra is not required *)
       ▷ i -@A> sacc ∗
       (* the descriptor is ready in the tx page *)
       ▷ TX@ i := p_tx ∗
       (* is the receiver and the transaction has been retrieved *)
       ▷ wh -{q}>t (j, i, ps, tt) ∗ ▷ wh ->re true }}}
  ExecI @ i
  {{{ RET (false, ExecI) ;
      (* PC is incremented *)
      PC @@ i ->r (ai ^+ 1)%f ∗ ai ->a wi ∗
      (* donesn't have access to psd anymore *)
      i -@A> (sacc ∖ ps) ∗
      (* return Succ to R0 *)
      R0 @@ i ->r (encode_hvc_ret_code Succ) ∗
      R1 @@ i ->r wh ∗
      (* the same tx *)
      TX@ i := p_tx ∗
      (* the transaction is marked as unretrieved *)
      wh -{q}>t(j, i, ps, tt) ∗ wh ->re false
      }}}.
Proof.
  iIntros (Hneq_tx Hin_acc Hdecode_i Hdecode_f Φ) "(>PC & >mem_ins & >R0 & >R1 & >acc & >tx & >tran & >re) HΦ".
  iApply (sswp_lift_atomic_step ExecI);[done|].
  iIntros (n σ1) "%Hsche state".
  rewrite /scheduled /= /scheduler in Hsche.
  assert (σ1.1.1.2 = i) as Heq_cur. { case_bool_decide;last done. by apply fin_to_nat_inj. }
  clear Hsche.
  iModIntro.
  iDestruct "state" as "(Hnum & mem & regs & mb & rx_state & pgt_owned & pgt_acc & pgt_excl &
                            trans & hpool & retri & %Hwf & %Hdisj & %Hconsis)".
  (* valid regs *)
  iDestruct ((gen_reg_valid3 i PC ai R0 r0 R1 wh Heq_cur) with "regs PC R0 R1")
    as "(%Hlookup_PC & %Hlookup_R0 & %Hlookup_R1)";eauto.
  (* valid pt *)
  iDestruct (access_agree_check_true (tpa ai) i with "pgt_acc acc") as %Hcheckpg_ai;eauto.
  (* valid mem *)
  iDestruct (gen_mem_valid ai wi with "mem mem_ins") as %Hlookup_ai.
  (* valid tx rx *)
  iDestruct (mb_valid_tx i p_tx with "mb tx") as %Heq_tx.
  (* valid trans *)
  iDestruct (trans_valid_Some with "trans tran") as %[re Hlookup_tran].
  iDestruct (trans_valid_handle_Some with "tran") as %Hvalid_handle.
  iDestruct (retri_valid_Some with "retri re") as %[meta Hlookup_tran'].
  rewrite Hlookup_tran in Hlookup_tran'.
  inversion Hlookup_tran'. subst re. clear meta Hlookup_tran' H1.
  iSplit.
  - (* reducible *)
    iPureIntro.
    apply (reducible_normal i Hvc ai wi);eauto.
    rewrite Heq_tx //.
  - iModIntro.
    iIntros (m2 σ2) "vmprop_auth %HstepP".
    iFrame "vmprop_auth".
    apply (step_ExecI_normal i Hvc ai wi) in HstepP;eauto.
    2: rewrite Heq_tx //.
    remember (exec Hvc σ1) as c2 eqn:Heqc2.
    rewrite /exec /hvc Hlookup_R0 /= Hdecode_f /relinquish Hlookup_R1 /get_transaction /= Hlookup_tran Heq_cur /= in Heqc2.
    case_bool_decide;last done. clear H0. simpl in Heqc2.
    case_bool_decide;last done. clear H0.
    destruct HstepP;subst m2 σ2; subst c2; simpl.
    rewrite /gen_vm_interp.
    (* unchanged part *)
    rewrite (preserve_get_rx_gmap σ1).
    2: rewrite p_upd_pc_mb //.
    rewrite (preserve_get_mb_gmap σ1).
    2: rewrite p_upd_pc_mb //.
    rewrite p_upd_pc_mem p_upd_reg_mem p_rvk_acc_mem p_upd_tran_mem.
    iFrame "Hnum mem mb rx_state".
    (* upd regs *)
    rewrite (u_upd_pc_regs _ i ai). 2: done.
    2: { rewrite u_upd_reg_regs p_rvk_acc_current_vm p_upd_tran_current_vm.
         rewrite (preserve_get_reg_gmap σ1). rewrite lookup_insert_ne. solve_reg_lookup. done. f_equal.
    }
    rewrite u_upd_reg_regs p_rvk_acc_current_vm p_upd_tran_current_vm Heq_cur.
    rewrite (preserve_get_reg_gmap σ1);last done.
    iDestruct ((gen_reg_update2_global PC i _ (ai ^+ 1)%f R0 i _ (encode_hvc_ret_code Succ)) with "regs PC R0")
      as ">[$ [PC R0]]";eauto.
    (* upd pgt *)
    rewrite (preserve_get_own_gmap (update_page_table_global revoke_access (update_transaction σ1 wh (j, i, ps, tt, false)) i ps) (update_incr_PC _)).
    2: rewrite p_upd_pc_pgt p_upd_reg_pgt //.
    rewrite p_rvk_acc_own. rewrite (preserve_get_own_gmap σ1);last done.
    iFrame "pgt_owned".
    rewrite (preserve_get_access_gmap (update_page_table_global revoke_access (update_transaction σ1 wh (j, i, ps, tt, true)) i ps) (update_incr_PC _)).
    2: rewrite p_upd_pc_pgt p_upd_reg_pgt //.
    iDestruct (access_agree with "pgt_acc acc") as %Hlookup_pgt_acc.
    rewrite (u_rvk_acc_acc _ _ _ sacc).
    2: {
      rewrite p_upd_tran_pgt.
      intros p Hin_p.
      specialize (Hconsis wh _ Hlookup_tran p Hin_p).
      simpl in Hconsis.
      destruct tt.
      done.
      eexists;eauto.
      eexists;eauto.
    }
    2: rewrite (preserve_get_access_gmap σ1);done.
    rewrite (preserve_get_access_gmap σ1);last done.
    iDestruct (access_update (sacc∖ ps) with "pgt_acc acc") as ">[$ acc]". done.
    rewrite (preserve_get_excl_gmap (update_page_table_global revoke_access (update_transaction σ1 wh (j, i, ps, tt, false)) i ps) (update_incr_PC _)).
    2: rewrite p_upd_pc_pgt p_upd_reg_pgt //.
    rewrite (p_rvk_acc_excl _ _ j tt).
    2: {
      intros p Hin.
      specialize (Hconsis wh _ Hlookup_tran p Hin).
      destruct tt; simpl in Hconsis.
      done.
      rewrite p_upd_tran_pgt //.
      rewrite p_upd_tran_pgt //.
    }
    rewrite (preserve_get_excl_gmap σ1);last done.
    iFrame "pgt_excl".
    (* upd tran *)
    rewrite (preserve_get_trans_gmap (update_transaction σ1 wh (j, i, ps, tt, false)) (update_incr_PC _)).
    2: rewrite p_upd_pc_trans p_upd_reg_trans //.
    rewrite u_upd_tran_trans.
    rewrite insert_id.
    2: rewrite /get_trans_gmap /get_transactions_gmap lookup_fmap Hlookup_tran //=.
    iFrame "trans".
    (* upd hp *)
    rewrite (preserve_get_hpool_gset (update_transaction σ1 wh (j, i, ps, tt, false)) (update_incr_PC _)).
    2: rewrite p_upd_pc_trans p_upd_reg_trans //. rewrite p_upd_tran_hp.
    iFrame "hpool".
    (* upd retri *)
    rewrite (preserve_get_retri_gmap (update_transaction σ1 wh (j, i, ps, tt, false)) (update_incr_PC _)).
    2: rewrite p_upd_pc_trans p_upd_reg_trans //.
    2: { exists (Some (j, i, ps, tt, true)). split;eauto. }
    rewrite u_upd_tran_retri.
    iDestruct (retri_update_flip with "retri re") as ">[$ re]".
    (* inv_trans_wellformed *)
    rewrite (preserve_inv_trans_wellformed (update_transaction σ1 wh (j, i, ps, tt, false))).
    2: rewrite p_upd_pc_trans p_upd_reg_trans //.
    iAssert (⌜inv_trans_wellformed (update_transaction σ1 wh (j, i, ps, tt, false))⌝%I) as "$". iPureIntro.
    apply (p_upd_tran_inv_wf σ1 wh);eauto.
    (* inv_trans_pgt_consistent *)
    rewrite (preserve_inv_trans_pgt_consistent (update_page_table_global revoke_access (update_transaction σ1 wh (j, i, ps, tt, false)) i ps) (update_incr_PC _)).
    2: rewrite p_upd_pc_trans p_upd_reg_trans //.
    2: rewrite p_upd_pc_pgt p_upd_reg_pgt //.
    iAssert (⌜inv_trans_pgt_consistent (update_page_table_global revoke_access (update_transaction σ1 wh (j, i, ps, tt, false)) i ps)⌝%I) as "$". iPureIntro.
    apply p_relinquish_inv_consist;auto.
    { destruct Hwf as [_ [Hwf _]]. specialize (Hwf wh _ Hlookup_tran). done. }
    (* inv_trans_ps_disj *)
    rewrite (preserve_inv_trans_ps_disj (update_transaction σ1 wh (j, i, ps, tt, false))).
    2: rewrite p_upd_pc_trans p_upd_reg_trans //.
    iAssert (⌜inv_trans_ps_disj (update_transaction σ1 wh (j, i, ps, tt, false))⌝%I) as "$". iPureIntro.
    eapply p_upd_tran_inv_disj.
    apply Hdisj.
    exact Hlookup_tran.
    done.
    (* just_scheduled *)
    iModIntro.
    rewrite /just_scheduled_vms /just_scheduled.
    rewrite /scheduled /machine.scheduler /= /scheduler.
    rewrite p_upd_pc_current_vm p_upd_reg_current_vm p_rvk_acc_current_vm p_upd_tran_current_vm.
    rewrite Heq_cur.
    iSplitL "".
    set fl := (filter _ _).
    assert (fl = []) as ->.
    {
      rewrite /fl.
      induction n.
      - simpl.
        rewrite filter_nil //=.
      - rewrite seq_S.
        rewrite filter_app.
        rewrite IHn.
        simpl.
        rewrite filter_cons_False /=. rewrite filter_nil //.
        rewrite andb_negb_l //.
    }
    by iSimpl.
    (* Φ *)
    case_bool_decide;last contradiction.
    simpl. iApply "HΦ".
    rewrite /fresh_handles. iFrame.
Qed.

Lemma mem_relinquish_invalid_handle {E i wi sacc r0 r2 wh p_tx} ai:
  tpa ai ≠ p_tx ->
  (tpa ai) ∈ sacc ->
  (* the current instruction is hvc *)
  (* the decoding of wi is correct *)
  decode_instruction wi = Some(Hvc) ->
  (* the hvc call to invoke is retrieve *)
  decode_hvc_func r0 = Some(Relinquish) ->
  wh ∉ valid_handles ->
  {SS{{(* the encoding of instruction wi is stored in location ai *)
       ▷ (PC @@ i ->r ai) ∗ ▷ ai ->a wi ∗
       (* registers *)
       ▷ (R0 @@ i ->r r0) ∗
       ▷ (R1 @@ i ->r wh) ∗
       ▷ (R2 @@ i ->r r2) ∗
       ▷ i -@A> sacc ∗
       ▷ TX@ i := p_tx}}}
   ExecI @ i; E
   {{{ RET (false, ExecI) ;
       (* PC is incremented *)
       PC @@ i ->r (ai ^+ 1)%f ∗ ai ->a wi ∗
       R0 @@ i ->r (encode_hvc_ret_code Error) ∗
       R1 @@ i ->r wh ∗
       R2 @@ i ->r (encode_hvc_error InvParam) ∗
       i -@A> sacc ∗
       TX@ i := p_tx
   }}}.
Proof.
  iIntros (Hneq_tx Hin_acc Hdecode_i Hdecode_f Hnin_wh Φ)
          "(>PC & >mem_ins & >R0 & >R1 & >R2 & >acc & >tx) HΦ".
  iApply (sswp_lift_atomic_step ExecI);[done|].
  iIntros (n σ1) "%Hsche state".
  rewrite /scheduled /= /scheduler in Hsche.
  assert (σ1.1.1.2 = i) as Heq_cur. { case_bool_decide;last done. by apply fin_to_nat_inj. }
  clear Hsche.
  iModIntro.
  iDestruct "state" as "(Hnum & mem & regs & mb & rx_state & pgt_owned & pgt_acc & pgt_excl &
                            trans & hpool & retri & %Hwf & %Hdisj & %Hconsis)".
  (* valid regs *)
  iDestruct ((gen_reg_valid4 i PC ai R0 r0 R1 wh R2 r2 Heq_cur) with "regs PC R0 R1 R2")
    as "(%Hlookup_PC & %Hlookup_R0 & %Hlookup_R1 & %Hlookup_R2)";eauto.
  (* valid pt *)
  iDestruct (access_agree_check_true (tpa ai) i with "pgt_acc acc") as %Hcheckpg_ai;eauto.
  (* valid mem *)
  iDestruct (gen_mem_valid ai wi with "mem mem_ins") as %Hlookup_ai.
  (* valid tx *)
  iDestruct (mb_valid_tx i p_tx with "mb tx") as %Heq_tx.
  (* valid tran *)
  iSplit.
  - (* reducible *)
    iPureIntro.
    apply (reducible_normal i Hvc ai wi);auto.
    rewrite Heq_tx //.
  - iModIntro.
    iIntros (m2 σ2) "vmprop_auth %HstepP".
    iFrame "vmprop_auth".
    apply (step_ExecI_normal i Hvc ai wi) in HstepP;eauto.
    2: rewrite Heq_tx //.
    remember (exec Hvc σ1) as c2 eqn:Heqc2.
    rewrite /exec /hvc Hlookup_R0 /= Hdecode_f /relinquish Hlookup_R1 /= in Heqc2.
    assert (Hwh_None: get_transaction σ1 wh = None).
    {
      destruct Hwf as [_ [_ Hwf]].
      rewrite /inv_finite_handles in Hwf.
      rewrite Hwf in Hnin_wh.
      rewrite not_elem_of_dom in Hnin_wh.
      rewrite /get_transaction Hnin_wh //.
      case_bool_decide;done.
    }
    rewrite Hwh_None /= in Heqc2.
    destruct HstepP;subst m2 σ2; subst c2; simpl.
    iDestruct (hvc_error_update (E:= E) InvParam with "PC R0 R2 [$Hnum $mem $regs $mb $rx_state $pgt_owned $pgt_acc $pgt_excl $ trans $hpool $retri]")
    as ">[[$ $] ?]". 1-4: auto. iPureIntro. auto.
    rewrite /scheduled /machine.scheduler /= /scheduler.
    rewrite p_upd_pc_current_vm 2!p_upd_reg_current_vm Heq_cur.
    case_bool_decide;last contradiction.
    simpl. iApply "HΦ".
    iFrame.
    by iFrame.
Qed.

Lemma mem_relinquish_fresh_handle {E i wi sacc r0 r2 wh sh q p_tx} ai:
  tpa ai ≠ p_tx ->
  (tpa ai) ∈ sacc ->
  decode_instruction wi = Some(Hvc) ->
  decode_hvc_func r0 = Some(Relinquish) ->
  wh ∈ sh ->
  {SS{{▷ (PC @@ i ->r ai) ∗ ▷ ai ->a wi ∗
       ▷ (R0 @@ i ->r r0) ∗
       ▷ (R1 @@ i ->r wh) ∗
       ▷ (R2 @@ i ->r r2) ∗
       ▷ i -@A> sacc ∗
       ▷ TX@ i := p_tx ∗
       ▷ fresh_handles q sh}}}
   ExecI @ i; E
   {{{ RET (false, ExecI) ;
       PC @@ i ->r (ai ^+ 1)%f ∗ ai ->a wi ∗
       R0 @@ i ->r (encode_hvc_ret_code Error) ∗
       R1 @@ i ->r wh ∗
       R2 @@ i ->r (encode_hvc_error InvParam) ∗
       i -@A> sacc ∗
       TX@ i := p_tx ∗
       fresh_handles q sh
   }}}.
Proof.
  iIntros (Hneq_tx Hin_acc Hdecode_i Hdecode_f Hin_wh Φ)
          "(>PC & >mem_ins & >R0 & >R1 & >R2 & >acc & >tx & >[hp handles]) HΦ".
  iApply (sswp_lift_atomic_step ExecI);[done|].
  iIntros (n σ1) "%Hsche state".
  rewrite /scheduled /= /scheduler in Hsche.
  assert (σ1.1.1.2 = i) as Heq_cur. { case_bool_decide;last done. by apply fin_to_nat_inj. }
  clear Hsche.
  iModIntro.
  iDestruct "state" as "(Hnum & mem & regs & mb & rx_state & pgt_owned & pgt_acc & pgt_excl &
                            trans & hpool & retri & %Hwf & %Hdisj & %Hconsis)".
  (* valid regs *)
  iDestruct ((gen_reg_valid4 i PC ai R0 r0 R1 wh R2 r2 Heq_cur) with "regs PC R0 R1 R2")
    as "(%Hlookup_PC & %Hlookup_R0 & %Hlookup_R1 & %Hlookup_R2)";eauto.
  (* valid pt *)
  iDestruct (access_agree_check_true (tpa ai) i with "pgt_acc acc") as %Hcheckpg_ai;eauto.
  (* valid mem *)
  iDestruct (gen_mem_valid ai wi with "mem mem_ins") as %Hlookup_ai.
  (* valid tx *)
  iDestruct (mb_valid_tx i p_tx with "mb tx") as %Heq_tx.
  (* valid hpool *)
  iDestruct (hpool_valid with "hpool hp") as %Heq_hp.
  (* valid tran *)
  iAssert (⌜get_transaction σ1 wh = None⌝%I) as %Hwh_None.
  {
    iDestruct (big_sepS_elem_of _ _ wh with "handles") as "[tran _]".
    done.
    iDestruct (trans_valid_None with "trans tran") as %Hlookup_tran.
    iPureIntro.
    rewrite /get_transaction Hlookup_tran //.
    case_bool_decide;done.
  }
  iSplit.
  - (* reducible *)
    iPureIntro.
    apply (reducible_normal i Hvc ai wi);auto.
    rewrite Heq_tx //.
  - iModIntro.
    iIntros (m2 σ2) "vmprop_auth %HstepP".
    iFrame "vmprop_auth".
    apply (step_ExecI_normal i Hvc ai wi) in HstepP;eauto.
    2: rewrite Heq_tx //.
    remember (exec Hvc σ1) as c2 eqn:Heqc2.
    rewrite /exec /hvc Hlookup_R0 /= Hdecode_f /relinquish Hlookup_R1 /= in Heqc2.
    rewrite Hwh_None /= in Heqc2.
    destruct HstepP;subst m2 σ2; subst c2; simpl.
    iDestruct (hvc_error_update (E:= E) InvParam with "PC R0 R2 [$Hnum $mem $regs $mb $rx_state $pgt_owned $pgt_acc $pgt_excl $ trans $hpool $retri]")
    as ">[[$ $] ?]". 1-4: auto. iPureIntro. auto.
    rewrite /scheduled /machine.scheduler /= /scheduler.
    rewrite p_upd_pc_current_vm 2!p_upd_reg_current_vm Heq_cur.
    case_bool_decide;last contradiction.
    simpl. iApply "HΦ".
    iFrame.
    by iFrame.
Qed.

Lemma mem_relinquish_invalid_trans {E i wi sacc r0 r2 wh meta q p_tx} ai:
  tpa ai ≠ p_tx ->
  (tpa ai) ∈ sacc ->
  decode_instruction wi = Some(Hvc) ->
  decode_hvc_func r0 = Some(Relinquish) ->
  meta.1.1.2 ≠ i ->
  {SS{{▷ (PC @@ i ->r ai) ∗ ▷ ai ->a wi ∗
       ▷ (R0 @@ i ->r r0) ∗
       ▷ (R1 @@ i ->r wh) ∗
       ▷ (R2 @@ i ->r r2) ∗
       ▷ i -@A> sacc ∗
       ▷ TX@ i := p_tx ∗
       ▷ wh -{q}>t (meta)
       }}}
   ExecI @ i; E
   {{{ RET (false, ExecI) ;
       PC @@ i ->r (ai ^+ 1)%f ∗ ai ->a wi ∗
       R0 @@ i ->r (encode_hvc_ret_code Error) ∗
       R1 @@ i ->r wh ∗
       R2 @@ i ->r (encode_hvc_error Denied) ∗
       i -@A> sacc ∗
       TX@ i := p_tx ∗
       wh -{q}>t (meta)
   }}}.
Proof.
  iIntros (Hneq_tx Hin_acc Hdecode_i Hdecode_f Hin_wh Φ)
          "(>PC & >mem_ins & >R0 & >R1 & >R2 & >acc & >tx & >tran) HΦ".
  iApply (sswp_lift_atomic_step ExecI);[done|].
  iIntros (n σ1) "%Hsche state".
  rewrite /scheduled /= /scheduler in Hsche.
  assert (σ1.1.1.2 = i) as Heq_cur. { case_bool_decide;last done. by apply fin_to_nat_inj. }
  clear Hsche.
  iModIntro.
  iDestruct "state" as "(Hnum & mem & regs & mb & rx_state & pgt_owned & pgt_acc & pgt_excl &
                            trans & hpool & retri & %Hwf & %Hdisj & %Hconsis)".
  (* valid regs *)
  iDestruct ((gen_reg_valid4 i PC ai R0 r0 R1 wh R2 r2 Heq_cur) with "regs PC R0 R1 R2")
    as "(%Hlookup_PC & %Hlookup_R0 & %Hlookup_R1 & %Hlookup_R2)";eauto.
  (* valid pt *)
  iDestruct (access_agree_check_true (tpa ai) i with "pgt_acc acc") as %Hcheckpg_ai;eauto.
  (* valid mem *)
  iDestruct (gen_mem_valid ai wi with "mem mem_ins") as %Hlookup_ai.
  (* valid tx *)
  iDestruct (mb_valid_tx i p_tx with "mb tx") as %Heq_tx.
  (* valid tran *)
  iDestruct (trans_valid_Some with "trans tran") as %[? Hlookup_tran].
  iDestruct (trans_valid_handle_Some with "tran") as %Hvalid_handle.
  iSplit.
  - (* reducible *)
    iPureIntro.
    apply (reducible_normal i Hvc ai wi);auto.
    rewrite Heq_tx //.
  - iModIntro.
    iIntros (m2 σ2) "vmprop_auth %HstepP".
    iFrame "vmprop_auth".
    apply (step_ExecI_normal i Hvc ai wi) in HstepP;eauto.
    2: rewrite Heq_tx //.
    remember (exec Hvc σ1) as c2 eqn:Heqc2.
    rewrite /exec /hvc Hlookup_R0 /= Hdecode_f /relinquish Hlookup_R1 /= in Heqc2.
    rewrite /get_transaction Hlookup_tran /= in Heqc2.
    destruct meta as [[[? ?] ?] ?].
    case_bool_decide;last contradiction. clear H0. simpl in Heqc2.
    case_bool_decide;rewrite Heq_cur // in H0.
    rewrite andb_false_r /= in Heqc2.
    destruct HstepP;subst m2 σ2; subst c2; simpl.
    iDestruct (hvc_error_update (E:= E) Denied with "PC R0 R2 [$Hnum $mem $regs $mb $rx_state $pgt_owned $pgt_acc $pgt_excl $ trans $hpool $retri]")
    as ">[[$ $] ?]". 1-4: auto. iPureIntro. auto.
    rewrite /scheduled /machine.scheduler /= /scheduler.
    rewrite p_upd_pc_current_vm 2!p_upd_reg_current_vm Heq_cur.
    case_bool_decide;last contradiction.
    simpl. iApply "HΦ".
    iFrame.
    by iFrame.
Qed.

Lemma mem_relinquish_not_retrieved{E i wi sacc r0 r2 wh q p_tx} ai:
  tpa ai ≠ p_tx ->
  (tpa ai) ∈ sacc ->
  decode_instruction wi = Some(Hvc) ->
  decode_hvc_func r0 = Some(Relinquish) ->
  {SS{{▷ (PC @@ i ->r ai) ∗ ▷ ai ->a wi ∗
       ▷ (R0 @@ i ->r r0) ∗
       ▷ (R1 @@ i ->r wh) ∗
       ▷ (R2 @@ i ->r r2) ∗
       ▷ i -@A> sacc ∗
       ▷ TX@ i := p_tx ∗
       ▷ wh -{q}>re false
       }}}
   ExecI @ i; E
   {{{ RET (false, ExecI) ;
       PC @@ i ->r (ai ^+ 1)%f ∗ ai ->a wi ∗
       R0 @@ i ->r (encode_hvc_ret_code Error) ∗
       R1 @@ i ->r wh ∗
       R2 @@ i ->r (encode_hvc_error Denied) ∗
       i -@A> sacc ∗
       TX@ i := p_tx ∗
       wh -{q}>re false
   }}}.
Proof.
  iIntros (Hneq_tx Hin_acc Hdecode_i Hdecode_f Φ)
          "(>PC & >mem_ins & >R0 & >R1 & >R2 & >acc & >tx & >re) HΦ".
  iApply (sswp_lift_atomic_step ExecI);[done|].
  iIntros (n σ1) "%Hsche state".
  rewrite /scheduled /= /scheduler in Hsche.
  assert (σ1.1.1.2 = i) as Heq_cur. { case_bool_decide;last done. by apply fin_to_nat_inj. }
  clear Hsche.
  iModIntro.
  iDestruct "state" as "(Hnum & mem & regs & mb & rx_state & pgt_owned & pgt_acc & pgt_excl &
                            trans & hpool & retri & %Hwf & %Hdisj & %Hconsis)".
  (* valid regs *)
  iDestruct ((gen_reg_valid4 i PC ai R0 r0 R1 wh R2 r2 Heq_cur) with "regs PC R0 R1 R2")
    as "(%Hlookup_PC & %Hlookup_R0 & %Hlookup_R1 & %Hlookup_R2)";eauto.
  (* valid pt *)
  iDestruct (access_agree_check_true (tpa ai) i with "pgt_acc acc") as %Hcheckpg_ai;eauto.
  (* valid mem *)
  iDestruct (gen_mem_valid ai wi with "mem mem_ins") as %Hlookup_ai.
  (* valid tx *)
  iDestruct (mb_valid_tx i p_tx with "mb tx") as %Heq_tx.
  (* valid tran *)
  iDestruct (retri_valid_Some with "retri re") as %[? Hlookup_re].
  iDestruct (retri_valid_handle_Some with "re") as %Hvalid_handle.
  iSplit.
  - (* reducible *)
    iPureIntro.
    apply (reducible_normal i Hvc ai wi);auto.
    rewrite Heq_tx //.
  - iModIntro.
    iIntros (m2 σ2) "vmprop_auth %HstepP".
    iFrame "vmprop_auth".
    apply (step_ExecI_normal i Hvc ai wi) in HstepP;eauto.
    2: rewrite Heq_tx //.
    remember (exec Hvc σ1) as c2 eqn:Heqc2.
    rewrite /exec /hvc Hlookup_R0 /= Hdecode_f /relinquish Hlookup_R1 /= in Heqc2.
    rewrite /get_transaction Hlookup_re /= in Heqc2.
    destruct x as [[[? ?] ?] ?].
    assert (Heq_c2 : (m2,σ2) = (ExecI, update_incr_PC (update_reg (update_reg σ1 R0 (encode_hvc_ret_code Error)) R2 (encode_hvc_error Denied)))).
    {
      case_bool_decide;last contradiction.
      destruct HstepP;subst m2 σ2; subst c2; done.
    }
    inversion Heq_c2. clear H1 H2 Heq_c2 Heqc2.
    iDestruct (hvc_error_update (E:= E) Denied with "PC R0 R2 [$Hnum $mem $regs $mb $rx_state $pgt_owned $pgt_acc $pgt_excl $ trans $hpool $retri]")
    as ">[[$ $] ?]". 1-4: auto. iPureIntro. auto.
    rewrite /scheduled /machine.scheduler /= /scheduler.
    rewrite p_upd_pc_current_vm 2!p_upd_reg_current_vm Heq_cur.
    case_bool_decide;last contradiction.
    simpl. iApply "HΦ".
    iFrame.
    by iFrame.
Qed.

End mem_relinquish.


Require Import Min.

Require Import msl.msl_standard.
Require Import Maps.
Require Import FuncListMachine.
Require Import lemmas.

Open Scope pred.

Program Definition guards (n:nat) (X:pred world) (stk:stack) : pred world :=
  fun prt =>
    match prt with (p,(r,t)) =>

      forall p',
        necR p p' ->
        X (p',(r,t)) ->
        safe t p' r stk /\
        (level p' >= n -> eventually_halts t p' r stk)
  end.
Next Obligation.
  unfold hereditary; intros.
  destruct a as [p [r' t]].
  destruct a' as [p' [r'' t']].
  hnf in H.
  simpl in H.
  unfold prog in *.
  case_eq (age1 p); intros.
  rewrite H1 in H.
  inv H.
  spec H0 p'0.
  spec H0.
  apply rt_trans with p'; auto.
  apply rt_step; auto.
  spec H0; auto.
  rewrite H1 in H; discriminate.
Qed.

Program Definition term_guards (t:store -> option nat) (n:nat) (X:pred world) (stk:stack) : pred world :=
  fun prt =>
    match prt with (p,(r,t')) =>

      forall p',
        necR p p' ->
        X (p',(r,t')) ->
        exists n',
          t r = Some n' /\
          safe t' p' r stk /\
          (level p' >= (n'+n) -> eventually_halts t' p' r stk)
  end.
Next Obligation.
  unfold hereditary; intros.
  destruct a as [? [? ?]].
  destruct a' as [? [? ?]].
  intros.
  hnf in H.
  unfold prog in *.
  simpl in H.
  case_eq (age1 p); intros; rewrite H3 in H; inv H.
  spec H0 p'. spec H0.
  apply rt_trans with p0; auto.
  apply rt_step; auto.
  spec H0; auto.
Qed.

Program Definition funptr (l:label) (A:Type) (P Q: A -> pred world) : pred world :=
  fun prt =>
    match prt with (p,(_,t)) =>
      exists i,  prog_lookup p l = Some i /\
        (forall stk p' n t' (x:A),
          termMeasure_incr t t' ->
           laterR p p' ->
           (forall r', guards n (Q x) stk (p',(r' ,t'))) ->
           (forall r , term_guards (t l) n (P x) ((i;;instr_nil _)::stk) (p',(r,t'))))
    end.
Next Obligation.
  unfold hereditary; intros.
  destruct a as [p [r' t]].
  destruct a' as [p' [r'' t']].
  hnf in H; simpl in H.
  case_eq (age1 p); intros.
  unfold prog in *.
  rewrite H1 in H.
  inv H.
  rename t' into t.
  destruct H0 as [i [? ?]].
  rewrite K.knot_age1 in H1.
  case_eq (K.unsquash p); intros.
  rewrite H2 in H1.
  destruct n; try discriminate.
  inv H1.
  exists (fmap_instr (K.approx n) i).
  split.
  unfold prog_lookup.
  rewrite K.unsquash_squash; simpl.
  unfold KnotInput.fmap.
  apply fmap_eqn.
  unfold prog_lookup in H.
  rewrite H2 in H.
  auto.
  intros.
  spec H0 stk p' n0 t' x.
  spec H0; auto.
  spec H0.
  apply t_trans with (K.squash (n,f)); auto.
  apply t_step.
  hnf. simpl.
  rewrite K.knot_age1. rewrite H2. auto.
  spec H0. auto.
  hnf; intros.
  spec H0 r p'0 H5 H6.
  destruct H0 as [n' [? ?]].
  exists n'; split; auto.
  destruct H7; split.
  revert H7; apply safe_approx with n; eauto.
  replace n with (level (K.squash (n,f))).
  apply later_level.
  apply Rt_Rft_trans with p'; auto.
  rewrite K.knot_level.
  rewrite K.unsquash_squash; auto.
  hnf; eauto.
  hnf; auto.
  constructor; auto.
  apply (intro_instr_approx_rel _ _ (i;;instr_nil _)); auto.
  apply stack_approx_rel_refl.
  intros; spec H8; auto.
  revert H8.
  apply ev_halts_approx with n.
  replace n with (level (K.squash (n,f))).
  apply later_level.
  apply Rt_Rft_trans with p'; auto.
  rewrite K.knot_level.
  rewrite K.unsquash_squash; auto.
  hnf; eauto.
  hnf; auto.
  constructor; auto.
  apply (intro_instr_approx_rel _ _ (i;;instr_nil _)); auto.
  apply stack_approx_rel_refl.

  unfold prog in *.
  rewrite H1 in H.
  discriminate.
Qed.

Lemma boxy_funptr : forall l A P Q,
  boxy K.expandM (funptr l A P Q).
Proof.
  intros. apply boxy_i; auto.
  simpl; intros.
  destruct w; destruct w'.
  destruct o; destruct o0.
  rewrite K.expandM_spec in H.
  destruct H.
  assert (k=k0).
  hnf in H.
  apply K.unsquash_inj.
  destruct (K.unsquash k). destruct (K.unsquash k0).
  destruct H; f_equal; auto.
  subst k0.
  destruct H1. simpl in *.
  destruct H0 as [i [? ?]].
  exists i; split; auto.
  intros.
  spec H3 stk p' n t' x. spec H3; auto.
  do 2 intro. destruct (H2 l0 r0); auto.
  rewrite H9; auto.
  spec H3; auto.
  spec H3; auto.
  spec H3 r p'0 H7 H8.
  destruct H3 as [n' [? ?]].
  exists n'; split; auto.
  destruct (H2 l r); auto.
  rewrite H3 in H10; discriminate.
  congruence.
Qed.

(* Definition of the hoare relation and rules *)

Definition hoare (t:terminationMeasure) (n':nat) (G R P:pred world) (c:instruction) (Q:pred world) :=
  forall t', termMeasure_incr t t' ->

  forall p n k stk,
    (forall s, G (p,(s,t'))) ->
    (forall r', guards n R stk       (p,(r',t'))) ->
    (forall r', guards n Q (k::stk)  (p,(r',t'))) ->
    (forall r,  guards (n'+n) P ((c ;; k)::stk) (p,(r,t'))).

Lemma hoare_weaken : forall t t' x x' (G G' R R' P P' Q Q':pred world) i,
  termMeasure_incr t t' ->
  x <= x' ->
  G' |-- G  ->
  R  |-- R' ->
  P' |-- P  ->
  Q  |-- Q' ->
  hoare t  x  G  R  P  i Q ->
  hoare t' x' G' R' P' i Q'.
Proof.
  intros until i; repeat intro.
  hnf in H5.
  spec H5 t'0.
  spec H5; auto.
  do 2 intro. destruct (H l r0); auto.
  rewrite H12; auto.
  spec H5 p n k stk.
  spec H5; auto.
  spec H5. repeat intro. eapply H8; eauto.
  spec H5. repeat intro. eapply H9; eauto.
  spec H5 r p' H10.
  spec H5; auto.
  destruct H5; split; auto.
  intro. spec H12. omega.
  auto.
Qed.

Lemma hoare_weaken_time : forall t x x' G R P i Q,
  x <= x' ->
  hoare t x G R P i Q ->
  hoare t x' G R P i Q.
Proof.
  intros until Q. intro. apply hoare_weaken; auto; hnf; auto.
Qed.

Lemma hoare_weaken_pre : forall t x G R P P' i Q,
  P' |-- P ->
  hoare t x G R P i Q ->
  hoare t x G R P' i Q .
Proof.
  intros until Q. intro.
  apply hoare_weaken; auto; hnf; auto.
Qed.

Lemma hoare_weaken_post : forall t x G R P i Q Q',
  Q |-- Q' ->
  hoare t x G R P i Q ->
  hoare t x G R P i Q'.
Proof.
  intros until Q'. intro.
  apply hoare_weaken; auto; hnf; auto.
Qed.

Lemma hoare_ex_pre : forall t x G R T P i Q,
  (forall z:T, hoare t x G R (P z) i Q) ->
  hoare t x G R (exp P) i Q.
Proof.
  repeat intro.
  destruct H5.
  spec H x0.
  eapply H; eauto.
Qed.

Lemma hoare_fact_pre : forall t x G R (X:Prop) P i Q,
  (X -> hoare t x G R P i Q) ->
  hoare t x G R (!!X && P) i Q.
Proof.
  repeat intro.
  destruct H5. hnf in H5.
  spec H H5. eapply H; eauto.
Qed.

Lemma hoare_return : forall t (G R:pred world),
  hoare t 0 G R R instr_return FF.
Proof.
  repeat intro.
  spec H1 r p' H3 H4.
  destruct H1. split.
  repeat intro.
  inv H6. econstructor.
  eapply step_return.
  inv H7. apply H1; auto.
  intro. spec H5. omega.
  destruct H5 as [pz [rz ?]].
  exists pz. exists rz.
  econstructor. eapply step_return.
  auto.
Qed.

Lemma hoare_getlabel : forall t l v (G R P:pred world),
  hoare t 0 G R
    (box (setM v (value_label l)) P)
    (instr_getlabel l v)
    P.
Proof.
  repeat intro.
  spec H2 (r#v <- (value_label l)).
  spec H2 p' H3.
  spec H2. apply H4. constructor; auto.
  destruct H2. split.
  repeat intro.
  inv H6. econstructor. econstructor.
  inv H7. apply H2; auto.
  intro; spec H5. omega.
  destruct H5 as [pz [rz ?]].
  exists pz; exists rz.
  econstructor. econstructor.
  auto.
Qed.

Lemma hoare_step_fetch0 : forall t v1 v2 x1 x2 (G R P:pred world),
  hoare t 0 G R
    (store_op (fun r => r#v1 = Some (value_cons x1 x2)) && box (setM v2 x1) P)
    (instr_fetch_field v1 0 v2)
    P.
Proof.
  repeat intro.
  destruct H4.
  destruct H4 as [_ [? _]].
  spec H2 (r#v2 <- x1).
  spec H2 p' H3.
  spec H2. apply H5. constructor. auto.
  destruct H2. split.
  repeat intro.
  inv H7.
  econstructor. econstructor; eauto.
  inv H8.
  apply H2; auto.
  replace x1 with a0 by congruence. auto.
  intro. spec H6. omega.
  destruct H6 as [pz [rz ?]].
  exists pz; exists rz.
  econstructor. econstructor. eauto.
  auto.
Qed.

Lemma hoare_step_fetch1 : forall t v1 v2 x1 x2 (G R P:pred world),
  hoare t 0 G R
    (store_op (fun r => r#v1 = Some (value_cons x1 x2)) && box (setM v2 x2) P)
    (instr_fetch_field v1 1 v2)
    P.
Proof.
  repeat intro.
  destruct H4.
  destruct H4 as [_ [? _]].
  spec H2 (r#v2 <- x2).
  spec H2 p' H3.
  spec H2. apply H5. constructor. auto.
  destruct H2. split.
  repeat intro.
  inv H7.
  econstructor. econstructor; eauto.
  inv H8.
  apply H2; auto.
  replace x2 with a1 by congruence. auto.
  intro. spec H6. omega.
  destruct H6 as [pz [rz ?]].
  exists pz; exists rz.
  econstructor. econstructor. eauto.
  auto.
Qed.

Lemma hoare_cons : forall t v1 v2 v3 x1 x2 (G R P:pred world),
  hoare t 0 G R
     (store_op (fun r => r#v1 = Some x1 /\ r#v2 = Some x2) &&
        box (setM v3 (value_cons x1 x2)) P)
     (instr_cons v1 v2 v3)
     P.
Proof.
  repeat intro.
  destruct H4.
  destruct H4 as [_ [[? ?] _]].
  spec H2 (r#v3 <- (value_cons x1 x2)).
  spec H2 p' H3.
  spec H2.
  apply H5. constructor. auto.
  destruct H2. split.
  repeat intro.
  inv H8.
  econstructor. econstructor; eauto.
  inv H9.
  apply H2.
  replace x1 with a1 by congruence.
  replace x2 with a2 by congruence.
  auto.
  intro. spec H7. omega.
  destruct H7 as [pz [rz ?]].
  exists pz; exists rz.
  econstructor. econstructor; eauto.
  auto.
Qed.

Lemma hoare_if : forall t x v s1 s2 G R P Q,
  P |-- store_op (fun r => match r#v with
                           | Some (value_label l) => l = L 0
                           | Some (value_cons _ _) => True
                           | _ => False
                           end) ->
  hoare t x G R (P && store_op (fun r => r#v = Some (value_label (L 0)))) s1 Q ->
  hoare t x G R (P && store_op (fun r => exists x1, exists x2, r#v = Some (value_cons x1 x2))) s2 Q ->
  hoare t x G R P (instr_if_nil v s1 s2) Q.
Proof.
  repeat intro.
  generalize H7; intros.
  apply H in H8.
  simpl in H8. destruct H8 as [_ [? _]].
  case_eq (r#v); intros; rewrite H9 in H8;
    try tauto.
  destruct v0.

  (* nil case *)
  subst l.
  spec H0 t' H2 p n k.
  spec H0 stk.
  do 3 (spec H0; auto).
  spec H0 r p' H6.
  spec H0.
  split; auto.
  simpl. intuition.
  destruct H0; split.
  repeat intro.
  inv H10.
  econstructor 1.
  eapply step_if_nil1. auto.
  inv H11.
  eapply H0; eauto.
  rewrite H22 in H9. discriminate.
  intro; spec H8; auto.
  destruct H8 as [pz [rz ?]].
  exists pz; exists rz.
  econstructor.
  eapply step_if_nil1; auto.
  auto.

  (* cons case *)
  spec H1 t' H2 p n k.
  spec H1 stk.
  do 3 (spec H1; auto).
  spec H1 r p' H6.
  spec H1. split. auto.
  simpl; intuition. eauto.
  destruct H1. split.
  repeat intro.
  inv H11.
  econstructor 1. eapply step_if_nil2; eauto.
  eapply H1; eauto.
  inv H12. rewrite H23 in H9; discriminate.
  rewrite H23 in H9. inv H9. auto.
  intro; spec H10; auto.
  destruct H10 as [pz [rz ?]].
  exists pz; exists rz.
  econstructor.
  eapply step_if_nil2; eauto.
  auto.
Qed.

Lemma hoare_call : forall t x G R v Q,
  let wp :=
    EX l:label, EX A:Type, EX lP:(A->pred world), EX lQ:(A -> pred world), EX n':nat, EX a:A,
      store_op (fun r => r#v = Some (value_label l) /\ t l r = Some n' /\ n' < x) &&
      (G --> funptr l A lP lQ) &&
      lP a && (closed (lQ a --> Q))
 in
  hoare t x G R wp (instr_call v) Q.
Proof.
  repeat intro.
  unfold wp in H4.
  destruct H4 as [l [A [lP [lQ [n' [a ?]]]]]].
  destruct H4 as [[[? ?] ?] ?].
  destruct H4 as [_ [? _]].
  destruct H4 as [? [? ?]].
  destruct x. exfalso; omega.
  assert (funptr l A lP lQ (p',(r,t'))).
  apply H5. auto.
  apply pred_nec_hereditary with (p,(r,t')); auto.
  rewrite worldNec_unfold; intuition.
  case_eq (age1 p'); intros.
  destruct H10 as [i [? ?]].
  spec H12 (k::stk) p0 n t' a.
  spec H12. hnf; auto.
  spec H12. apply t_step. auto.
  spec H12.
    intro r'. spec H2 r'.
    repeat intro.
    spec H2 p'0.
    spec H2.
    apply rt_trans with p'; auto.
    apply rt_trans with p0; auto.
    apply rt_step; auto.
    spec H2; auto.
    spec H7 (p',(r',t')).
    spec H7. simpl; hnf; auto.
    apply H7.
    rewrite worldNec_unfold; intuition.
    apply rt_trans with p0; auto.
    apply rt_step; auto.
    auto.

  spec H12 r p0. spec H12; auto.
  spec H12. apply pred_nec_hereditary with (p',(r,t')); auto.
  rewrite worldNec_unfold; intuition.
  destruct H12 as [n2 [? ?]].
  destruct (H l r). congruence.
  rewrite <- H14 in H12.
  rewrite H8 in H12. inv H12. clear H14.

  destruct H13. split.
  repeat intro.
  inv H14.
  econstructor 1.
  eapply step_call with (i':=i); eauto.
  inv H15.
  assert (p0 = p'1) by congruence. subst p'1.
  assert (l = l0) by congruence. subst l0.
  assert (i = i'0) by congruence. subst i'0.
  apply H12; auto.
  apply (af_level2 age_facts) in H11.
  congruence.
  intro. spec H13.
  apply (af_level2 age_facts) in H11. omega.
  destruct H13 as [pz [rz ?]].
  exists pz; exists rz.
  econstructor.
  econstructor; eauto.
  auto.

  split.
  clear -H11.
  repeat intro.
  apply stepstar_stepN in H. destruct H as [n H].
  revert p' H11 p'0 s' k k' stk H.
  induction n; simpl; intros.
  inv H.
  econstructor 1.
  eapply step_call_apocalypse.
  rewrite <- (af_level1 age_facts); auto.
  inv H.
  inv H1.
  hnf in H12. rewrite H12 in H11. discriminate.
  eapply IHn; eauto.
  rewrite (af_level1 age_facts) in H11.
  intro. exfalso. omega.
Qed.

Lemma hoare_assert : forall t (G R P:pred world) (Q:K.assert),
  boxy K.expandM G ->
  G && P |-- (proj1_sig Q) ->
  hoare t 0 G R P (instr_assert Q) P.
Proof.
  repeat intro.
  split.
  hnf; intros.
  inv H7.
  econstructor 1.
  econstructor.
  apply H0. split; auto.
  eapply pred_nec_hereditary.
  2: apply H2.
  instantiate (1:=s').
  rewrite worldNec_unfold. intuition.
  inv H8.
  destruct (H4 s'0 p'1); auto.
  repeat intro.
  destruct (H4 r p'); auto.
  spec H9. omega.
  destruct H9 as [p'' [r' ?]].
  exists p''; exists r'.
  econstructor 2.
  econstructor.
  apply H0.
  split; auto.
  eapply pred_nec_hereditary.
  2: apply H2.
  instantiate (1:=r).
  rewrite worldNec_unfold; intuition.
  auto.
Qed.

Lemma hoare_seq : forall t x y G R P Q S i1 i2,
  hoare t x G R P i1 Q ->
  hoare t y G R Q i2 S ->
  hoare t (x+y) G R P (i1 ;; i2) S.
Proof.
  intros. hnf; intros.
  assert (guards (x+(y+n)) P ((i1;;i2;;k)::stk) (p,(r,t'))).
  apply H; auto.
  repeat intro.
  spec H3 r' p' H5 H6.
  intuition.
  repeat intro.
  spec H5 p' H6 H7.
  destruct H5; split.
  repeat intro.
  inv H9.
  econstructor 1. econstructor.
  inv H10.
  eapply H5; eauto.
  intro.
  spec H8. omega.
  destruct H8 as [pz [rz ?]].
  exists pz; exists rz.
  econstructor. econstructor.
  auto.
Qed.

(* Verifying function bodies and entire programs *)

Definition verify_prog (t:terminationMeasure) (G:pred world) (psi:program K.assert) (G':pred world) :=
  forall n r,
     agedfrom (K.squash (n,psi),(r,t)) && |>(box K.expandM (closed G))
       |-- box K.expandM (closed G').

Lemma verify_complete : forall G G' psi t,
  G' |-- G ->
  verify_prog t G psi G' ->
  forall n r, G' (K.squash (n,psi),(r,t)).
Proof.
  intros.
  spec H0 n r.
  cut (agedfrom (K.squash (n,psi),(r,t)) |-- (box K.expandM (closed G'))).
  intros.
  eapply H1.
  hnf; apply rt_refl.
  apply K.expandM_refl.
  hnf; simpl; auto.
  apply goedel_loeb.
  apply derives_trans with
    (agedfrom (K.squash (n,psi),(r,t)) && |>(box K.expandM (closed G))); auto.
  intros a Ha; destruct Ha; split; auto.
  clear H1.
  revert a H2.
  do 3 apply box_positive; auto.
Qed.

Lemma verify_func : forall psi l (G:pred world) (A:Type) (P Q:A -> pred world) i t,
  psi#l = Some i ->

  (forall a p r t', termMeasure_incr t t' -> proj1_sig (P a) (p,(r,t')) -> exists n, t l r = Some n) ->

  (forall a n,
    let Pr  := P a && store_op (fun r' => t l r' = Some n) in
    let Pr' a' := P a' && store_op (fun r' => exists n', t l r' = Some n' /\ n' < n) in
    hoare t n (funptr l A Pr' Q && G) (Q a) Pr i FF) ->

  verify_prog t  G psi G ->
  verify_prog t (funptr l A P Q && G) psi (funptr l A P Q && G).
Proof.
  repeat intro.
  destruct H3.
  unfold closed in H6.
  do 3 rewrite box_and in H6.
  destruct H6.
  split. 2: eapply H2; eauto; split; eauto.
  destruct a. destruct a'. destruct a'0.
  destruct H5.
  destruct p. destruct p1. destruct o.
  simpl in H5, H8. subst p0 t1.
  rewrite K.expandM_spec in H4.
  assert (k = k0 /\ r = s /\ t = t0).
  simpl in H3. rewrite worldNec_unfold in H3.
  intuition.
  hnf in H3.
  apply K.unsquash_inj.
  destruct (K.unsquash k). destruct (K.unsquash k0).
  f_equal; intuition.
  destruct H5 as [? [? ?]]; subst s t0 k0.
  destruct H4 as [_ ?].
  destruct H4. simpl in H4, H5.
  assert (Hlookup :
    prog_lookup k l =
      Some (fmap_instr (K.approx (level k)) i)).
  replace (fmap_instr (K.approx (level k)) i)
    with (fmap_instr (K.approx (level k)) (fmap_instr (K.approx n) i)).
  apply nec_prog_lookup with (K.squash (n,psi)); auto.
  simpl in H3. rewrite worldNec_unfold in H3; intuition.
  unfold prog_lookup. rewrite K.unsquash_squash.
  simpl. unfold KnotInput.fmap.
  apply fmap_eqn. auto.
  rewrite collapse_instr_approx.
  rewrite min_l; auto.
  replace n with (level (K.squash (n,psi))).
  apply nec_level. simpl in H3. rewrite worldNec_unfold in H3; intuition.
  rewrite K.knot_level. rewrite K.unsquash_squash; auto.

  simpl.
  exists (fmap_instr (K.approx (level k)) i).
  split. auto.

  clear s0.
  intros stk p' n0 t' x G1 G2 G3 r0.
  revert stk p' n0 t' x G1 G2 G3.
  set (R r1 r2 :=
           match t l r1, t l r2 with
           | Some n1, Some n2 => n1 < n2
           | _, _ => False
           end).
  assert (well_founded R).
  clear. hnf; intro a.
  case_eq (t l a); intros.
  revert a H.
  induction n using (well_founded_induction lt_wf); intros.
  constructor; intros.
  hnf in H1.
  case_eq (t l y); intros.
  rewrite H2 in H1. rewrite H0 in H1.
  apply H with n0; auto.
  rewrite H2 in H1. elim H1.
  constructor; intros.
  hnf in H0. destruct (t l y).
  rewrite H in H0. elim H0. elim H0.

  move r0 after H8.
  induction r0 using (well_founded_induction H8).
  intros.
  destruct (H0 x p'0 r0 t') as [n' ?]; auto.
  eapply termMeasure_incr_trans; eauto.
  exists n'; split; auto.
  destruct (H5 l r0); congruence.

  spec H1 x n' t'.
  spec H1. eapply termMeasure_incr_trans; eauto.
  spec H1 p' n0 (instr_nil K.assert) stk.
  spec H1.

    repeat intro.
    split.
    exists (fmap_instr (K.approx (level p')) i).
    split.
    replace (fmap_instr (K.approx (level p')) i)
      with (fmap_instr (K.approx (level p')) (fmap_instr (K.approx (level k)) i)).
    apply nec_prog_lookup with k; auto.
    apply Rt_Rft; auto.
    rewrite collapse_instr_approx.
    rewrite min_l; auto.
    apply later_level in G2.
    unfold prog in *. omega.

    clear H1.
    repeat intro.
    destruct H16.
    simpl in H17.
    destruct H17 as [_ [? _]].
    destruct H17 as [n'' [? ?]].
    exists n''. split.
    destruct (H5 l r1). congruence.
    destruct (G1 l r1); congruence.
    spec H9 r1. spec H9.
    hnf. rewrite H17. rewrite H12. auto.
    spec H9 stk0 p'1 n1 t'0 x0.
    spec H9.
    eapply termMeasure_incr_trans; eauto.
    spec H9. apply t_trans with p'; auto.
    spec H9. auto.
    spec H9 p'2. spec H9. auto.
    spec H9. auto.
    destruct H9 as [n2 [? ?]].
    assert (n'' = n2).
    destruct (H5 l r1); congruence.
    subst n''.
    destruct H19; split.
    revert H19.
    apply safe_approx with (level p').
    apply later_level.
    apply Rt_Rft_trans with p'1; auto.
    hnf; auto.
    hnf; auto.
    constructor. hnf. simpl. f_equal.
    rewrite collapse_instr_approx.
    rewrite collapse_instr_approx_same.
    rewrite min_l; auto.
    apply later_level in G2.
    unfold prog in *; omega.
    apply stack_approx_rel_refl.
    intro. spec H20. auto.
    revert H20.
    apply ev_halts_approx with (level p').
    apply later_level. apply Rt_Rft_trans with p'1; auto.
    hnf; auto.
    hnf. auto.
    constructor. hnf. simpl. f_equal.
    rewrite collapse_instr_approx.
    rewrite collapse_instr_approx_same.
    rewrite min_l; auto.
    apply later_level in G2.
    unfold prog in *; omega.
    apply stack_approx_rel_refl.
    eapply H7.
    instantiate (1:=(p',(r,t))).
    simpl.
    rewrite worldLater_unfold. intuition.
    instantiate (1:= (p',(r,t'))).
    rewrite K.expandM_spec.
    split. hnf. destruct (K.unsquash p'); split; hnf; auto.
    split; simpl; auto. hnf; auto.
    eapply termMeasure_incr_trans; eauto.
    split; simpl; auto.

  spec H1. auto.
  spec H1. repeat intro. elim H14.
  spec H1 r0.
  spec H1 p'0.
  spec H1; auto.
  spec H1. split; auto.
  simpl. auto.
  destruct H1; split.
  revert H1.
  apply safe_approx with (level k).
  apply later_level. apply Rt_Rft_trans with p'; auto.
  hnf; auto.
  hnf; auto.
  constructor.
  hnf. simpl. f_equal.
  rewrite collapse_instr_approx_same; auto.
  apply stack_approx_rel_refl.
  intro; spec H13; auto.
  revert H13.
  apply ev_halts_approx with (level k).
  apply later_level. apply Rt_Rft_trans with p'; auto.
  hnf; auto.
  hnf; auto.
  constructor.
  hnf. simpl. f_equal.
  rewrite collapse_instr_approx_same; auto.
  apply stack_approx_rel_refl.
Qed.

Lemma end_assert_lemma : forall Q t n p p' r r' stk,
    stepN n t p p' r (stk++(instr_assert Q ;; instr_return ;; instr_nil _) :: nil) r' nil ->
    stepstar t p p' r (stk++(instr_return ;; instr_nil _) :: nil) r' nil /\ proj1_sig Q (p',(r',t)).
Proof.
  induction n; simpl; intros; inv H.
  destruct stk; discriminate.
  destruct stk. simpl in H1.
  inv H1. simpl.
  split; auto.
  apply stepN_stepstar with n; auto.
  inv H2. inv H.
  inv H0. auto.
  inv H.

  simpl in H1.
  inv H1.
  apply IHn with (stk:= i0::stk) in H2.
  intuition. econstructor. econstructor; auto. auto.
  apply IHn with (stk:= i0::stk) in H2.
  intuition. econstructor. econstructor; auto. auto.
  apply IHn with (stk:= i0::stk) in H2.
  intuition. econstructor. econstructor; eauto. auto.
  apply IHn with (stk:= i0::stk) in H2.
  intuition. econstructor. econstructor; eauto. auto.
  apply IHn with (stk:= i0::stk) in H2.
  intuition. econstructor. econstructor; eauto. auto.
  apply IHn with (stk:= (i1;;i2;;i3)::stk) in H2.
  intuition. econstructor. econstructor; eauto. auto.
  apply IHn with (stk:= (i1;;i0)::stk) in H2.
  intuition. econstructor. econstructor; eauto. auto.
  apply IHn with (stk:= (i2;;i0)::stk) in H2.
  intuition. econstructor. eapply step_if_nil2; eauto. auto.
  apply IHn with (stk:= (i'0;;instr_nil _)::i0::stk) in H2.
  intuition. econstructor. econstructor; eauto. auto.
  apply IHn with (stk:= (instr_call v;;i0)::stk) in H2. intuition.
  apply IHn with (stk:=stk) in H2.
  intuition. econstructor. econstructor. auto.
Qed.

(* Fundamental liveness theorem.  A verified function,
   when started in a state satisfying its precondition,
   will halt in a state satisfying its postcondition.
 *)

Lemma verify_totally_correct : forall t G A P Q psi l x
  (HQ:forall x, boxy K.expandM (Q x)),
  verify_prog t G psi G ->
  G |-- funptr l A P Q ->
  forall r,
    (forall n, P x (K.squash (n,psi),(r#(L 0) <- (value_label l),t))) ->
    exists n, exists p', exists r',
      stepstar t (K.squash (n,psi)) p'
        r ((instr_getlabel l (L 0) ;; instr_call (L 0) ;; instr_return ;; instr_nil _)::nil)
        r' nil /\
      Q x (p',(r',t)).
Proof.
  intros.
  assert (forall n r, G (K.squash (n,psi),(r,t))).
  apply verify_complete with G; auto.
  hnf; auto.
  set (r' :=(r#(L 0) <- (value_label l))).
  assert (exists n, t l r' = Some n).
  assert (funptr l A P Q (K.squash (1,psi),(r,t))) by auto.
  destruct H3 as [i [? ?]].
  spec H4 (nil : stack) (K.squash (0,psi)) 0 t x.
  spec H4. hnf; auto.
  spec H4. apply t_step. hnf.
  rewrite K.knot_age1. rewrite K.unsquash_squash.
  f_equal. apply K.unsquash_inj.
  repeat rewrite K.unsquash_squash.
  f_equal.
  change ((KnotInput.fmap (K.approx 0) oo KnotInput.fmap (K.approx 1)) psi =
    KnotInput.fmap (K.approx 0) psi).
  rewrite KnotInput.fmap_comp.
  replace 1 with (1+0) by omega.
  rewrite <- (K.approx_approx1 1 0); auto.
  spec H4.
  repeat intro. split; repeat intro.
  inv H7. constructor 2.
  inv H8.
  exists p'. exists r'0. apply stepstar_O.
  spec H4 r' (K.squash (0,psi)).
  spec H4. auto.
  spec H4. auto.
  destruct H4 as [n' [? ?]]. eauto.
  destruct H3 as [n ?].
  assert (funptr l A P Q (K.squash (S n,psi),(r,t))) by auto.
  destruct H4 as [i [? ?]].
  spec H5 ((instr_assert (exist _ (Q x) (HQ x)) ;; instr_return ;; instr_nil K.assert)::nil).
  spec H5 (K.squash (n,psi)) 0 t x.
  spec H5. hnf; auto.
  spec H5.
  apply t_step.
  hnf. rewrite K.knot_age1.
  rewrite K.unsquash_squash; simpl.
  f_equal.
  apply K.unsquash_inj.
  repeat rewrite K.unsquash_squash.
  f_equal.
  transitivity (KnotInput.fmap (K.approx n oo K.approx (S n)) psi).
  rewrite <- KnotInput.fmap_comp; auto.
  replace (K.approx n oo K.approx (S n)) with (K.approx n); auto.
  extensionality.
  unfold compose.
  change (K.approx n x0 = (K.approx n oo K.approx (1+n)) x0).
  rewrite <- K.approx_approx1; auto.
  hnf; auto.
  spec H5.
  repeat intro.
  split.
  hnf.
  intros.
  inv H8.
  econstructor 1.
  econstructor.
  auto.
  inv H9. simpl in *.
  inv H10.
  econstructor 1.
  econstructor.
  inv H8.
  inv H9.
  constructor.
  inv H8.
  intros.
  econstructor.
  econstructor.
  econstructor 2.
  econstructor.
  simpl; auto.
  econstructor. econstructor.
  econstructor 1.
  spec H5 r' (K.squash (n,psi)).
  spec H5; auto.
  spec H5. auto.
  destruct H5 as [n' [? ?]].
  assert (n = n') by congruence. subst n'.
  destruct H6. spec H7; auto.
  rewrite K.knot_level.
  rewrite K.unsquash_squash; simpl. omega.
  exists (S n).
  destruct H7 as [pz [rz ?]].
  exists pz; exists rz.
  cut
    (stepstar t (K.squash (n, psi)) pz r'
         ((i;; instr_nil K.assert)
          :: (instr_return;; instr_nil K.assert) :: nil) rz nil
         /\ Q x (pz,(rz,t))).
  intros [? ?]; split; auto.
  econstructor 2.
  econstructor.
  econstructor 2.
  econstructor; eauto.
  rewrite get_set_same; auto.
  hnf; simpl.
  rewrite K.knot_age1.
  rewrite K.unsquash_squash.
  reflexivity.
  match goal with [ |- stepstar _ ?X _ _ _ _ _ ] =>
    replace X with (K.squash (n,psi))
  end.
  auto.
  apply K.unsquash_inj.
  repeat rewrite K.unsquash_squash.
  f_equal.
  symmetry.
  transitivity (KnotInput.fmap (K.approx n oo K.approx (S n)) psi).
  rewrite <- KnotInput.fmap_comp; auto.
  change (S n) with (1+n).
  rewrite <- K.approx_approx1; auto.

  apply stepstar_stepN in H7. destruct H7.
  eapply end_assert_lemma with (Q:=exist _ (Q x) (HQ x))
    (stk:=(i;;instr_nil _)::nil). eauto.
Qed.

(* Weaker corallary: a program with a safe entry point
   will eventually halt.
 *)
Corollary verify_halts : forall t G psi l,
  verify_prog t G psi G ->
  G |-- funptr l unit (fun _ => TT) (fun _ => TT) ->
  forall r, exists n,
    eventually_halts t (K.squash (n,psi)) r
        ((instr_getlabel l (L 0) ;; instr_call (L 0) ;; instr_return ;; instr_nil _)::nil).
Proof.
  intros.
  destruct (verify_totally_correct t G unit (fun _ => TT) (fun _ => TT) psi l tt) with (r:=r)
    as [n [p' [r' [? ?]]]]; auto.
  exists n. hnf. eauto.
Qed.