Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import omega.Omega.
Require Import Setoid.
Require Import ZArith.
Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.
Local Open Scope struct_scope.
Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.
Require Import depoolContract.DePoolFunc.
Require Import depoolContract.DePoolConsts.
Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
Require Import depoolContract.Scenarios.ScenarioCommon.
Import DePoolSpec.LedgerClass.SolidityNotations.
Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.
Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100.
Module Scenario8  (dc : DePoolConstsTypesSig XTypesSig StateMonadSig).
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig dc.
Import dc.
Module ScenarioCommon := ScenarioCommon dc.
Import ScenarioCommon.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Lemma Scenario_StakeLose_ParticipantVestingValidatorOrdinary: forall
                        (minStake validatorAssurance proxyCode validatorWallet   participantRewardFraction : Z)
                        (proxyCode : TvmCell)
                        (now_constructor msg_pubkey_constructor : Z)
                        (NetParams_init : NetParams)
                        (stakeV :Z )
                        (NetParams_addOrdinaryStake :  NetParams)
                        (now_addOrdinaryStake msg_value_addOrdinaryStake msg_sender_addOrdinaryStake : Z)
                        (stake beneficiary withdrawalPeriod totalPeriod : Z )
                        (now_addVestingOrLock msg_value_addVestingOrLock msg_sender_addVestingOrLock : Z)
                        (now_round1  msg_value_round1 msg_sender_round1 : Z)
                        (NetParams_round1 :  NetParams)
                        (queryId0 validatorKey stakeAt maxFactor adnlAddr : Z)
                        ( signature : XList XInteger8 )
                        (now_participateInElections  msg_value_participateInElections msg_sender_participateInElections : Z)
                        (NetParams_participateInElections :  NetParams)
                        (queryId comment elector : Z)
                        (now_onStakeAccept  msg_value_onStakeAccept msg_sender_onStakeAccept : Z)
                        (NetParams_onStakeAccept :  NetParams)
                        (stake beneficiary withdrawalPeriod totalPeriod : Z )
                        (NetParams_addVestingOrLock :  NetParams)
                        (now_addVestingOrLock msg_value_addVestingOrLock msg_sender_addVestingOrLock : Z)
                        (now_toWaitingIfValidatorWinElections  msg_value_toWaitingIfValidatorWinElections msg_sender_toWaitingIfValidatorWinElections : Z)
                        (NetParams_toWaitingIfValidatorWinElections :  NetParams)
                        (now_onSuccessToRecoverStake  msg_value_onSuccessToRecoverStake msg_sender_onSuccessToRecoverStake : Z)
                        (NetParams_onSuccessToRecoverStake :  NetParams)
                        (now_toWaitingReward  msg_value_toWaitingReward msg_sender_toWaitingReward : Z)
                        (NetParams_toWaitingReward :  NetParams),
let l_init_NetParams := withNetParams default NetParams_init in
let l_init := {$ l_init_NetParams With (VMState_ι_now,   now_constructor);
                                       (VMState_ι_msg_pubkey,   msg_pubkey_constructor)$} in
let l_constructor:= exec_state (DePoolContract_Ф_Constructor6 minStake validatorAssurance proxyCode validatorWallet   participantRewardFraction  ) l_init in
let (r, l_fin) := run  (modify (fun l => withNetParams l NetParams_addOrdinaryStake) >>
                        modify (fun l => {$ l With (VMState_ι_now,   now_addOrdinaryStake);
                                                   (VMState_ι_msg_value , msg_value_addOrdinaryStake);
                                                   (VMState_ι_msg_sender , msg_sender_addOrdinaryStake) $}) >>
                        do _ ← DePoolContract_Ф_addOrdinaryStake'' stakeV ??;
                        modify (fun l => withNetParams l NetParams_addVestingOrLock) >>
                        modify (fun l => {$ l With (VMState_ι_now,   now_addVestingOrLock);
                                                   (VMState_ι_msg_value , msg_value_addVestingOrLock);
                                                   (VMState_ι_msg_sender , msg_sender_addVestingOrLock) $}) >>
                        do _ ← DePoolContract_Ф_addVestingOrLock'' stakeV beneficiary withdrawalPeriod totalPeriod true ??;
                        modify (fun l => {$ l With (VMState_ι_now,   now_addVestingOrLock);
                                                   (VMState_ι_msg_value , msg_value_addVestingOrLock);
                                                   (VMState_ι_msg_sender , msg_sender_addVestingOrLock) $}) >>
                        do _ ← DePoolContract_Ф_addVestingOrLock'' stake beneficiary withdrawalPeriod totalPeriod true ??;
                        modify (fun l => withNetParams l NetParams_round1) >>
                        modify (fun l => {$ l With (VMState_ι_now,          now_round1);
                                                   (VMState_ι_msg_value ,   msg_value_round1);
                                                   (VMState_ι_msg_sender ,  msg_sender_round1) $}) >>
                        do _ ← DePoolContract_Ф_ticktock ??;
                        modify (fun l => withNetParams l NetParams_participateInElections) >>
                        modify (fun l => {$ l With (VMState_ι_now,          now_participateInElections);
                                                   (VMState_ι_msg_value ,   msg_value_participateInElections);
                                                   (VMState_ι_msg_sender ,  msg_sender_participateInElections) $}) >>
                        do _ ← DePoolContract_Ф_participateInElections'' queryId0 validatorKey stakeAt maxFactor adnlAddr signature ??;
                        modify (fun l => withNetParams l NetParams_onStakeAccept) >>
                        modify (fun l => {$ l With (VMState_ι_now,          now_onStakeAccept);
                                                   (VMState_ι_msg_value ,   msg_value_onStakeAccept);
                                                   (VMState_ι_msg_sender ,  msg_sender_onStakeAccept) $}) >>
                        do _ ← DePoolContract_Ф_onStakeAccept queryId comment elector ??;
                        modify (fun l => withNetParams l NetParams_toWaitingIfValidatorWinElections) >>
                        modify (fun l => {$ l With (VMState_ι_now,          now_toWaitingIfValidatorWinElections);
                                                   (VMState_ι_msg_value ,   msg_value_toWaitingIfValidatorWinElections);
                                                   (VMState_ι_msg_sender ,  msg_sender_toWaitingIfValidatorWinElections) $}) >>
                        do _ ← DePoolContract_Ф_ticktock ??;
                        modify (fun l => withNetParams l NetParams_onSuccessToRecoverStake) >>
                        modify (fun l => {$ l With (VMState_ι_now,          now_onSuccessToRecoverStake);
                                                   (VMState_ι_msg_value ,   msg_value_onSuccessToRecoverStake);
                                                   (VMState_ι_msg_sender ,  msg_sender_onSuccessToRecoverStake) $}) >>
                        do _ ← DePoolContract_Ф_onSuccessToRecoverStake queryId elector ??;
                        modify (fun l => withNetParams l NetParams_toWaitingReward) >>
                        modify (fun l => {$ l With (VMState_ι_now,          now_toWaitingReward);
                                                   (VMState_ι_msg_value ,   msg_value_toWaitingReward);
                                                   (VMState_ι_msg_sender ,  msg_sender_toWaitingReward) $}) >>
                        do _ ← DePoolContract_Ф_ticktock ?;
                        $ I )  l_constructor in errorValueIsValue r = true ->
msg_sender_addOrdinaryStake = validatorWallet ->
msg_sender_addVestingOrLock <> validatorWallet ->
beneficiary <> validatorWallet ->
(now_round1 >=? NetParams_round1 ->> NetParams_ι_utime_until - NetParams_round1 ->> NetParams_ι_electionsStartBefore) = true ->
((negb (tvm_hash (NetParams_init ->> NetParams_ι_curValidatorData) =? tvm_hash (NetParams_round1 ->> NetParams_ι_curValidatorData))) &&
(negb (tvm_hash (NetParams_init ->> NetParams_ι_prevValidatorData) =? tvm_hash (NetParams_round1 ->> NetParams_ι_curValidatorData))))%bool= true ->
(stakeV >=? validatorAssurance) = true ->
( tvm_hash  (NetParams_round1 ->> NetParams_ι_curValidatorData)  =?  tvm_hash  (NetParams_toWaitingIfValidatorWinElections ->> NetParams_ι_prevValidatorData))  = true ->
(now_toWaitingIfValidatorWinElections >=? NetParams_toWaitingIfValidatorWinElections ->> NetParams_ι_utime_until - NetParams_toWaitingIfValidatorWinElections ->> NetParams_ι_electionsStartBefore) = true ->
(negb (0 =? tvm_hash ((NetParams_toWaitingIfValidatorWinElections ->> NetParams_ι_curValidatorData)))) = true ->
((negb (tvm_hash ((NetParams_toWaitingReward ->> NetParams_ι_curValidatorData)) =? tvm_hash ((NetParams_round1 ->> NetParams_ι_curValidatorData)))) &&
(negb (tvm_hash ((NetParams_toWaitingReward ->> NetParams_ι_prevValidatorData)) =? tvm_hash ((NetParams_round1 ->> NetParams_ι_curValidatorData)))))%bool= true ->
(now_toWaitingReward >=? NetParams_toWaitingReward ->> NetParams_ι_utime_since + NetParams_round1 ->> NetParams_ι_stakeHeldFor + DePoolLib_ι_ELECTOR_UNFREEZE_LAG) = true ->
(msg_value_onSuccessToRecoverStake + DePoolLib_ι_PROXY_FEE >=? stake/2 + stakeV) = true ->
let reward := 0  in
let rewardV := 0  in
let optRound := eval_state ( ↓ ( RoundsBase_Ф_fetchRound queryId ) ) l_fin in
let round := maybeGet optRound in
let stakes :=  round ->> RoundsBase_ι_Round_ι_stakes in
let optStake := stakes ->fetch beneficiary in
let optStakeV := stakes ->fetch validatorWallet in
let current_stakes := maybeGet optStake in
let current_stakesV := maybeGet optStakeV in
now_onSuccessToRecoverStake > now_addVestingOrLock ->
let periodQty := (now_onSuccessToRecoverStake - now_addVestingOrLock) / withdrawalPeriod in
let p := (maybeGet (current_stakes ->> RoundsBase_ι_StakeValue_ι_vesting)) in
let withdrawalValue := stake/2 * withdrawalPeriod / totalPeriod in
let withdrawalTons := intMin  (periodQty * withdrawalValue)  (stake/2)  in
let remainingAmount := stake/2 - withdrawalTons in
remainingAmount < minStake ->
(round ->> RoundsBase_ι_Round_ι_stake = stake/2 + stakeV)
/\ (p ->> RoundsBase_ι_InvestParams_ι_remainingAmount  = remainingAmount)
/\ (current_stakesV ->> RoundsBase_ι_StakeValue_ι_ordinary  = withdrawalTons + reward)
/\ (current_stakesV ->> RoundsBase_ι_StakeValue_ι_ordinary  = stakeV + rewardV).
Proof.

Abort.

End Scenario8.


From hahn Require Import Hahn.
Require Import Events.
Require Import Execution.
Require Import AuxRel2.

Set Implicit Arguments.

Section CO.

Variables G : execution.
Variable I : actid -> Prop.  (* issued *)
Variable T : actid -> Prop.  (* all writes in certified thread *)

Notation "'E'" := (acts_set G).
Notation "'lab'" := (lab G).
Notation "'sb'" := (sb G).
Notation "'rf'" := (rf G).
Notation "'co'" := (co G).
Notation "'W'" := (fun a => is_true (is_w lab a)).
Notation "'loc'" := (loc lab).
Notation "'same_loc'" := (same_loc lab).
Notation "'Loc_' l" := (fun x => loc x = Some l) (at level 1).
Notation "'W_' l" := (W ∩₁ Loc_ l) (at level 1).

Hypothesis IT: I ∪₁ T ≡₁ E ∩₁ W.

Lemma IN_I: I ⊆₁ E ∩₁ W.
Proof using IT.
rewrite <- IT; basic_solver 21.
Qed.

Lemma IN_T: T ⊆₁ E ∩₁ W.
Proof using IT.
rewrite <- IT; basic_solver 21.
Qed.

Hypothesis wf_coE : co ≡ ⦗E⦘ ⨾ co ⨾ ⦗E⦘.
Hypothesis wf_coD : co ≡ ⦗W⦘ ⨾ co ⨾ ⦗W⦘.
Hypothesis wf_col : co ⊆ same_loc.
Hypothesis co_trans : transitive co.
Hypothesis wf_co_total : forall ol, is_total (E ∩₁ W ∩₁ (fun x => loc x = ol)) co.
Hypothesis co_irr : irreflexive co.

Definition col l := (⦗Loc_ l⦘ ⨾ co ⨾ ⦗Loc_ l⦘).

Definition col0 l := (⦗I⦘ ⨾ col l ⨾ ⦗I⦘ ∪ ⦗T⦘ ⨾ col l ⨾ ⦗T⦘ ∪ ⦗I⦘ ⨾ col l ⨾ ⦗T⦘)⁺.

Definition new_col l := pref_union (col0 l) ((I ∩₁ Loc_ l) × (E ∩₁ W ∩₁ Loc_ l \₁ I)).

Definition new_co x y := exists l, (new_col l) x y.

Lemma col_in_co l : col l ⊆ co.
Proof using.
unfold col; basic_solver.
Qed.

Lemma co_in_col x y : co x y -> exists l, col l x y.
Proof using wf_coD wf_col.
unfold new_co, col; ins; unfolder; ins; desf.
hahn_rewrite (dom_l wf_coD) in H; unfolder in H; desc.
generalize (is_w_loc lab x H); ins; desf.
eexists; splits; eauto.
eexists; splits; eauto.
eexists; splits; eauto.
apply wf_col in H0; unfold Events.same_loc in H0; congruence.
Qed.

Lemma wf_colE l : col l ≡ ⦗E⦘ ⨾ col l ⨾ ⦗E⦘.
Proof using wf_coE.
apply dom_helper_3; unfold col; rewrite wf_coE; basic_solver.
Qed.

Lemma wf_colD l : col l ≡ ⦗W_ l⦘ ⨾ col l ⨾ ⦗W_ l⦘.
Proof using wf_coD.
apply dom_helper_3; unfold col; rewrite wf_coD; basic_solver.
Qed.

Lemma wf_coll l : col l ⊆ same_loc.
Proof using wf_col.
unfold col; rewrite wf_col; basic_solver.
Qed.

Lemma col_trans l : transitive (col l).
Proof using co_trans.
unfold col.
rewrite <- restr_relE.
by apply transitive_restr.
Qed.

Lemma wf_col_total l : is_total (E ∩₁ W ∩₁ Loc_ l) (col l).
Proof using wf_coD wf_coE wf_co_total.
rewrite wf_colD, wf_colE.
unfold col; rewrite !seqA.
arewrite (⦗W_ l⦘ ⨾ ⦗E⦘ ⨾ ⦗Loc_ l⦘ ≡ ⦗E ∩₁ W ∩₁ Loc_ l⦘) by basic_solver.
arewrite (⦗Loc_ l⦘ ⨾ ⦗E⦘ ⨾ ⦗W_ l⦘ ≡ ⦗E ∩₁ W ∩₁ Loc_ l⦘) by basic_solver.
rewrite <- restr_relE.
apply is_total_restr.
apply wf_co_total.
Qed.

Lemma col_irr l: irreflexive (col l).
Proof using co_irr.
unfold col.
rewrite <- restr_relE.
by apply irreflexive_restr.
Qed.

Lemma acyclic_new_col l : acyclic (new_col l).
Proof using IT co_irr co_trans wf_coD wf_coE wf_co_total.
eapply acyclic_pref_union with (dom:=I ∩₁ Loc_ l).
- unfold col0.
  arewrite_id ⦗I⦘.
  arewrite_id ⦗T⦘.
  relsf.
  generalize (@col_trans l); ins; relsf; apply col_irr.
- unfold col0; relsf.
- assert (XX: restr_rel (I ∩₁ Loc_ l) (col l) ⊆ col0 l).
  by unfold col0; rewrite <- ct_step; basic_solver 21.
  rewrite <- XX.
  apply is_total_restr.
  rewrite IN_I.
  eapply wf_col_total.
- unfolder; ins; desf; splits; eauto; intro; desf.
Qed.

Lemma wf_new_colE l : new_col l ≡ ⦗E⦘ ⨾ new_col l ⨾ ⦗E⦘.
Proof using IT wf_coE.
apply dom_helper_3.
unfold new_col, pref_union, col0; unfolder; ins; desf.
2: by generalize (IN_I H); basic_solver 12.
induction H; [|basic_solver].
desf; apply (wf_colE l) in H0; unfolder in H0; desf; eauto.
Qed.

Lemma wf_new_colD l : new_col l ≡ ⦗W_ l⦘ ⨾ new_col l ⨾ ⦗W_ l⦘.
Proof using IT wf_coD.
apply dom_helper_3.
unfold new_col, pref_union, col0; unfolder; ins; desf.
2: by generalize (IN_I H); basic_solver 12.
induction H; [|basic_solver].
desf; apply (wf_colD l) in H0; unfolder in H0; desf; eauto.
Qed.

Lemma wf_new_coll l : new_col l ⊆ same_loc.
Proof using IT wf_coD.
rewrite wf_new_colD; unfold Events.same_loc.
unfolder; ins; desf; congruence.
Qed.

Lemma wf_new_col_total l : is_total (E ∩₁ W ∩₁ Loc_ l) (new_col l).
Proof using IT wf_coD wf_coE wf_co_total.
unfold new_col, pref_union.
unfolder; ins; desf.
destruct (classic (col0 l a b)) as [|X]; eauto 8.
destruct (classic (col0 l b a)) as [|Y]; eauto 8.
assert (XX: ~ (⦗I⦘ ⨾ col l ⨾ ⦗I⦘ ∪ ⦗T⦘ ⨾ col l ⨾ ⦗T⦘ ∪ ⦗I⦘ ⨾ col l ⨾ ⦗T⦘) a b).
by intro; eapply X; vauto.
assert (YY: ~ (⦗I⦘ ⨾ col l ⨾ ⦗I⦘ ∪ ⦗T⦘ ⨾ col l ⨾ ⦗T⦘ ∪ ⦗I⦘ ⨾ col l ⨾ ⦗T⦘) b a).
by intro; eapply Y; vauto.

assert (Ta: ~ I a -> T a).
by assert (S: (E ∩₁ W) a) by basic_solver; apply IT in S; unfolder in S; ins; desf.
assert (Tb: ~ I b -> T b).
by assert (S: (E ∩₁ W) b) by basic_solver; apply IT in S; unfolder in S; ins; desf.

assert (TOT: col l a b \/ col l b a).
by apply wf_col_total; basic_solver.
destruct (classic (I a)), (classic (I b)); desf.
- exfalso; unfolder in XX; basic_solver 22.
- exfalso; unfolder in YY; basic_solver 22.
- exfalso; unfolder in XX; basic_solver 22.
- eauto 20.
- eauto 20.
- exfalso; unfolder in YY; basic_solver 22.
- exfalso; unfolder in XX; basic_solver 22.
- exfalso; unfolder in YY; basic_solver 22.
Qed.

Lemma new_col_trans l : transitive (new_col l).
Proof using IT co_irr co_trans wf_coD wf_coE wf_co_total.
apply transitiveI; unfolder; ins; desf.
eapply tot_ex.
- apply wf_new_col_total.
- hahn_rewrite wf_new_colE in H0.
hahn_rewrite wf_new_colD in H0.
unfolder in H0; basic_solver 21.
- hahn_rewrite wf_new_colE in H.
hahn_rewrite wf_new_colD in H.
unfolder in H; basic_solver 21.
- intro.
eapply acyclic_new_col.
eapply t_trans, t_trans; vauto.
- intro.
eapply acyclic_new_col.
eapply t_trans; vauto.
Qed.

Lemma new_col_irr l : irreflexive (new_col l).
Proof using IT co_irr co_trans wf_coD wf_coE wf_co_total.
red; ins; eapply acyclic_new_col; vauto.
Qed.

Lemma wf_new_coE : new_co ≡ ⦗E⦘ ⨾ new_co ⨾ ⦗E⦘.
Proof using IT wf_coE.
unfold new_co; unfolder; ins; desf; splits; ins; desf; eauto.
apply (wf_new_colE l) in H; unfolder in H; desf; eauto.
Qed.

Lemma wf_new_coD : new_co ≡ ⦗W⦘ ⨾ new_co ⨾ ⦗W⦘.
Proof using IT wf_coD.
unfold new_co; unfolder; ins; desf; splits; ins; desf; eauto.
apply (wf_new_colD l) in H; unfolder in H; desf; eauto.
Qed.

Lemma wf_new_col : new_co ⊆ same_loc.
Proof using IT wf_coD.
unfold new_co; unfolder; ins; desf; splits; ins; desf; eauto.
apply (@wf_new_coll l) in H; unfolder in H; desf; eauto.
Qed.

Lemma new_co_trans : transitive new_co.
Proof using IT co_irr co_trans wf_coD wf_coE wf_co_total.
unfold new_co; unfolder; ins; desf; splits; ins; desf; eauto.
hahn_rewrite wf_new_colD in H0.
hahn_rewrite wf_new_colD in H.
unfolder in H0; unfolder in H; desf.
exists l; eapply new_col_trans; eauto.
Qed.

Lemma wf_new_co_total : forall ol, is_total (E ∩₁ W ∩₁ (fun x => loc x = ol)) new_co.
Proof using IT wf_coD wf_coE wf_co_total.
unfold new_co; ins; unfolder; ins; desf.
generalize (is_w_loc lab a IWa1); ins; desf.
cut (new_col l a b \/ new_col l b a); [by basic_solver 21|].
apply wf_new_col_total; auto.
basic_solver.
unfolder; splits; ins; desf; congruence.
Qed.

Lemma new_co_irr : irreflexive new_co.
Proof using IT co_irr co_trans wf_coD wf_coE wf_co_total.
unfold new_co; ins; unfolder; ins; desf.
eapply new_col_irr; eauto.
Qed.

Lemma new_co_I : new_co ⨾ ⦗ I ⦘  ⊆ co ⨾ ⦗ I ⦘.
Proof using IT co_irr co_trans wf_coD wf_coE wf_co_total.
unfolder; intros x y [R K]; desf.
unfold new_co in R; desc.
hahn_rewrite wf_new_colE in R.
hahn_rewrite wf_new_colD in R.
unfolder in R; desf; splits; auto.
eapply tot_ex.
- apply wf_co_total.
- basic_solver.
- unfolder; splits; eauto; congruence.
- intro.
assert (S: (E ∩₁ W) z) by basic_solver.
apply IT in S; unfolder in S; ins; desf.
* eapply new_col_irr, new_col_trans; try edone.
red; red; unfold col0, col; left; apply t_step; basic_solver 12.
* eapply new_col_irr, new_col_trans; try edone.
red; red; unfold col0, col; left; apply t_step; basic_solver 12.
- intro; subst.
eby eapply new_col_irr.
Qed.

Lemma T_new_co : ⦗ T ⦘ ⨾ new_co  ⊆ ⦗ T ⦘ ⨾ co.
Proof using IT co_irr co_trans wf_coD wf_coE wf_co_total.
unfolder; intros x y [K1 R]; desf.
unfold new_co in R; desc.
hahn_rewrite wf_new_colE in R.
hahn_rewrite wf_new_colD in R.
unfolder in R; desf; splits; auto.
eapply tot_ex.
- apply wf_co_total.
- basic_solver.
- unfolder; splits; eauto; congruence.
- intro.
assert (S: (E ∩₁ W) z) by basic_solver.
apply IT in S; unfolder in S; ins; desf.
* eapply new_col_irr, new_col_trans; try edone.

red; red; unfold col0, col. left; apply t_step.
assert (I y \/ T y) by (apply IT; basic_solver).
desf; basic_solver 12.
* eapply new_col_irr, new_col_trans; try edone.
red; red; unfold col0, col; left; apply t_step.
assert (I y \/ T y) by (apply IT; basic_solver).
desf; basic_solver 12.
- intro; subst.
eby eapply new_col_irr.
Qed.

Lemma new_co_in : new_co  ⊆ co ⨾ ⦗ I ⦘ ∪
⦗ T ⦘ ⨾ co ∪ ⦗ I \₁ T ⦘ ⨾ new_co ⨾ ⦗ T \₁ I ⦘.
Proof using IT co_irr co_trans wf_coD wf_coE wf_co_total.
rewrite (wf_new_coD), (wf_new_coE) at 1.
rewrite !seqA.
arewrite (⦗W⦘ ⨾ ⦗E⦘ ⊆ ⦗E ∩₁ W⦘) by basic_solver.
arewrite (⦗E⦘ ⨾ ⦗W⦘ ⊆ ⦗E ∩₁ W⦘) by basic_solver.
rewrite <- IT.

arewrite (I ∪₁ T ⊆₁ (I \₁ T) ∪₁ T) at 1.
unfolder; ins; desf; tauto.

arewrite (I ∪₁ T ⊆₁ (T \₁ I) ∪₁ I) at 1.
unfolder; ins; desf; tauto.

rewrite !id_union; relsf.

sin_rewrite !T_new_co.
sin_rewrite new_co_I.
basic_solver 21.
Qed.

Lemma T_I_col0_I_T l :
  ⦗ T \₁ I ⦘ ⨾ col0 l ⨾ ⦗ I \₁ T ⦘  ⊆
  ⦗ T \₁ I ⦘ ⨾ col l ⨾ ⦗ I ∩₁ T ⦘ ⨾ col l ⨾ ⦗ I \₁ T ⦘.
Proof using co_trans.
unfold col0 at 1.
arewrite (⦗T⦘ ⊆ ⦗T \₁ I⦘ ∪ ⦗I ∩₁ T⦘) at 2.
unfolder; ins ;desf; tauto.
relsf.
rewrite <- !unionA.
rewrite unionC.
rewrite <- !unionA.
rewrite path_ut_first; relsf; unionL.
- transitivity (∅₂ : actid -> actid -> Prop); [|basic_solver].
  rewrite path_ut_last; relsf; unionL.
  rewrite ct_begin; basic_solver.
  rewrite (rtE (⦗I⦘ ⨾ col l ⨾ ⦗T⦘ ∪ ⦗I⦘ ⨾ col l ⨾ ⦗I⦘)).
  relsf; unionL.
  basic_solver.
  rewrite ct_begin; basic_solver.
- arewrite (⦗I⦘ ⨾ col l ⨾ ⦗T⦘ ∪ ⦗I⦘ ⨾ col l ⨾ ⦗I⦘ ∪ ⦗T⦘ ⨾ col l ⨾ ⦗T \₁ I⦘ ⊆ col l).
  basic_solver.
  arewrite (col l ∪ ⦗T⦘ ⨾ col l ⨾ ⦗I ∩₁ T⦘ ⊆ col l).
  basic_solver.
  generalize (@col_trans l); ins; relsf.
  basic_solver 21.
Qed.

Lemma T_I_new_col_I_T l :
  ⦗ T \₁ I ⦘ ⨾ new_col l ⨾ ⦗ I \₁ T ⦘  ⊆
  col l ⨾ ⦗ I ∩₁ T ⦘ ⨾ col l.
Proof using co_trans.
unfold new_col, pref_union.
unfolder; ins; desf.
assert (A: (⦗ T \₁ I ⦘ ⨾ col0 l ⨾ ⦗ I \₁ T ⦘) x y) by basic_solver.
apply T_I_col0_I_T in A; unfolder in A; basic_solver 10.
Qed.

Lemma T_I_new_co_I_T :
  ⦗ T \₁ I ⦘ ⨾ new_co ⨾ ⦗ I \₁ T ⦘  ⊆
  co ⨾ ⦗ I ∩₁ T ⦘ ⨾ co.
Proof using co_trans.
unfold new_co.
unfolder; ins; desf.
assert (A: (⦗ T \₁ I ⦘ ⨾ new_col l ⨾ ⦗ I \₁ T ⦘) x y) by basic_solver.
apply T_I_new_col_I_T in A; unfolder in A; desf.
unfold col in *; unfolder in *; desf; eauto 10.
Qed.

Lemma co_for_split: codom_rel (⦗set_compl I⦘ ⨾ (immediate new_co)) ⊆₁ T.
Proof using IT wf_coD wf_coE.
unfolder; ins; desf.
destruct (classic (T x)) as [|X]; auto.
exfalso.
hahn_rewrite wf_new_coE in H0.
hahn_rewrite wf_new_coD in H0.
unfolder in H0; desf.
assert (Ix: I x).
by assert (S: (E ∩₁ W) x) by basic_solver; apply IT in S; unfolder in S; ins; desf.
unfold new_co, new_col, pref_union in *; desc.
destruct H4 as [K|]; cycle 1.
by unfolder in H2; basic_solver 21.
unfold col0 in *.
destruct K.
unfolder in H2; basic_solver 21.
eauto 12.
Qed.

Lemma new_col_helper l : ⦗ T ⦘ ⨾ col l ⨾ ⦗ I ∩₁ T ⦘ ⨾ col l ⨾ ⦗ I ⦘ ⊆ new_col l.
Proof using.
unfold new_col, pref_union, col0.
unfolder; ins; left; desf.
eapply t_trans; apply t_step; eauto 15.
Qed.

Lemma new_co_helper : ⦗ T ⦘ ⨾ co ⨾ ⦗ I ∩₁ T ⦘ ⨾ co ⨾ ⦗ I ⦘ ⊆ new_co.
Proof using wf_coD wf_col.
unfold new_co.
unfolder; ins; desf.
apply co_in_col in H0.
apply co_in_col in H2.
desf.
assert (l = l0); subst.
{ hahn_rewrite wf_colD in H0.
  hahn_rewrite wf_colD in H2.
  unfolder in *; desf. }
exists l0.
apply new_col_helper.
basic_solver 12.
Qed.

Lemma I_co_in_new_co : ⦗ I ⦘ ⨾ co ⊆ new_co.
Proof using IT wf_coD wf_coE wf_col.
unfold new_co.
unfolder; ins; desf.
apply co_in_col in H0.
desf.
exists l.
unfold new_col, pref_union, col0.
left.
apply t_step.
destruct (classic (I y)).
basic_solver 11.
right; unfolder; splits; eauto.
hahn_rewrite (wf_colE) in H0.
hahn_rewrite (wf_colD) in H0.
unfolder in H0; desf.
assert ((I ∪₁ T) y).
eapply IT; basic_solver.
unfolder in *; desf.
Qed.

End CO.

Global Add Parametric Morphism : col0 with signature
    eq ==> (@set_subset actid) ==> (@set_subset actid) ==> eq ==>
       (@inclusion actid) as col0_mori.
Proof using.
  ins. unfold col0. rewrite H, H0. basic_solver.
Qed.

Global Add Parametric Morphism : col0 with signature
    eq ==> (@set_equiv actid) ==> (@set_equiv actid) ==> eq ==>
       (@same_relation actid) as col0_more.
Proof using.
  ins. destruct H, H0.
  split; apply col0_mori; basic_solver.
Qed.

Global Add Parametric Morphism : new_co with signature
    eq ==> (@set_equiv actid) ==> (@set_equiv actid) ==>
       (@inclusion actid) as new_co_more_impl.
Proof using.
  ins. unfold new_co, new_col.
  unfolder. ins. desc. red in H1.
  destruct H, H0.
  exists l. des.
  { left. eapply col0_mori; eauto. }
  apply pref_union_alt.
  right. split.
  { splits; vauto.
    { by apply H. }
    intro. apply H6. basic_solver. }
  intro. apply H4. eapply col0_mori; eauto.
Qed.

Global Add Parametric Morphism : new_co with signature
    eq ==> (@set_equiv actid) ==> (@set_equiv actid) ==>
       (@same_relation actid) as new_co_more.
Proof using.
  ins. split; [| symmetry in H, H0]; eapply new_co_more_impl; eauto.
Qed.


Require Import Coq.Strings.String.
Require Import Mem.
Require Import Prog.
Require Import List.
Require Import Word.
Require Import Rec.
Require Import BFile.
Require Import BasicProg.
Require Import Log.
Require Import Hoare.
Require Import Pred PredCrash.
Require Import Omega.
Require Import Rec.
Require Import Array.
Require Import ListPred.
Require Import GenSepN.
Require Import BFile.
Require Import FileRecArray.
Require Import Bool.
Require Import SepAuto.
Require Import Log.
Require Import Cache.
Require Import ListUtils.
Require Import AsyncDisk.
Require Import Errno.
Require Import DestructVarname.
Import ListNotations.
Require HexString.

Set Implicit Arguments.

Module DIR.

  Definition filename_len := (HexString.to_nat "0x400" (* 1024 *) - addrlen - addrlen).
  Definition filename := word filename_len.

  Module DentSig <: FileRASig.

    Definition itemtype : Rec.type := Rec.RecF
        ([("name",  Rec.WordF filename_len);
          ("inum",  Rec.WordF addrlen);
          ("valid", Rec.WordF 1);
          ("isdir", Rec.WordF 1);
          ("unused", Rec.WordF (addrlen - 2))
         ]).

    Definition items_per_val := valulen / (Rec.len itemtype).

    Theorem blocksz_ok : valulen = Rec.len (Rec.ArrayF itemtype items_per_val).
    Proof.
      unfold items_per_val; simpl.
      rewrite valulen_is. apply Nat.eqb_eq.
      compute; reflexivity.
    Qed.

  End DentSig.

  Module Dent := FileRecArray DentSig.

  (*************  dirent accessors  *)

  Definition dent := Dent.Defs.item.
  Definition dent0 := Dent.Defs.item0.

  Fact resolve_selN_dent0 : forall l i d,
    d = dent0 -> selN l i d = selN l i dent0.
  Proof.
    intros; subst; auto.
  Qed.

  Hint Rewrite resolve_selN_dent0 using reflexivity : defaults.

  Definition bit2bool bit := if (bit_dec bit) then false else true.
  Definition bool2bit bool : word 1 := if (bool_dec bool true) then $1 else $0.

  Definition DEIsDir (de : dent) := Eval compute_rec in de :-> "isdir".
  Definition DEValid (de : dent) := Eval compute_rec in de :-> "valid".
  Definition DEName  (de : dent) := Eval compute_rec in de :-> "name".
  Definition DEInum  (de : dent) := Eval compute_rec in # (de :-> "inum").
  Definition mk_dent (name : filename) inum isdir : dent := Eval cbn in
      dent0 :=> "valid" := $1 :=>
                "name" := name :=>
                "inum" := $ inum :=>
                "isdir" := bool2bit isdir.

  Definition is_dir   (de : dent) := bit2bool (DEIsDir de).
  Definition is_valid (de : dent) := bit2bool (DEValid de).
  Definition name_is  (n : filename) (de : dent) :=
      if (weq n (DEName de)) then true else false.

  (*************  rep invariant  *)

  Definition dmatch (de: dent) : @pred filename (@weq filename_len) (addr * bool) :=
    if bool_dec (is_valid de) false then emp
    else (DEName de) |-> (DEInum de, is_dir de) * [[ DEInum de <> 0 ]].

  Definition rep f dmap :=
    exists delist,
    (Dent.rep f delist)%pred (list2nmem (BFILE.BFData f)) /\
    listpred dmatch delist dmap.

  Definition rep_macro Fm Fi m bxp ixp inum dmap ilist frees f ms sm : (@pred _ addr_eq_dec valuset) :=
    (exists flist,
    [[[ m ::: Fm * BFILE.rep bxp sm ixp flist ilist frees (BFILE.MSAllocC ms) (BFILE.MSCache ms) (BFILE.MSICache ms) (BFILE.MSDBlocks ms) ]]] *
    [[[ flist ::: Fi * inum |-> f ]]] *
    [[ rep f dmap ]])%pred.

  (*************  program  *)

  Definition lookup_f name de (_ : addr) := (is_valid de) && (name_is name de).

  Definition ifind_lookup_f lxp ixp dnum name ms :=
    Dent.ifind lxp ixp dnum (lookup_f name) ms.

  Definition ifind_invalid lxp ixp dnum ms :=
    Dent.ifind lxp ixp dnum (fun de _ => negb (is_valid de)) ms.

  Definition lookup lxp ixp dnum name ms :=
    let^ (ms, r) <- ifind_lookup_f lxp ixp dnum name ms;
    match r with
    | None => Ret ^(ms, None)
    | Some (_, de) => Ret ^(ms, Some (DEInum de, is_dir de))
    end.

  Definition readent := (filename * (addr * bool))%type.

  Definition readdir lxp ixp dnum ms :=
    let^ (ms, dents) <- Dent.readall lxp ixp dnum ms;
    let r := map (fun de => (DEName de, (DEInum de, is_dir de))) (filter is_valid dents) in
    Ret ^(ms, r).

  Definition unlink lxp ixp dnum name ms :=
    let^ (ms, r) <- ifind_lookup_f lxp ixp dnum name ms;
    match r with
    | None => Ret ^(ms, 0, Err ENOENT)
    | Some (ix, _) =>
        ms <- Dent.put lxp ixp dnum ix dent0 ms;
        Ret ^(ms, ix, OK tt)
    end.

  Definition link' lxp bxp ixp dnum name inum isdir ms :=
    let de := mk_dent name inum isdir in
    let^ (ms, r) <- ifind_invalid lxp ixp dnum ms;
    match r with
    | Some (ix, _) =>
        ms <- Dent.put lxp ixp dnum ix de ms;
        Ret ^(ms, ix+1, OK tt)
    | None =>
        let^ (ms, ok) <- Dent.extend lxp bxp ixp dnum de ms;
        Ret ^(ms, 0, ok)
    end.

  (* link without hint *)
  Definition link'' lxp bxp ixp dnum name inum isdir (ix0:addr) ms :=
    let^ (ms, ix, r0) <- link' lxp bxp ixp dnum name inum isdir ms;
    Ret ^(ms, ix, r0).

  (* link with hint *)
  Definition link lxp bxp ixp dnum name inum isdir ix0 ms :=
    let de := mk_dent name inum isdir in
    let^ (ms, len) <- BFILE.getlen lxp ixp dnum ms;
    If (lt_dec ix0 (len * Dent.RA.items_per_val)) {
      let^ (ms, res) <- Dent.get lxp ixp dnum ix0 ms;
      match (is_valid res) with
      | true =>
        let^ (ms, ix, r0) <- link' lxp bxp ixp dnum name inum isdir ms;
        Ret ^(ms, ix, r0)
      | false =>
        ms <- Dent.put lxp ixp dnum ix0 de ms;
        Ret ^(ms, ix0+1, OK tt)
      end
    } else {
(* calling extend here slows down performance drastically.
        let^ (ms, ok) <- Dent.extend lxp bxp ixp dnum de ms;
        Ret ^(ms, ix0+1, ok)  *)
      let^ (ms, ix, r0) <- link' lxp bxp ixp dnum name inum isdir ms;
      Ret ^(ms, ix, r0)
    }.

  (*************  basic lemmas  *)

  Fact bit2bool_0 : bit2bool $0 = false.
  Proof.
    unfold bit2bool; destruct (bit_dec $0); auto.
    contradict e; apply natToWord_discriminate; auto.
  Qed.

  Fact bit2bool_1 : bit2bool $1 = true.
  Proof.
    unfold bit2bool; destruct (bit_dec $1); auto.
    apply eq_sym in e; contradict e.
    apply natToWord_discriminate; auto.
  Qed.

  Fact bit2bool_1_ne : bit2bool $1 <> false.
  Proof. rewrite bit2bool_1; congruence. Qed.

  Fact bit2bool_0_ne : bit2bool $0 <> true.
  Proof. rewrite bit2bool_0; congruence. Qed.

  Local Hint Resolve bit2bool_0 bit2bool_1 bit2bool_0_ne bit2bool_1_ne.

  Lemma bit2bool2bit : forall b, bit2bool (bool2bit b) = b.
  Proof.
    destruct b; cbn; auto.
  Qed.

  Lemma bool2bit2bool : forall b,  bool2bit (bit2bool b) = b.
  Proof.
    unfold bit2bool; intros.
    destruct (bit_dec b); subst; auto.
  Qed.

  Lemma lookup_f_ok: forall name de a,
    lookup_f name de a = true ->
    is_valid de = true /\ DEName de = name.
  Proof.
    unfold lookup_f, name_is; intuition.
    apply andb_true_iff in H; tauto.
    destruct (weq name (DEName de)); auto.
    contradict H.
    rewrite andb_true_iff; easy.
  Qed.

  Lemma lookup_f_nf: forall name de a,
    lookup_f name de a = false ->
    is_valid de = false \/ DEName de <> name.
  Proof.
    unfold lookup_f, name_is; intuition.
    apply andb_false_iff in H; intuition.
    destruct (weq name (DEName de)); intuition.
  Qed.

  Lemma lookup_notindomain': forall l ix name,
    Forall (fun e => (lookup_f name e ix) = false) l
    -> listpred dmatch l =p=> notindomain name.
  Proof.
    induction l; unfold pimpl; simpl; intros.
    apply emp_notindomain; auto.
    inversion H; subst.

    destruct (Sumbool.sumbool_of_bool (is_valid a)).
    destruct (lookup_f_nf name a ix); try congruence.
    eapply notindomain_mem_except; eauto.
    eapply ptsto_mem_except.
    pred_apply; unfold dmatch at 1.
    rewrite e, IHl by eauto; simpl; cancel.

    pred_apply; rewrite IHl by eauto; cancel.
    unfold dmatch; rewrite e; simpl; auto.
  Qed.

  Lemma lookup_notindomain: forall l name,
    (forall i, i < length l -> lookup_f name (selN l i dent0) i = false) ->
    listpred dmatch l =p=> notindomain name.
  Proof.
    intros.
    eapply lookup_notindomain' with (ix := 0).
    eapply selN_Forall; eauto.
  Qed.

  Definition dmatch_ex name (de: dent) : @pred filename (@weq filename_len) (addr * bool) :=
    if (name_is name de) then emp
    else dmatch de.

  Definition dmatch_ex_same : forall de,
    dmatch_ex (DEName de) de = emp.
  Proof.
    unfold dmatch_ex, name_is; intros.
    destruct (weq (DEName de) (DEName de)); congruence.
  Qed.

  Definition dmatch_ex_diff : forall name de,
    name <> (DEName de) ->
    dmatch_ex name de = dmatch de.
  Proof.
    unfold dmatch_ex, name_is; intros.
    destruct (weq name (DEName de)); congruence.
  Qed.

  Lemma dmatch_ex_ptsto : forall l name v,
    (name |-> v * listpred dmatch l)
    =p=> (name |-> v * listpred (dmatch_ex name) l).
  Proof.
    induction l; simpl; intros; auto.
    unfold dmatch_ex at 1, dmatch at 1, dmatch at 2, name_is.
    destruct (bool_dec (is_valid a) false).
    destruct (weq name (DEName a));
    rewrite sep_star_comm, sep_star_assoc;
    setoid_rewrite sep_star_comm at 2; rewrite IHl; cancel.

    destruct (weq name (DEName a)); subst.
    unfold pimpl; intros; exfalso.
    eapply ptsto_conflict_F with (m := m) (a := DEName a).
    pred_apply; cancel.
    eapply pimpl_trans with (b := (name |-> v * listpred dmatch l * [[DEInum a <> 0 ]] * _)%pred).
    cancel. rewrite IHl. cancel.
  Qed.

  Lemma lookup_ptsto: forall l name ix,
    ix < length l ->
    lookup_f name (selN l ix dent0) ix = true ->
    listpred dmatch l =p=> listpred (dmatch_ex name) l *
       (name |-> (DEInum (selN l ix dent0), is_dir (selN l ix dent0))).
  Proof.
    induction l; intros.
    simpl; inversion H.
    pose proof (lookup_f_ok _ _ _ H0) as [Hx Hy].
    destruct ix; subst; simpl in *.
    unfold dmatch at 1; rewrite Hx, dmatch_ex_same; simpl.
    eapply pimpl_trans with (b := (DEName a |-> _ * listpred dmatch l * _)%pred).
    cancel. rewrite dmatch_ex_ptsto; cancel.

    assert (ix < length l) by omega.
    rewrite IHl; eauto; try solve [ cancel ].
    unfold dmatch_ex at 2, dmatch, name_is.
    destruct (bool_dec (is_valid _) false);
    destruct (weq (DEName _) _); try solve [ cancel ].
    rewrite e; repeat destruct_prod.
    unfold pimpl; intros; exfalso.
    eapply ptsto_conflict_F with (m := m) (a := DEName (w, (w0, (w1, (w2, (w3, u)))))).
    pred_apply; cancel.
  Qed.

  Definition readmatch (de: readent) : @pred _ (@weq filename_len) _ :=
    fst de |-> snd de.

  Lemma readmatch_ok : forall l,
    listpred dmatch l =p=> listpred readmatch
      (map (fun de => (DEName de, (DEInum de, is_dir de))) (filter is_valid l)).
  Proof.
    induction l; simpl; auto.
    unfold dmatch at 1; destruct (is_valid a); simpl.
    rewrite IHl; cancel.
    cancel.
  Qed.

  Lemma dmatch_dent0_emp :  dmatch dent0 = emp.
  Proof.
    unfold dmatch, dent0.
    destruct (bool_dec (is_valid _) false); auto.
    contradict n.
    compute; auto.
  Qed.

  Lemma listpred_dmatch_dent0_emp : forall l i dmap,
    listpred dmatch l dmap ->
    is_valid (selN l i dent0) = true ->
    i < length l ->
    listpred dmatch (updN l i dent0) (mem_except dmap (DEName (selN l i dent0))).
  Proof.
    intros.
    apply listpred_updN; auto.
    rewrite dmatch_dent0_emp.
    eapply ptsto_mem_except; pred_apply.
    rewrite listpred_isolate by eauto.
    unfold dmatch at 2; rewrite H0; simpl.
    repeat cancel.
  Qed.

  Lemma dmatch_mk_dent : forall name inum isdir,
    goodSize addrlen inum ->
    dmatch (mk_dent name inum isdir) = (name |-> (inum, isdir) * [[ inum <> 0 ]])%pred.
  Proof.
    unfold dmatch, mk_dent, is_valid, is_dir; intros; cbn.
    rewrite bit2bool_1, wordToNat_natToWord_idempotent', bit2bool2bit; auto.
  Qed.

  Lemma listpred_dmatch_mem_upd : forall l i dmap name inum isdir,
    notindomain name dmap ->
    negb (is_valid (selN l i dent0)) = true ->
    listpred dmatch l dmap ->
    i < length l -> inum <> 0 ->
    goodSize addrlen inum ->
    listpred dmatch (updN l i (mk_dent name inum isdir)) (Mem.upd dmap name (inum, isdir)).
  Proof.
    intros.
    apply listpred_updN; auto.
    rewrite dmatch_mk_dent by auto.
    eapply pimpl_apply. cancel.
    apply ptsto_upd_disjoint.
    apply negb_true_iff in H0.
    pred_apply.
    setoid_rewrite listpred_isolate with (def := dent0) at 1; eauto.
    unfold dmatch at 2; rewrite H0; cancel.
    eauto.
  Qed.

  Lemma listpred_dmatch_repeat_dent0 : forall n,
    listpred dmatch (repeat dent0 n) <=p=> emp.
  Proof.
    induction n; intros; simpl; eauto.
    split; rewrite dmatch_dent0_emp, IHn; cancel.
  Qed.

  Lemma listpred_dmatch_ext_mem_upd : forall l dmap name inum isdir,
    notindomain name dmap ->
    (forall i, i < length l -> negb (is_valid (selN l i dent0)) = false) ->
    listpred dmatch l dmap ->
    goodSize addrlen inum -> inum <> 0 ->
    listpred dmatch (l ++ @updN (Rec.data Dent.RA.itemtype) (Dent.Defs.block0) 0 (mk_dent name inum isdir))
                    (Mem.upd dmap name (inum, isdir)).
  Proof.
    intros.
    pose proof (Dent.Defs.items_per_val_gt_0).
    erewrite <- Nat.sub_diag, <- updN_app2, Dent.Defs.block0_repeat by auto.
    apply listpred_updN; auto.
    rewrite app_length, repeat_length; omega.

    replace (length l) with (length l + 0) by omega.
    rewrite removeN_app_r, removeN_repeat, listpred_app by auto.
    rewrite listpred_dmatch_repeat_dent0.
    rewrite dmatch_mk_dent by auto.
    eapply pimpl_apply. cancel.
    apply ptsto_upd_disjoint; auto.
  Qed.

  Lemma listpred_dmatch_eq_mem : forall l m m',
    listpred dmatch l m -> listpred dmatch l m' ->
    m = m'.
  Proof.
    induction l; cbn; intros m m' H H'.
    - apply emp_empty_mem_only in H.
      apply emp_empty_mem_only in H'.
      congruence.
    - unfold dmatch at 1 in H.
      unfold dmatch at 1 in H'.
      destruct bool_dec.
      apply IHl; pred_apply; cancel.
      eapply pimpl_trans in H; [| cancel..].
      eapply pimpl_trans in H'; [| cancel..].
      revert H. revert H'.
      unfold_sep_star.
      intros. repeat deex.
      match goal with H1 : (ptsto _ _ ?m), H2 : (ptsto _ _ ?m') |- _ =>
        assert (m = m') by (eapply ptsto_complete; eauto); subst
      end.
      f_equal.
      eauto.
  Qed.

  Lemma listpred_dmatch_notindomain: forall delist dmap name x,
    notindomain name dmap ->
    listpred dmatch delist (upd dmap name x) ->
    listpred dmatch delist =p=> notindomain name * name |-> x.
  Proof.
    intros. intros m ?.
    replace m with (upd dmap name x) in * by (eauto using listpred_dmatch_eq_mem).
    apply ptsto_upd_disjoint; auto.
  Qed.

  Lemma dmatch_no_0_inum: forall f m, dmatch f m ->
    forall name isdir, m name = Some (0, isdir) -> False.
  Proof.
    unfold dmatch.
    intros; destruct bool_dec; destruct_lifts.
    congruence.
    unfold ptsto in *. intuition.
    destruct (weq name (DEName f)); subst.
    congruence.
    denote (m name = Some _) as Hm.
    denote (m _ = None) as Ha.
    rewrite Ha in Hm by auto.
    congruence.
  Unshelve.
    all: auto; repeat constructor.
  Qed.

  Lemma listpred_dmatch_no_0_inum: forall dmap m,
    listpred dmatch dmap m ->
    forall name isdir, m name = Some (0, isdir) -> False.
  Proof.
    induction dmap; cbn; intros.
    congruence.
    revert H.
    unfold_sep_star.
    intros. repeat deex.
    unfold mem_union in *.
    destruct (m1 name) eqn:?.
    denote (Some _ = Some _) as Hs; inversion Hs; subst; clear Hs.
    eauto using dmatch_no_0_inum.
    eauto.
  Unshelve.
    all: eauto.
  Qed.

  (*************  correctness theorems  *)

  Notation MSLL := BFILE.MSLL.
  Notation MSAlloc := BFILE.MSAlloc.
  Notation MSCache := BFILE.MSCache.
  Notation MSAllocC := BFILE.MSAllocC.
  Notation MSIAllocC := BFILE.MSIAllocC.
  Notation MSDBlocks := BFILE.MSDBlocks.

  Theorem lookup_ok : forall lxp bxp ixp dnum name ms,
    {< F Fm Fi m0 sm m dmap ilist frees f,
    PRE:hm LOG.rep lxp F (LOG.ActiveTxn m0 m) (MSLL ms) sm hm *
           rep_macro Fm Fi m bxp ixp dnum dmap ilist frees f ms sm
    POST:hm' RET:^(ms',r)
           LOG.rep lxp F (LOG.ActiveTxn m0 m) (MSLL ms') sm hm' *
           rep_macro Fm Fi m bxp ixp dnum dmap ilist frees f ms' sm *
           [[ MSAlloc ms' = MSAlloc ms ]] *
           [[ MSAllocC ms' = MSAllocC ms ]] *
         ( [[ r = None /\ notindomain name dmap ]] \/
           exists inum isdir Fd,
           [[ r = Some (inum, isdir) /\ inum <> 0 /\
                   (Fd * name |-> (inum, isdir))%pred dmap ]])
    CRASH:hm'  exists ms',
           LOG.rep lxp F (LOG.ActiveTxn m0 m) (MSLL ms') sm hm'
    >} lookup lxp ixp dnum name ms.
  Proof.
    unfold lookup, ifind_lookup_f, rep_macro, rep.
    safestep.
    safestep.
    or_r; cancel.
    eapply listpred_dmatch_no_0_inum; eauto.
    eapply ptsto_valid'.
    denote DEInum as Hd.
    erewrite selN_inb in Hd by auto.
    rewrite <- Hd.
    eapply lookup_ptsto; eauto.
    eapply lookup_ptsto; eauto.
    or_l; cancel.
    apply lookup_notindomain; auto.
  Unshelve.
    all: try (exact false || exact emp).
    all: eauto.
  Qed.

  Theorem readdir_ok : forall lxp bxp ixp dnum ms,
    {< F Fm Fi m0 sm m dmap ilist frees f,
    PRE:hm   LOG.rep lxp F (LOG.ActiveTxn m0 m) (MSLL ms) sm hm *
             rep_macro Fm Fi m bxp ixp dnum dmap ilist frees f ms sm
    POST:hm' RET:^(ms',r)
             LOG.rep lxp F (LOG.ActiveTxn m0 m) (MSLL ms') sm hm' *
             rep_macro Fm Fi m bxp ixp dnum dmap ilist frees f ms' sm *
             [[ listpred readmatch r dmap ]] *
             [[ MSAlloc ms' = MSAlloc ms ]] *
             [[ MSCache ms' = MSCache ms ]] *
             [[ MSAllocC ms' = MSAllocC ms ]] *
             [[ MSIAllocC ms' = MSIAllocC ms ]] *
             [[ MSDBlocks ms' = MSDBlocks ms ]]
    CRASH:hm'  exists ms',
           LOG.rep lxp F (LOG.ActiveTxn m0 m) (MSLL ms') sm hm'
    >} readdir lxp ixp dnum ms.
  Proof.
    unfold readdir, rep_macro, rep.
    safestep.
    step.
    apply readmatch_ok.
  Qed.

  Local Hint Resolve mem_except_notindomain.

  Theorem unlink_ok : forall lxp bxp ixp dnum name ms,
    {< F Fm Fi m0 sm m dmap ilist frees,
    PRE:hm   LOG.rep lxp F (LOG.ActiveTxn m0 m) (MSLL ms) sm hm *
             exists f, rep_macro Fm Fi m bxp ixp dnum dmap ilist frees f ms sm
    POST:hm' RET:^(ms', hint, r) exists m' dmap',
             LOG.rep lxp F (LOG.ActiveTxn m0 m') (MSLL ms') sm hm' *
             exists f', rep_macro Fm Fi m' bxp ixp dnum dmap' ilist frees f' ms' sm *
             [[ dmap' = mem_except dmap name ]] *
             [[ notindomain name dmap' ]] *
             [[ r = OK tt -> indomain name dmap ]] *
             [[ MSAlloc ms' = MSAlloc ms ]] *
             [[ MSAllocC ms' = MSAllocC ms ]] *
             [[ MSIAllocC ms' = MSIAllocC ms ]]
    CRASH:hm' LOG.intact lxp F m0 sm hm'
    >} unlink lxp ixp dnum name ms.
  Proof.
    unfold unlink, ifind_lookup_f, rep_macro, rep.
    step.
    step.

    apply Dent.Defs.item0_wellformed.
    msalloc_eq.

    denote (lookup_f) as HH.
    pose proof (lookup_f_ok _ _ _ HH) as [Hx Hy].

    step.

    eexists; split; eauto.
    apply listpred_dmatch_dent0_emp; auto.

    rewrite lookup_ptsto by eauto.
    unfold pimpl; intros.
    eapply sep_star_ptsto_indomain.
    pred_apply; cancel.

    rewrite <- notindomain_mem_eq; auto.
    eapply lookup_notindomain; eauto.
    eapply lookup_notindomain; eauto.

  Unshelve.
    all: easy.
  Qed.

  Theorem link'_ok : forall lxp bxp ixp dnum name inum isdir ms,
    {< F Fm Fi m0 sm m dmap ilist frees,
    PRE:hm   LOG.rep lxp F (LOG.ActiveTxn m0 m) (MSLL ms) sm hm *
             exists f, rep_macro Fm Fi m bxp ixp dnum dmap ilist frees f ms sm *
             [[ notindomain name dmap ]] *
             [[ goodSize addrlen inum ]] *
             [[ inum <> 0 ]]
    POST:hm' RET:^(ms', ixhint', r) exists m',
             [[ MSAlloc ms' = MSAlloc ms ]] *
             [[ MSIAllocC ms' = MSIAllocC ms ]] *
           (([[ isError r ]] * LOG.rep lxp F (LOG.ActiveTxn m0 m') (MSLL ms') sm hm')
        \/  ([[ r = OK tt ]] *
             exists dmap' Fd ilist' frees' f',
             LOG.rep lxp F (LOG.ActiveTxn m0 m') (MSLL ms') sm hm' *
             rep_macro Fm Fi m' bxp ixp dnum dmap' ilist' frees' f' ms' sm *
             [[ dmap' = Mem.upd dmap name (inum, isdir) ]] *
             [[ (Fd * name |-> (inum, isdir))%pred dmap' ]] *
             [[ (Fd dmap /\ notindomain name dmap) ]] *
             [[ BFILE.ilist_safe ilist  (BFILE.pick_balloc frees  (MSAlloc ms'))
                                 ilist' (BFILE.pick_balloc frees' (MSAlloc ms')) ]] *
             [[ BFILE.treeseq_ilist_safe dnum ilist ilist' ]] ))
    CRASH:hm' LOG.intact lxp F m0 sm hm'
    >} link' lxp bxp ixp dnum name inum isdir ms.
  Proof.
    unfold link', ifind_lookup_f, ifind_invalid, rep_macro, rep.
    step.
    step; msalloc_eq.

    (* case 1: use avail entry *)
    cbv; tauto.
    step; msalloc_eq.
    or_r; cancel.
    eexists; split; eauto.
    apply listpred_dmatch_mem_upd; auto.
    eapply ptsto_upd_disjoint; eauto.
    apply BFILE.ilist_safe_refl.
    apply BFILE.treeseq_ilist_safe_refl.

    (* case 2: extend new entry *)
    cbv; tauto.

    step; msalloc_eq.
    or_r; cancel; eauto.
    eexists; split; eauto.
    eapply listpred_dmatch_ext_mem_upd; eauto.
    eapply ptsto_upd_disjoint; eauto.
  Unshelve.
    all: eauto.
  Qed.

  Hint Extern 1 ({{ _ }} Bind (link' _ _ _ _ _ _ _ _) _) => apply link'_ok : prog.

  Theorem link_ok : forall lxp bxp ixp dnum name inum isdir ixhint ms,
    {< F Fm Fi m0 sm m dmap ilist frees,
    PRE:hm   LOG.rep lxp F (LOG.ActiveTxn m0 m) (MSLL ms) sm hm *
             exists f, rep_macro Fm Fi m bxp ixp dnum dmap ilist frees f ms sm *
             [[ notindomain name dmap ]] *
             [[ goodSize addrlen inum ]] *
             [[ inum <> 0 ]]
    POST:hm' RET:^(ms', ixhint', r) exists m',
             [[ MSAlloc ms' = MSAlloc ms ]] *
             [[ MSIAllocC ms' = MSIAllocC ms ]] *
           (([[ isError r ]] * LOG.rep lxp F (LOG.ActiveTxn m0 m') (MSLL ms') sm hm')
        \/  ([[ r = OK tt ]] *
             exists dmap' Fd ilist' frees' f',
             LOG.rep lxp F (LOG.ActiveTxn m0 m') (MSLL ms') sm hm' *
             rep_macro Fm Fi m' bxp ixp dnum dmap' ilist' frees' f' ms' sm *
             [[ dmap' = Mem.upd dmap name (inum, isdir) ]] *
             [[ (Fd * name |-> (inum, isdir))%pred dmap' ]] *
             [[ (Fd dmap /\ notindomain name dmap) ]] *
             [[ BFILE.ilist_safe ilist  (BFILE.pick_balloc frees  (MSAlloc ms'))
                                 ilist' (BFILE.pick_balloc frees' (MSAlloc ms')) ]] *
             [[ BFILE.treeseq_ilist_safe dnum ilist ilist' ]] ))
    CRASH:hm' LOG.intact lxp F m0 sm hm'
    >} link lxp bxp ixp dnum name inum isdir ixhint ms.
  Proof.
    unfold link, rep_macro, rep.
    step.
    step; msalloc_eq.

    (* case 1: try entry hint *)
    step.
    erewrite Dent.items_length_ok with (xp := f) (m := (list2nmem (BFILE.BFData f))).
    unfold Dent.RA.RALen. auto.
    pred_apply; cancel.
    destruct is_valid eqn:?.
    (* working around a 'not found' Coq bug, probably #4202 in simpl *)
    prestep. unfold rep_macro, rep. norm. cancel.
    intuition ((pred_apply; cancel) || eauto).
    step.
    or_r. cancel.
    eauto.
    eapply listpred_dmatch_notindomain; eauto.
    eauto.
    cancel.

    (* case 2: use hinted entry *)
    step; msalloc_eq.
    erewrite Dent.items_length_ok with (xp := f) (m := (list2nmem (BFILE.BFData f))).
    unfold Dent.RA.RALen. auto.
    pred_apply; cancel.
    cbv; tauto.
    step.
    or_r; cancel.
    eexists; split; eauto.
    apply listpred_dmatch_mem_upd; auto.
    rewrite Bool.negb_true_iff; auto.
    erewrite Dent.items_length_ok with (xp := f) (m := (list2nmem (BFILE.BFData f))).
    unfold Dent.RA.RALen. auto.
    pred_apply; cancel.
    eapply ptsto_upd_disjoint; auto.
    apply BFILE.ilist_safe_refl.
    apply BFILE.treeseq_ilist_safe_refl.

    (* case 3: hint was out of bounds, so ignore it *)
    (* working around a 'not found' Coq bug, probably #4202 in simpl *)
    prestep. unfold rep_macro, rep. norm. cancel.
    intuition ((pred_apply; cancel) || eauto).
    step.
    or_r. cancel.
    eauto.
    eapply listpred_dmatch_notindomain; eauto.
    eauto.
    cancel.
  Unshelve.
    all: eauto.
  Qed.

  Hint Extern 1 ({{_}} Bind (lookup _ _ _ _ _) _) => apply lookup_ok : prog.
  Hint Extern 1 ({{_}} Bind (unlink _ _ _ _ _) _) => apply unlink_ok : prog.
  Hint Extern 1 ({{_}} Bind (link _ _ _ _ _ _ _ _ _) _) => apply link_ok : prog.
  Hint Extern 1 ({{_}} Bind (readdir _ _ _ _) _) => apply readdir_ok : prog.

  Hint Extern 0 (okToUnify (rep ?f _) (rep ?f _)) => constructor : okToUnify.

  (*************  Lemma for callers *)

  Theorem dmatch_complete : forall de m1 m2, dmatch de m1 -> dmatch de m2 -> m1 = m2.
  Proof.
    unfold dmatch, is_dir; intros.
    destruct (bool_dec (is_valid de) false).
    apply emp_complete; eauto.
    eapply ptsto_complete; pred_apply; cancel.
  Qed.

  Lemma listpred_dmatch_eq : forall l m1 m2,
    listpred dmatch l m1
    -> listpred dmatch l m2
    -> m1 = m2.
  Proof.
    induction l; simpl; auto.
    apply emp_complete; auto.
    intros m1 m2.
    unfold_sep_star; intuition.
    repeat deex; f_equal.
    eapply dmatch_complete; eauto.
    eapply IHl; eauto.
  Qed.

  Lemma rep_mem_eq : forall f m1 m2,
    rep f m1 ->
    rep f m2 ->
    m1 = m2.
  Proof.
    unfold rep; intros.
    repeat deex.
    pose proof (Dent.rep_items_eq H0 H1); subst.
    eapply listpred_dmatch_eq; eauto.
  Qed.

  Theorem bfile0_empty : rep BFILE.bfile0 empty_mem.
  Proof.
    unfold rep, Dent.rep, Dent.items_valid.
    exists nil; firstorder.
    exists nil; simpl.
    setoid_rewrite Dent.Defs.ipack_nil.
    assert (emp (list2nmem (@nil valuset))) by firstorder.
    pred_apply; cancel.
    apply Forall_nil.
  Qed.

  Theorem rep_no_0_inum: forall f m, rep f m ->
    forall name isdir, m name = Some (0, isdir) -> False.
  Proof.
    unfold rep. intros. repeat deex.
    eauto using listpred_dmatch_no_0_inum.
  Qed.

  Theorem crash_eq : forall f f' m1 m2,
    BFILE.file_crash f f' ->
    rep f m1 ->
    rep f' m2 ->
    m1 = m2.
  Proof.
    intros.
    apply eq_sym.
    eapply rep_mem_eq; eauto.

    unfold rep in *.
    repeat deex.
    eexists; intuition eauto.
    assert (delist0 = delist).
    eapply Dent.file_crash_rep_eq; eauto.
    subst; eauto.
  Qed.

  Theorem crash_rep : forall f f' m,
    BFILE.file_crash f f' ->
    rep f m ->
    rep f' m.
  Proof.
    unfold rep; intros.
    repeat deex.
    eexists; intuition eauto.
    eapply Dent.file_crash_rep; eauto.
  Qed.

End DIR.