From Coq Require Import Lia.
From Coq Require Import List. Import ListNotations.
From Coq Require Import Logic.Decidable.
From Coq Require Import ZArith.
From ConCert.Utils Require Import Automation.
From ConCert.Utils Require Import RecordUpdate.
From ConCert.Execution Require Import Blockchain.
From ConCert.Execution Require Import Serializable.
From ConCert.Execution Require Import ResultMonad.

Section BuildUtils.
Context {BaseTypes : ChainBase}.

(* The empty state is always reachable *)
Lemma reachable_empty_state :
  reachable empty_state.
Proof.
  repeat constructor.
Qed.

(* Transitivity property of reachable and ChainTrace *)
Lemma reachable_trans from to :
  reachable from -> ChainTrace from to -> reachable to.
Proof.
  intros [].
  constructor.
  now eapply ChainedList.clist_app.
Qed.

(* Transitivity property of reachable and ChainStep *)
Lemma reachable_step from to :
  reachable from -> ChainStep from to -> reachable to.
Proof.
  intros [].
  now do 2 econstructor.
Qed.

(* If a state is reachable then the finalized_height cannot be larger than the chain_height *)
Lemma finalized_heigh_chain_height bstate :
  reachable bstate ->
  finalized_height bstate < S (chain_height bstate).
Proof.
  intros [trace].
  remember empty_state.
  induction trace as [ | Heq from to trace IH step ]; subst.
  - auto.
  - destruct_chain_step;
    try destruct_action_eval;
    rewrite_environment_equiv;
    auto.
    + now inversion valid_header.
Qed.

(* If a state is reachable and contract state is stored on an address
    then that address must also have some contract deployed to it *)
Lemma contract_states_deployed to (addr : Address) (state : SerializedValue) :
  reachable to ->
  env_contract_states to addr = Some state ->
  exists wc, env_contracts to addr = Some wc.
Proof.
  intros [trace].
  remember empty_state.
  induction trace as [ | Heq from to trace IH step ];
    subst; intros.
  - discriminate.
  - destruct_chain_step;
      only 2: destruct_action_eval;
      rewrite_environment_equiv;
      setoid_rewrite env_eq; cbn in *;
      destruct_address_eq; now subst.
Qed.

(* If a state is reachable and contract state is stored on an address
    then that address must be a contract address *)
Lemma contract_states_addr_format to (addr : Address) (state : SerializedValue) :
  reachable to ->
  env_contract_states to addr = Some state ->
  address_is_contract addr = true.
Proof.
  intros ? deployed_state.
  apply contract_states_deployed in deployed_state as []; auto.
  now eapply contract_addr_format.
Qed.

Hint Resolve reachable_empty_state
             reachable_trans
             reachable_step : core.

(* A state `to` is reachable through `mid` if `mid` is reachable and there exists a trace
    from `mid` to `to`. This captures that there is a valid execution ending up in `to`
    and going through the state `mid` at some point *)
Definition reachable_through mid to := reachable mid /\ inhabited (ChainTrace mid to).

(* A state is always reachable through itself *)
Lemma reachable_through_refl : forall bstate,
  reachable bstate -> reachable_through bstate bstate.
Proof.
  intros bstate reach.
  split; auto.
  do 2 constructor.
Qed.

(* Transitivity property of reachable_through and ChainStep *)
Lemma reachable_through_trans' : forall from mid to,
  reachable_through from mid -> ChainStep mid to -> reachable_through from to.
Proof.
  intros * [reach [trace]] step.
  repeat (econstructor; eauto).
Qed.

(* Transitivity property of reachable_through *)
Lemma reachable_through_trans : forall from mid to,
  reachable_through from mid -> reachable_through mid to -> reachable_through from to.
Proof.
  intros * [[trace_from] [trace_mid]] [_ [trace_to]].
  do 2 constructor.
  assumption.
  now eapply ChainedList.clist_app.
Qed.

(* Reachable_through can also be constructed from ChainStep instead of a
   ChainTrace since a ChainTrace can be constructed from a ChainStep *)
Lemma reachable_through_step : forall from to,
  reachable from -> ChainStep from to -> reachable_through from to.
Proof.
  intros * reach_from step.
  apply reachable_through_refl in reach_from.
  now eapply reachable_through_trans'.
Qed.

(* Any ChainState that is reachable through another ChainState is reachable *)
Lemma reachable_through_reachable : forall from to,
  reachable_through from to -> reachable to.
Proof.
  intros * [[trace_from] [trace_to]].
  constructor.
  now eapply ChainedList.clist_app.
Qed.

Hint Resolve reachable_through_refl
             reachable_through_trans'
             reachable_through_trans
             reachable_through_step
             reachable_through_reachable : core.

(* If a state has a contract deployed to some addr then any other state
    reachable through the first state must also have the same contract
    deployed to the same addr *)
Lemma reachable_through_contract_deployed : forall from to addr wc,
  reachable_through from to -> env_contracts from addr = Some wc ->
    env_contracts to addr = Some wc.
Proof.
  intros * [reach [trace]] deployed.
  induction trace as [ | from mid to trace IH step ].
  - assumption.
  - destruct_chain_step;
      only 2: destruct_action_eval;
      rewrite_environment_equiv; cbn;
      destruct_address_eq; subst; try easy.
    now rewrite IH in not_deployed by assumption.
Qed.

(* If a state has a contract state on some addr then any other state
    reachable through the first state must also have the some contract
    state on the same addr *)
Lemma reachable_through_contract_state : forall from to addr cstate,
  reachable_through from to -> env_contract_states from addr = Some cstate ->
    exists new_cstate, env_contract_states to addr = Some new_cstate.
Proof.
  intros * [reachable [trace]] deployed_state.
  generalize dependent cstate.
  induction trace as [ | from mid to trace IH step ];
    intros cstate deployed_state.
  - now eexists.
  - destruct_chain_step;
      only 2: destruct_action_eval;
      try rewrite_environment_equiv;
      try setoid_rewrite env_eq;
      cbn in *;
      destruct_address_eq; now subst.
Qed.

(* If a state is reachable through another state then it cannot have a lower chain height *)
Lemma reachable_through_chain_height : forall from to,
  reachable_through from to -> from.(chain_height) <= to.(chain_height).
Proof.
  intros * [reachable [trace]].
  induction trace as [ | from mid to trace IH step ].
  - apply Nat.le_refl.
  - destruct_chain_step;
    try destruct_action_eval;
    rewrite_environment_equiv; cbn; auto.
    + now inversion valid_header.
Qed.

(* If a state is reachable through another state then it cannot have a lower current slot *)
Lemma reachable_through_current_slot : forall from to,
  reachable_through from to -> from.(current_slot) <= to.(current_slot).
Proof.
  intros * [reachable [trace]].
  induction trace as [ | from mid to trace IH step ].
  - apply Nat.le_refl.
  - destruct_chain_step;
    try destruct_action_eval;
    rewrite_environment_equiv; cbn; auto.
    + now inversion valid_header.
Qed.

(* If a state is reachable through another state then it cannot have a lower finalized height *)
Lemma reachable_through_finalized_height : forall from to,
  reachable_through from to -> from.(finalized_height) <= to.(finalized_height).
Proof.
  intros * [reachable [trace]].
  induction trace as [ | from mid to trace IH step ].
  - apply Nat.le_refl.
  - destruct_chain_step;
    try destruct_action_eval;
    rewrite_environment_equiv; cbn; auto.
    + now inversion valid_header.
Qed.

(* Initial contract balance will always be positive in reachable states *)
Lemma deployment_amount_nonnegative : forall {Setup : Type} `{Serializable Setup}
                                      bstate caddr dep_info
                                      (trace : ChainTrace empty_state bstate),
  deployment_info Setup trace caddr = Some dep_info ->
  (0 <= dep_info.(deployment_amount))%Z.
Proof.
  intros * deployment_info_some.
  remember empty_state.
  induction trace; subst.
  - discriminate.
  - destruct_chain_step; auto.
    destruct_action_eval; auto.
    cbn in deployment_info_some.
    destruct_address_eq; auto.
    destruct_match in deployment_info_some;
      try congruence.
    inversion_clear deployment_info_some.
    now apply Z.ge_le.
Qed.

Definition receiver_can_receive_transfer (bstate : ChainState) act_body :=
  match act_body with
  | act_transfer to _ => address_is_contract to = false \/
    (exists wc state,
      env_contracts bstate to = Some wc /\
      env_contract_states bstate to = Some state /\
      forall (bstate_new : ChainState) ctx, exists new_state, wc_receive wc bstate_new ctx state None = Ok (new_state, []))
  | _ => True
  end.

(* This axiom states that for any reachable state and any contract it is
    decidable whether or not there is an address where the contract can be deployed to.
   This is not provable in general with the assumption ChainBase makes about
    addresses and the function address_is_contract. However, this should be
    provable in any sensible instance of ChainBase *)
Axiom deployable_address_decidable : forall bstate wc setup act_origin act_from amount,
  reachable bstate ->
  decidable (exists addr state, address_is_contract addr = true
            /\ env_contracts bstate addr = None
            /\ wc_init wc
                  (transfer_balance act_from addr amount bstate)
                  (build_ctx act_origin act_from addr amount amount)
                  setup = Ok state).

Ltac action_not_decidable :=
  right; intro;
  match goal with
  | H : exists bstate new_acts, inhabited (ActionEvaluation _ _ bstate new_acts) |- False =>
    destruct H as [bstate_new [new_acts [action_evaluation]]];
    destruct_action_eval; try congruence
  end; repeat
  match goal with
  | H : {| act_origin := _; act_from := _; act_body := _ |} = {| act_origin := _; act_from := _; act_body := match ?msg with | Some _ => _ | None =>_ end |} |- False =>
    destruct msg
  | H : {| act_origin := _; act_from := _; act_body := _ |} = {| act_origin := _; act_from := _; act_body := _ |} |- False =>
    inversion H; subst; clear H
  end.

Ltac action_decidable :=
  left; do 2 eexists; constructor;
  match goal with
  | H : wc_receive _ _ _ _ ?m = Ok _ |- _ => eapply (eval_call _ _ _ _ _ m)
  | H : wc_init _ _ _ _ = Ok _ |- _ => eapply eval_deploy
  | H : context [act_transfer _ _] |- _ => eapply eval_transfer
  end;
  eauto; try now constructor.

Ltac rewrite_balance :=
  match goal with
  | H := context [if (_ =? ?to)%address then _ else _ ],
    H2 : Environment |- _ =>
    assert (new_to_balance_eq : env_account_balances H2 to = H);
    [ try rewrite_environment_equiv; cbn; unfold H; destruct_address_eq; try congruence; lia |
    now rewrite <- new_to_balance_eq in *]
  end.

(* For any reachable state and an action it is decidable if it is
    possible to evaluate the action in the state *)
Open Scope Z_scope.
Lemma action_evaluation_decidable : forall bstate act,
  reachable bstate ->
  decidable (exists bstate' new_acts, inhabited (ActionEvaluation bstate act bstate' new_acts)).
Proof.
  intros * reach.
  destruct act eqn:Hact.
  destruct act_body;
    (destruct (amount >=? 0) eqn:amount_positive;
    [destruct (amount <=? env_account_balances bstate act_from) eqn:balance |
      action_not_decidable; now rewrite Z.geb_leb, Z.leb_gt in amount_positive (* Eliminate cases where amount is negative *)];
    [| action_not_decidable; now rewrite Z.leb_gt in balance ]); (* Eliminate cases where sender does not have enough balance *)
  try (destruct (address_is_contract to) eqn:to_is_contract;
    [destruct (env_contracts bstate to) eqn:to_contract;
    [destruct (env_contract_states bstate to) eqn:contract_state |] |]);
  try now action_not_decidable. (* Eliminate cases with obvious contradictions *)
  all : rewrite Z.geb_leb, <- Zge_is_le_bool in amount_positive.
  all : rewrite Z.leb_le in balance.
  - (* act_body = act_transfer to amount *)
    pose (new_to_balance := if (address_eqb act_from to)
                         then (env_account_balances bstate to)
                         else (env_account_balances bstate to) + amount).
    destruct (wc_receive w
        (transfer_balance act_from to amount bstate)
        (build_ctx act_origin act_from to new_to_balance amount)
        s None) eqn:receive.
    + (* Case: act_transfer is evaluable by eval_call *)
      destruct t.
      pose (bstate' := (set_contract_state to s0
                       (transfer_balance act_from to amount bstate))).
      action_decidable.
      rewrite_balance.
    + (* Case: act_transfer is not evaluable by eval_call
          because wc_receive returned None *)
      action_not_decidable.
      rewrite_balance.
  - (* act_body = act_transfer to amount *)
    (* Case: act_transfer is evaluable by eval_transfer *)
    pose (bstate' := (transfer_balance act_from to amount bstate)).
    action_decidable.
  - (* act_body = act_call to amount msg *)
    pose (new_to_balance := if (address_eqb act_from to)
                         then (env_account_balances bstate to)
                         else (env_account_balances bstate to) + amount).
    destruct (wc_receive w
        (transfer_balance act_from to amount bstate)
        (build_ctx act_origin act_from to new_to_balance amount)
        s (Some msg)) eqn:receive.
    + (* Case: act_call is evaluable by eval_call *)
      destruct t.
      pose (bstate' := (set_contract_state to s0
                       (transfer_balance act_from to amount bstate))).
      action_decidable.
      rewrite_balance.
    + (* Case: act_call is not evaluable by eval_call
          because wc_receive returned None *)
      action_not_decidable.
      rewrite_balance.
  - (* act_body = act_call to amount msg *)
    (* Case: contradiction *)
    action_not_decidable.
    now apply contract_addr_format in deployed; auto.
  - (* act_body = act_deploy amount c setup *)
    apply deployable_address_decidable
      with (wc := c) (setup := setup) (act_origin := act_origin)
      (act_from := act_from) (amount := amount)
      in reach.
    destruct reach as [[to [state [to_is_contract_addr [to_not_deployed init]]]] | no_deployable_addr].
    + (* Case: act_deploy is evaluable by eval_deploy *)
      pose (bstate' := (set_contract_state to state
                       (add_contract to c
                       (transfer_balance act_from to amount bstate)))).
      action_decidable.
    + (* Case: act_deploy is not evaluable by eval_deploy
          because no there is no available contract address
          that this contract can be deployed to *)
      action_not_decidable.
      apply no_deployable_addr.
      eauto.
Qed.
Close Scope Z_scope.

(* Property stating that an action does not produce any new action when evaluated *)
Definition produces_no_new_acts act : Prop :=
  forall bstate bstate' new_acts, ActionEvaluation bstate act bstate' new_acts -> new_acts = [].

(* Property on a ChainState queue stating all actions are from accounts and produces
    no new actions when evaluated. This ensures that the queue can be emptied successfully *)
Definition emptyable queue : Prop :=
  Forall act_is_from_account queue /\
  Forall produces_no_new_acts queue.

(* An empty queue is always emptyable *)
Lemma empty_queue_is_emptyable : emptyable [].
Proof.
  now constructor.
Qed.

(* A subset of an emptyable queue is also emptyable *)
Lemma emptyable_cons : forall x l,
  emptyable (x :: l) -> emptyable l.
Proof.
  intros * [acts_from_account no_new_acts].
  apply Forall_inv_tail in acts_from_account.
  now apply Forall_inv_tail in no_new_acts.
Qed.

(* For any reachable state it is possible to empty the chain_state_queue
    if the queue only contains action that satisfy the following
    1) the action is from a user and not a contract
    2) the action does not produce any actions when evaluated
   For any property that holds on the starting state this also hold on
    the state with an empty queue if it can be proven that the property
    holds after evaluating any action.
*)
Lemma empty_queue : forall bstate (P : ChainState -> Prop),
  reachable bstate ->
  emptyable (chain_state_queue bstate) ->
  P bstate ->
  (forall (bstate bstate' : ChainState) act acts, reachable bstate -> reachable bstate' -> P bstate ->
    chain_state_queue bstate = act :: acts -> chain_state_queue bstate' = acts ->
    (inhabited (ActionEvaluation bstate act bstate' []) \/ EnvironmentEquiv bstate bstate') -> P bstate' ) ->
    exists bstate', reachable_through bstate bstate' /\ P bstate' /\ (chain_state_queue bstate') = [].
Proof.
  intros * reach [acts_from_account no_new_acts].
  remember (chain_state_queue bstate) as queue.
  generalize dependent bstate.
  induction queue; intros bstate reach Hqueue_eq HP HP_preserved.
  - (* Case: queue is already empty, thus we are already done *)
    now eexists.
  - (* Case: queue contains at least one action,
        thus we need to either discard or evaluate it *)
    apply list.Forall_cons_1 in acts_from_account as [act_from_a acts_from_account].
    apply list.Forall_cons_1 in no_new_acts as [no_new_acts_from_a no_new_acts].
    edestruct action_evaluation_decidable as
      [[mid_env [new_acts [action_evaluation]]] | no_action_evaluation]; eauto.
    + (* Case: the action is evaluable *)
      pose (build_chain_state mid_env (new_acts ++ queue)) as mid.
      assert (step : ChainStep bstate mid) by (now eapply step_action).
      apply no_new_acts_from_a in action_evaluation as new_acts_eq; subst.
      eapply HP_preserved with (bstate' := mid) in HP; eauto.
      apply IHqueue in HP as [to [reachable_through [P_to queue_to]]]; subst; eauto.
      now exists to.
    + (* Case: the action not is evaluable *)
      pose (bstate<| chain_state_queue := queue |>) as mid.
      assert (step : ChainStep bstate mid).
      { eapply step_action_invalid; try easy.
        intros. apply no_action_evaluation.
        now do 2 eexists.
      }
      apply reachable_step in step as reachable_mid; eauto.
      apply IHqueue in reachable_mid as [to [reachable_through [P_to queue_to]]]; eauto.
      exists to.
      intuition.
      eauto.
      eapply (HP_preserved bstate mid); eauto.
      now right.
Qed.

(* wc_receive and contract receive are equivalent *)
Lemma wc_receive_to_receive : forall {Setup Msg State Error : Type}
                                    `{Serializable Setup}
                                    `{Serializable Msg}
                                    `{Serializable State}
                                    `{Serializable Error}
                                    (contract : Contract Setup Msg State Error)
                                    chain cctx cstate msg new_cstate new_acts,
  contract.(receive) chain cctx cstate (Some msg) = Ok (new_cstate, new_acts) <->
  wc_receive contract chain cctx ((@serialize State _) cstate) (Some ((@serialize Msg _) msg)) = Ok ((@serialize State _) new_cstate, new_acts).
Proof.
  split; intros receive_some.
  - cbn.
    rewrite !deserialize_serialize.
    cbn.
    now rewrite receive_some.
  - apply wc_receive_strong in receive_some as
      (prev_state' & msg' & new_state' & prev_state_eq & msg_eq & new_state_eq & receive_some).
    apply serialize_injective in new_state_eq. subst.
    rewrite deserialize_serialize in prev_state_eq.
    inversion prev_state_eq. subst.
    destruct msg' eqn:Hmsg.
    + cbn in msg_eq.
      now rewrite deserialize_serialize in msg_eq.
    + inversion msg_eq.
Qed.

(* wc_init and contract init are equivalent *)
Lemma wc_init_to_init : forall {Setup Msg State Error : Type}
                               `{Serializable Setup}
                               `{Serializable Msg}
                               `{Serializable State}
                               `{Serializable Error}
                               (contract : Contract Setup Msg State Error)
                               chain cctx cstate setup,
  contract.(init) chain cctx setup = Ok cstate <->
  wc_init contract chain cctx ((@serialize Setup _) setup) = Ok ((@serialize State _) cstate).
Proof.
  split; intros init_some.
  - cbn.
    rewrite deserialize_serialize.
    cbn.
    now rewrite init_some.
  - apply wc_init_strong in init_some as
      (setup_strong & result_strong & serialize_setup & serialize_result & init_some).
    apply serialize_injective in serialize_result. subst.
    rewrite deserialize_serialize in serialize_setup.
    now inversion serialize_setup.
Qed.

Open Scope Z_scope.
(* Lemma showing that there exists a future ChainState with an added block *)
Lemma add_block : forall bstate reward creator acts slot_incr,
  reachable bstate ->
  chain_state_queue bstate = [] ->
  address_is_contract creator = false ->
  reward >= 0->
  (slot_incr > 0)%nat ->
  Forall act_is_from_account acts ->
  Forall act_origin_is_eq_from acts ->
    (exists bstate',
       reachable_through bstate bstate'
    /\ chain_state_queue bstate' = acts
    /\ EnvironmentEquiv
        bstate'
        (add_new_block_to_env {| block_height := S (chain_height bstate);
          block_slot := current_slot bstate + slot_incr;
          block_finalized_height := finalized_height bstate;
          block_creator := creator;
          block_reward := reward; |} bstate)).
Proof.
  intros * reach queue creator_not_contract
    reward_positive slot_incr_positive
    acts_from_accounts origins_from_accounts.
  pose (header :=
    {| block_height := S (chain_height bstate);
       block_slot := current_slot bstate + slot_incr;
       block_finalized_height := finalized_height bstate;
       block_creator := creator;
       block_reward := reward; |}).
  pose (bstate_with_acts := (bstate<|chain_state_queue := acts|>
                                   <|chain_state_env := add_new_block_to_env header bstate|>)).
  assert (step_with_acts : ChainStep bstate bstate_with_acts).
  { eapply step_block; try easy.
    - constructor; try easy.
      + cbn. lia.
      + split; try (cbn; lia). cbn.
        now apply finalized_heigh_chain_height.
  }
  exists bstate_with_acts.
  split; eauto.
  split; eauto.
  constructor; try reflexivity.
Qed.

(* Lemma showing that there exists a future ChainState with the
    same contract states where the current slot is <slot> *)
Lemma forward_time_exact : forall bstate reward creator slot,
  reachable bstate ->
  chain_state_queue bstate = [] ->
  address_is_contract creator = false ->
  reward >= 0 ->
  (current_slot bstate < slot)%nat ->
    (exists bstate' header,
       reachable_through bstate bstate'
    /\ IsValidNextBlock header bstate
    /\ (slot = current_slot bstate')%nat
    /\ chain_state_queue bstate' = []
    /\ EnvironmentEquiv
        bstate'
        (add_new_block_to_env header bstate)).
Proof.
  intros bstate reward creator slot reach queue
    creator_not_contract reward_positive slot_not_hit.
  eapply add_block with (slot_incr := (slot - current_slot bstate)%nat) in reach as new_block; try easy.
  destruct new_block as [bstate_with_act [reach' [queue' env_eq]]].
  do 2 eexists.
  split; eauto.
  do 3 try split; only 9: apply env_eq; eauto; cbn; try lia.
  - now apply finalized_heigh_chain_height.
  - rewrite_environment_equiv. cbn. lia.
Qed.

(* Lemma showing that there exists a future ChainState with the
    same contract states where the current slot is at least <slot> *)
Lemma forward_time : forall bstate reward creator slot,
  reachable bstate ->
  chain_state_queue bstate = [] ->
  address_is_contract creator = false ->
  reward >= 0 ->
    (exists bstate' header,
       reachable_through bstate bstate'
    /\ IsValidNextBlock header bstate
    /\ (slot <= current_slot bstate')%nat
    /\ chain_state_queue bstate' = []
    /\ EnvironmentEquiv
        bstate'
        (add_new_block_to_env header bstate)).
Proof.
  intros * reach queue creator_not_contract reward_positive.
  destruct (slot - current_slot bstate)%nat eqn:slot_hit.
  - eapply add_block with (slot_incr := 1%nat) in reach as new_block; try easy.
    destruct new_block as [bstate_with_act [reach' [queue' env_eq]]].
    do 2 eexists.
    split; eauto.
    do 3 try split; only 9: apply env_eq; eauto; cbn; try lia.
    + now apply finalized_heigh_chain_height.
    + apply NPeano.Nat.sub_0_le in slot_hit.
      rewrite_environment_equiv. cbn. lia.
  - specialize forward_time_exact with (slot := slot) as
      (bstate' & header & reach' & header_valid & slot_hit' & queue' & env_eq);
      try easy.
    do 2 eexists.
    split; eauto.
    intuition.
Qed.

(* Lemma showing that there exists a future ChainState
    where the contract call is evaluated *)
Lemma evaluate_action : forall {Setup Msg State Error : Type}
                              `{Serializable Setup}
                              `{Serializable Msg}
                              `{Serializable State}
                              `{Serializable Error}
                               (contract : Contract Setup Msg State Error)
                               bstate origin from caddr amount msg acts new_acts
                               cstate new_cstate,
  reachable bstate ->
  chain_state_queue bstate = {| act_from := from;
                                act_origin := origin;
                                act_body := act_call caddr amount ((@serialize Msg _) msg) |} :: acts ->
  amount >= 0 ->
  env_account_balances bstate from >= amount ->
  env_contracts bstate caddr = Some (contract : WeakContract) ->
  env_contract_states bstate caddr = Some ((@serialize State _) cstate) ->
  Blockchain.receive contract (transfer_balance from caddr amount bstate)
                     (build_ctx origin from caddr (if (address_eqb from caddr)
                         then (env_account_balances bstate caddr)
                         else (env_account_balances bstate caddr) + amount) amount)
                     cstate (Some msg) = Ok (new_cstate, new_acts) ->
    (exists bstate',
       reachable_through bstate bstate'
    /\ env_contract_states bstate' caddr = Some ((@serialize State _) new_cstate)
    /\ chain_state_queue bstate' = (map (build_act origin caddr) new_acts) ++ acts
    /\ EnvironmentEquiv
        bstate'
        (set_contract_state caddr ((@serialize State _) new_cstate) (transfer_balance from caddr amount bstate))).
Proof.
  intros * reach queue amount_nonnegative enough_balance%Z.ge_le
    deployed deployed_state receive_some.
  pose (new_to_balance := if (address_eqb from caddr)
                         then (env_account_balances bstate caddr)
                         else (env_account_balances bstate caddr) + amount).
  pose (bstate' := (bstate<|chain_state_queue := (map (build_act origin caddr) new_acts) ++ acts|>
                          <|chain_state_env := set_contract_state caddr ((@serialize State _) new_cstate)
                                                  (transfer_balance from caddr amount bstate)|>)).
  assert (new_to_balance_eq : env_account_balances bstate' caddr = new_to_balance) by
   (cbn; destruct_address_eq; easy).
  assert (step : ChainStep bstate bstate').
  - eapply step_action; eauto.
    eapply eval_call with (msg := Some ((@serialize Msg _) msg)); eauto.
    + rewrite new_to_balance_eq.
      now apply wc_receive_to_receive in receive_some.
    + constructor; reflexivity.
  - exists bstate'.
    split; eauto.
    repeat split; eauto.
    cbn.
    now destruct_address_eq.
Qed.

(* Lemma showing that there exists a future ChainState
    where the transfer action is evaluated *)
Lemma evaluate_transfer : forall bstate origin from to amount acts,
  reachable bstate ->
  chain_state_queue bstate = {| act_from := from;
                                act_origin := origin;
                                act_body := act_transfer to amount |} :: acts ->
  amount >= 0 ->
  env_account_balances bstate from >= amount ->
  address_is_contract to = false ->
    (exists bstate',
       reachable_through bstate bstate'
    /\ chain_state_queue bstate' = acts
    /\ EnvironmentEquiv
        bstate'
        (transfer_balance from to amount bstate)).
Proof.
  intros * reach queue amount_nonnegative enough_balance%Z.ge_le to_not_contract.
  pose (bstate' := (bstate<|chain_state_queue := acts|>
                          <|chain_state_env := (transfer_balance from to amount bstate)|>)).
  assert (step : ChainStep bstate bstate').
  - eapply step_action with (new_acts := []); eauto.
    eapply eval_transfer; eauto.
    constructor; reflexivity.
  - eexists bstate'.
    split; eauto.
    repeat split; eauto.
Qed.

(* Lemma showing that if an action in the queue is invalid then
    there exists a future ChainState with the same environment
    where that action is discarded *)
Lemma discard_invalid_action : forall bstate act acts,
  reachable bstate ->
  chain_state_queue bstate = act :: acts ->
  act_is_from_account act ->
  (forall (bstate0 : Environment) (new_acts : list Action), ActionEvaluation bstate act bstate0 new_acts -> False) ->
    (exists bstate',
       reachable_through bstate bstate'
    /\ chain_state_queue bstate' = acts
    /\ EnvironmentEquiv
        bstate'
        bstate).
Proof.
  intros * reach queue act_from_account no_action_evaluation.
  pose (bstate' := (bstate<|chain_state_queue := acts|>)).
  assert (step : ChainStep bstate bstate').
  - eapply step_action_invalid; eauto.
    constructor; reflexivity.
  - eexists bstate'.
    split; eauto.
    repeat split; eauto.
Qed.

(* Lemma showing that for any permutation of the queue there
    exists a future ChainState with the same environment
    end the queue permuted *)
Lemma permute_queue : forall bstate acts acts_permuted,
  reachable bstate ->
  chain_state_queue bstate = acts ->
  Permutation.Permutation acts acts_permuted ->
    (exists bstate',
       reachable_through bstate bstate'
    /\ chain_state_queue bstate' = acts_permuted
    /\ EnvironmentEquiv
        bstate'
        bstate).
Proof.
  intros * reach queue perm.
  pose (bstate' := (bstate<|chain_state_queue := acts_permuted|>)).
  assert (step : ChainStep bstate bstate').
  - eapply step_permute.
    + econstructor; eauto.
    + now rewrite queue.
  - eexists bstate'.
    split; eauto.
    repeat split; eauto.
Qed.

(* Lemma showing that there exists a future ChainState
    where the contract is deployed *)
Lemma deploy_contract : forall {Setup Msg State Error : Type}
                              `{Serializable Setup}
                              `{Serializable Msg}
                              `{Serializable State}
                              `{Serializable Error}
                               (contract : Contract Setup Msg State Error)
                               bstate origin from caddr amount acts setup cstate,
  reachable bstate ->
  chain_state_queue bstate = {| act_from := from;
                                act_origin := origin;
                                act_body := act_deploy amount contract ((@serialize Setup _) setup) |} :: acts ->
  amount >= 0 ->
  env_account_balances bstate from >= amount ->
  address_is_contract caddr = true ->
  env_contracts bstate caddr = None ->
  Blockchain.init contract
        (transfer_balance from caddr amount bstate)
        (build_ctx origin from caddr amount amount)
        setup = Ok cstate ->
    (exists bstate' (trace : ChainTrace empty_state bstate'),
       reachable_through bstate bstate'
    /\ env_contracts bstate' caddr = Some (contract : WeakContract)
    /\ env_contract_states bstate' caddr = Some ((@serialize State _) cstate)
    /\ deployment_info Setup trace caddr = Some (build_deployment_info origin from amount setup)
    /\ chain_state_queue bstate' = acts
    /\ EnvironmentEquiv
        bstate'
        (set_contract_state caddr ((@serialize State _) cstate)
        (add_contract caddr contract
        (transfer_balance from caddr amount bstate)))).
Proof.
  intros * reach queue amount_nonnegative enough_balance%Z.ge_le
    caddr_is_contract not_deployed init_some.
  pose (bstate' := (bstate<|chain_state_queue := acts|>
                          <|chain_state_env :=
                            (set_contract_state caddr ((@serialize State _) cstate)
                            (add_contract caddr contract
                            (transfer_balance from caddr amount bstate)))|>)).
  assert (step : ChainStep bstate bstate').
  - eapply step_action with (new_acts := []); eauto.
    eapply eval_deploy; eauto.
    + now apply wc_init_to_init in init_some.
    + constructor; reflexivity.
  - exists bstate'.
    destruct reach as [trace].
    exists (ChainedList.snoc trace step).
    split; eauto.
    repeat split; eauto;
    try (cbn; now destruct_address_eq).
    cbn. destruct_chain_step; try congruence.
    + destruct_action_eval;
        try congruence; cbn in *; subst; rewrite queue in queue_prev; inversion queue_prev; subst.
      * destruct_address_eq.
        -- now rewrite deserialize_serialize.
        -- inversion env_eq.
           cbn in contracts_eq.
           specialize (contracts_eq caddr).
           now rewrite address_eq_refl, address_eq_ne in contracts_eq.
      * now destruct msg.
    + exfalso. eapply no_eval.
      rewrite queue in queue_prev.
      inversion queue_prev.
      eapply eval_deploy; eauto.
      * now apply wc_init_to_init in init_some.
      * now constructor.
    + rewrite <- env_eq in not_deployed.
      cbn in not_deployed.
      now destruct_address_eq.
Qed.
Close Scope Z_scope.

Lemma step_reachable_through_exists : forall from mid (P : ChainState -> Prop),
  reachable_through from mid ->
  (exists to : ChainState, reachable_through mid to /\ P to) ->
  (exists to : ChainState, reachable_through from to /\ P to).
Proof.
  intros * reach [to [reach_ HP]].
  now exists to.
Qed.

End BuildUtils.

Global Hint Resolve reachable_through_refl
             reachable_through_trans'
             reachable_through_trans
             reachable_through_step
             reachable_through_reachable : core.

Global Hint Resolve reachable_through_refl
             reachable_through_trans'
             reachable_through_trans
             reachable_through_step
             reachable_through_reachable : core.

Local Ltac update_fix term1 term2 H H_orig H' :=
  match H with
  | context G [ term1 ] =>
    let x := context G [ term2 ] in
      update_fix term1 term2 x H_orig H'
  | _ =>
    let h := fresh "H" in
      assert H; [H' | clear H_orig; rename h into H_orig]
  end.

(* Replaces all occurrences of <term1> with <term2> in hypothesis <H>
    using tactic <H'> to prove the old hypothesis implies the updated *)
Local Ltac update_ term1 term2 H H' :=
  match type of H with
  | context G [ term1 ] =>
    let x := context G [ term2 ] in
      update_fix term1 term2 x H H'
  end.

Tactic Notation "update" constr(t1) "with" constr(t2) "in" hyp(H) := update_ t1 t2 H ltac:(try (cbn; easy)).
Tactic Notation "update" constr(t1) "with" constr(t2) "in" hyp(H) "by" tactic(G) := update_ t1 t2 H G.
Tactic Notation "update" constr(t2) "in" hyp(H) := let t1 := type of H in update_ t1 t2 H ltac:(try (cbn; easy)).
Tactic Notation "update" constr(t2) "in" hyp(H) "by" tactic(G) := let t1 := type of H in update_ t1 t2 H G.

Local Ltac only_on_match tac :=
  match goal with
  | |- exists bstate', reachable_through ?bstate bstate' /\ _ => tac
  | |- _ => idtac
  end.

Local Ltac update_chainstate bstate1 bstate2 :=
  match goal with
  | H : reachable bstate1 |- _ => clear H
  | H : chain_state_queue bstate1 = _ |- _ => clear H
  | H : IsValidNextBlock _ bstate1.(chain_state_env).(env_chain) |- _ => clear H
  | H : reachable_through bstate1 bstate2 |- _ =>
      update (reachable bstate2) in H
  | H : env_contracts bstate1.(chain_state_env) _ = Some _ |- _ =>
      update bstate1 with bstate2 in H by (now rewrite_environment_equiv)
  | H : env_contract_states bstate1.(chain_state_env) _ = Some _ |- _ =>
      update bstate1 with bstate2 in H by (now rewrite_environment_equiv)
  | H : context [ bstate1 ] |- _ =>
    match type of H with
    | EnvironmentEquiv _ _ => fail 1
    | _ => update bstate1 with bstate2 in H by (try (rewrite_environment_equiv; cbn; easy))
    end
  end;
  only_on_match ltac:(progress update_chainstate bstate1 bstate2).

(* Tactic for updating goal and all occurrences of an old ChainState
    after adding a future ChainState to the environment. *)
Ltac update_all :=
  match goal with
  | Hreach : reachable_through ?bstate1 ?bstate2,
    Henv_eq : EnvironmentEquiv ?bstate2.(chain_state_env) (add_new_block_to_env ?header ?bstate1.(chain_state_env)) |-
    exists bstate3, reachable_through ?bstate1 bstate3 /\ _ =>
      apply (step_reachable_through_exists bstate1 bstate2); auto;
      update_chainstate bstate1 bstate2;
      only_on_match ltac:(
        clear Henv_eq;
        (try clear dependent header);
        clear dependent bstate1)
  | Hreach : reachable_through ?bstate1 ?bstate2,
    Henv_eq : EnvironmentEquiv ?bstate2.(chain_state_env) _ |-
    exists bstate3, reachable_through ?bstate1 bstate3 /\ _ =>
      apply (step_reachable_through_exists bstate1 bstate2); auto;
      update_chainstate bstate1 bstate2;
      only_on_match ltac:(
        clear Henv_eq;
        clear dependent bstate1)
  | Hreach : reachable_through ?bstate1 ?bstate2 |-
    exists bstate3, reachable_through ?bstate1 bstate3 /\ _ =>
      apply (step_reachable_through_exists bstate1 bstate2); auto;
      update (reachable bstate2) in Hreach;
      only_on_match ltac:(clear dependent bstate1)
  end.

Ltac forward_time slot_ :=
  let new_bstate := fresh "bstate" in
  let new_header := fresh "header" in
  let new_header_valid := fresh "header_valid" in
  let new_reach := fresh "reach" in
  let new_queue := fresh "queue" in
  let new_env_eq := fresh "env_eq" in
  let new_slot_hit := fresh "slot_hit" in
  match goal with
  | Hqueue : (chain_state_queue ?bstate) = [],
    Hreach : reachable ?bstate |-
    exists bstate', reachable_through ?bstate bstate' /\ _ =>
      specialize (forward_time bstate) with (slot := slot_)
        as [new_bstate [new_header [new_reach [new_header_valid [new_slot_hit [new_queue new_env_eq]]]]]]
  end.

Ltac forward_time_exact slot_ :=
  let new_bstate := fresh "bstate" in
  let new_header := fresh "header" in
  let new_header_valid := fresh "header_valid" in
  let new_reach := fresh "reach" in
  let new_queue := fresh "queue" in
  let new_env_eq := fresh "env_eq" in
  let new_slot_hit := fresh "slot_hit" in
  match goal with
  | Hqueue : (chain_state_queue ?bstate) = [],
    Hreach : reachable ?bstate |-
    exists bstate', reachable_through ?bstate bstate' /\ _ =>
      specialize (forward_time_exact bstate) with (slot := slot_)
        as [new_bstate [new_header [new_reach [new_header_valid [new_slot_hit [new_queue new_env_eq]]]]]]
  end.

Ltac add_block acts_ slot_ :=
  let new_bstate := fresh "bstate" in
  let new_reach := fresh "reach" in
  let new_queue := fresh "queue" in
  let new_env_eq := fresh "env_eq" in
  match goal with
  | Hqueue : (chain_state_queue ?bstate) = [],
    Hreach : reachable ?bstate |-
    exists bstate', reachable_through ?bstate bstate' /\ _ =>
      specialize add_block with (acts := acts_) (slot_incr := slot_)
        as [new_bstate [new_reach [new_queue new_env_eq]]];
      [apply Hreach | apply Hqueue| | | | | |]
  end.

Ltac evaluate_action contract_ :=
  let new_bstate := fresh "bstate" in
  let new_reach := fresh "reach" in
  let new_deployed_state := fresh "deployed_state" in
  let new_queue := fresh "queue" in
  let new_env_eq := fresh "env_eq" in
  match goal with
  | Hqueue : (chain_state_queue ?bstate) = _,
    Hreach : reachable ?bstate |-
    exists bstate', reachable_through ?bstate bstate' /\ _ =>
      specialize (evaluate_action contract_) as
        [new_bstate [new_reach [new_deployed_state [new_queue new_env_eq]]]];
      [apply Hreach | rewrite Hqueue | | | | | | ]
  end.

Ltac evaluate_transfer :=
  let new_bstate := fresh "bstate" in
  let new_reach := fresh "reach" in
  let new_queue := fresh "queue" in
  let new_env_eq := fresh "env_eq" in
  match goal with
  | Hqueue : (chain_state_queue ?bstate) = _,
    Hreach : reachable ?bstate |-
    exists bstate', reachable_through ?bstate bstate' /\ _ =>
      specialize evaluate_transfer as
        [new_bstate [new_reach [new_queue new_env_eq]]];
      [apply Hreach | rewrite Hqueue | | | | ]
  end.

Ltac discard_invalid_action :=
  let new_bstate := fresh "bstate" in
  let new_reach := fresh "reach" in
  let new_queue := fresh "queue" in
  let new_env_eq := fresh "env_eq" in
  match goal with
  | Hqueue : (chain_state_queue ?bstate) = _,
    Hreach : reachable ?bstate |-
    exists bstate', reachable_through ?bstate bstate' /\ _ =>
      specialize discard_invalid_action as
        [new_bstate [new_reach [new_queue new_env_eq]]];
      [apply Hreach | rewrite Hqueue | | | ]
  end.

Ltac empty_queue H :=
  let new_bstate := fresh "bstate" in
  let new_reach := fresh "reach" in
  let new_queue := fresh "queue" in
  let temp_H := fresh "H" in
  let temp_eval := fresh "eval" in
   match goal with
  | Hempty : emptyable (chain_state_queue ?bstate),
    Hreach : reachable ?bstate |-
    exists bstate', reachable_through ?bstate bstate' /\ _ =>
      pattern (bstate) in H;
      match type of H with
      | ?f bstate =>
        specialize (empty_queue bstate f) as
          [new_bstate [new_reach [temp_H new_queue]]];
        [apply Hreach | apply Hempty | apply H |
        clear H;
        intros ?bstate_from ?bstate_to ?act ?acts ?reach_from ?reach_to
          H ?queue_from ?queue_to [[temp_eval] | ?env_eq];
          only 1: destruct_action_eval |
        clear H; rename temp_H into H]
      end
  end.

Ltac deploy_contract contract_ :=
  let new_bstate := fresh "bstate" in
  let new_reach := fresh "reach" in
  let new_deployed_state := fresh "deployed_state" in
  let new_contract_deployed := fresh "contract_deployed" in
  let new_queue := fresh "queue" in
  let new_env_eq := fresh "env_eq" in
  let new_cstate := fresh "cstate" in
  let contract_not_deployed := fresh "trace" in
  let deploy_info := fresh "deploy_info" in
  match goal with
  | Hqueue : (chain_state_queue ?bstate) = _,
    Hreach : reachable ?bstate,
    Haddress : address_is_contract ?caddr = true,
    Hdeployed : env_contracts ?bstate.(chain_state_env) ?caddr = None |-
    exists bstate', reachable_through ?bstate bstate' /\ _ =>
      specialize (deploy_contract contract_) as
        (new_bstate & trace & new_reach & new_contract_deployed &
          new_deployed_state & deploy_info & new_queue & new_env_eq);
      [apply Hreach | rewrite Hqueue | | |
       apply Haddress | apply Hdeployed | |
       clear Haddress Hdeployed;
       match type of new_deployed_state with
       | env_contract_states _ _ = Some ((@serialize _ _) ?state) => remember state as new_cstate
       end
       ]
  end.


Require Import Memory.
Require Import Values.
Require Import Coqlib.
Require Import Integers.
Require Import AST.
Require Import Znumtheory.
Require Import vellvm_tactics.

Module MoreMem.

Export Mem.

Transparent load alloc.

Definition meminj : Type := block -> option (block * Z).

(** A memory injection defines a relation between values that is the
  identity relation, except for pointer values which are shifted
  as prescribed by the memory injection. *)

Inductive val_inject (mi: meminj): val -> val -> Prop :=
  | val_inject_int:
      forall wz i, val_inject mi (Vint wz i) (Vint wz i)
  | val_inject_float:
      forall f, val_inject mi (Vfloat f) (Vfloat f)
  | val_inject_ptr:
      forall b1 ofs1 b2 ofs2 delta,
      mi b1 = Some (b2, delta) ->
      ofs2 = Int.add 31 ofs1 (Int.repr 31 delta) ->
      val_inject mi (Vptr b1 ofs1) (Vptr b2 ofs2)
  | val_inject_inttoptr:
      forall i, val_inject mi (Vinttoptr i) (Vinttoptr i)
  | val_inject_undef: val_inject mi Vundef Vundef.

Hint Resolve val_inject_int val_inject_float val_inject_ptr val_inject_inttoptr
             val_inject_undef.

Inductive val_list_inject (mi: meminj): list val -> list val-> Prop:=
  | val_nil_inject :
      val_list_inject mi nil nil
  | val_cons_inject : forall v v' vl vl' ,
      val_inject mi v v' -> val_list_inject mi vl vl'->
      val_list_inject mi (v :: vl) (v' :: vl').

Hint Resolve val_nil_inject val_cons_inject.

(* Properties of val_inject *)
Lemma val_load_result_inject:
  forall f chunk v1 v2,
  val_inject f v1 v2 ->
  val_inject f (Val.load_result chunk v1) (Val.load_result chunk v2).
Proof.
  intros. inv H; destruct chunk; simpl; try econstructor; eauto.
    destruct (eq_nat_dec n 31); try econstructor; eauto.
    destruct (eq_nat_dec n 31); try econstructor; eauto.
Qed.

Lemma val_load_result_inject_2: forall (f : block -> option (block * Z))
  (v : val) (m : memory_chunk) (Hchk : Val.has_chunk v m)
  (Hinj : val_inject f (Val.load_result m v) (Val.load_result m v)),
  val_inject f v v.
Proof.
  intros.
  destruct m, v; try inv Hchk; auto.
Qed.

Lemma val_inject__has_chunkb: forall mi v1 v2 m
  (H : val_inject mi v1 v2),
  Val.has_chunkb v1 m = Val.has_chunkb v2 m.
Proof. intros. inv H; auto. Qed.

(** Monotone evolution of a memory injection. *)

Definition inject_incr (f1 f2: meminj) : Prop :=
  forall b b' delta, f1 b = Some(b', delta) -> f2 b = Some(b', delta).

Lemma inject_incr_refl :
   forall f , inject_incr f f .
Proof. unfold inject_incr. auto. Qed.

Lemma inject_incr_trans :
  forall f1 f2 f3,
  inject_incr f1 f2 -> inject_incr f2 f3 -> inject_incr f1 f3 .
Proof .
  unfold inject_incr; intros. eauto.
Qed.

Lemma val_inject_incr:
  forall f1 f2 v v',
  inject_incr f1 f2 ->
  val_inject f1 v v' ->
  val_inject f2 v v'.
Proof.
  intros. inv H0; eauto.
Qed.

Lemma val_list_inject_incr:
  forall f1 f2 vl vl' ,
  inject_incr f1 f2 -> val_list_inject f1 vl vl' ->
  val_list_inject f2 vl vl'.
Proof.
  induction vl; intros; inv H0. auto.
  constructor. eapply val_inject_incr; eauto. auto.
Qed.

Hint Resolve inject_incr_refl val_inject_incr val_list_inject_incr.

Inductive memval_inject (f: meminj): memval -> memval -> Prop :=
  | memval_inject_byte:
      forall wz n, memval_inject f (Byte wz n) (Byte wz n)
  | memval_inject_ptr:
      forall b1 ofs1 b2 ofs2 delta n,
      f b1 = Some (b2, delta) ->
      ofs2 = Int.add 31 ofs1 (Int.repr 31 delta) ->
      memval_inject f (Pointer b1 ofs1 n) (Pointer b2 ofs2 n)
  | memval_inject_inttoptr:
      forall i n, memval_inject f (IPointer i n) (IPointer i n)
  | memval_inject_undef: memval_inject f Undef Undef.

(* Properties of memval_inject. *)
Lemma memval_inject_incr: forall f f' v1 v2,
  memval_inject f v1 v2 -> inject_incr f f' -> memval_inject f' v1 v2.
Proof.
  intros. inv H; econstructor. rewrite (H0 _ _ _ H1). reflexivity. auto.
Qed.

Lemma inj_bytes_inject:
  forall f wz bl,
    list_forall2 (memval_inject f) (inj_bytes wz bl) (inj_bytes wz bl).
Proof.
  induction bl; constructor; auto. constructor.
Qed.

Lemma repeat_Undef_inject_self:
  forall f n,
  list_forall2 (memval_inject f) (list_repeat n Undef) (list_repeat n Undef).
Proof.
  induction n; simpl; constructor; auto. constructor.
Qed.

(* Properties of proj_bytes. *)
Lemma proj_bytes_inject_some:
  forall f vl vl',
  list_forall2 (memval_inject f) vl vl' ->
  forall n bl,
  proj_bytes n vl = Some bl ->
  proj_bytes n vl' = Some bl.
Proof.
  induction 1; simpl. congruence.
  inv H; try congruence.

  intros.
  destruct (eq_nat_dec wz n0); auto.
  remember (proj_bytes n0 al) as R.
  destruct R.
    inv H. rewrite (IHlist_forall2 n0 l); auto.
    congruence.
Qed.

Lemma proj_bytes_inject_none:
  forall f vl vl',
  list_forall2 (memval_inject f) vl vl' ->
  forall n,
  proj_bytes n vl = None ->
  proj_bytes n vl' = None.
Proof.
  induction 1; simpl. congruence.
  inv H; try congruence.

  intros.
  destruct (eq_nat_dec wz n0); auto.
  remember (proj_bytes n0 al) as R.
  destruct R.
    inv H. rewrite (IHlist_forall2 n0); auto.
Qed.

Lemma proj_bytes_not_inject:
  forall f vl vl',
  list_forall2 (memval_inject f) vl vl' ->
  forall n,
  proj_bytes n vl = None -> proj_bytes n vl' <> None -> In Undef vl.
Proof.
  induction 1; simpl; intros.
    congruence.
    inv H; try congruence; auto.
    destruct (eq_nat_dec wz n); subst; auto.
      remember (proj_bytes n al) as R.
      remember (proj_bytes n bl) as R'.
      destruct R; destruct R';
        try solve [inversion H1 | inversion H2 | contradict H2; auto].
        right. eapply IHlist_forall2; eauto.
          rewrite <- HeqR'. intro. inversion H.
      contradict H2; auto.
Qed.

(* Properties of proj_pointer *)
Definition meminj_no_overlap (f: meminj) : Prop :=
  forall b1 b1' delta1 b2 b2' delta2,
  b1 <> b2 ->
  f b1 = Some (b1', delta1) ->
  f b2 = Some (b2', delta2) ->
  b1' <> b2'.

Lemma meminj_no_overlap_spec : forall f b1 b d1 b2 d2,
  meminj_no_overlap f -> f b1 = Some (b, d1) -> f b2 = Some (b, d2) ->
  b1 = b2 /\ d1 = d2.
Proof.
  intros.
  destruct (zeq b1 b2); subst.
    rewrite H1 in H0.
    inv H0. split; auto.

    elimtype False. unfold meminj_no_overlap in H.
    eapply H in n; eauto.
Qed.

Lemma check_pointer_inject_true:
  forall f vl vl',
  list_forall2 (memval_inject f) vl vl' ->
  forall n b ofs b' delta,
  check_pointer n b ofs vl = true ->
  f b = Some(b', delta) ->
  check_pointer n b' (Int.add 31 ofs (Int.repr 31 delta)) vl' = true.
Proof.
  induction 1; intros; destruct n; simpl in *; auto.
  inv H; auto.
  destruct (andb_prop _ _ H1). destruct (andb_prop _ _ H).
  destruct (andb_prop _ _ H5).
  assert (n = n0) by (apply beq_nat_true; auto).
  assert (b = b0) by (eapply proj_sumbool_true; eauto).
  assert (ofs = ofs1) by (eapply proj_sumbool_true; eauto).
  subst. rewrite H3 in H2; inv H2.
  unfold proj_sumbool. rewrite dec_eq_true. rewrite dec_eq_true.
  rewrite <- beq_nat_refl. simpl. eauto.
Qed.

Definition meminj_zero_delta (f: meminj) : Prop :=
  forall b b' delta, f b = Some(b', delta) -> delta = 0.

Lemma check_pointer_inject_false:
  forall f vl vl',
  list_forall2 (memval_inject f) vl vl' ->
  meminj_no_overlap f ->
  meminj_zero_delta f ->
  forall n b ofs b' delta,
  check_pointer n b ofs vl = false ->
  f b = Some(b', delta) ->
  check_pointer n b' (Int.add 31 ofs (Int.repr 31 delta)) vl' = false.
Proof.
  induction 1; intros; destruct n; simpl in *; auto.
  inv H; auto.
  apply andb_false_elim in H3.
  destruct H3 as [H3 | H3].
    apply andb_false_elim in H3.
    destruct H3 as [H3 | H3].
      apply andb_false_elim in H3.
      destruct H3 as [H3 | H3].
        apply andb_false_intro1.
        apply andb_false_intro1.
        apply andb_false_intro1.
        unfold eq_block in *.
        destruct (zeq b b0); subst; inv H3.
        unfold meminj_no_overlap in H1.
        eapply H1 in n1; eauto.
        destruct (zeq b' b2); subst; try solve [contradict n1; auto | auto].

        apply andb_false_intro1.
        apply andb_false_intro1.
        apply andb_false_intro2.
        apply H2 in H4. apply H2 in H5. subst.
        rewrite Int.add_zero. rewrite Int.add_zero. auto.
      apply andb_false_intro1.
      apply andb_false_intro2; auto.
    eauto using andb_false_intro2.
Qed.

Lemma check_ipointer_inject_true:
  forall f vl vl',
  list_forall2 (memval_inject f) vl vl' ->
  forall n i,
  check_ipointer n i vl = true ->
  check_ipointer n i vl' = true.
Proof.
  induction 1; intros; destruct n; simpl in *; auto.
  inv H; auto.

  destruct (andb_prop _ _ H1). destruct (andb_prop _ _ H).
  apply IHlist_forall2 in H2.
  congruence.
Qed.

Lemma check_ipointer_inject_false:
  forall f vl vl',
  list_forall2 (memval_inject f) vl vl' ->
  forall n i,
  check_ipointer n i vl = false ->
  check_ipointer n i vl' = false.
Proof.
  induction 1; intros; destruct n; simpl in *; auto.
  inv H; auto.

  apply andb_false_elim in H1.
  destruct H1; auto using andb_false_intro1.
    apply IHlist_forall2 in e.
    auto using andb_false_intro2.
Qed.

Lemma proj_ipointer_inject:
  forall f vl1 vl2,
  list_forall2 (memval_inject f) vl1 vl2 ->
  val_inject f (proj_ipointer vl1) (proj_ipointer vl2).
Proof.
  intros. unfold proj_ipointer.
  inversion H; subst. auto. inversion H0; subst; auto.
  case_eq (check_ipointer (size_chunk_nat Mint32) i
             (IPointer i n :: al)); intros.
  exploit check_ipointer_inject_true. eexact H. eauto. eauto.
  intro. rewrite H3. econstructor; eauto.

  exploit check_ipointer_inject_false. eexact H. eauto. eauto.
  intro. rewrite H3. econstructor; eauto.
Qed.

Lemma proj_pointer_inject:
  forall f vl1 vl2,
  meminj_no_overlap f ->
  meminj_zero_delta f ->
  list_forall2 (memval_inject f) vl1 vl2 ->
  val_inject f (proj_pointer vl1) (proj_pointer vl2).
Proof.
  intros f v11 v12 J1 J2 H. unfold proj_pointer.
  inversion H; subst. auto. inversion H0; subst; auto.
  case_eq (check_pointer (size_chunk_nat Mint32) b0 ofs1
             (Pointer b0 ofs1 n :: al)); intros.

  exploit check_pointer_inject_true; eauto.
  intro. rewrite H4. econstructor; eauto.

  exploit check_pointer_inject_false; eauto.
  intro. rewrite H4. econstructor; eauto.
Qed.

Lemma proj_pointer_undef:
  forall vl, In Undef vl -> proj_pointer vl = Vundef.
Proof.
  intros; unfold proj_pointer.
  destruct vl; auto. destruct m; auto.
  rewrite check_pointer_undef. auto. auto.
Qed.

Lemma proj_ipointer_undef:
  forall vl, In Undef vl -> proj_ipointer vl = Vundef.
Proof.
  intros; unfold proj_ipointer.
  destruct vl; auto. destruct m; auto.
  rewrite check_ipointer_undef. auto. auto.
Qed.

(* Properties of encode/decode val *)
Theorem encode_val_inject:
  forall f v1 v2 chunk,
  val_inject f v1 v2 ->
  list_forall2 (memval_inject f) (encode_val chunk v1) (encode_val chunk v2).
Proof.
  intros. inv H; simpl.
    apply inj_bytes_inject.
    apply inj_bytes_inject.

    destruct chunk; try apply repeat_Undef_inject_self.
    destruct (eq_nat_dec n 31); subst; try apply repeat_Undef_inject_self.
      simpl; repeat econstructor; auto.

    destruct chunk; try apply repeat_Undef_inject_self.
    destruct (eq_nat_dec n 31); subst; try apply repeat_Undef_inject_self.
      unfold inj_ipointer; simpl; repeat econstructor; auto.

    destruct chunk; try apply repeat_Undef_inject_self.
Qed.

Theorem decode_val_inject:
  forall f vl1 vl2 chunk,
  meminj_no_overlap f ->
  meminj_zero_delta f ->
  list_forall2 (memval_inject f) vl1 vl2 ->
  val_inject f (decode_val chunk vl1) (decode_val chunk vl2).
Proof.
  intros f vl1 vl2 chunk JJ JJ2 H. unfold decode_val.
  case_eq (proj_bytes (wz_of_chunk chunk) vl1); intros.
    exploit proj_bytes_inject_some; eauto. intros. rewrite H1.
    destruct chunk; constructor.

    exploit proj_bytes_inject_none; eauto. intros. rewrite H1.
    destruct chunk; auto.
    destruct (eq_nat_dec n 31); subst; auto.
      assert (H2 := H).
      apply proj_pointer_inject in H2; auto.
      destruct (@proj_pointer_inv vl1) as [J1 | [b1 [ofs1 J1]]]; rewrite J1.
        rewrite J1 in H2. inv H2.
        apply proj_ipointer_inject; auto.

        rewrite J1 in H2. inv H2. eauto.
Qed.

Record mem_inj (f: meminj) (m1 m2: mem) : Prop :=
  mk_mem_inj {
    mi_access:
      forall b1 b2 delta chunk ofs p,
      f b1 = Some(b2, delta) ->
      valid_access m1 chunk b1 ofs p ->
      valid_access m2 chunk b2 (ofs + delta) p;
    mi_memval:
      forall b1 ofs b2 delta,
      f b1 = Some(b2, delta) ->
      perm m1 b1 ofs Nonempty ->
      memval_inject f (m1.(mem_contents) b1 ofs) (m2.(mem_contents) b2 (ofs + delta))
  }.

(** Preservation of permissions *)

Lemma perm_inj:
  forall f m1 m2 b1 ofs p b2 delta,
  mem_inj f m1 m2 ->
  perm m1 b1 ofs p ->
  f b1 = Some(b2, delta) ->
  perm m2 b2 (ofs + delta) p.
Proof.
  intros.
  assert (valid_access m1 (Mint 7) b1 ofs p).
    split. red; intros. simpl in H2. rewrite bytesize_chunk_7_eq_1 in H2. replace ofs0 with ofs by omega. auto.
    simpl. apply Zone_divide.
  exploit mi_access; eauto. intros [A B].
  apply A. simpl; rewrite bytesize_chunk_7_eq_1; omega.
Qed.

(** Preservation of loads. *)

Lemma getN_inj:
  forall f m1 m2 b1 b2 delta,
  mem_inj f m1 m2 ->
  f b1 = Some(b2, delta) ->
  forall n ofs,
  range_perm m1 b1 ofs (ofs + Z_of_nat n) Readable ->
  list_forall2 (memval_inject f)
               (getN n ofs (m1.(mem_contents) b1))
               (getN n (ofs + delta) (m2.(mem_contents) b2)).
Proof.
  induction n; intros; simpl.
  constructor.
  rewrite inj_S in H1.
  constructor.
  eapply mi_memval; eauto.
  apply perm_implies with Readable.
  apply H1. omega. constructor.
  replace (ofs + delta + 1) with ((ofs + 1) + delta) by omega.
  apply IHn. red; intros; apply H1; omega.
Qed.

Lemma load_inj:
  forall f m1 m2 chunk b1 ofs b2 delta v1,
  meminj_no_overlap f ->
  meminj_zero_delta f ->
  mem_inj f m1 m2 ->
  load chunk m1 b1 ofs = Some v1 ->
  f b1 = Some (b2, delta) ->
  exists v2, load chunk m2 b2 (ofs + delta) = Some v2 /\ val_inject f v1 v2.
Proof.
  intros f m1 m2 chunk b1 ofs b2 delta v1 J1 J2 H H0 H1.
  exists (decode_val chunk (getN (size_chunk_nat chunk) (ofs + delta) (m2.(mem_contents) b2))).
  split. unfold load. apply pred_dec_true.
  eapply mi_access; eauto with mem.
  exploit load_result; eauto. intro. rewrite H2.
  apply decode_val_inject; auto. apply getN_inj; auto.
  rewrite <- size_chunk_conv. exploit load_valid_access; eauto.
  intros [A B]. auto.
Qed.

(** Preservation of stores. *)

Lemma setN_inj:
  forall (access: Z -> Prop) delta f vl1 vl2,
  list_forall2 (memval_inject f) vl1 vl2 ->
  forall p c1 c2,
  (forall q, access q -> memval_inject f (c1 q) (c2 (q + delta))) ->
  (forall q, access q -> memval_inject f ((setN vl1 p c1) q)
                                         ((setN vl2 (p + delta) c2) (q + delta))).
Proof.
  induction 1; intros; simpl.
  auto.
  replace (p + delta + 1) with ((p + 1) + delta) by omega.
  apply IHlist_forall2; auto.
  intros. unfold update at 1. destruct (zeq q0 p). subst q0.
  rewrite update_s. auto.
  rewrite update_o. auto. omega.
Qed.

Lemma store_mapped_inj:
  forall f chunk m1 b1 ofs v1 n1 m2 b2 delta v2,
  mem_inj f m1 m2 ->
  store chunk m1 b1 ofs v1 = Some n1 ->
  meminj_no_overlap f ->
  f b1 = Some (b2, delta) ->
  val_inject f v1 v2 ->
  exists n2,
    store chunk m2 b2 (ofs + delta) v2 = Some n2
    /\ mem_inj f n1 n2.
Proof.
  intros. inversion H.
  assert (valid_access m2 chunk b2 (ofs + delta) Writable).
    eapply mi_access0; eauto with mem.
  destruct (valid_access_store _ _ _ _ v2 H4) as [n2 STORE].
  exists n2; split. eauto.
  constructor.
(* access *)
  intros.
  eapply store_valid_access_1; [apply STORE |].
  eapply mi_access0; eauto.
  eapply store_valid_access_2; [apply H0 |]. auto.
(* mem_contents *)
  intros.
  assert (perm m1 b0 ofs0 Nonempty). eapply perm_store_2; eauto.
  rewrite (store_mem_contents _ _ _ _ _ _ H0).
  rewrite (store_mem_contents _ _ _ _ _ _ STORE).
  unfold update.
  destruct (zeq b0 b1). subst b0.
  (* block = b1, block = b2 *)
  assert (b3 = b2) by congruence. subst b3.
  assert (delta0 = delta) by congruence. subst delta0.
  rewrite zeq_true.
  apply setN_inj with (access := fun ofs => perm m1 b1 ofs Nonempty).
  apply encode_val_inject; auto. auto. auto.
  destruct (zeq b3 b2). subst b3.
  (* block <> b1, block = b2 *)
  rewrite setN_other. auto.
  rewrite encode_val_length. rewrite <- size_chunk_conv. intros.
  assert (b2 <> b2).
    eapply H1; eauto.
  congruence.
  (* block <> b1, block <> b2 *)
  eauto.
Qed.

Lemma store_unmapped_inj:
  forall f chunk m1 b1 ofs v1 n1 m2,
  mem_inj f m1 m2 ->
  store chunk m1 b1 ofs v1 = Some n1 ->
  f b1 = None ->
  mem_inj f n1 m2.
Proof.
  intros. inversion H.
  constructor.
(* access *)
  eauto with mem.
(* mem_contents *)
  intros.
  rewrite (store_mem_contents _ _ _ _ _ _ H0).
  rewrite update_o. eauto with mem.
  congruence.
Qed.

Lemma store_outside_inj:
  forall f m1 m2 chunk b ofs v m2',
  mem_inj f m1 m2 ->
  (forall b' delta ofs',
    f b' = Some(b, delta) ->
    perm m1 b' ofs' Nonempty ->
    ofs' + delta < ofs \/ ofs' + delta >= ofs + size_chunk chunk) ->
  store chunk m2 b ofs v = Some m2' ->
  mem_inj f m1 m2'.
Proof.
  intros. inversion H. constructor.
(* access *)
  eauto with mem.
(* mem_contents *)
  intros.
  rewrite (store_mem_contents _ _ _ _ _ _ H1).
  unfold update. destruct (zeq b2 b). subst b2.
  rewrite setN_outside. auto.
  rewrite encode_val_length. rewrite <- size_chunk_conv.
  eapply H0; eauto.
  eauto with mem.
Qed.

(** Preservation of allocations *)

Lemma alloc_right_inj:
  forall f m1 m2 lo hi b2 m2',
  mem_inj f m1 m2 ->
  alloc m2 lo hi = (m2', b2) ->
  mem_inj f m1 m2'.
Proof.
  intros. injection H0. intros NEXT MEM.
  inversion H. constructor.
(* access *)
  intros. eauto with mem.
(* mem_contents *)
  intros.
  assert (valid_access m2 (Mint 7) b0 (ofs + delta) Nonempty).
    eapply mi_access0; eauto.
    split. simpl. red; intros. rewrite bytesize_chunk_7_eq_1 in H3. assert (ofs0 = ofs) by omega. congruence.
    simpl. apply Zone_divide.
  assert (valid_block m2 b0) by eauto with mem.
  rewrite <- MEM; simpl. rewrite update_o. eauto with mem.
  rewrite NEXT. apply sym_not_equal. eauto with mem.
Qed.

(** Preservation of frees *)

Lemma free_right_inj:
  forall f m1 m2 b lo hi m2',
  mem_inj f m1 m2 ->
  free m2 b lo hi = Some m2' ->
  (forall b1 delta ofs p,
    f b1 = Some(b, delta) -> perm m1 b1 ofs p ->
    lo <= ofs + delta < hi -> False) ->
  mem_inj f m1 m2'.
Proof.
  intros. exploit free_result; eauto. intro FREE. inversion H. constructor.
(* access *)
  intros. exploit mi_access0; eauto. intros [RG AL]. split; auto.
  red; intros. eapply perm_free_1; eauto.
  destruct (zeq b2 b); auto. subst b. right.
  destruct (zlt ofs0 lo); auto. destruct (zle hi ofs0); auto.
  elimtype False. eapply H1 with (ofs := ofs0 - delta). eauto.
  apply H3. omega. omega.
(* mem_contents *)
  intros. rewrite FREE; simpl.
  specialize (mi_memval0 _ _ _ _ H2 H3).
  assert (b=b2 /\ lo <= ofs+delta < hi \/ (b<>b2 \/ ofs+delta<lo \/ hi <= ofs+delta)) by (unfold block; omega).
  destruct H4. destruct H4. subst b2.
  specialize (H1 _ _ _ _ H2 H3). elimtype False; auto.
  rewrite (clearN_out _ _ _ _ _ _ H4); auto.
Qed.

Lemma free_inj:
  forall f m1 m2 b1 b2 delta lo hi m1' m2',
  meminj_no_overlap f ->
  meminj_zero_delta f ->
  mem_inj f m1 m2 ->
  free m1 b1 lo hi = Some m1' ->
  free m2 b2 (lo+delta) (hi+delta) = Some m2' ->
  f b1 = Some (b2, delta) ->
  mem_inj f m1' m2'.
Proof.
  intros f m1 m2 b1 b2 delta lo hi m1' m2' J J' H H0 H1 H2.
  exploit free_result; eauto.
  intro FREE. inversion H. constructor.
(* access *)
  intros.
  assert (valid_access m2 chunk b3 (ofs + delta0) p) as [RG AL]
  by (exploit mi_access0; eauto with mem).

  split; auto.
  red; intros. eapply perm_free_1; eauto.
  destruct (zeq b3 b2); auto.
    subst b2. right.
    destruct (zlt ofs0 (lo + delta)); auto.
    destruct (zle (hi + delta) ofs0); auto.
    destruct (@meminj_no_overlap_spec f b0 b3 delta0 b1 delta J H3 H2)
      as [G1 G2]; subst.
    assert (lo <= ofs0 - delta < hi) as J1.
      clear - g g0. auto with zarith.
    assert (ofs <= ofs0 - delta < ofs + size_chunk chunk) as J2.
      clear - H5. auto with zarith.
    destruct H4 as [H41 H42].
    apply H41 in J2.
    eapply perm_free_2 with (p:=p) in J1; eauto.
    congruence.

(* mem_contents *)
  intros. rewrite FREE; simpl.
  assert (FREE':=H0). apply free_result in FREE'.
  rewrite FREE'; simpl.
  assert (b0=b1 /\ lo <= ofs < hi \/ (b1<>b0 \/ ofs<lo \/ hi <= ofs)) as J1
    by (unfold block; omega).
  assert (b2=b3 /\ lo+delta <= ofs+delta < hi+delta \/
    (b2<>b3 \/ ofs+delta<lo+delta \/ hi+delta <= ofs+delta))
    as J2 by (unfold block; omega).
  destruct J1 as [J1 | J1].
    destruct J1 as [J11 J12]; subst.
    eapply perm_free_2 with (p:=Nonempty) in H0; eauto.
    congruence.

    rewrite (clearN_out _ _ _ _ _ _ J1).
    destruct J2 as [J2 | J2].
      destruct J2 as [J21 J22]; subst.
      destruct (@meminj_no_overlap_spec f b0 b3 delta0 b1 delta J H3 H2)
        as [G1 G2]; subst.
      assert (lo <= ofs < hi) as EQ.
        clear - J22. auto with zarith.
      clear - J1 EQ.
      destruct J1 as [J1 | J1]; try solve [congruence].
      contradict EQ; auto with zarith.

      assert (W1:=H2). apply J' in W1. subst.
      assert (W2:=H3). apply J' in W2. subst.
      rewrite (clearN_out _ _ _ _ _ _ J2).
      eapply perm_free_3 in H4; eauto.
Qed.

Global Opaque load alloc.

Lemma free_left_nonmap_inj:
  forall f m1 m2 b lo hi m1' (Hprop: f b = None),
  mem_inj f m1 m2 ->
  Mem.free m1 b lo hi = Some m1' ->
  mem_inj f m1' m2.
Proof.
  intros. exploit Mem.free_result; eauto. intro FREE. inversion H. constructor.
(* access *)
  intros. eauto with mem.
(* mem_contents *)
  intros. rewrite FREE; simpl.
  assert (b=b1 /\ lo <= ofs < hi \/ (b<>b1 \/ ofs<lo \/ hi <= ofs))
    by (unfold Values.block; omega).
  destruct H3.
    destruct H3. subst b1. uniq_result.

    rewrite (Mem.clearN_out _ _ _ _ _ _ H3).
    apply mi_memval; auto.
    eapply Mem.perm_free_3; eauto.
Qed.

End MoreMem.


(*
 * Copyright (c) 2009-2011, Andrew Appel, Robert Dockins and Aquinas Hobor.
 *
 *)

Require Import msl.base.
Require Import msl.sepalg.
Require Import msl.psepalg.
Require Import msl.sepalg_generators.
Require Import msl.cjoins.
Require Import msl.eq_dec.

(** The cross split axiom looks unwieldly,
    but here we show that it arises naturally
    as a kind of distributivity property.
    Cross split can be rendered, with some accuracy,
    as "the separation algebra is distributive."
 *)

  (** This definition mirrors the definition of
      distributivity in a join-semilattice.  This
      definition generalizes the standard notion of
      distributivity in a lattice, but only mentions
      of the lattice operators.  Here we transplant
      the semilattice definition into the setting
      of separation algebras.
    *)
  Definition sa_distributive (A: Type) {JOIN: Join A} :=
    forall a b x z,
      join a b z ->
      constructive_join_sub x z ->
      {a' : A & {b' : A &
           (constructive_join_sub a' a * constructive_join_sub b' b * join a' b' x)%type}}.

(*
  (** We define this weaker version of cross-split
      in order to show that the sa_distributive
      axiom is equivalent. The ordinary cross_split
      is more constructive (it uses a sigma type rather
      than 'exists'), so we have to weaken it to show
      the correspondence.  We could, instead, define
      and use a constructive version of join_sub.
    *)
  Definition weak_cross_split `{sepalg A} :=
    forall a b c d z : A,
      join a b z ->
      join c d z ->
      exists x:(A*A*A*A), match x with (ac,ad,bc,bd) =>
         join ac ad a /\
         join bc bd b /\
         join ac bc c /\
         join ad bd d
       end.
*)

  (** Here we show that the cross split axiom is
      the same as the statement of distributivity
      for join semilattices transliterated into the
      setting of separation algebras.
    *)
  Theorem cross_split_distibutive {A} `{Perm_alg A}{SA: Sep_alg A}{CS: Cross_alg A} :
          sa_distributive A.
  Proof.
    intros ? ? ? ? H1 [x0 H2].
    destruct (CS _ _ _ _ _ H1 H2) as [[[[? ?] ?] ?] ?].
    intuition eauto.
    exists a0.
    exists a2.
    intuition eauto.
    econstructor; eauto.
    econstructor; eauto.
  Qed.

  Theorem distributive_cross_split {A} `{Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}:
     sa_distributive A -> Cross_alg A.
  Proof.
    intros H0.
    repeat intro.
    hnf in H0.
    destruct (H0 a b c z H1) as [a' [b' [[?H ?H] ?H]]].
    exists d; auto.
    destruct H3 as [q ?H].
    destruct H4 as [w ?H].
    exists (a',q,b',w). split; auto. split; auto. split; auto.
    destruct (join_assoc H3 H1) as [f [? ?]].
    apply join_comm in H6.
    destruct (join_assoc H4 H6) as [g [? ?]].
    assert (H10: g = d); [ | rewrite H10 in *; auto].
    apply join_comm in H7.
    apply join_comm in H9.
    destruct (join_assoc H9 H7) as [h [? ?]].
    generalize (join_eq H5 (join_comm H10)); intro.
    rewrite <- H12 in *; clear H12 h.
    eapply join_canc; eauto.
  Qed.

(** NOTICE ABOUT REDUNDANT LEMMAS:
 Since sa_distribute <-> cross_split, many of the proofs below are redundant.
 This was part of an experiment to see whether, in general, sa_distributive is
 simpler to prove than cross_split.  Short answer:  not really.
*)

Lemma distributive_equiv: forall A, @sa_distributive  _ (@Join_equiv A).
Proof.
  repeat intro.
 destruct H; subst.
 exists x; exists x; repeat split; auto.
Qed.

Lemma cross_split_equiv : forall A,  @Cross_alg _ (@Join_equiv A).
Proof.
  repeat intro.
  destruct H; destruct H0. subst. exists (((z,z),z),z). repeat split; auto.
Qed.

Lemma distributive_fun: forall A (JOIN: Join A) (key: Type),
               sa_distributive A -> @sa_distributive (key -> A) (Join_fun key A JOIN).
Proof.
unfold sa_distributive; intros.
assert (forall k, constructive_join_sub (x k) (z k)).
destruct X0 as [y ?].
intro k; exists (y k); auto.
assert (J := fun (k: key) => X (a k) (b k) (x k) (z k) (H k) (X1 k)).
clear X.
exists (fun k => projT1 (J k)).
exists (fun k => projT1 (projT2 (J k))).
split; [split|].
exists (fun k => proj1_sig (fst (fst (projT2 (projT2 (J k))))));
intro k; destruct (J k) as [ak' [bk' [[c c0] j]]];  simpl; destruct c; auto.
exists (fun k => proj1_sig (snd (fst (projT2 (projT2 (J k))))));
intro k; destruct (J k) as [ak' [bk' [[c c0] j]]];  simpl; destruct c0; auto.
intro k; destruct (J k) as [ak' [bk' [[c c0] j]]]; simpl; auto.
Qed.

Instance cross_split_fun: forall A (JOIN: Join A) (key: Type),
          Cross_alg A -> Cross_alg (key -> A).
Proof.
repeat intro.
pose (f (x: key) := projT1 (X (a x) (b x) (c x) (d x) (z x) (H x) (H0 x))).
pose (g (x: key) := projT2 (X (a x) (b x) (c x) (d x) (z x) (H x) (H0 x))).
pose (ac (x: key) := fst (fst (fst (f x)))).
pose (ad (x: key) := snd (fst (fst (f x)))).
pose (bc (x: key) := snd (fst (f x))).
pose (bd (x: key) := snd (f x)).
exists (ac,ad,bc,bd).
unfold ac, ad, bc, bd, f; clear ac ad bc bd f.
repeat split; intro x; simpl;
generalize (g x);  destruct (projT1 (X (a x) (b x) (c x) (d x) (z x) (H x) (H0 x))) as [[[? ?] ?] ?]; simpl; intuition.
Qed.

Lemma sa_distributive_prod : forall A B saA saB,
  @sa_distributive A saA ->
  @sa_distributive B saB ->
  @sa_distributive (A * B) (Join_prod A _ B _).
Proof.
 intros.
 intros [a1 a2] [b1 b2] [c1 c2] [z1 z2] [? ?].
 intros [[d1 d2] [? ?]].
 simpl in *.
 destruct (X a1 b1 c1 z1 H) as [a1' [b1' [[[u1 ?] [v1 ?]] ?]]]. exists d1; auto.
 destruct (X0 a2 b2 c2 z2 H0) as [a2' [b2' [[[u2 ?] [v2 ?]] ?]]]. exists d2; auto.
 exists (a1',a2'). exists (b1',b2').
 split; [split|].
 exists (u1,u2); split; auto.
 exists (v1,v2); split; auto.
 split; auto.
Qed.

Instance Cross_prod : forall A B saA saB,
  @Cross_alg A saA ->
  @Cross_alg B saB ->
  @Cross_alg (A * B) (Join_prod _ saA _ saB).
Proof.
  repeat intro.
  destruct a as [a1 a2].
  destruct b as [b1 b2].
  destruct c as [c1 c2].
  destruct d as [d1 d2].
  destruct z as [z1 z2].
  destruct H.
  destruct H0.
  simpl in *.
  destruct (X a1 b1 c1 d1 z1)
    as [p ?]; auto.
  destruct p as [[[s1 p1] q1] r1].
  destruct (X0 a2 b2 c2 d2 z2)
    as [p ?]; auto.
  destruct p as [[[s2 p2] q2] r2].
  exists ((s1,s2),(p1,p2),(q1,q2),(r1,r2)).
  simpl; intuition; (split; simpl; auto).
Qed.

Lemma sa_distributive_bij : forall A B JA bij,
  @sa_distributive A JA ->
  @sa_distributive B (Join_bij A JA B bij).
Proof.
 repeat intro.
 destruct X0 as [u ?]. unfold Join_bij; simpl.
 destruct bij. simpl.
 destruct (X (bij_g a) (bij_g b) (bij_g x) (bij_g z)) as [a' [b' [[[? ?] [? ?]] ?]]]; auto.
 exists (bij_g u); auto.
 exists (bij_f a'); exists (bij_f b'); split; [split|].
 exists (bij_f x0); hnf; repeat rewrite bij_gf; auto.
 exists (bij_f x1); hnf; repeat rewrite bij_gf; auto.
 hnf; repeat rewrite bij_gf; auto.
Qed.

Lemma Cross_bij : forall A B JA bij,
  @Cross_alg A  JA ->
  @Cross_alg B (Join_bij A JA B bij).
Proof.
  repeat intro. unfold join, Join_bij in *.
  destruct bij. simpl in *.
  destruct (X (bij_g a) (bij_g b) (bij_g c) (bij_g d) (bij_g z)); auto.
  destruct x as [[[s p] q] r].
  exists (bij_f s,bij_f p,bij_f q,bij_f r).
  simpl.
  repeat rewrite bij_gf.
  auto.
Qed.

Lemma constructive_join_sub_smash {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}:
  (forall x:A, {identity x}+{~identity x}) ->
  forall a c : lifted JA,
    constructive_join_sub (proj1_sig a) (proj1_sig c) ->
    @constructive_join_sub (option (lifted JA)) _ (Some a) (Some c).
Proof.
intros.
destruct X0 as [b ?].
destruct (X b).
assert (a=c).
destruct a; destruct c. apply exist_ext.
simpl in j.
eapply join_eq; try apply j. apply join_comm; apply identity_unit; eauto.
subst c.
exists None; constructor.
exists (Some (mk_lifted _ (nonidentity_nonunit n))).
constructor.
destruct a; destruct c; simpl in *.
auto.
Qed.

Lemma sa_distributive_smash : forall A JA {PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A},
  (forall x:A, {identity x}+{~identity x}) ->
  @sa_distributive A JA ->
  sa_distributive (option (lifted JA)).
Proof.
intros. unfold Join_lower, Join_lift; simpl.
intros [[a Ha]|].
2: intros; assert (b=z) by (inv H; auto); subst z; exists None; exists x;
    split; [split|]; auto; [ econstructor  | ]; constructor.
intros [[b Hb]|].
2: intros b [[z Hz]|] ? ?;
 [assert (a=z) by (inv H; auto); subst z; clear H;
   rewrite (proof_irr Hz Ha) in X1; clear Hz; exists b; exists None;
    split; [split|]; auto
 | elimtype False; inv H];
  [ econstructor  | ]; constructor.
intros [[c Hc]|].
2: intros ? ? ?; exists None; exists None; split; [split|]; econstructor; econstructor.
intros [[z Hz]|] H Hj.
2: elimtype False; inv H.
destruct (X0 a b c z) as [a' [b' [[? ?] ?]]].
inv H. apply H3.
inversion Hj.
destruct x.
exists (lifted_obj l). inv H0.  apply H4.
assert (c=z) by (inv H0; auto). replace c with z.
apply constructive_join_sub_refl.
destruct (X a') as [Pa'|Pa']; [exists None | exists (Some (mk_lifted _ (nonidentity_nonunit Pa'))) ].
assert (b'=c) by (eapply join_eq; try apply j; apply identity_unit; eauto).
subst b'.
exists (Some (mk_lifted c Hc)).
split; [split|]; eauto. econstructor; econstructor.
apply constructive_join_sub_smash; auto.
constructor.
destruct (X b') as [Pb'|Pb']; [exists None | exists (Some (mk_lifted _ (nonidentity_nonunit Pb')))].
split; [split|]; eauto.
apply constructive_join_sub_smash; auto.
econstructor; econstructor.
apply join_unit2. econstructor; eauto.
f_equal. apply exist_ext.
symmetry. eapply join_eq. eapply join_comm; apply j.  apply identity_unit; eauto.
split; [split|]; eauto.
apply constructive_join_sub_smash; auto.
apply constructive_join_sub_smash; auto.
constructor; auto.
Qed.

Lemma Cross_smash : forall A (JA: Join A) {PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A},
  (forall x:A, {identity x}+{~identity x}) ->
  Cross_alg A ->
  Cross_alg (option (lifted JA)).
Proof.
  intros.
  hnf; intros.
  destruct a as [[a Na] | ].
Focus 2.
  apply join_unit1_e in H; [ | apply None_identity]. subst z.
  exists (None,None,c,d); repeat split; auto; constructor; auto.
  destruct b as [[b Nb] | ].
Focus 2.
  apply join_unit2_e in H; [ | apply None_identity]. subst z.
  exists (c,d,None,None); repeat split; auto; constructor; auto.
  destruct c as [[c Nc] | ].
Focus 2.
  apply join_unit1_e in H0; [ | apply None_identity]. subst z.
  exists (None, Some (exist nonunit _ Na), None, Some (exist nonunit _ Nb));
     repeat split; auto; constructor.
  destruct d as [[d Nd] | ].
Focus 2.
  apply join_unit2_e in H0; [ | apply None_identity]. subst z.
  exists (Some (exist nonunit _ Na), None,Some (exist nonunit _ Nb),None); repeat split; auto; constructor; auto.

  destruct z as [[z Nz] | ]; [ | elimtype False; inv H].
  destruct (X0 a b c d z) as [[[[ac ad] bc] bd] [? [? [? ?]]]]; try (inv H; inv H0; auto). clear H H0.
  destruct (X ac) as [Nac | Nac ].
  apply Nac in H1. subst ad. apply Nac in H3. subst bc.
  destruct (X bd) as [Nbd | Nbd].
  apply join_unit2_e in H4; auto. subst d.
  apply join_unit2_e in H2; auto. subst c.
  rewrite (proof_irr Nd Na) in *. rewrite (proof_irr Nc Nb) in *.
  exists (None, Some (exist nonunit a Na), Some (exist nonunit b Nb), None);
    repeat split; auto;  constructor.
  exists (None, Some (exist nonunit a Na), Some (exist nonunit c Nc),
      Some (exist nonunit bd (nonidentity_nonunit Nbd))).
  repeat split; auto;  try constructor. apply H2. apply H4.
  destruct (X ad) as [Nad | Nad].
  apply join_unit2_e in H1; auto. subst ac.
  apply join_unit1_e in H4; auto. subst bd.
  destruct (X bc) as [Nbc | Nbc].
  apply join_unit2_e in H3; auto. subst c.
  apply join_unit1_e in H2; auto. subst d.
  rewrite (proof_irr Nd Nb) in *. rewrite (proof_irr Nc Na) in *.
  exists (Some (exist nonunit a Na), None, None, Some (exist nonunit b Nb));
    repeat split; auto; constructor.
  apply nonidentity_nonunit in Nbc.
  exists (Some (exist nonunit a Na), None, Some (exist nonunit _ Nbc), Some (exist nonunit d Nd));
    repeat split; auto; constructor. apply H2. apply H3.
  destruct (X bc) as [Nbc | Nbc].
  apply join_unit2_e in H3; auto. subst ac.
  apply join_unit1_e in H2; auto. subst bd.
  apply nonidentity_nonunit in Nad.
  exists (Some (exist nonunit c Nc), Some (exist nonunit _ Nad), None, Some (exist nonunit b Nb));
    repeat split; auto; try constructor. apply H1. apply H4.
  destruct (X bd) as [Nbd | Nbd].
  apply join_unit2_e in H2; auto. subst bc.
  apply join_unit2_e in H4; auto. subst ad.
  apply nonidentity_nonunit in Nbc.   apply nonidentity_nonunit in Nad.
    apply nonidentity_nonunit in Nac.
  exists (Some (exist nonunit ac Nac), Some (exist nonunit d Nd),
             Some (exist nonunit b Nb), None).
    repeat split; auto; try constructor. apply H1. apply H3.
  apply nonidentity_nonunit in Nbc.   apply nonidentity_nonunit in Nad.
    apply nonidentity_nonunit in Nac. apply nonidentity_nonunit in Nbd.
  exists (Some (exist nonunit ac Nac), Some (exist nonunit ad Nad),
             Some (exist nonunit bc Nbc), Some (exist nonunit bd Nbd)).
  repeat split; constructor; assumption.
Qed.

Lemma cross_split_fpm : forall A B
      (JB: Join B) (PB: Perm_alg B)(SB : Sep_alg B)(CB: Canc_alg B)
  (Bdec: forall x:B, {identity x}+{~identity x}) ,
  Cross_alg B  ->
  Cross_alg (fpm A (lifted JB)) .
Proof.
  intros.
  assert (Cross_alg (A -> option (lifted JB))).
  apply cross_split_fun. apply Cross_smash; auto.

  hnf. intros [a Ha] [b Hb] [c Hc] [d Hd] [z Hz].
  simpl; intros.
  destruct (X0 a b c d z); auto.
  destruct x as [[[s p] q] r].
  decompose [and] y; clear y.
  assert (Hs : finMap s).
  destruct Ha.
  exists x.
  intros.
  spec H1 a0.
  rewrite e in H1; auto. inv H1; auto.
  assert (Hq : finMap q).
  destruct Hb.
  exists x.
  intros.
  spec H3 a0. inv H3; auto. rewrite H9; rewrite e; auto.
  rewrite e in H8; auto. inv H8.
  assert (Hr : finMap r).
  destruct Hb.
  exists x.
  intros.
  spec H3 a0.
  rewrite e in H3; auto. inv H3; auto.
  assert (Hp : finMap p).
  destruct Hd.
  exists x. intros. spec H5 a0. rewrite e in H5; auto. inv H5; auto.
  exists (exist _ s Hs, exist _ p Hp, exist _ q Hq, exist _ r Hr).
  simpl; intuition.
Qed.

Lemma Cross_fpm (A B: Type){JB: Join B} {PB: Perm_alg B}{PosB : Pos_alg B}
  {CrB: Cross_alg B}:   Cross_alg (fpm A B) .
 (* Warning: This lemma is valid, but it's not clear that it's useful *)
Proof.
  intros.
  assert (Cross_alg (A -> option B)).
  apply cross_split_fun.
  unfold Cross_alg.
  destruct a as [a |]. destruct b as [b|]. destruct c as [c|]. destruct d as [d|].
  destruct z as [z|].
  intros.
  hnf in H.
  assert (join a b z) by (clear - H; inv H; auto).
  assert (join c d z) by (clear - H0; inv H0; auto).
  clear H H0.
  destruct (CrB _ _ _ _ _ H1 H2) as [[[[s p] q] r] [? [? [? ?]]]].
  exists (Some s, Some p, Some q, Some r); repeat split; try constructor; auto.
  intros. elimtype False; inv H.
  intros. assert (z = Some c) by (clear - H0; inv H0; auto).
  subst. assert (join a b c) by   (clear - H; inv H; auto).
  exists (Some a, None, Some b, None); repeat split; try constructor; auto.
  intros.
  destruct d as [d|].
  assert (z=Some d) by (clear - H0; inv H0; auto). subst z.
  exists (None, Some a, None, Some b); repeat split; try constructor; auto.
  clear - H; inv H; auto.
  elimtype False; inv H0; inv H.
  destruct c as [c|]. destruct d as [d|].
  intros.
  assert (z = Some a) by (clear - H; inv H; auto). subst z.
  exists (Some c, Some d, None, None); repeat split; try constructor; eauto.
  inv H0; auto.
  intros. assert (z = Some a) by (clear - H; inv H; auto). subst.
  assert (a=c) by (clear - H0; inv H0; auto). subst c.
  exists (Some a, None, None, None); repeat split; try constructor; auto.
  intros.
  assert (z=d) by (clear - H0; inv H0; auto). subst d.
  assert (z = Some a) by (inv H; auto).
  subst.
  exists (None, Some a, None, None); repeat split; try constructor; auto.
  destruct b as [b|]. destruct c as [c|]. destruct d as [d|].
  intros.
  assert (z=Some b) by (inv H; auto). subst.
  exists (None, None, Some c, Some d); repeat split; try constructor; auto.
  inv H0; auto.
  intros.
  assert (z = Some b) by (inv H; auto); subst.
  assert (c=b) by (inv H0; auto); subst.
  exists (None, None, Some b, None); repeat split; try constructor; auto.
  intros.
  assert (z=d) by (clear - H0; inv H0; auto). subst d.
  assert (z=Some b) by (inv H; auto). subst.
  exists (None, None, None, Some b); repeat split; try constructor; auto.
  intros. assert (z=None) by (inv H; auto).
  subst.
  exists (None, None, None, None).
  inv H0; repeat split; constructor.

  intros [a Ha] [b Hb] [c Hc] [d Hd] [z Hz].
  simpl; intros.
  unfold Cross_alg in X.
  destruct (X (fun x => a x) b c d z); auto.
  destruct x as [[[s p] q] r].
  decompose [and] y; clear y.
  assert (Hs : finMap s).
  destruct Ha.
  exists x.
  intros.
  spec H1 a0.
  rewrite e in H1; auto. inv H1; auto.
  assert (Hq : finMap q).
  destruct Hb.
  exists x.
  intros.
  spec H3 a0. inv H3; auto. rewrite H9; rewrite e; auto.
  rewrite e in H8; auto. inv H8.
  assert (Hr : finMap r).
  destruct Hb.
  exists x.
  intros.
  spec H3 a0.
  rewrite e in H3; auto. inv H3; auto.
  assert (Hp : finMap p).
  destruct Hd.
  exists x. intros. spec H5 a0. rewrite e in H5; auto. inv H5; auto.
  exists (exist _ s Hs, exist _ p Hp, exist _ q Hq, exist _ r Hr).
  simpl; intuition.
Qed.

Definition opposite_bij {A B} (b: bijection A B) : bijection B A :=
 Bijection _ _ (bij_g _ _ b) (bij_f _ _ b) (bij_gf _ _ b) (bij_fg _ _ b).

Lemma Cross_bij' : forall A B JA JB bij,
  @Cross_alg B JB ->
   JB =  (Join_bij A JA B bij) ->
  @Cross_alg A  JA.
Proof.
  repeat intro. subst. unfold join, Join_bij in *.
  destruct bij. simpl in *.
  destruct (X (bij_f a) (bij_f b) (bij_f c) (bij_f d) (bij_f z)).
  red. repeat rewrite bij_gf; auto.
  red. repeat rewrite bij_gf; auto.
  destruct x as [[[s p] q] r].
  exists (bij_g s,bij_g p,bij_g q,bij_g r).
  unfold join in y.
  repeat rewrite bij_gf in y.
  auto.
Qed.

Definition option_bij {A B} (D: bijection A B) : bijection (option A) (option B).
 apply
 (Bijection (option A) (option B)
    (fun a => match a with Some a' => Some (bij_f _ _ D a') | None => None end)
    (fun b => match b with Some b' => Some (bij_g _ _ D b') | None => None end)).
 intros. destruct x; simpl; auto. rewrite bij_fg. auto.
 intros. destruct x; simpl; auto. rewrite bij_gf. auto.
Defined.