 (*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  Ifnot, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export cvterm.
Require Export csubst.
Require Export computation3.
Require Export list. (* WTF!!*)

Definition mkcv_tnat {o} (vs : list NVar) : @CVTerm o vs := mk_cv vs mkc_tnat.

Definition mk_isl {o} (t : @NTerm o) := mk_ite t mk_btrue mk_bfalse.

Lemma wf_term_decide_iff {p} :
  forall (a : @NTerm p) v1 b1 v2 b2,
    (wf_term a
     # wf_term b1
     # wf_term b2)
    <=> wf_term (mk_decide a v1 b1 v2 b2).
Proof.
  introv; split; intro wf; repnd.
  - allrw @wf_term_eq.
    constructor; simpl; unfold num_bvars; simpl; auto.
    sp; subst; constructor; auto.
  - allrw @wf_term_eq.
    inversion wf as [| | o l bwf e ]; subst.
    generalize (bwf (nobnd a)) (bwf (bterm [v1] b1)) (bwf (bterm [v2] b2)); clear bwf; intros bwf1 bwf2 bwf3.
    autodimp bwf1 hyp; autodimp bwf2 hyp; autodimp bwf3 hyp; try (complete (simpl; sp)).
    inversion bwf1; subst.
    inversion bwf2; subst.
    inversion bwf3; subst; sp.
Qed.

Lemma isprog_vars_decide_iff {p} :
  forall vs (a : @NTerm p) v1 a1 v2 a2,
    isprog_vars vs (mk_decide a v1 a1 v2 a2)
    <=> (isprog_vars vs a
         # isprog_vars (v1 :: vs) a1
         # isprog_vars (v2 :: vs) a2).
Proof.
  introv; split; intro k; try (repnd; apply isprog_vars_decide); auto.
  allrw @isprog_vars_eq; allsimpl.
  allrw remove_nvars_nil_l.
  allrw subvars_eq.
  allrw app_nil_r.
  allrw subset_app; repnd.
  allrw <- @wf_term_eq.
  apply wf_term_decide_iff in k; repnd.
  allrw <- subvars_eq.
  allrw subvars_remove_nvars.
  allrw subvars_eq.
  dands; auto.
  - introv i; simpl.
    apply k2 in i; allrw in_app_iff; allsimpl; sp.
  - introv i; simpl.
    apply k0 in i; allrw in_app_iff; allsimpl; sp.
Qed.

Lemma isprog_vars_ite {p} :
  forall vs (a b c : @NTerm p),
    (isprog_vars vs a # isprog_vars vs b # isprog_vars vs c)
    <=> isprog_vars vs (mk_ite a b c).
Proof.
  introv.
  unfold mk_ite.
  rw @isprog_vars_decide_iff.
  allrw @isprog_vars_cons_newvar; sp.
Qed.

Lemma isprog_vars_ite_implies {p} :
  forall vs (a b c : @NTerm p),
    isprog_vars vs a
    -> isprog_vars vs b
    -> isprog_vars vs c
    -> isprog_vars vs (mk_ite a b c).
Proof.
  intros; apply isprog_vars_ite; sp.
Qed.

Definition mkcv_ite {p} (vs : list NVar) (a b c : @CVTerm p vs) :=
  let (t1,x1) := a in
  let (t2,x2) := b in
  let (t3,x3) := c in
  exist (isprog_vars vs)
        (mk_ite t1 t2 t3)
        (isprog_vars_ite_implies vs t1 t2 t3 x1 x2 x3).

Lemma isprog_vars_isl {o} :
  forall vs (t : @NTerm o), isprog_vars vs (mk_isl t) <=> isprog_vars vs t.
Proof.
  introv.
  unfold mk_isl.
  rw <- @isprog_vars_ite.
  split; intro k; repnd; dands; eauto 3 with slow.
Qed.

Lemma isprog_isl {o} :
  forall (t : @NTerm o),
    isprog (mk_isl t) <=> isprog t.
Proof.
  introv; unfold mk_isl.
  rw @isprog_decide_iff.
  split; intro k; repnd; dands; tcsp; eauto 3 with slow.
Qed.

Lemma implies_isprog_isl {o} :
  forall (t : @NTerm o), isprog t -> isprog (mk_isl t).
Proof.
  introv isp; apply isprog_isl; auto.
Qed.

Definition mkc_isl {o} (t : @CTerm o) : CTerm :=
  let (a,x) := t in exist isprog (mk_isl a) (implies_isprog_isl a x).

Definition mk_assert {o} (t : @NTerm o) := mk_ite t mk_unit mk_void.

Lemma isprog_vars_unit {o} :
  forall vs, @isprog_vars o vs mk_unit.
Proof.
  introv; rw @isprog_vars_eq; simpl; dands; eauto 3 with slow.
Qed.
Hint Resolve isprog_vars_unit : slow.

Lemma isprog_assert {o} :
  forall (t : @NTerm o),
    isprog (mk_assert t) <=> isprog t.
Proof.
  introv; unfold mk_assert.
  rw @isprog_decide_iff.
  split; intro k; repnd; dands; tcsp; eauto 3 with slow.
Qed.

Lemma implies_isprog_assert {o} :
  forall (t : @NTerm o), isprog t -> isprog (mk_assert t).
Proof.
  introv isp; apply isprog_assert; auto.
Qed.

Definition mkc_assert {o} (t : @CTerm o) : CTerm :=
  let (a,x) := t in exist isprog (mk_assert a) (implies_isprog_assert a x).

Definition mkcv_prod {p} vs (A B : @CVTerm p vs) : CVTerm vs :=
  let (a,x) := A in
  let (b,y) := B in
  exist (isprog_vars vs) (mk_prod a b) (isprog_vars_prod_implies vs a b x y).

Definition mkcv_less_than {o} (vs : list NVar) (t1 t2 : @CVTerm o vs) : CVTerm vs :=
  let (a,x) := t1 in
  let (b,y) := t2 in
    exist (isprog_vars vs) (mk_less_than a b) (isprog_vars_less_than_implies a b vs x y).

Lemma mkc_natk_eq {o} :
  forall (t : @CTerm o),
    mkc_natk t
    = mkc_set
        mkc_int
        nvarx
        (mkcv_prod
           [nvarx]
           (mkcv_le [nvarx] (mkcv_zero [nvarx]) (mkc_var nvarx))
           (mkcv_less_than [nvarx] (mkc_var nvarx) (mk_cv [nvarx] t))).
Proof.
  introv.
  destruct_cterms.
  apply cterm_eq; simpl; auto.
  unfold mk_natk.
  rw @newvar_prog; auto.
Qed.

Lemma closed_if_isprog {o} :
  forall (t : @NTerm o),
    isprog t -> closed t.
Proof.
  introv isp.
  apply closed_if_program.
  apply isprogram_eq; auto.
Qed.
Hint Resolve closed_if_isprog : slow.

Lemma mkcv_prod_substc {o} :
  forall v (a b : @CVTerm o [v]) t,
    alphaeqc
      (substc t v (mkcv_prod [v] a b))
      (mkc_prod (substc t v a) (substc t v b)).
Proof.
  introv.
  destruct_cterms.
  unfold alphaeqc; simpl.
  unfold subst.
  repeat (rw @cl_lsubst_lsubst_aux; eauto 3 with slow).
  simpl; fold_terms; rw memvar_singleton.
  constructor; simpl; auto.
  introv k.
  repeat (destruct n; tcsp).
  unfold selectbt; simpl.

  pose proof (newvar_prog (lsubst_aux x0 [(v, x)])) as h.
  autodimp h hyp.
  { apply isprog_vars_nil_implies_isprog.
    rw <- @cl_lsubst_lsubst_aux; eauto 3 with slow.
    apply csubst.isprog_vars_lsubst; allsimpl; auto .
    introv j; repndors; subst; tcsp.
    apply isprogram_eq; auto. }
  rw h.

  boolvar.

  { rw @lsubst_aux_trivial_cl_term in h; allsimpl;
    [|apply disjoint_singleton_r; apply newvar_prop].
    rw (lsubst_aux_trivial_cl_term x0 [(newvar x0,x)]); allsimpl;
    [|apply disjoint_singleton_r; apply newvar_prop].
    rw h; rw @lsubst_aux_nil; auto. }

  { pose proof (ex_fresh_var (nvarx
                                :: (newvar x0)
                                :: (all_vars (lsubst_aux x0 [(v, x)]))
                                ++ (all_vars (lsubst_aux x0 [(v, x)])))) as fv;
    exrepnd; allsimpl; allrw in_app_iff.
    allrw not_over_or; repnd; GC.
    apply (al_bterm _ _ [v0]); allsimpl; auto.
    { rw disjoint_singleton_l; allrw in_app_iff; allrw not_over_or; sp. }
    unfold var_ren; simpl.

    assert (free_vars (lsubst_aux x0 [(v, x)]) = []) as f.
    { apply null_iff_nil.
      apply closed_null_free_vars.
      apply closed_if_isprog.
      apply isprog_vars_nil_implies_isprog.
      rw <- @cl_lsubst_lsubst_aux; eauto 3 with slow.
      apply csubst.isprog_vars_lsubst; allsimpl; auto .
      introv j; repndors; subst; tcsp.
      apply isprogram_eq; auto. }

    repeat (rw @lsubst_trivial4; simpl; auto);
      allrw disjoint_singleton_l; try (rw f); simpl; tcsp;
      introv j; repndors; tcsp; ginv; simpl;
      apply disjoint_singleton_l; auto. }
Qed.

Lemma mkcv_fun_substc {o} :
  forall v (a b : @CVTerm o [v]) t,
    alphaeqc
      (substc t v (mkcv_fun [v] a b))
      (mkc_fun (substc t v a) (substc t v b)).
Proof.
  introv.
  destruct_cterms.
  unfold alphaeqc; simpl.
  unfold subst.
  repeat (rw @cl_lsubst_lsubst_aux; eauto 3 with slow).
  simpl; fold_terms; rw memvar_singleton.
  constructor; simpl; auto.
  introv k.
  repeat (destruct n; tcsp).
  unfold selectbt; simpl.

  pose proof (newvar_prog (lsubst_aux x0 [(v, x)])) as h.
  autodimp h hyp.
  { apply isprog_vars_nil_implies_isprog.
    rw <- @cl_lsubst_lsubst_aux; eauto 3 with slow.
    apply csubst.isprog_vars_lsubst; allsimpl; auto .
    introv j; repndors; subst; tcsp.
    apply isprogram_eq; auto. }
  rw h.

  boolvar.

  { rw @lsubst_aux_trivial_cl_term in h; allsimpl;
    [|apply disjoint_singleton_r; apply newvar_prop].
    rw (lsubst_aux_trivial_cl_term x0 [(newvar x0,x)]); allsimpl;
    [|apply disjoint_singleton_r; apply newvar_prop].
    rw h; rw @lsubst_aux_nil; auto. }

  { pose proof (ex_fresh_var (nvarx
                                :: (newvar x0)
                                :: (all_vars (lsubst_aux x0 [(v, x)]))
                                ++ (all_vars (lsubst_aux x0 [(v, x)])))) as fv;
    exrepnd; allsimpl; allrw in_app_iff.
    allrw not_over_or; repnd; GC.
    apply (al_bterm _ _ [v0]); allsimpl; auto.
    { rw disjoint_singleton_l; allrw in_app_iff; allrw not_over_or; sp. }
    unfold var_ren; simpl.

    assert (free_vars (lsubst_aux x0 [(v, x)]) = []) as f.
    { apply null_iff_nil.
      apply closed_null_free_vars.
      apply closed_if_isprog.
      apply isprog_vars_nil_implies_isprog.
      rw <- @cl_lsubst_lsubst_aux; eauto 3 with slow.
      apply csubst.isprog_vars_lsubst; allsimpl; auto .
      introv j; repndors; subst; tcsp.
      apply isprogram_eq; auto. }

    repeat (rw @lsubst_trivial4; simpl; auto);
      allrw disjoint_singleton_l; try (rw f); simpl; tcsp;
      introv j; repndors; tcsp; ginv; simpl;
      apply disjoint_singleton_l; auto. }
Qed.

Definition mkcv_not {p} vs (t : @CVTerm p vs) : CVTerm vs :=
  let (a,x) := t in
    exist (isprog_vars vs) (mk_not a) (implies_isprog_vars_not vs a x).

Lemma mkcv_le_eq {o} :
  forall vs (a b : @CVTerm o vs),
    mkcv_le vs a b = mkcv_not vs (mkcv_less_than vs b a).
Proof.
  introv.
  destruct_cterms.
  apply cvterm_eq; simpl; auto.
Qed.

Lemma mkc_not_eq {o} :
  forall (a : @CTerm o),
    mkc_not a = mkc_fun a mkc_void.
Proof.
  introv.
  destruct_cterms.
  apply cterm_eq; simpl; auto.
Qed.

Definition mkcv_void {o} (vs : list NVar) : @CVTerm o vs := mk_cv vs mkc_void.

Lemma mkcv_not_eq {o} :
  forall vs (a : @CVTerm o vs),
    mkcv_not vs a = mkcv_fun vs a (mkcv_void vs).
Proof.
  introv.
  destruct_cterms.
  apply cvterm_eq; simpl; auto.
Qed.

Lemma mkcv_not_substc {o} :
  forall v a (t : @CTerm o),
    substc t v (mkcv_not [v] a)
    = mkc_not (substc t v a).
Proof.
  introv.
  rw @mkc_not_eq.
  rw @mkcv_not_eq.

  destruct_cterms.
  apply cterm_eq; simpl.
  repeat unfsubst; simpl; fold_terms.
  allrw @sub_filter_nil_r.
  repeat (rw memvar_singleton; boolvar; allsimpl; tcsp).
  boolvar; tcsp.
Qed.

Definition mkcv_false {o} (vs : list NVar) : @CVTerm o vs := mk_cv vs mkc_false.
Definition mkcv_true {o} (vs : list NVar) : @CVTerm o vs := mk_cv vs mkc_true.

Lemma mkcv_less_than_eq {o} :
  forall vs (a b : @CVTerm o vs),
    mkcv_less_than vs a b = mkcv_less vs a b (mkcv_true vs) (mkcv_false vs).
Proof.
  introv.
  destruct_cterms.
  apply cvterm_eq; simpl; auto.
Qed.

Lemma mkc_less_than_eq {o} :
  forall a b : @CTerm o, mkc_less_than a b = mkc_less a b mkc_true mkc_false.
Proof.
  introv.
  destruct_cterms.
  apply cterm_eq; simpl; sp.
Qed.

Lemma mkcv_less_substc {o} :
  forall v a b c d (t : @CTerm o),
    substc t v (mkcv_less [v] a b c d)
    = mkc_less (substc t v a) (substc t v b) (substc t v c) (substc t v d).
Proof.
  introv.
  destruct_cterms.
  apply cterm_eq; simpl.
  repeat unfsubst.
Qed.

Lemma mkcv_true_substc {o} :
  forall v (t : @CTerm o),
    substc t v (mkcv_true [v])
    = mkc_true.
Proof.
  introv.
  destruct_cterms.
  apply cterm_eq; tcsp.
Qed.

Lemma mkcv_false_substc {o} :
  forall v (t : @CTerm o),
    substc t v (mkcv_false [v])
    = mkc_false.
Proof.
  introv.
  destruct_cterms.
  apply cterm_eq; simpl.
  unfsubst; simpl.
  allrw memvar_singleton; boolvar; simpl; tcsp.
  boolvar; simpl; tcsp.
Qed.

Lemma mkcv_less_than_substc {o} :
  forall v a b (c : @CTerm o),
    substc c v (mkcv_less_than [v] a b)
    = mkc_less_than (substc c v a) (substc c v b).
Proof.
  introv.
  rw @mkcv_less_than_eq.
  rw @mkc_less_than_eq.
  rw @mkcv_less_substc.
  rw @mkcv_true_substc.
  rw @mkcv_false_substc.
  auto.
Qed.

Lemma mkcv_le_substc2 {o} :
  forall v a b (c : @CTerm o),
    substc c v (mkcv_le [v] a b)
    = mkc_le (substc c v a) (substc c v b).
Proof.
  introv.
  rw @mkcv_le_eq.
  rw @mkc_le_eq.
  rw @mkcv_not_substc.
  rw @mkcv_less_than_substc.
  auto.
Qed.

Lemma mkc_zero_eq {o} :
  @mkc_zero o = mkc_nat 0.
Proof.
  apply cterm_eq; simpl; auto.
Qed.

Lemma mkc_nat_eq {o} :
  forall n, @mkc_nat o n = mkc_integer (Z.of_nat n).
Proof.
  introv.
  apply cterm_eq; simpl; auto.
Qed.

Lemma isvalue_zero {o} : @isvalue o mk_zero.
Proof.
  unfold mk_zero; eauto with slow.
Qed.
Hint Resolve isvalue_zero : slow.

Lemma iscvalue_zero {o} : @iscvalue o mkc_zero.
Proof.
  unfold iscvalue; simpl; eauto 3 with slow.
Qed.
Hint Resolve iscvalue_zero : slow.

Lemma wf_fix_iff {p} :
  forall a : @NTerm p, wf_term (mk_fix a) <=> wf_term a.
Proof.
  introv; split; intro i.
  - allrw @wf_term_eq.
    inversion i as [| | o lnt k e]; subst; allsimpl.
    generalize (k (nobnd a)); intros k1.
    repeat (dest_imp k1 hyp).
    inversion k1; subst; sp.
  - apply wf_fix; auto.
Qed.

Lemma isprog_vars_fix {p} :
  forall (a : @NTerm p) vs,
    isprog_vars vs (mk_fix a) <=> isprog_vars vs a.
Proof.
  introv.
  repeat (rw @isprog_vars_eq; simpl).
  repeat (rw @remove_nvars_nil_l).
  rw @app_nil_r.
  allrw <- @wf_term_eq.
  allrw @wf_fix_iff; split; sp.
Qed.

Lemma isprog_vars_fix_implies {p} :
  forall (a : @NTerm p) vs,
    isprog_vars vs a
    -> isprog_vars vs (mk_fix a).
Proof.
  introv ispa.
  apply isprog_vars_fix; sp.
Qed.

Definition mkcv_fix {p} vs (t : @CVTerm p vs) : CVTerm vs :=
  let (a,x) := t in
    exist (isprog_vars vs) (mk_fix a) (isprog_vars_fix_implies a vs x).

Definition mkc_vbot {p} v : @CTerm p := mkc_fix (mkc_lam v (mkc_var v)).

Lemma isprog_get_cterm {o} :
  forall (t : @CTerm o), isprog (get_cterm t).
Proof.
  introv; destruct_cterms; auto.
Qed.
Hint Resolve isprog_get_cterm : slow.

(*
*** Local Variables:
*** coq-load-path: ("." "./close/")
*** End:
*)


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

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

Local Open Scope struct_scope.

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

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

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

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

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

Import DePoolSpec.LedgerClass.SolidityNotations.

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

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

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

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

Definition DePoolContract_Ф__returnOrReinvest_while (Л_chunkSize Л_round1ValidatorsElectedFor: XInteger) : LedgerT (ErrorValue True XInteger) :=
    ( WhileE ( ( ↑17 D2! LocalState_ι__returnOrReinvest_Л_startIndex ?< $ Л_chunkSize ) !&
    ( !¬ ( ( ↑17 D2! LocalState_ι__returnOrReinvest_Л_round2 ^^ RoundsBase_ι_Round_ι_stakes) ->empty ) ) )
 do
 (
 declareLocal {( Л_addr :>: XAddress , Л_stake :>: RoundsBase_ι_StakeValue )} := ( ↑17 U1! delMin LocalState_ι__returnOrReinvest_Л_round2 ^^ RoundsBase_ι_Round_ι_stakes ) (* ->get *) ;

 DePoolContract_Ф__returnOrReinvestForParticipant (!
          ↑17 D2! LocalState_ι__returnOrReinvest_Л_round2 ,
          ↑17 D2! LocalState_ι__returnOrReinvest_Л_round0 ,
          $ Л_addr ,
          $ Л_stake ,
          $ xBoolFalse ,
          $ Л_round1ValidatorsElectedFor !) >>=
 fun ea => xErrorMapDefaultF (fun a => (↑17 U1! {( LocalState_ι__returnOrReinvest_Л_round0 , LocalState_ι__returnOrReinvest_Л_round2 )} := $ a ) >> continue! (xValue I))
           ea (fun er => break! (xError er)))) >>=
     fun r => return! (xProdSnd r).

Definition DePoolContract_Ф__returnOrReinvest_tailer ( Л_chunkSize Л_round1ValidatorsElectedFor: XInteger) : LedgerT (XErrorValue RoundsBase_ι_Round XInteger ) :=
    do _ ← DePoolContract_Ф__returnOrReinvest_while Л_chunkSize Л_round1ValidatorsElectedFor ?;
    ( RoundsBase_Ф_setRound0 (! ↑17 D2! LocalState_ι__returnOrReinvest_Л_round0 !) ) >>
( If ( ( ↑17 D2! LocalState_ι__returnOrReinvest_Л_round2 ^^ RoundsBase_ι_Round_ι_stakes ) ->empty )
then
{
   (↑17 U1! LocalState_ι__returnOrReinvest_Л_round2 ^^ RoundsBase_ι_Round_ι_step :=
                      ξ$ RoundsBase_ι_RoundStepP_ι_Completed ) >>

    this->sendMessage ( $ DePoolContract_Ф_ticktockF ) with {|| messageValue ::= $ DePool_ι_VALUE_FOR_SELF_CALL ,
                                       messageBounce ::= $ xBoolFalse||}
   } ) >>
return!! ( ↑17 D2! LocalState_ι__returnOrReinvest_Л_round2 ) .

Definition DePoolContract_Ф__returnOrReinvest_header ( Л_round2 : RoundsBase_ι_Round ) ( Л_chunkSize : XInteger8 ) : LedgerT ( XErrorValue RoundsBase_ι_Round XInteger ) :=

( declareInit LocalState_ι__returnOrReinvest_Л_round2   := $ Л_round2 ) >>
tvm_accept () >>
( declareGlobal! LocalState_ι__returnOrReinvest_Л_round0 :>: RoundsBase_ι_Round := RoundsBase_Ф_getRound0 () ) >>
 U0! Л_round := ( RoundsBase_Ф_getRound1 () ) ;
 declareLocal Л_round1ValidatorsElectedFor :>: XInteger32 :=  $ Л_round ->> RoundsBase_ι_Round_ι_validatorsElectedFor ;
( declareGlobal! LocalState_ι__returnOrReinvest_Л_startIndex :>: XInteger := $ xInt0 ) >>
If!! ( !¬ ( ↑17 D1! ( D2! LocalState_ι__returnOrReinvest_Л_round2 ) ^^
            RoundsBase_ι_Round_ι_isValidatorStakeCompleted ) )
then
{
  ( ↑17 U1! LocalState_ι__returnOrReinvest_Л_round2 ^^
        RoundsBase_ι_Round_ι_isValidatorStakeCompleted := $ xBoolTrue ) >>
  declareLocal Л_optStake :>: (XMaybe RoundsBase_ι_StakeValue) := (D1! (↑17 D2! LocalState_ι__returnOrReinvest_Л_round2 ^^
                                                                           RoundsBase_ι_Round_ι_stakes)
         ->fetch ( ↑2 D2! ValidatorBase_ι_m_validatorWallet ) ) ;
   If! ( ( $ Л_optStake ) ->hasValue )
   then
   {
    declareLocal Л_stake :>: RoundsBase_ι_StakeValue := ( $ Л_optStake ) ->get ;
    ( ↑17 U1! LocalState_ι__returnOrReinvest_Л_startIndex := $ xInt1 ) >>
    ( ↑↑17 U2! delete LocalState_ι__returnOrReinvest_Л_round2 ^^
             RoundsBase_ι_Round_ι_stakes [[ ↑2 D2! ValidatorBase_ι_m_validatorWallet ]] ) >>
    U0! Л_rounds ?:=
        DePoolContract_Ф__returnOrReinvestForParticipant (!
         ↑17 D2! LocalState_ι__returnOrReinvest_Л_round2 ,
         ↑17 D2! LocalState_ι__returnOrReinvest_Л_round0 ,
         ↑2 D2! ValidatorBase_ι_m_validatorWallet ,
         $ Л_stake ,
         $ xBoolTrue ,
         $ Л_round1ValidatorsElectedFor !) ;
( ↑17 U1! {( LocalState_ι__returnOrReinvest_Л_round0 , LocalState_ι__returnOrReinvest_Л_round2 )} := $ Л_rounds )
   } ; $ I
} ;  DePoolContract_Ф__returnOrReinvest_tailer Л_chunkSize Л_round1ValidatorsElectedFor .

Lemma DePoolContract_Ф__returnOrReinvest_eq:
DePoolContract_Ф__returnOrReinvest = DePoolContract_Ф__returnOrReinvest_header.
Proof.
    unfold DePoolContract_Ф__returnOrReinvest.
    unfold DePoolContract_Ф__returnOrReinvest_header.
    unfold DePoolContract_Ф__returnOrReinvest_while.
    auto.
Qed.

Opaque DePoolContract_Ф__returnOrReinvest_while DePoolContract_Ф__returnOrReinvestForParticipant DePoolContract_Ф__returnOrReinvest_tailer.

Lemma DePoolContract_Ф__returnOrReinvest_header_exec : forall (Л_round2 : RoundsBase_ι_Round ) ( chunkSize : XInteger8 )
                                                        (l: Ledger) ,
let round2 := Л_round2 in
let la := exec_state tvm_accept l in
let round0 := eval_state (↓ RoundsBase_Ф_getRound0) la in
let round1 := eval_state (↓ RoundsBase_Ф_getRound1) la in
let round1ValidatorsElectedFor := round1 ->> RoundsBase_ι_Round_ι_validatorsElectedFor in
let if1 := negb (round2 ->> RoundsBase_ι_Round_ι_isValidatorStakeCompleted) in
let m_validatorWallet := eval_state (↑2 ε ValidatorBase_ι_m_validatorWallet) la in
let stakes :=  round2 ->> RoundsBase_ι_Round_ι_stakes in
let optStake := stakes ->fetch m_validatorWallet in
let if2 := isSome optStake in
let stake := maybeGet optStake in
let startIndex := if if1 then if if2 then 1 else 0 else 0 in
let stakes := if if1 then if if2 then stakes ->delete m_validatorWallet else stakes else stakes in
let round2 := if if1 then if if2 then
            {$round2 with (RoundsBase_ι_Round_ι_isValidatorStakeCompleted, true);
                          (RoundsBase_ι_Round_ι_stakes, stakes) $} else
            {$round2 with (RoundsBase_ι_Round_ι_isValidatorStakeCompleted, true) $} else
            round2 in
let newl := {$la With (LocalState_ι__returnOrReinvest_Л_round2, round2);
                      (LocalState_ι__returnOrReinvest_Л_round0, round0);
                      (LocalState_ι__returnOrReinvest_Л_startIndex, startIndex)  $} in

let (erounds, newl) := if if1 then
                            if if2 then
                            run (↓ DePoolContract_Ф__returnOrReinvestForParticipant round2 round0 m_validatorWallet stake true round1ValidatorsElectedFor) newl
                            else (Value (round0, round2), newl)
                      else (Value (round0, round2), newl) in
let ml1 := newl in
let bRounds := errorValueIsValue erounds in
let (round0, round2)  := errorMapDefault Datatypes.id erounds (round0, round2) in
let newl := {$newl With (LocalState_ι__returnOrReinvest_Л_round2, round2);
                        (LocalState_ι__returnOrReinvest_Л_round0, round0) $} in
let (eWhile, newl) := run (DePoolContract_Ф__returnOrReinvest_tailer chunkSize round1ValidatorsElectedFor) newl   in
let bl := exec_state (DePoolContract_Ф__returnOrReinvest_tailer chunkSize round1ValidatorsElectedFor) {$la With (LocalState_ι__returnOrReinvest_Л_startIndex, 0);
                                (LocalState_ι__returnOrReinvest_Л_round2, round2);
                                (LocalState_ι__returnOrReinvest_Л_round0, round0)  $} in
exec_state (DePoolContract_Ф__returnOrReinvest_header Л_round2 chunkSize) l =
if if1 then
    if if2 then
        if bRounds then newl
        else ml1
    else bl
else bl .
Proof.

    intros.
    destructLedger l.
    compute. idtac.

    Time repeat destructIf_solve2. idtac.
    all: try destructFunction6 DePoolContract_Ф__returnOrReinvestForParticipant; auto. idtac.
    all: try case_eq x; intros; auto. idtac.
    destructFunction2 DePoolContract_Ф__returnOrReinvest_tailer; auto. idtac.
    case_eq x0; intros; auto. idtac.
    destructFunction2 DePoolContract_Ф__returnOrReinvest_tailer; auto. idtac.
    destructFunction2 DePoolContract_Ф__returnOrReinvest_tailer; auto. idtac.
    destructFunction2 DePoolContract_Ф__returnOrReinvest_tailer; auto.

Qed.

Lemma DePoolContract_Ф__returnOrReinvest_header_eval : forall (Л_round2 : RoundsBase_ι_Round ) ( chunkSize : XInteger8 )
                                                        (l: Ledger) ,
let round2 := Л_round2 in
let la := exec_state tvm_accept l in
let round0 := eval_state (↓ RoundsBase_Ф_getRound0) la in
let round1 := eval_state (↓ RoundsBase_Ф_getRound1) la in
let round1ValidatorsElectedFor := round1 ->> RoundsBase_ι_Round_ι_validatorsElectedFor in
let if1 := negb (round2 ->> RoundsBase_ι_Round_ι_isValidatorStakeCompleted) in
let m_validatorWallet := eval_state (↑2 ε ValidatorBase_ι_m_validatorWallet) la in
let stakes :=  round2 ->> RoundsBase_ι_Round_ι_stakes in
let optStake := stakes ->fetch m_validatorWallet in
let if2 := isSome optStake in
let stake := maybeGet optStake in
let startIndex := if if1 then if if2 then 1 else 0 else 0 in
let stakes := if if1 then if if2 then stakes ->delete m_validatorWallet else stakes else stakes in
let round2 := if if1 then if if2 then
            {$round2 with (RoundsBase_ι_Round_ι_isValidatorStakeCompleted, true);
                          (RoundsBase_ι_Round_ι_stakes, stakes) $} else
            {$round2 with (RoundsBase_ι_Round_ι_isValidatorStakeCompleted, true) $} else
            round2 in
let newl := {$la With (LocalState_ι__returnOrReinvest_Л_round2, round2);
                      (LocalState_ι__returnOrReinvest_Л_round0, round0);
                      (LocalState_ι__returnOrReinvest_Л_startIndex, startIndex)  $} in

let (erounds, newl) := if if1 then
                            if if2 then
                            run (↓ DePoolContract_Ф__returnOrReinvestForParticipant round2 round0 m_validatorWallet stake true round1ValidatorsElectedFor) newl
                            else (Value (round0, round2), newl)
                      else (Value (round0, round2), newl) in
let ml1 := newl in
let bRounds := errorValueIsValue erounds in
let (round0, round2)  := errorMapDefault Datatypes.id erounds (round0, round2) in
let newl := {$newl With (LocalState_ι__returnOrReinvest_Л_round2, round2);
                        (LocalState_ι__returnOrReinvest_Л_round0, round0) $} in
let (eWhile, newl) := run (DePoolContract_Ф__returnOrReinvest_tailer chunkSize round1ValidatorsElectedFor) newl   in
let br := eval_state (DePoolContract_Ф__returnOrReinvest_tailer chunkSize round1ValidatorsElectedFor) {$la With (LocalState_ι__returnOrReinvest_Л_startIndex, 0);
                                (LocalState_ι__returnOrReinvest_Л_round2, round2);
                                (LocalState_ι__returnOrReinvest_Л_round0, round0)  $} in

eval_state (DePoolContract_Ф__returnOrReinvest_header Л_round2 chunkSize) l =
if if1 then
    if if2 then
        if bRounds then eWhile
        else errorMapDefaultF (fun _ => Value default) erounds (fun e => Error e)
    else br
else br .
Proof.

    intros.
    destructLedger l.
    compute. idtac.

    Time repeat destructIf_solve2. idtac.
    all: try destructFunction6 DePoolContract_Ф__returnOrReinvestForParticipant; auto. idtac.
    all: try case_eq x; intros; auto. idtac.
    destructFunction2 DePoolContract_Ф__returnOrReinvest_tailer; auto. idtac.
    case_eq x0; intros; auto. idtac.
    destructFunction2 DePoolContract_Ф__returnOrReinvest_tailer; auto. idtac.
    destructFunction2 DePoolContract_Ф__returnOrReinvest_tailer; auto. idtac.
    destructFunction2 DePoolContract_Ф__returnOrReinvest_tailer; auto.

Qed.

Transparent DePoolContract_Ф__returnOrReinvest_tailer.

Lemma DePoolContract_Ф__returnOrReinvest_tailer_exec : forall (chunkSize round1ValidatorsElectedFor : XInteger8 )
                                                        (l: Ledger) ,
let (eWhile, newl) := run (DePoolContract_Ф__returnOrReinvest_while chunkSize round1ValidatorsElectedFor) l in
let bWhile := errorValueIsValue eWhile in
let ml2 := newl in
let round0 := eval_state (↑17 ε LocalState_ι__returnOrReinvest_Л_round0) newl in
let round2 := eval_state (↑17 ε LocalState_ι__returnOrReinvest_Л_round2) newl in
let if3 : bool := xHMapIsNull (round2 ->> RoundsBase_ι_Round_ι_stakes)  in

let newl := exec_state (↓ RoundsBase_Ф_setRound0 round0) newl in
let round2 := if if3 then {$ round2 with (RoundsBase_ι_Round_ι_step, RoundsBase_ι_RoundStepP_ι_Completed) $}
                     else round2 in

let oldMessages := VMState_ι_messages ( Ledger_ι_VMState newl ) in
let newMessage  := {| contractAddress :=  0 ;
                      contractFunction := DePoolContract_Ф_ticktockF  ;
                      contractMessage := {| messageValue :=  DePool_ι_VALUE_FOR_SELF_CALL ;
                                            messageFlag  := 0 ;
                                            messageBounce := false
                                            |} |} in
let newl := if if3 then {$newl With (LocalState_ι__returnOrReinvest_Л_round2, round2);
                                    (VMState_ι_messages, newMessage :: oldMessages) $} else newl in
exec_state (DePoolContract_Ф__returnOrReinvest_tailer chunkSize round1ValidatorsElectedFor) l =
if bWhile then newl
else ml2.
Proof.

    intros.
    destructLedger l.
    compute. idtac.

    Time repeat destructIf_solve2. idtac.
    destructFunction2 DePoolContract_Ф__returnOrReinvest_while; auto. idtac.
    case_eq x; intros; auto. idtac.
    Time repeat destructIf_solve2.

Qed.

Lemma DePoolContract_Ф__returnOrReinvest_tailer_eval : forall (chunkSize round1ValidatorsElectedFor : XInteger8 )
                                                        (l: Ledger) ,
let (eWhile, newl) := run (DePoolContract_Ф__returnOrReinvest_while chunkSize round1ValidatorsElectedFor) l in
let bWhile := errorValueIsValue eWhile in
let ml2 := newl in
let round0 := eval_state (↑17 ε LocalState_ι__returnOrReinvest_Л_round0) newl in
let round2 := eval_state (↑17 ε LocalState_ι__returnOrReinvest_Л_round2) newl in
let if3 : bool := xHMapIsNull (round2 ->> RoundsBase_ι_Round_ι_stakes)  in

let newl := exec_state (↓ RoundsBase_Ф_setRound0 round0) newl in
let round2 := if if3 then {$ round2 with (RoundsBase_ι_Round_ι_step, RoundsBase_ι_RoundStepP_ι_Completed) $}
                     else round2 in

let oldMessages := VMState_ι_messages ( Ledger_ι_VMState newl ) in
let newMessage  := {| contractAddress :=  0 ;
                      contractFunction := DePoolContract_Ф_ticktockF  ;
                      contractMessage := {| messageValue :=  DePool_ι_VALUE_FOR_SELF_CALL ;
                                            messageFlag  := 0 ;
                                            messageBounce := false
                                            |} |} in
let newl := if if3 then {$newl With (LocalState_ι__returnOrReinvest_Л_round2, round2);
                                    (VMState_ι_messages, newMessage :: oldMessages) $} else newl in
eval_state (DePoolContract_Ф__returnOrReinvest_tailer chunkSize round1ValidatorsElectedFor) l =
if bWhile then Value round2
else errorMapDefaultF (fun _ => Value default) eWhile (fun e => Error e).
Proof.

    intros.
    destructLedger l.
    compute. idtac.

    Time repeat destructIf_solve2. idtac.
    destructFunction2 DePoolContract_Ф__returnOrReinvest_while; auto. idtac.
    case_eq x; intros; auto. idtac.
    Time repeat destructIf_solve2.

Qed.

End DePoolContract_Ф__returnOrReinvest.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Main.
From Categories Require Import Ext_Cons.Arrow.
From Categories Require Import Basic_Cons.Terminal.
From Categories Require Import Basic_Cons.Equalizer.
From Categories Require Import Basic_Cons.Facts.Equalizer_Monic.
From Categories Require Import Coq_Cats.Type_Cat.Card_Restriction.
From Categories Require Import Archetypal.Discr.Discr Archetypal.Discr.NatFacts.

From Categories Require Import Limits.GenProd_GenSum.
From Categories Require Import Limits.Limit.

Local Open Scope functor_scope.

Section GenProd_Eq_Complete.
  Context {C : Category}.

  Local Ltac ElimUnit := repeat match goal with [H : unit |- _] => destruct H end.

  Section GenProd_Eq_Limits.
    Context {J : Category}.

    Context {OProd : ∀ (map : J → C), (Π map)%object}
            {HProd : ∀ (map : (Arrow J) → C), (Π map)%object}
            {Eqs : Has_Equalizers C}
    .

    Section Limits_Exist.
      Context (D : J –≻ C).

      Local Notation DTarg := (fun f => (D _o (Targ f))%object) (only parsing).
      Local Notation DF := Discr_Func (only parsing).
      Local Notation OPR := (OProd (D _o)%object) (only parsing).
      Local Notation HPR := (HProd DTarg) (only parsing).

      Program Definition Projs_Cone : Cone (DF DTarg) :=
        {|
          cone_apex := Const_Func 1 (OPR _o tt);
          cone_edge := {|Trans := fun f => Trans (cone_edge OPR) (Targ f)|}
        |}.

      Definition Projs : (OPR –≻ HPR)%morphism :=
        Trans (LRKE_morph_ex HPR Projs_Cone) tt.

      Program Definition D_imgs_Cone : Cone (DF DTarg) :=
        {|
          cone_apex := Const_Func 1 (OPR _o tt);
          cone_edge :=
            {|
              Trans :=
                fun f =>
                  (D _a (Arr f) ∘ (Trans (cone_edge OPR) (Orig f)))%morphism
            |}
        |}.

      Definition D_imgs : (OPR –≻ HPR)%morphism :=
        Trans (LRKE_morph_ex HPR D_imgs_Cone) tt.

      Program Definition Lim_Cone : Cone D :=
        {|
          cone_apex := Const_Func 1 (Eqs _ _ Projs D_imgs);
          cone_edge :=
            {|Trans :=
                fun d => ((Trans (cone_edge OPR) d)
                         ∘ (equalizer_morph (Eqs _ _ Projs D_imgs)))%morphism
            |}
        |}.

      Next Obligation.
      Proof.
        simpl_ids.
        set (W :=
               f_equal
                 (fun t :
                        (((Const_Func 1 (((OProd (D _o)) _o) tt)%object)
                             ∘ (Functor_To_1_Cat (Discr_Cat (Arrow J))))
                          –≻ (DF DTarg))%nattrans
                  =>
                    ((Trans t {|Arr := h|})
                       ∘ (equalizer_morph (Eqs _ _ Projs D_imgs)))%morphism
                 )
                 (cone_morph_com (LRKE_morph_ex HPR D_imgs_Cone))
            ).
        set (W' :=
               f_equal
                 (fun t :
                        (((Const_Func 1 (((OProd (D _o)) _o) tt)%object)
                             ∘ (Functor_To_1_Cat (Discr_Cat (Arrow J))))
                          –≻ (DF DTarg))%nattrans
                  =>
                    (Trans t {|Arr := h|}
                           ∘ (equalizer_morph (Eqs _ _ Projs D_imgs)))%morphism
                 )
                 (cone_morph_com (LRKE_morph_ex HPR Projs_Cone))
            ).
        clearbody W W'.
        rewrite (assoc_sym _ _ ((D _a) h)).
        cbn in *.
        fold D_imgs in W.
        fold Projs in W'.
        rewrite W'.
        etransitivity; [|symmetry; apply W].
        clear W W'.
        repeat rewrite assoc.
        apply (
            f_equal
              (fun f =>
                 compose f
                         (Trans
                            (HProd (fun f : Arrow J => (D _o)%object (Targ f)))
                            {| Arr := h |}
                         )
              )
          ).
        apply (
            f_equal (
                fun f =>
                  compose f
                          (((HProd (fun f : Arrow J =>
                                      (D _o)%object (Targ f))) _a) tt)
              )
          ).
        apply equalizer_morph_com.
      Qed.

      Next Obligation.
      Proof.
        symmetry.
        apply Lim_Cone_obligation_1.
      Qed.

      Section Every_Cone_Equalizes.
        Context (Cn : Cone D).

        Local Hint Extern 1 => progress cbn.

        Program Definition Cone_to_DF_DCone : Cone (DF (D _o)%object) :=
          {|
            cone_apex := Cn;
            cone_edge :=
              @NatTrans_compose
                _ _
                (Cn ∘ (Functor_To_1_Cat (Discr_Cat J)))
                (Discr_Func ((Cn ∘ (Functor_To_1_Cat J))%functor _o)%object) _
                {|Trans := fun _ => id |} (Discretize (cone_edge Cn))
          |}.

        Definition From_Cone_to_OPR : (Cn –≻ OPR)%morphism :=
          Trans (LRKE_morph_ex OPR Cone_to_DF_DCone) tt.

        Program Definition Cone_to_DF_DTrag_Cone : Cone (DF DTarg) :=
          {|
            cone_apex := Cn;
            cone_edge := {|Trans :=
                             fun c => Trans (Discretize (cone_edge Cn)) (Targ c)|}
          |}.

        Program Definition Cone_Morph_From_Cone_to_DF_DTrag_Cone_to_HPR_1 :
          Cone_Morph _ Cone_to_DF_DTrag_Cone HPR :=
          {|
            cone_morph :=
              {|Trans :=
                  fun f =>
                    match f as u return (((Cn _o) u)%object –≻ (_ u))%morphism
                    with
                    | tt => (Projs ∘ From_Cone_to_OPR)%morphism
                    end
              |}
          |}.

        Next Obligation.
        Proof.
          ElimUnit.
          do 2 rewrite From_Term_Cat.
          auto.
        Qed.

        Next Obligation.
        Proof.
          symmetry.
          apply Cone_Morph_From_Cone_to_DF_DTrag_Cone_to_HPR_1_obligation_1.
        Qed.

        Next Obligation.
        Proof.
          apply NatTrans_eq_simplify.
          extensionality x; cbn.
          unfold Projs, From_Cone_to_OPR.
          set (H :=
                 f_equal
                   (fun w :
                        ((Projs_Cone
                            ∘ (Functor_To_1_Cat (Discr_Cat (Arrow J)))
                         ) –≻ (DF DTarg))%nattrans
                    =>
                      (
                        (Trans w x)
                          ∘ (Trans
                               (LRKE_morph_ex
                                  (OProd (D _o)%object) Cone_to_DF_DCone) tt)
                      )%morphism
                   )
                   (
                     cone_morph_com
                       (
                         LRKE_morph_ex
                           (HProd (fun f : Arrow J => (D _o)%object (Targ f)))
                           Projs_Cone
                       )
                   )
              );
            clearbody H; cbn in H.
          repeat rewrite assoc_sym in H.
          repeat rewrite assoc_sym.
          etransitivity; [|apply H]; clear H.
          set (H :=
                 f_equal
                   (
                     fun w :
                         ((Cone_to_DF_DCone
                             ∘ (Functor_To_1_Cat (Discr_Cat J))
                          ) –≻ (DF (D _o)%object))%nattrans
                     =>
                       Trans w (Targ x)
                   )
                   (cone_morph_com (LRKE_morph_ex
                                      (OProd (D _o)%object) Cone_to_DF_DCone))
              ).
          cbn in *.
          rewrite From_Term_Cat in H; simpl_ids in H.
          trivial.
        Qed.

        Program Definition Cone_Morph_From_Cone_to_DF_DTrag_Cone_to_HPR_2 :
          Cone_Morph _ Cone_to_DF_DTrag_Cone HPR :=
          {|
            cone_morph :=
              {|Trans :=
                  fun f =>
                    match f as u return (((Cn _o)%object u) –≻ (_ u))%morphism
                    with
                    | tt => (D_imgs ∘ From_Cone_to_OPR)%morphism
                    end
              |}
          |}.

        Next Obligation.
        Proof.
          ElimUnit.
          do 2 rewrite From_Term_Cat; simpl_ids; trivial.
        Qed.

        Next Obligation.
        Proof.
          symmetry.
          apply Cone_Morph_From_Cone_to_DF_DTrag_Cone_to_HPR_2_obligation_1.
        Qed.

        Next Obligation.
        Proof.
          apply NatTrans_eq_simplify.
          extensionality x.
          cbn.
          unfold D_imgs, From_Cone_to_OPR.
          set (H :=
                 f_equal
                   (
                     fun w :
                         ((D_imgs_Cone
                             ∘ (Functor_To_1_Cat (Discr_Cat (Arrow J)))
                          ) –≻ (DF DTarg))%nattrans
                     =>
                       (
                         (Trans w x)
                           ∘ (Trans
                                (LRKE_morph_ex
                                   (OProd (D _o)%object) Cone_to_DF_DCone)tt)
                       )%morphism
                   )
                   (
                     cone_morph_com
                       (LRKE_morph_ex
                          (HProd (fun f : Arrow J =>
                                    (D _o)%object (Targ f))) D_imgs_Cone )
                   )
              );
            clearbody H; cbn in H.
          repeat rewrite assoc_sym in H.
          repeat rewrite assoc_sym.
          etransitivity; [|apply H]; clear H.
          set (H :=
                 f_equal
                   (
                     fun w :
                         ((Cone_to_DF_DCone
                             ∘ (Functor_To_1_Cat (Discr_Cat J))
                          ) –≻ (DF (D _o)%object))%nattrans
                     =>
                       (((D _a) (Arr x)) ∘ (Trans w (Orig x)))%morphism
                   )
                   (cone_morph_com
                      (LRKE_morph_ex (OProd (D _o)%object) Cone_to_DF_DCone))
              );
            clearbody H; cbn in H.
          rewrite From_Term_Cat in H; simpl_ids in H.
          repeat rewrite assoc_sym in H.
          repeat rewrite assoc_sym.
          etransitivity; [|apply H]; clear H.
          cbn_rewrite <- (@Trans_com _ _ _ _ Cn).
          rewrite From_Term_Cat; auto.
        Qed.

        Lemma From_Cone_to_Obj_Prod_Equalizes :
          (Projs ∘ From_Cone_to_OPR = D_imgs ∘ From_Cone_to_OPR)%morphism.
        Proof.
          match goal with
            [|- ?A = ?B] =>
            change A with
            (Trans Cone_Morph_From_Cone_to_DF_DTrag_Cone_to_HPR_1 tt);
              change B with
              (Trans Cone_Morph_From_Cone_to_DF_DTrag_Cone_to_HPR_2 tt)
          end.
          match goal with
            [|- Trans ?A tt = Trans ?B tt] =>
            assert (A = B) as Heq; [|rewrite Heq]; trivial
          end.
          apply (LRKE_morph_unique HPR).
        Qed.

        Definition From_Cone_to_Lim_Cone : (Cn –≻ Lim_Cone)%morphism :=
          equalizer_morph_ex _  From_Cone_to_Obj_Prod_Equalizes.

        Program Definition Cone_Morph_to_Lim_Cone : Cone_Morph D Cn Lim_Cone :=
          {|
            cone_morph :=
              {|
                Trans :=
                  fun c =>
                    match c as u return ((Cn _o u)%object –≻ _)%morphism with
                      tt => From_Cone_to_Lim_Cone
                    end
              |}
          |}.

        Next Obligation.
        Proof.
          ElimUnit.
          rewrite From_Term_Cat; auto.
        Qed.

        Next Obligation.
          symmetry.
          apply Cone_Morph_to_Lim_Cone_obligation_1.
        Qed.

        Next Obligation.
        Proof.
          apply NatTrans_eq_simplify.
          extensionality x.
          unfold From_Cone_to_Lim_Cone.
          cbn in *.
          set (H :=
                 equalizer_morph_ex_com
                   (Eqs _ _ Projs D_imgs)
                   From_Cone_to_Obj_Prod_Equalizes
              );
            clearbody H; cbn in H.
          simpl_ids.
          rewrite assoc.
          match goal with
            [|- _ = (?A ∘ ?B)%morphism] =>
            replace B with From_Cone_to_OPR
          end.
          clear H.
          unfold From_Cone_to_OPR.
          set (H :=
                 f_equal
                   (
                     fun w :
                         ((Cone_to_DF_DCone ∘ (Functor_To_1_Cat (Discr_Cat J))
                          ) –≻ (DF (D _o)%object))%nattrans
                     =>
                       Trans w x
                   )
                   (cone_morph_com (LRKE_morph_ex
                                      (OProd (D _o)%object) Cone_to_DF_DCone))
              ).
          cbn in H.
          rewrite From_Term_Cat in H; simpl_ids in H.
          trivial.
        Qed.

      End Every_Cone_Equalizes.

      Section Cone_Morph_to_Lim_Cone_Cone_Morph_to_OPR.
        Context {Cn : Cone D} (h : Cone_Morph _ Cn Lim_Cone).

        Program Definition Cone_Morph_to_Lim_Cone_Cone_Morph_to_OPR :
          Cone_Morph _ (Cone_to_DF_DCone Cn) OPR :=
          {|
            cone_morph :=
              {|
                Trans :=
                  fun c =>
                    match c as u return
                          (((Cn _o) u)
                             –≻ (((OProd (D _o)) _o) u))%object%morphism
                    with
                    | tt => (equalizer_morph (Eqs _ _ Projs D_imgs)
                                            ∘ Trans h tt)%morphism
                    end
              |}
          |}.

        Next Obligation.
        Proof.
          ElimUnit.
          rewrite From_Term_Cat; auto.
        Qed.

        Next Obligation.
        Proof.
          symmetry.
          apply Cone_Morph_to_Lim_Cone_Cone_Morph_to_OPR_obligation_1.
        Qed.

        Next Obligation.
        Proof.
          apply NatTrans_eq_simplify.
          extensionality x.
          cbn.
          set (H :=
                 f_equal
                   (fun w : ((Cn ∘ (Functor_To_1_Cat J)) –≻ D)%nattrans =>
                      Trans w x)
                   (cone_morph_com h)
              ).
          cbn in H.
          simpl_ids in H.
          rewrite From_Term_Cat; simpl_ids.
          rewrite assoc in H.
          trivial.
        Qed.

      End Cone_Morph_to_Lim_Cone_Cone_Morph_to_OPR.

      Local Notation CMCOPR :=
        Cone_Morph_to_Lim_Cone_Cone_Morph_to_OPR (only parsing).

      Program Definition Lim_Cone_is_Limit : Limit D :=
        {|
          LRKE := Lim_Cone;
          LRKE_morph_ex := Cone_Morph_to_Lim_Cone
        |}.

      Next Obligation.
      Proof.
        set (H := LRKE_morph_unique
                    (OProd (D _o)%object) _ (CMCOPR h) (CMCOPR h')).
        apply (
            f_equal
              (fun w : ((Cone_to_DF_DCone Cn) –≻ (OProd (D _o)%object))%nattrans =>
                 Trans w tt)
          ) in H.
        cbn in H.
        apply NatTrans_eq_simplify.
        extensionality x; destruct x.
        apply (@mono_morphism_monomorphic
                 _ _ _ (@Equalizer_Monic _ _ _ _ _ (Eqs _ _ Projs D_imgs))).
        trivial.
      Qed.

    End Limits_Exist.
  End GenProd_Eq_Limits.

  Section Restricted_Limits.
    Context (P : Card_Restriction)
            {CHRP : ∀ (A : Type) (map : A → C), (P A) → (Π map)%object}
            {HE : Has_Equalizers C}
    .

    Definition Restr_GenProd_Eq_Restr_Limits : Has_Restr_Limits C P :=
      fun J D PJ PA =>
        @Lim_Cone_is_Limit
          J
          (fun map => CHRP J map PJ)
          (fun map => CHRP (Arrow J) map PA)
          HE
          D
    .

  End Restricted_Limits.

  Section Complete.
    Context {CHAP : ∀ (A : Type) (map : A → C), (Π map)%object}
            {HE : Has_Equalizers C}.

    Definition GenProd_Eq_Complete : Complete C :=
      fun J =>
        Local_to_Global_Right
          _
          _
          (fun D => @Lim_Cone_is_Limit J (CHAP J) (CHAP (Arrow J)) HE D)
    .

  End Complete.

End GenProd_Eq_Complete.

Section GenSum_CoEq_Complete.
  Context {C : Category}.

  Section GenSum_CoEq_CoLimits.
    Context {J : Category}
            {OSum : ∀ (map : J → C), (Σ map)%object}
            {HSum : ∀ (map : (Arrow J) → C), (Σ map)%object}
            {Eqs : Has_CoEqualizers C}
    .

    Section Limits_Exist.
      Context (D : J –≻ C).

      Program Definition CoLim_CoCone_is_CoLimit : CoLimit D :=
        @Lim_Cone_is_Limit
          (C^op)
          (J^op)
          (fun map => GenSum_to_GenProd (OSum map))
          (fun map => GenSum_to_GenProd (GenSum_IsoType (Arrow_OP_Iso J) HSum map))
          Eqs
          (Opposite_Functor D)
      .

    End Limits_Exist.
  End GenSum_CoEq_CoLimits.

  Section Restricted_CoLimits.
    Context (P : Card_Restriction)
            {CHRP : ∀ (A : Type) (map : A → C), (P A) → (Σ map)%object}
            {HE : Has_CoEqualizers C}
    .

    Definition Restr_GenSum_CoEq_Restr_CoLimits : Has_Restr_CoLimits C P :=
      fun J D PJ PA =>
        @CoLim_CoCone_is_CoLimit
          J
          (fun map => CHRP J map PJ)
          (fun map => CHRP (Arrow J) map PA)
          HE
          D
    .

  End Restricted_CoLimits.

  Section CoComplete.
    Context {CHAP : ∀ (A : Type) (map : A → C), (Σ map)%object}
            {HE : Has_CoEqualizers C}
    .

    Definition GenSum_CoEq_CoComplete : CoComplete C :=
      fun J =>
        Local_to_Global_Left
          _
          _
          (fun D => @CoLim_CoCone_is_CoLimit J (CHAP J) (CHAP (Arrow J)) HE D)
    .

  End CoComplete.

End GenSum_CoEq_Complete.


From RecordUpdate Require Import RecordSet.

From Perennial.goose_lang Require Import crash_modality.
From Perennial.program_logic Require Import atomic.

From Goose.github_com.mit_pdos.perennial_examples Require Import async_mem_alloc_inode.

(* TODO: alloc_crash_proof must be imported early since otherwise it messes up a
bunch of things, like Z_scope, encode, and val *)
From Perennial.algebra Require Import own_discrete.
From Perennial.program_proof.examples Require Import alloc_crash_proof.
From Perennial.goose_lang.lib Require Import lock.crash_lock.
From Perennial.program_proof Require Import async_disk_prelude.
From Perennial.goose_lang.lib Require Import into_val typed_slice.
From Perennial.goose_lang Require Import crash_borrow.

From Perennial.program_proof Require Import async_marshal_block async_disk_lib.

Definition InodeMaxBlocks: Z := 511.

Module inode.
  Record t :=
    mk { (* addresses consumed by this inode *)
         addrs: gset u64;
         blocks: list Block; }.
  Global Instance _eta: Settable _ := settable! mk <addrs; blocks>.
  Global Instance _witness: Inhabited t := populate!.

  Definition wf σ := length σ.(blocks) ≤ InodeMaxBlocks.
  Definition size σ := length σ.(blocks).
End inode.

#[global]
Hint Unfold inode.wf InodeMaxBlocks : word.

Section goose.
Context `{!heapGS Σ}.
Context `{!stagedG Σ}.
Context `{!allocG Σ}.

(* The client picks the namespaces that we use for everything. *)
Context (inodeN allocN: namespace).

Implicit Types (σ: inode.t) (addr: u64).
Implicit Types (l:loc) (γ:gname) (P: inode.t → iProp Σ).

Definition is_inode_durable addr σ (addrs: list u64) : iProp Σ :=
  ∃ (hdr: Block),
    "%Hwf" ∷ ⌜inode.wf σ⌝ ∗
    "%Hencoded" ∷ ⌜block_encodes hdr ([EncUInt64 (length addrs)] ++ (EncUInt64 <$> addrs))⌝ ∗
    "%Haddrs_set" ∷ ⌜list_to_set addrs = σ.(inode.addrs)⌝ ∗
    "Hhdr" ∷ int.Z addr d↦[hdr] hdr ∗
    (* TODO: this does not support reading lock-free; we could make it [∃ q,
    int.Z a d↦{q} b], but that wouldn't support lock-free writes if we
    implemented those *)
    "Hdata" ∷ [∗ list] a;b ∈ addrs;σ.(inode.blocks), int.Z a d↦[b] b
.
Local Hint Extern 1 (environments.envs_entails _ (is_inode_durable _ _ _)) => unfold is_inode_durable : core.

Theorem is_inode_durable_read addr σ addrs :
  is_inode_durable addr σ addrs -∗
    ∃ hdr,
      "%Hwf" ∷ ⌜inode.wf σ⌝ ∗
      "%Hencoded" ∷ ⌜block_encodes hdr ([EncUInt64 (length addrs)] ++ (EncUInt64 <$> addrs))⌝ ∗
      "%Haddrs_set" ∷ ⌜list_to_set addrs = σ.(inode.addrs)⌝ ∗
      "Hhdr" ∷ int.Z addr d↦[hdr] hdr ∗
      "Hdata" ∷ ([∗ list] a;b ∈ addrs;σ.(inode.blocks), int.Z a d↦[b] b) ∗
      "Hdurable" ∷ □(int.Z addr d↦[hdr] hdr -∗
                    ([∗ list] a;b ∈ addrs;σ.(inode.blocks), int.Z a d↦[b] b) -∗
                   is_inode_durable addr σ addrs).
Proof.
  iNamed 1.
  iExists _; iFrame "∗ %".
  iIntros "!> Hhdr Hdata".
  iExists _; iFrame "∗ %".
Qed.

Definition inode_linv (l:loc) (addr:u64) σ : iProp Σ :=
  ∃ (addr_s: Slice.t) (addrs: list u64),
    "%Hwf" ∷ ⌜inode.wf σ⌝ ∗
    "Hdurable" ∷ is_inode_durable addr σ addrs ∗
    "addrs" ∷ l ↦[Inode :: "addrs"] (slice_val addr_s) ∗
    "Haddrs" ∷ is_slice addr_s uint64T 1 addrs
.
Local Hint Extern 1 (environments.envs_entails _ (inode_linv _ _ _)) => unfold inode_linv : core.

Definition inode_cinv_precrash addr σ: iProp Σ :=
  ∃ addrs (hdr hdrm: Block),
    "%Hwf" ∷ ⌜inode.wf σ⌝ ∗
    "%Hencoded" ∷ ⌜block_encodes hdr ([EncUInt64 (length addrs)] ++ (EncUInt64 <$> addrs))⌝ ∗
    "%Haddrs_set" ∷ ⌜list_to_set addrs = σ.(inode.addrs)⌝ ∗
    "Hhdr" ∷ int.Z addr d↦[hdr] hdrm ∗
    (* TODO: this does not support reading lock-free; we could make it [∃ q,
    int.Z a d↦{q} b], but that wouldn't support lock-free writes if we
    implemented those *)
    "Hdata" ∷ [∗ list] a;b ∈ addrs;σ.(inode.blocks), int.Z a d↦[b] b.

Definition inode_cinv_postcrash addr σ : iProp Σ :=
  ∃ addrs, is_inode_durable addr σ addrs.

Local Hint Extern 1 (environments.envs_entails _ (inode_cinv_precrash _ _)) => unfold inode_cinv_precrash : core.
Local Hint Extern 1 (environments.envs_entails _ (inode_cinv_postcrash _ _)) => unfold inode_cinv_postcrash : core.

Definition inode_state l d (lref: loc) addr : iProp Σ :=
  "#d" ∷ readonly (l ↦[Inode :: "d"] (disk_val d)) ∗
  "#m" ∷ readonly (l ↦[Inode :: "m"] #lref) ∗
  "#addr" ∷ readonly (l ↦[Inode :: "addr"] #addr).

Definition is_inode l P (addr: u64) : iProp Σ :=
  ∃ d (lref: loc),
    "Hro_state" ∷ inode_state l d lref addr ∗
    "#Hlock" ∷ is_crash_lock inodeN #lref
              (∃ σ, "Hlockinv" ∷ inode_linv l addr σ ∗ "HP" ∷ P σ)
              (∃ σ, "Hlockcinv" ∷ inode_cinv_precrash addr σ ∗ "HP" ∷ P σ).

Definition pre_inode l addr σ : iProp Σ :=
  ∃ d (lref: loc),
    "Hro_state" ∷ inode_state l d lref addr ∗
    "Hfree_lock" ∷ is_free_crash_lock lref ∗
    "Hlockinv" ∷ inode_linv l addr σ.

Global Instance is_inode_crash l addr σ :
  IntoCrash (inode_linv l addr σ) (λ _, ∃ addrs, is_inode_durable addr σ addrs)%I.
Proof.
  hnf; iIntros "Hinv".
  iNamed "Hinv".
  iExists addrs.
  iFrame.
  auto.
Qed.

Theorem inode_durable_to_cinv addr σ addrs :
  is_inode_durable addr σ addrs -∗ inode_cinv_precrash addr σ.
Proof.
  iNamed 1.
  iExists _; iFrame. iExists _, _. iFrame. eauto.
Qed.

Theorem inode_linv_to_cinv l addr σ :
  inode_linv l addr σ -∗ inode_cinv_precrash addr σ.
Proof.
  iNamed 1.
  iNamed "Hdurable".
  iExists _; iFrame.
  iExists _, _. iFrame. eauto.
Qed.

Theorem inode_linv_to_cinv' l addr σ :
  inode_linv l addr σ -∗ inode_cinv_postcrash addr σ.
Proof. iNamed 1. iExists _; iFrame. Qed.

Theorem pre_inode_to_cinv l addr σ :
  pre_inode l addr σ -∗ inode_cinv_precrash addr σ.
Proof. iNamed 1. iApply inode_linv_to_cinv; iFrame. Qed.

Theorem pre_inode_to_cinv' l addr σ :
  pre_inode l addr σ -∗ inode_cinv_postcrash addr σ.
Proof. iNamed 1. iApply inode_linv_to_cinv'; iFrame. Qed.

Theorem inode_cinv_post_to_pre addr σ :
  inode_cinv_postcrash addr σ -∗ inode_cinv_precrash addr σ.
Proof. iNamed 1. iExists _, _, _. eauto with iFrame. Qed.

Global Instance is_inode_Persistent l P addr :
  Persistent (is_inode l P addr).
Proof. apply _. Qed.

(* to initialize the system, we use this theorem to turn a zero block into a
valid post-crash inode state, which we can then recover with the usual [Open]
recovery procedure. *)
Theorem init_inode addr :
  int.Z addr d↦[block0] block0 -∗ inode_cinv_postcrash addr (inode.mk ∅ []).
Proof.
  iIntros "Hhdr".
  iExists [], block0.
  cbv [inode.blocks big_sepL2].
  iFrame "Hhdr".
  iPureIntro.
  split_and!.
  - rewrite /inode.wf /=.
    cbv; congruence.
  - reflexivity.
  - reflexivity.
Qed.

Theorem is_inode_alloc l P addr σ :
  P σ -∗
  pre_inode l addr σ ==∗
  init_cancel (is_inode l P addr)
             (∃ σ', inode_cinv_precrash addr σ' ∗ P σ').
Proof.
  iIntros "HP Hinode"; iNamed "Hinode".
  iDestruct (alloc_crash_lock_init_cancel inodeN _
                           (∃ σ, "Hlockinv" ∷ inode_linv l addr σ ∗ "HP" ∷ P σ)%I
                           (∃ σ, "Hlockcinv" ∷ inode_cinv_precrash addr σ ∗ "HP" ∷ P σ)%I
            with "[$Hfree_lock Hlockinv HP]") as "H".
  { iSplitL "".
    * iModIntro. iIntros "H". iNamed "H".
      iExists _; iFrame.
      iApply inode_linv_to_cinv; auto.
    * iExists _. eauto with iFrame.
  }
  iApply (init_cancel_wand with "H [Hro_state]").
  { iIntros "H". iExists _, _; iFrame. }
  { eauto with iFrame. }
Qed.

Theorem wpc_Open {d} {addr σ} :
  {{{ inode_cinv_postcrash addr σ }}}
    async_mem_alloc_inode.Open (disk_val d) #addr @ ⊤
  {{{ l, RET #l; pre_inode l addr σ }}}
  {{{ inode_cinv_precrash addr σ }}}.
Proof.
  iIntros (Φ Φc) "Hinode HΦ"; iNamed "Hinode".
  iAssert (□ (int.Z addr d↦[hdr] hdr ∗
              ([∗ list] a;b ∈ addrs;σ.(inode.blocks), int.Z a d↦[b] b) -∗
              inode_cinv_precrash addr σ))%I as "#Hinode".
  { eauto 10 with iFrame. }
  iDestruct (big_sepL2_length with "Hdata") as %Hblocklen.
  rewrite /Open.
  wpc_pures.
  { iLeft in "HΦ". iApply "HΦ". iApply ("Hinode" with "[$]"). }
  iCache with "HΦ Hhdr Hdata".
  { crash_case. iApply ("Hinode" with "[$]"). }
  wpc_pures.
  wpc_apply (wpc_Read with "Hhdr").
  iSplit; [ | iNext ].
  { iLeft in "HΦ". iIntros "Hhdr". iApply "HΦ". iApply ("Hinode" with "[$]"). }
  iIntros (s) "(Hhdr&Hs)".
  wpc_frame.
  wp_pures.
  iDestruct (slice.is_slice_to_small with "Hs") as "Hs".
  wp_apply (wp_new_dec with "Hs"); first eauto.
  iIntros (dec) "Hdec".
  wp_apply (wp_Dec__GetInt with "Hdec"); iIntros "Hdec".
  wp_pures.
  wp_apply (wp_Dec__GetInts _ _ _ addrs [] with "[Hdec]").
  { rewrite Hblocklen. word. }
  { rewrite app_nil_r; iFrame. }
  iIntros (addr_s) "[_ Haddrs]".
  wp_pures.
  rewrite -wp_fupd.
  wp_apply wp_new_free_crash_lock.
  iIntros (lref) "Hlock".
  wp_apply wp_allocStruct; first val_ty.
  iIntros (l) "inode".
  iDestruct (struct_fields_split with "inode") as "(d&m&addr&addrs&_)".
  iMod (readonly_alloc_1 with "d") as "#d".
  iMod (readonly_alloc_1 with "m") as "#m".
  iMod (readonly_alloc_1 with "addr") as "#addr".
  iModIntro.
  iNamed 1.
  iApply "HΦ".
  iExists _, _; iFrame.
  iSplitR.
  { iFrame "#". }
  iExists _, _; iFrame "% ∗".
  iExists _; iFrame "% ∗".
Qed.

Theorem is_inode_durable_addrs addr σ addrs :
  is_inode_durable addr σ addrs -∗
  ⌜list_to_set addrs = σ.(inode.addrs)⌝.
Proof.
  iNamed 1.
  iFrame "%".
Qed.

Theorem is_inode_durable_size addr σ addrs :
  is_inode_durable addr σ addrs -∗ ⌜length addrs = length σ.(inode.blocks)⌝.
Proof.
  iNamed 1.
  iDestruct (big_sepL2_length with "Hdata") as "$".
Qed.

Definition used_blocks_pre l σ addrs: iProp Σ :=
  ∃ addr_s,
    "%Haddr_set" ∷ ⌜list_to_set addrs = σ.(inode.addrs)⌝ ∗
    "addrs" ∷ l ↦[Inode :: "addrs"] (slice_val addr_s) ∗
    "Haddrs" ∷ is_slice addr_s uint64T 1 addrs.

(* this lets the caller frame out the durable state for the crash invariant and
the memory state for UsedBlocks *)
Theorem pre_inode_read_addrs l addr σ :
  pre_inode l addr σ -∗
  ∃ addrs, used_blocks_pre l σ addrs ∗
           is_inode_durable addr σ addrs ∗
           (used_blocks_pre l σ addrs -∗
            is_inode_durable addr σ addrs -∗
            pre_inode l addr σ).
Proof.
  iNamed 1.
  iNamed "Hlockinv".
  iDestruct (is_inode_durable_addrs with "Hdurable") as "%Haddr_set".
  iExists addrs.
  iSplitL "addrs Haddrs".
  { iExists _; iFrame "% ∗". }
  iFrame.
  iNamed 1.
  iIntros "Hdurable".
  iExists _, _; iFrame.
  iExists _, _; iFrame "∗ %".
Qed.

Theorem wp_Inode__UsedBlocks {l σ addrs} :
  {{{ used_blocks_pre l σ addrs }}}
    Inode__UsedBlocks #l
  {{{ (s:Slice.t), RET (slice_val s);
      is_slice s uint64T 1 addrs ∗
      ⌜list_to_set addrs = σ.(inode.addrs)⌝ ∗
      (is_slice s uint64T 1 addrs -∗ used_blocks_pre l σ addrs) }}}.
Proof.
  iIntros (Φ) "Hinode HΦ"; iNamed "Hinode".
  wp_call.
  wp_loadField.
  iApply "HΦ".
  iFrame "∗ %".
  iIntros "Haddrs".
  iExists _; iFrame.
Qed.

Theorem wpc_Inode__UsedBlocks {l σ addr} :
  {{{ pre_inode l addr σ  }}}
    Inode__UsedBlocks #l @ ⊤
  {{{ (s:Slice.t) (addrs: list u64), RET (slice_val s);
      is_slice s uint64T 1 addrs ∗
      ⌜list_to_set addrs = σ.(inode.addrs)⌝ ∗
      (is_slice s uint64T 1 addrs -∗ pre_inode l addr σ) ∧ inode_cinv_precrash addr σ }}}
  {{{ inode_cinv_precrash addr σ }}}.
Proof.
  iIntros (Φ Φc) "Hinode HΦ"; iNamed "Hinode".
  (* TODO: wpc_call is broken here (maybe because the only redex is an App) *)
  rewrite /Inode__UsedBlocks.
  wpc_pures.
  { iLeft in "HΦ". iApply "HΦ". iApply inode_linv_to_cinv; eauto. }
  iNamed "Hlockinv".
  wpc_frame "HΦ Hdurable".
  { crash_case. iNamed "Hdurable". iExists _, _, _. eauto with iFrame. }
  wp_loadField.
  iNamed 1.
  iApply "HΦ".
  iFrame "Haddrs".
  iDestruct (is_inode_durable_addrs with "Hdurable") as "%Haddr_set".
  iSplitR; first auto.
  iSplit.
  - iIntros "Haddrs".
    iExists _, _; iFrame.
    iExists _, _; iFrame "∗ %".
  - iNamed "Hdurable". iExists _, _, _; eauto with iFrame.
Qed.

Ltac crash_lock_open H :=
  lazymatch goal with
  | [ |- envs_entails _ (wpc _ _ _ _ _) ] =>
    match iTypeOf H with
    | Some (_, crash_locked _ _ _ _) =>
      iApply (use_crash_locked with H);
      [ try eauto
      | iSplit; [ try iFromCache | ]
      ]
    | Some (_, _) => fail 1 "crash_lock_open:" H "is not a crash_locked fact"
    | None => fail 1 "crash_lock_open:" H "not found"
    end
  | _ => fail 1 "crash_lock_open: not a wpc"
  end.

Theorem wpc_Inode__Read {l P addr} {off: u64} :
  ⊢ {{{ "Hinode" ∷ is_inode l P addr }}}
    <<{ ∀∀ σ mb, ⌜mb = σ.(inode.blocks) !! int.nat off⌝ ∗ P σ }>>
      Inode__Read #l #off @ ∅
    <<{ P σ }>>
    {{{ s, RET (slice_val s); match mb with Some b => is_block s 1 b | None => ⌜s = Slice.nil⌝ end }}}
    {{{ True }}}.
Proof.
  iIntros (Φ Φc) "!# Hpre Hfupd"; iNamed "Hpre".
  iNamed "Hinode". iNamed "Hro_state".
  wpc_call; [done..|].
  iCache with "Hfupd"; first by crash_case.
  wpc_pures.
  wpc_bind_seq.
  wpc_frame.
  wp_loadField.
  wp_apply (crash_lock.acquire_spec with "Hlock"); first by set_solver.
  iIntros "His_locked".
  iNamed 1.
  wpc_pures.
  wpc_bind_seq.
  crash_lock_open "His_locked".
  (* XXX: todo, iNamed needs to be better about later *)
  iIntros "H". iDestruct "H" as (?) "(H1&HP)". iNamed "H1".
  iEval (rewrite /named) in "HP".

  iEval (rewrite ->(left_id True bi_wand)%I) in "Hfupd".
  iCache with "Hfupd Hlockinv HP".
  { iLeft in "Hfupd". iFrame. iExists _; iFrame. iApply inode_linv_to_cinv; eauto. }
  wpc_call.
  wpc_bind (_ ≥ _)%E.
  iNamed "Hlockinv".
  iCache with "Hfupd HP Hdurable".
  { iLeft in "Hfupd". iFrame. iExists _. iFrame.
    iNamed "Hdurable".
    iExists _, _, _. eauto 10 with iFrame. }
  iDestruct (is_inode_durable_size with "Hdurable") as %Hlen1.
  wpc_frame.
  wp_loadField.
  iDestruct (is_slice_sz with "Haddrs") as %Hlen2.
  autorewrite with len in Hlen2.
  wp_apply wp_slice_len.
  wp_pures. iModIntro.
  iNamed 1.
  wpc_if_destruct.
  - iApply ncfupd_wpc.
    iSplit.
    { iLeft in "Hfupd". iDestruct (inode_durable_to_cinv with "[$]") as "?". eauto 12 with iFrame. }
    iRight in "Hfupd".

    rewrite difference_empty_L.
    iMod ("Hfupd" $! σ None with "[$HP]") as "[HP HQ]".
    { iPureIntro.
      rewrite lookup_ge_None_2 //.
      lia. }
    iModIntro.
    iEval (rewrite ->(left_id True bi_wand)%I) in "HQ".
    wpc_pures.
    { iLeft in "HQ". iDestruct (inode_durable_to_cinv with "[$]") as "?". eauto 12 with iFrame. }
    iModIntro.
    iSplitR "HP addrs Haddrs Hdurable"; last first.
    { eauto 10 with iFrame. }
    iIntros "His_locked".
    iSplit; first by iLeft in "HQ". (* TODO(Ralf): can we avoid this double-proof? *)
    iCache with "HQ"; first by iLeft in "HQ".
    wpc_pures.
    wpc_frame "HQ".
    wp_loadField.
    wp_apply (crash_lock.release_spec with "His_locked"); auto.
    wp_pures. iModIntro.
    iNamed 1.
    iRight in "HQ".
    change slice.nil with (slice_val Slice.nil).
    iApply "HQ"; by iFrame.
  - destruct (list_lookup_lt _ addrs (int.nat off)) as [addr' Hlookup].
    { word. }
    iDestruct (is_slice_split with "Haddrs") as "[Haddrs_small Haddrs]".
    wpc_pures.
    wpc_frame_seq.
    wp_loadField.
    wp_apply (wp_SliceGet _ _ _ _ _ addrs with "[$Haddrs_small //]").
    iIntros "Haddrs_small"; iNamed 1.
    wpc_pures.
    iApply ncfupd_wpc.
    iSplit.
    { iLeft in "Hfupd". iDestruct (inode_durable_to_cinv with "[$]") as "?".
      eauto 10 with iFrame. }
    iDestruct (is_inode_durable_read with "Hdurable") as "H"; iNamed "H".
    iDestruct (big_sepL2_lookup_1_some with "Hdata") as "%Hblock_lookup"; eauto.
    destruct Hblock_lookup as [b0 Hlookup2].
    iDestruct (is_slice_split with "[$Haddrs_small $Haddrs]") as "Haddrs".
    iDestruct (big_sepL2_lookup_acc with "Hdata") as "[Hb Hdata]"; eauto.
    iRight in "Hfupd".
    rewrite difference_empty_L.
    iMod ("Hfupd" $! σ with "[$HP]") as "[HP HQ]".
    { iPureIntro; eauto. }
    iEval (rewrite ->(left_id True bi_wand)%I) in "HQ".
    iApply wpc_fupd. iModIntro.
    wpc_apply (wpc_Read with "Hb").
    iSplit.
    { iLeft in "HQ". iIntros "Hda".
      iSpecialize ("Hdata" with "Hda").
      iSpecialize ("Hdurable" with "Hhdr Hdata").
      iDestruct (inode_durable_to_cinv with "[$]") as "?".
      eauto 10 with iFrame. }
    iIntros "!>" (s) "[Hda Hb]".
    iSpecialize ("Hdata" with "Hda").
    iSpecialize ("Hdurable" with "Hhdr Hdata").
    iSplitR "Hdurable addrs Haddrs HP"; last first.
    { eauto 10 with iFrame. }
    iModIntro.
    iIntros "His_locked".
    iSplit; first by iLeft in "HQ". (* TODO(Ralf): can we avoid this double-proof? *)
    iCache with "HQ"; first by iLeft in "HQ".
    wpc_frame.
    wp_loadField.
    wp_apply (crash_lock.release_spec with "His_locked"); auto.
    wp_pures. iModIntro.
    iNamed 1.
    iApply "HQ".
    iFrame.
    rewrite Hlookup2.
    iDestruct (slice.is_slice_to_small with "Hb") as "Hb".
    by iFrame.
Qed.

Theorem wpc_Inode__Read_triple {l P addr} {off: u64} Q :
  {{{ "Hinode" ∷ is_inode l P addr ∗
      "Hfupd" ∷ (∀ σ σ' mb,
        ⌜σ' = σ ∧ mb = σ.(inode.blocks) !! int.nat off⌝ ∗
        P σ ={⊤}=∗ P σ' ∗ Q mb)
  }}}
    Inode__Read #l #off @ ⊤
  {{{ s mb, RET slice_val s;
      (match mb with
       | Some b => is_block s 1 b
       | None => ⌜s = Slice.nil⌝
       end) ∗ Q mb }}}
  {{{ True }}}.
Proof.
  iIntros (Φ Φc) "Hpre HΦ"; iNamed "Hpre".
  iApply (wpc_step_strong_mono _ _ _ _ _
         (λ v, (∃ s mb, ⌜ v = slice_val s ⌝ ∗
                match mb with
                | Some b => is_block s 1 b
                | None => ⌜s = Slice.nil⌝
                end ∗ Q mb))%I _ True with "[-HΦ] [HΦ]"); auto.
  2: { iSplit.
       * iNext. iIntros (?) "H". iDestruct "H" as (??) "(%&?)". subst.
         iModIntro. iRight in "HΦ". by iApply "HΦ".
       * iLeft in "HΦ". iIntros. iModIntro. by iApply "HΦ". }
  iApply (wpc_Inode__Read with "Hinode").
  iSplit; first done.
  rewrite difference_empty_L.
  iNext. iIntros (σ mb) "[%Hσ HP]". iMod ("Hfupd" with "[$HP //]") as "[HP HQ]".
  iModIntro.  iFrame "HP". iSplit.
  { eauto. }
  iIntros (s) "Hblock". iExists _, _; iSplit; first done. iFrame; iApply "Hblock".
Qed.

Theorem wpc_Inode__Size {l P addr}:
  ⊢ {{{ "Hinode" ∷ is_inode l P addr }}}
    <<{ ∀∀ σ (sz: u64), ⌜int.nat sz = inode.size σ⌝ ∗ P σ }>>
      Inode__Size #l @ ∅
    <<{ P σ }>>
    {{{ RET #sz; True }}}
    {{{ True }}}.
Proof.
  iIntros (Φ Φc) "!# Hpre Hfupd"; iNamed "Hpre".
  iNamed "Hinode". iNamed "Hro_state".
  iEval (rewrite ->(left_id True bi_wand)%I) in "Hfupd".
  rewrite /Inode__Size.
  wpc_pures; first by iLeft in "Hfupd".
  iCache with "Hfupd"; first by iLeft in "Hfupd".
  wpc_frame_seq.
  wp_loadField.
  wp_apply (crash_lock.acquire_spec with "Hlock"); auto.
  iIntros "His_locked".
  iNamed 1.
  wpc_pures.
  wpc_bind_seq.
  crash_lock_open "His_locked".
  iDestruct 1 as (σ) "(Hlockinv&HP)".
  iApply ncfupd_wpc.
  iSplit.
  { iLeft in "Hfupd". iModIntro. iFrame. iExists _; iFrame.
    iApply inode_linv_to_cinv. eauto. }
  iEval (rewrite /named) in "HP".
  iNamed "Hlockinv".
  iNamed "Hlockinv".
  iDestruct (is_slice_sz with "Haddrs") as %Haddrs_sz.
  iDestruct (is_inode_durable_size with "Hdurable") as %Hblocks_length.

  iRight in "Hfupd".
  rewrite difference_empty_L.
  iMod ("Hfupd" $! σ addr_s.(Slice.sz) with "[$HP]") as "[HP HQ]".
  { iPureIntro.
    rewrite /inode.size.
    autorewrite with len in Haddrs_sz.
    rewrite -Haddrs_sz //. }

  iModIntro.
  iEval (rewrite ->!(left_id True bi_wand)%I) in "HQ".
  iCache with "HQ Hdurable HP".
  { iLeft in "HQ".
    iDestruct (inode_durable_to_cinv with "[$]") as "?".
    eauto 10 with iFrame. }
  iApply wpc_fupd.
  wpc_frame.
  wp_loadField.
  wp_apply wp_slice_len.
  iNamed 1.
  iSplitR "HP addrs Haddrs Hdurable"; last first.
  { eauto 10 with iFrame.  }
  iIntros "!> His_locked".
  iSplit; first by iLeft in "HQ".
  iCache with "HQ"; first by iLeft in "HQ".
  wpc_pures.
  wpc_frame.
  wp_loadField.
  wp_apply (crash_lock.release_spec with "His_locked"); auto.
  wp_pures.
  iModIntro. iNamed 1.
  iRight in "HQ". by iApply "HQ".
Qed.

Theorem wpc_Inode__Size_triple {l P addr} (Q: u64 -> iProp Σ) (Qc: iProp Σ) :
  {{{ "Hinode" ∷ is_inode l P addr ∗
      "HQc" ∷ (∀ a, Q a -∗ Qc) ∗
      "Hfupd" ∷ (Qc ∧ (∀ σ σ' sz,
          ⌜σ' = σ ∧ int.nat sz = inode.size σ⌝ ∗
          P σ ={⊤}=∗ P σ' ∗ Q sz))
  }}}
    Inode__Size #l @ ⊤
  {{{ sz, RET #sz; Q sz }}}
  {{{ Qc }}}.
Proof.
  iIntros (Φ Φc) "Hpre HΦ"; iNamed "Hpre".
  iApply (wpc_step_strong_mono _ _ _ _ _
         (λ v, ∃ (sz : u64), ⌜ v = #sz ⌝ ∗ Q sz)%I _ Qc with "[-HΦ] [HΦ]"); auto.
  2: { iSplit.
       * iNext. iIntros (?) "H". iDestruct "H" as (?) "(%&?)". subst.
         iModIntro. iRight in "HΦ". by iApply "HΦ".
       * iLeft in "HΦ". iIntros. iModIntro. by iApply "HΦ". }
  iApply (wpc_Inode__Size with "Hinode").
  iSplit.
  { iLeft in "Hfupd". iIntros "_". eauto. }
  rewrite difference_empty_L.
  iNext. iIntros (σ mb) "[%Hσ HP]". iMod ("Hfupd" with "[$HP //]") as "[HP HQ]".
  iModIntro. iFrame "HP". iSplit.
  { iSpecialize ("HQc" with "[$]"). iIntros "_". eauto. }
  iIntros "_". eauto.
Qed.

Theorem wp_Inode__mkHdr {stk} l addr_s addrs :
  length addrs ≤ InodeMaxBlocks ->
  {{{ "addrs" ∷ l ↦[Inode :: "addrs"] (slice_val addr_s) ∗
      "Haddrs" ∷ is_slice addr_s uint64T 1 addrs
  }}}
    Inode__mkHdr #l @ stk
  {{{ s b, RET (slice_val s);
      is_block s 1 b ∗
      ⌜block_encodes b ([EncUInt64 (U64 $ length addrs)] ++ (EncUInt64 <$> addrs))⌝ ∗
      "addrs" ∷ l ↦[Inode :: "addrs"] (slice_val addr_s) ∗
      "Haddrs" ∷ is_slice addr_s uint64T 1 addrs
  }}}.
Proof.
  iIntros (Hbound Φ) "Hpre HΦ"; iNamed "Hpre".
  wp_call.
  wp_apply wp_new_enc; iIntros (enc) "Henc".
  wp_pures.
  wp_loadField.
  iDestruct (is_slice_sz with "Haddrs") as %Hlen.
  wp_apply wp_slice_len.
  wp_apply (wp_Enc__PutInt with "Henc").
  { word. }
  iIntros "Henc".
  wp_loadField.
  iDestruct (is_slice_split with "Haddrs") as "[Haddrs Hcap]".
  wp_apply (wp_Enc__PutInts with "[$Henc $Haddrs]").
  { word. }
  iIntros "[Henc Haddrs]".
  iDestruct (is_slice_split with "[$Haddrs $Hcap]") as "Haddrs".
  wp_apply (wp_Enc__Finish with "Henc").
  iIntros (??) "(%Henc&Hs)".
  wp_pures.
  iApply "HΦ".
  iFrame.
  iPureIntro.
  eapply block_encodes_eq; eauto.
  rewrite app_nil_l.
  repeat (f_equal; try word).
Qed.

Theorem wlog_assume_l {PROP:bi} (φ: Prop) (P: PROP) :
  φ →
  (⌜φ⌝ -∗ P) -∗
  ⌜φ⌝ ∗ P.
Proof.
  iIntros (H) "Himpl".
  iSplitR; auto.
  iApply ("Himpl" with "[//]").
Qed.

Lemma is_inode_durable_wf addr σ addrs :
  is_inode_durable addr σ addrs -∗
  ⌜inode.wf σ⌝.
Proof.
  iNamed 1.
  iFrame "%".
Qed.

Definition reserve_fupd E (Palloc: alloc.t → iProp Σ) : iProp Σ :=
  ∀ (σ σ': alloc.t) ma,
    ⌜match ma with
     | Some a => a ∈ alloc.free σ ∧ σ' = <[a:=block_reserved]> σ
     | None => σ' = σ ∧ alloc.free σ = ∅
     end⌝ -∗
  ▷ Palloc σ ={E}=∗ ▷ Palloc σ'.

(* free really means unreserve (we don't have a way to unallocate something
marked used) *)
Definition free_fupd E (Palloc: alloc.t → iProp Σ) (a:u64) : iProp Σ :=
  ∀ (σ: alloc.t),
    ⌜σ !! a = Some block_reserved⌝ -∗
  ▷ Palloc σ ={E}=∗ ▷ Palloc (<[a:=block_free]> σ).

(* This is useless because you need to do this together with some other action. *)
Definition use_fupd E (Palloc: alloc.t → iProp Σ) (a: u64): iProp Σ :=
  (∀ σ : alloc.t,
      ⌜σ !! a = Some block_reserved⌝ -∗
      ▷ Palloc σ ={E}=∗ ▷ Palloc (<[a:=block_used]> σ)).

Let Ψ (a: u64) := (∃ bd b, int.Z a d↦[bd] b)%I.

(* This does not fit the "atomic triple" pattern because of the possibility to
return [#false] without actually performing the commit.
It should be possible to phrase it as a "commit that does not change
anything", but that still requires atomic triples with an ∃∃ quantifier
in the atomic postcondition. *)
Theorem wpc_Inode__Append
        {l P addr}
        (* allocator stuff *)
        {Palloc γalloc domain}
        (alloc_ref: loc) q (b_s: Slice.t) (b0: Block) :
  inodeN ## allocN →
  ∀ Φ Φc,
      "Hinode" ∷ is_inode l P addr ∗
      "Hbdata" ∷ is_block b_s q b0 ∗
      "#Halloc" ∷ is_allocator Palloc Ψ allocN alloc_ref domain γalloc ∗
      "#Halloc_fupd" ∷ □ reserve_fupd (⊤ ∖ ↑allocN) Palloc ∗
      "#Hfree_fupd" ∷ □ (∀ a, free_fupd (⊤ ∖ ↑allocN) Palloc a) ∗
      "Hfupd" ∷ (Φc ∧ ▷ (Φ #false ∧ ∀ σ σ' addr',
        ⌜σ' = set inode.blocks (λ bs, bs ++ [b0])
                              (set inode.addrs ({[addr']} ∪.) σ)⌝ -∗
        ⌜inode.wf σ⌝ -∗
        ∀ s,
        ⌜s !! addr' = Some block_reserved⌝ -∗
         P σ ∗ ▷ Palloc s -∗ |NC={⊤ ∖ ↑allocN}=>
         P σ' ∗ ▷ Palloc (<[addr' := block_used]> s) ∗ (Φc ∧ Φ #true))) -∗
    WPC Inode__Append #l (slice_val b_s) #alloc_ref @ ⊤ {{ Φ }} {{ Φc }}.
Proof.
  iIntros (? Φ Φc) "Hpre"; iNamed "Hpre".
  iNamed "Hinode". iNamed "Hro_state".
  wpc_call.
  iCache with "Hfupd"; first by crash_case.
  wpc_pures.
  wpc_frame_seq.
  wp_apply (wp_Reserve _ _ _ (λ ma, emp)%I with "[$Halloc]"); auto.
  { (* Reserve fupd *)
    iIntros (σ σ' ma Htrans) "HP".
    iMod ("Halloc_fupd" with "[] HP"); eauto. }
  iIntros (a ok) "Hblock".
  iNamed 1.
  wpc_pures.
  wpc_if_destruct.
  - wpc_pures.
    iRight in "Hfupd".
    by iLeft in "Hfupd".
  - iDestruct "Hblock" as "[_ Hb]".
    wpc_pures.
    wpc_bind_seq.
    iApply (prepare_reserved_block_reuse with "Hb"); auto.
    iSplit; first by iFromCache.
    iIntros "Hb Hreserved".
    iDeexHyp "Hb".
    iAssert (□ ∀ bd b0, int.Z a d↦[bd] b0 ∗
                      (Φc) -∗
                      (Φc ∗ block_cinv Ψ γalloc a))%I as "#Hbc".
    { iIntros "!>" (bd' b') "(Hb & Hfupd)".
      iSplitL "Hfupd"; first done.
      iApply block_cinv_free_pred.
      iExists _, _; iFrame. }

    iCache with "Hfupd Hb".
    {  iLeft in "Hfupd". iDestruct ("Hbc" with "[$]") as "($&$)". }
    wpc_apply (wpc_Write' with "[$Hb $Hbdata]").
    iSplit.
    { iLeft in "Hfupd". iIntros "[Hb|Hb]"; try iFromCache.
      - iDestruct ("Hbc" with "[$]") as "($&$)".
      - iDestruct "Hb" as (b' Hcases) "Hb". iDestruct ("Hbc" with "[$]") as "($&$)".
    }
    iIntros "!> Hda".
    iDestruct "Hda" as (bd' Hcases) "[Hda _]".
    iFrame "Hreserved".
    iSplitR "Hda"; last first.
    { instantiate (1:=λ _, (∃ b', int.Z a d↦[b'] b0)%I); simpl.
      iSplitL.
      { iExists _. iExact "Hda". }
      iModIntro.
      iIntros "Hda". iDestruct "Hda" as (?) "Hda".
      iApply block_cinv_free_pred. iExists _, _; iFrame. }
    iIntros "Hreserved".
    iSplit; first iFromCache.
    wpc_pures.
    wpc_bind_seq.
    iApply (prepare_reserved_block_reuse with "Hreserved"); auto.
    iSplit.
    { iLeft in "Hfupd". eauto. }
    iIntros "Hb Hreserved".
    iDeexHyp "Hb".
    wpc_apply (wpc_Barrier1 with "[$Hb]").
    iSplit.
    { iLeft in "Hfupd". iIntros "Hb".
      iDestruct ("Hbc" with "[$]") as "($&$)".
    }
    iIntros "!> Hda".
    iFrame "Hreserved".
    iDestruct "Hda" as (->) "Hda".
    iSplitR "Hda"; last first.
    { instantiate (1:=λ _, (int.Z a d↦[b0] b0)%I); simpl.
      iSplitL.
      { iExact "Hda". }
      iModIntro.
      iIntros "Hda".
      iApply block_cinv_free_pred. iExists _, _; iFrame. }

    iIntros "Hreserved".
    iSplit; first iFromCache.
    wpc_pures.
    wpc_frame_seq.

    wp_loadField.
    wp_apply (crash_lock.acquire_spec with "Hlock"); auto.
    iIntros "His_locked". iNamed 1.
    wpc_pures.
    wpc_bind_seq.
    crash_lock_open "His_locked".
    iDestruct 1 as (σ) "(Hlockinv&HP)".
    iApply wpc_fupd.
    iEval (rewrite /named) in "HP".
    do 2 iNamed "Hlockinv".
    iCache with "Hfupd HP Hdurable".
    { iLeft in "Hfupd". iFrame.
      iExists _; iFrame.
      iDestruct (inode_durable_to_cinv with "[$]") as "?".
      eauto. }
    iDestruct (is_slice_sz with "Haddrs") as %Hlen1.
    autorewrite with len in Hlen1.
    iDestruct (is_inode_durable_size with "Hdurable") as %Hlen2.
    wpc_call.
    wpc_bind (slice.len _ ≥ _)%E.
    wpc_frame.
    wp_loadField.
    wp_apply wp_slice_len; wp_pures.
    iModIntro. iNamed 1.
    wpc_if_destruct.
    + wpc_pures.
      iSplitR "HP Hdurable addrs Haddrs"; last first.
      { iExists _; iFrame.
        do 1 iModIntro.
        iFrame. iExists _, _; iFrame "∗ %". }
      iModIntro.
      iIntros "His_locked".
      iSplit; first iFromCache.
      wpc_pures.
      wpc_frame_seq.
      wp_loadField.
      wp_apply (crash_lock.release_spec with "His_locked"); auto.
      iNamed 1.
      wpc_pures.
      wpc_frame_seq.
      wp_apply (wp_Free _ _ _ emp with "[$Halloc Hreserved]").
      { auto. }
      { iSplitL "Hreserved".
        { iApply (reserved_block_weaken with "[] [] Hreserved").
          { rewrite /Ψ. eauto. }
          { rewrite /Ψ/block_cinv. eauto. }
        }
        iIntros (σ' Hreserved) "HP".
        iMod ("Hfree_fupd" with "[//] HP") as "$".
        auto. }
      iIntros "_".
      wp_pures.
      iNamed 1.
      wpc_pures.
      iRight in "Hfupd".
      by iLeft in "Hfupd".
    + wpc_pures.
      wpc_frame_seq.
      wp_loadField.
      wp_apply (wp_SliceAppend (V:=u64) with "[$Haddrs]").
      iIntros (addr_s') "Haddrs".
      wp_storeField.
      iNamed 1.
      wpc_pures.
      wpc_frame_seq.
      wp_apply (wp_Inode__mkHdr with "[$addrs $Haddrs]").
      { autorewrite with len; simpl.
        word. }
      iIntros (s b') "(Hb&%Hencoded'&?&?)"; iNamed.
      iNamed 1.
      wpc_pures.
      wpc_loadField.

      iApply (prepare_reserved_block with "Hreserved"); auto; try lia.
      iSplit; first iFromCache.
      iIntros "Hda Hreserved".
      wpc_bind (Write _ _).
      (* hide this horrible postcondition for now *)
      match goal with
      | |- envs_entails _ (wpc _ _ _ ?Φ0 _) => set (Φ':=Φ0)
      end.
      wpc_apply (wpc_Write_ncfupd with "[$Hb]").
      iSplit.
      { iLeft in "Hfupd". iSplitR "Hda".
        * iFrame. iExists _; iFrame.
          iDestruct (inode_durable_to_cinv with "[$]") as "?".
          iFrame.
        * iApply block_cinv_free_pred. iExists _, _; iFrame. }
      iNamed "Hdurable".
      (* TODO: it would be nice in wpc_Write_ncfupd to learn what b' is before the
               later? but that would seem to require changing wpc_pre *)
      set (σ':=set inode.blocks (λ bs : list Block, bs ++ [b0])
                   (set inode.addrs (union {[a]}) σ)).
      iModIntro. iExists _, _. iFrame "Hhdr". iNext.
      iIntros (bd'') "[%Hcases'' Hhdr]".

      (*
      destruct Hcases'' as [Hnowrite|Hwrite].
       *)
      destruct (decide (bd'' = b')); last first.
      {
        assert (bd'' = hdr) by intuition eauto.
        (* The we will crash without the write hitting disk *)
        iModIntro. iSplit.
        - iLeft in "Hfupd". iFrame. iSplitR "Hda".
          * iExists _. iFrame. iExists _, _, _. iFrame. iFrame "%". subst. eauto.
          * iLeft. iExists _, _. iFrame.
        - iIntros "Hb".
          subst Φ'; cbv beta.
          wpc_pures.
          {
            iFrame.
            iLeft in "Hfupd". iFrame. iSplitR "Hda".
            * iExists _. iFrame. iExists _, _, _. iFrame. iFrame "%". subst. eauto.
            * iLeft. iExists _, _. iFrame.
          }
          (* But now we hit a barrier and we will derive a contradiction in the post-condition *)
          wpc_apply (wpc_Barrier1 with "[$Hhdr]").
          iSplit.
          {
            iFrame.
            iLeft in "Hfupd". iFrame. iIntros "Hhdr". iSplitR "Hda".
            * iExists _. iFrame. iExists _, _, _. iFrame. iFrame "%". subst. eauto.
            * iLeft. iExists _, _. iFrame.
          }
          iNext. iIntros "[%Hfalso ?]". exfalso. congruence.
      }
      iRight in "Hfupd".
      iRight in "Hfupd".
      iSpecialize ("Hfupd" $! σ σ' a with "[% //] [% //]").

      iMod (mark_used' _ _ _ _ _ (P σ' ∗ (Φc ∧ Φ #true))%I with "Hreserved [HP Hfupd]") as "Hget_used".
      { solve_ndisj. }
      { clear.
        iIntros (s Hreserved) "HPalloc".
        iMod ("Hfupd" with "[% //] [$HP $HPalloc]") as "(HP&HPalloc&HQ)".
        iFrame. eauto. }
      iModIntro.
      iDestruct "Hget_used" as "[ (HP&HQ) Hused]".
      iAssert (is_inode_durable addr
                 (set inode.blocks (λ bs : list Block, bs ++ [b0])
                      (set inode.addrs (union {[a]}) σ))
                 (addrs ++ [a]))
              with "[Hhdr Hdata Hda]" as "Hdurable".
      { iExists _; iFrame "∗ %".
        iSplitR.
        { iPureIntro.
          rewrite /inode.wf /=.
          autorewrite with len; simpl.
          word. }
        iSplitR.
        { iPureIntro.
          simpl.
          rewrite list_to_set_app_L.
          simpl.
          set_solver. }
        simpl; auto. subst. iFrame. }
      iDestruct (is_inode_durable_wf with "Hdurable") as %Hwf'.
      iCache (Φc)%I with "HQ".
      { by iLeft in "HQ". }
      match goal with
      | |- envs_entails _ ((?P ∗ _) ∧ _) =>
        iCache (P)%I with "HQ HP Hdurable"
      end.
      { iLeft in "HQ". iFrame. iExists _; iFrame.
        iDestruct (inode_durable_to_cinv with "[$]") as "?".
        iFrame.
      }
      iCache (block_cinv Ψ γalloc a) with "Hused".
      { iApply block_cinv_from_used; iFrame. }
      iSplit.
      { iLeft in "HQ". iFrame. iExists _. iFrame.
        iDestruct (inode_durable_to_cinv with "[$]") as "?".
        iFrame.
      }
      iIntros "Hb".
      subst Φ'; cbv beta.
      (* done applying wpc_Write_fupd *)

      wpc_pures.
      { iLeft in "HQ". iFrame. iExists _. iFrame.
        iDestruct (inode_durable_to_cinv with "[$]") as "?".
        iFrame.
      }
      wpc_apply (wpc_Barrier0); first done.
      iSplit.
      { iIntros. iLeft in "HQ". iFrame. iExists _. iFrame.
        iDestruct (inode_durable_to_cinv with "[$]") as "?".
        iFrame.
      }
      iNext. iIntros "_".
      wpc_pures.
      { iIntros. iLeft in "HQ". iFrame. iExists _. iFrame.
        iDestruct (inode_durable_to_cinv with "[$]") as "?".
        iFrame.
      }
      iModIntro.
      iSplitR "Hused"; last (iFromCache).
      iSplit.
      { iLeft in "HQ". iFrame. iExists _. iFrame.
        iDestruct (inode_durable_to_cinv with "[$]") as "?".
        iFrame. }
      iSplitR "HP Haddrs addrs Hdurable"; last first.
      { iExists _; iFrame. iModIntro.
        iExists _, _; iFrame "∗ %". }
      iModIntro.
      iIntros "His_locked".
      iSplit; first iFromCache.
      wpc_pures.
      wpc_frame_seq.
      wp_loadField.
      wp_apply (crash_lock.release_spec with "His_locked"); auto.
      iNamed 1.
      wpc_pures.
      (* RALF: we are throwing away an [is_block] here. *)
      by iRight in "HQ".
Qed.

(* Note that this spec is a lot weaker than the one above because in case of
failure, the resources put into "Hfupd" are lost! *)
Theorem wpc_Inode__Append_triple
        {l P addr}
        (* allocator stuff *)
        {Palloc γalloc domain}
        (Q: iProp Σ) (Qc: iProp Σ)
        (alloc_ref: loc) q (b_s: Slice.t) (b0: Block) :
  inodeN ## allocN →
  {{{ "Hinode" ∷ is_inode l P addr ∗
      "Hbdata" ∷ is_block b_s q b0 ∗
      "HQc" ∷ (Q -∗ Qc) ∗
      "#Halloc" ∷ is_allocator Palloc Ψ allocN alloc_ref domain γalloc ∗
      "#Halloc_fupd" ∷ □ reserve_fupd (⊤ ∖ ↑allocN) Palloc ∗
      "#Hfree_fupd" ∷ □ (∀ a, free_fupd (⊤ ∖ ↑allocN) Palloc a) ∗
      "Hfupd" ∷ (Qc ∧ (∀ σ σ' addr',
        ⌜σ' = set inode.blocks (λ bs, bs ++ [b0])
                              (set inode.addrs ({[addr']} ∪.) σ)⌝ -∗
        ⌜inode.wf σ⌝ -∗
        ∀ s,
        ⌜s !! addr' = Some block_reserved⌝ -∗
         P σ ∗ ▷ Palloc s ={⊤ ∖ ↑allocN}=∗
         P σ' ∗ ▷ Palloc (<[addr' := block_used]> s) ∗ Q))
  }}}
    Inode__Append #l (slice_val b_s) #alloc_ref @ ⊤
  {{{ (ok: bool), RET #ok; if ok then Q else emp }}}
  {{{ Qc }}}.
Proof.
  iIntros (? Φ Φc) "Hpre HΦ"; iNamed "Hpre".
  iApply (wpc_step_strong_mono _ _ _ _ _
         (λ v, ∃ (ok: bool), ⌜ v = #ok ⌝ ∗ if ok then Q else emp)%I _ Qc with "[-HΦ] [HΦ]"); auto.
  2: { iSplit.
       * iNext. iIntros (?) "H". iDestruct "H" as (?) "(%&?)". subst.
         iModIntro. iRight in "HΦ". by iApply "HΦ".
       * iLeft in "HΦ".  iIntros. iModIntro. by iApply "HΦ". }
  iApply (wpc_Inode__Append); try assumption.
  iFrame "Hinode Hbdata Halloc_fupd Hfree_fupd Halloc".
  iSplit.
  { by iLeft in "Hfupd".  }
  iSplit.
  { iClear "Hfupd". (* This is where resources are lost. *)
    iNext. iExists _; iSplit; first eauto. done. }
  iIntros "!>" (σ σ' addr' Hσ' Hσ s Hs) "HPs".
  iRight in "Hfupd".
  iMod ("Hfupd" $! _ _ _ Hσ' Hσ _ Hs with "HPs") as "($ & $ & HQ)".
  iIntros "!>". iSplit.
  { iDestruct ("HQc" with "[$]") as "$". }
  iExists _; iSplit; first auto. iFrame.
Qed.
End goose.

Section goose.
Context `{!heapGS Σ}.
Context `{!allocG Σ}.

Context (P: inode.t → iProp Σ).

Instance inode_cinv_pre_post addr σ :
  IntoCrash (inode_cinv_precrash addr σ) (λ _, inode_cinv_postcrash addr σ).
Proof.
  intros.
  hnf; iNamed 1.
  rewrite ?big_sepL2_alt.
  iDestruct "Hdata" as "(%Heq&Hl)".
  iCrash.
  iExists _, _. iFrame.
  rewrite ?big_sepL2_alt.
  iFrame. eauto.
Qed.

Instance inode_cinv_stable addr σ :
  IntoCrash (inode_cinv_postcrash addr σ) (λ _, inode_cinv_postcrash addr σ).
Proof.
  intros.
  hnf; iNamed 1.
  rewrite ?big_sepL2_alt.
  iDestruct "Hdata" as "(%Heq&Hl)".
  iCrash.
  iExists _, _. iFrame.
  rewrite ?big_sepL2_alt.
  iFrame. eauto.
Qed.

End goose.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, Collège de France and Inria Paris            *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU Lesser General Public License as        *)
(*  published by the Free Software Foundation, either version 2.1 of   *)
(*  the License, or  (at your option) any later version.               *)
(*  This file is also distributed under the terms of the               *)
(*  INRIA Non-Commercial License Agreement.                            *)
(*                                                                     *)
(* *********************************************************************)

(** Platform-specific built-in functions *)

Require Import String Coqlib.
Require Import AST Integers Floats Values.
Require Import Builtins0.

Inductive platform_builtin : Type :=
  | BI_fmin
  | BI_fmax.

Local Open Scope string_scope.

Definition platform_builtin_table : list (string * platform_builtin) :=
     ("__builtin_fmin", BI_fmin)
  :: ("__builtin_fmax", BI_fmax)
  :: nil.

Definition platform_builtin_sig (b: platform_builtin) : signature :=
  match b with
  | BI_fmin | BI_fmax =>
      mksignature (Tfloat :: Tfloat :: nil) Tfloat cc_default
  end.

Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (sig_res (platform_builtin_sig b)) :=
  match b with
  | BI_fmin =>
      mkbuiltin_n2t Tfloat Tfloat Tfloat
        (fun f1 f2 => match Float.compare f1 f2 with
                      | Some Lt => f1
                      | Some Eq | Some Gt | None => f2
                      end)
  | BI_fmax =>
      mkbuiltin_n2t Tfloat Tfloat Tfloat
        (fun f1 f2 => match Float.compare f1 f2 with
                      | Some Gt => f1
                      | Some Eq | Some Lt | None => f2
                      end)
  end.


Require Import GMuAnnot.Prelude.
Require Import GMuAnnot.Infrastructure.

Open Scope list_scope.

(* Proofs regarding proposition 2.1 from the paper *)
Section SimpleEquationProperties.

  Variable Σ : GADTEnv.

  Lemma teq_reflexivity : forall Δ T,
      entails_semantic Σ Δ (T ≡ T).
    cbn.
    intros.
    auto.
  Qed.

  Lemma teq_symmetry : forall Δ T U,
      entails_semantic Σ Δ (T ≡ U) ->
      entails_semantic Σ Δ (U ≡ T).
    cbn. intros.
    symmetry.
    auto.
  Qed.

  Lemma teq_transitivity : forall Δ T U V,
      entails_semantic Σ Δ (T ≡ U) ->
      entails_semantic Σ Δ (U ≡ V) ->
      entails_semantic Σ Δ (T ≡ V).
    cbn. intros.
    transitivity (subst_tt' U Θ); auto.
  Qed.

  Lemma subst_has_no_fv : forall Σ Δ Θ,
      subst_matches_typctx Σ Δ Θ ->
      (forall X U, List.In (X, U) Θ -> fv_typ U = \{}).
    induction 1; introv Hin.
    - false.
    - cbn in Hin.
      destruct Hin as [Hin | Hin].
      + inversions Hin.
        lets Hfv: wft_gives_fv H.
        cbn in Hfv.
        apply~ fset_extens.
      + apply* IHsubst_matches_typctx.
    - apply* IHsubst_matches_typctx.
  Qed.

  Lemma teq_axiom : forall Δ T U,
      List.In (tc_eq (T ≡ U)) Δ ->
      entails_semantic Σ Δ (T ≡ U).
    unfold entails_semantic.
    induction Δ; introv Hin M.
    - contradiction.
    - cbn in Hin.
      destruct Hin as [Hin | Hin].
      + subst. inversion M.
        easy.
      + inversion M; auto.
        cbn.
        repeat rewrite subst_tt_inside; auto.
        * f_equal.
          apply IHΔ; auto.
        * introv Uin.
          lets Fr: subst_has_no_fv Uin.
          -- eauto.
          -- rewrite Fr. apply notin_empty.
        * introv Uin.
          lets Fr: subst_has_no_fv Uin.
          -- eauto.
          -- rewrite Fr. apply notin_empty.
  Qed.

End SimpleEquationProperties.

Ltac fold_from_list :=
  repeat progress match goal with
  | [ H: context[LibList.fold_right (fun (x : var) (acc : fset var) => \{ x} \u acc) \{} ?L]  |- _ ] =>
    fold (from_list L) in H
  | |- context[LibList.fold_right (fun (x : var) (acc : fset var) => \{ x} \u acc) \{} ?L] =>
    fold (from_list L)
                  end.

Lemma notin_from_list : forall As (A : var),
    ~ (List.In A As) ->
    A \notin from_list As.
  intros.
  intro HF.
  lets [A' [Hin Heq]]: in_from_list HF.
  subst.
  auto.
Qed.

Lemma spawn_unit_subst : forall Σ As,
    DistinctList As ->
    exists Θ, length Θ = length As /\ subst_matches_typctx Σ (tc_vars As) Θ /\ substitution_sources Θ = from_list As.
  induction As as [| Ah Ats]; introv ADist.
  - cbn.
    exists (@nil (var * typ)).
    splits~.
    constructor.
  - inversions ADist.
    destruct IHAts as [LT [Len [Match Src]]]; auto.
    exists ((Ah, typ_unit) :: LT).
    splits.
    + cbn. auto.
    + constructor;
        fold (List.map tc_var Ats);
        fold (tc_vars Ats);
        auto.
      * rewrite Src.
        apply~ notin_from_list.
      * apply notin_dom_tc_vars.
        apply~ notin_from_list.
    + cbn.
      fold_from_list.
      fold (substitution_sources LT).
      rewrite Src.
      trivial.
Qed.

Lemma only_vars_is_tc_vars : forall Δ,
    (forall tc, List.In tc Δ -> exists A, tc = tc_var A) ->
    exists As, Δ = tc_vars As.
  induction Δ as [| [A | eq] Δt].
  - cbn. intros. exists (@nil var). cbn. trivial.
  - cbn. intro Hin.
    lets* [Ats EQ]: IHΔt.
    exists (A :: Ats). cbn.
    fold (tc_vars Ats).
    f_equal.
    auto.
  - cbn. intro Hin.
    false~ Hin. congruence.
Qed.

Lemma contradictory_env_test_0 : forall Σ Δ,
    entails_semantic Σ Δ (typ_unit ≡ (typ_unit ** typ_unit)) ->
    contradictory_bounds Σ Δ.
  introv Heq.
  unfold contradictory_bounds.
  intros.
  unfold entails_semantic in *.
  introv Hmatch.
  exfalso.
  lets HF: Heq Hmatch.
  rewrite subst_ttΘ_fresh in HF.
  - rewrite subst_ttΘ_fresh in HF.
    + false.
    + cbn. rewrite union_empty_r.
      rewrite~ inter_empty_r.
  - cbn.
    rewrite~ inter_empty_r.
Qed.

Lemma subst_ttΘ_into_abs : forall Θ A B,
    subst_tt' (A ==> B) Θ
    =
    (subst_tt' A Θ) ==> (subst_tt' B Θ).
  induction Θ as [| [X T] Θ]; cbn in *; trivial.
Qed.
Lemma subst_ttΘ_into_tuple : forall Θ A B,
    subst_tt' (A ** B) Θ
    =
    (subst_tt' A Θ) ** (subst_tt' B Θ).
  induction Θ as [| [X T] Θ]; cbn in *; trivial.
Qed.

Lemma contradictory_env_test : forall Σ Δ A B C D,
    entails_semantic Σ Δ ((A ==> B) ≡ (C ** D)) ->
    contradictory_bounds Σ Δ.
  introv Heq.
  unfold contradictory_bounds.
  intros.
  unfold entails_semantic in *.
  introv Hmatch.
  exfalso.
  lets HF: Heq Hmatch.
  rewrite subst_ttΘ_into_abs in HF.
  rewrite subst_ttΘ_into_tuple in HF.
  congruence.
Qed.

Lemma empty_is_not_contradictory : forall Σ,
    ~ (contradictory_bounds Σ emptyΔ).
  intros.
  intro HF.
  unfold contradictory_bounds in HF.
  asserts M: (subst_matches_typctx Σ emptyΔ (@nil (var*typ)));
    try econstructor.
  lets F: HF typ_unit (typ_unit ** typ_unit) (@nil (var * typ)) M.
  cbn in F.
  false.
Qed.

Lemma typing_exfalso : forall Σ Δ E e T1 T2 TT,
    {Σ, Δ, E} ⊢(TT) e ∈ T1 ->
    contradictory_bounds Σ Δ ->
    wft Σ Δ T2 ->
    {Σ, Δ, E} ⊢(Tgen) e ∈ T2.
  introv Typ Bounds.
  eapply typing_eq; eauto.
Qed.

Lemma inversion_typing_eq : forall Σ Δ E e T TT,
    {Σ, Δ, E} ⊢(TT) e ∈ T ->
    exists T',
      {Σ, Δ, E} ⊢(Treg) e ∈ T' /\ entails_semantic Σ Δ (T ≡ T').
  introv Htyp.
  lets Htyp2: Htyp.
  induction Htyp;
    try match goal with
        | [ H: {Σ, Δ, E} ⊢(Treg) ?e ∈ ?T |- _ ] =>
          exists T; split~; auto using teq_reflexivity
        end.
  lets [T' [IHTyp IHeq]]: IHHtyp Htyp.
  exists T'.
  split~.
  eauto using teq_symmetry, teq_transitivity.
Qed.

Lemma subst_has_no_fv2 : forall Σ Δ Θ Y,
    subst_matches_typctx Σ Δ Θ ->
    (forall A U, List.In (A, U) Θ -> Y \notin fv_typ U).
  introv M Hin.
  lets EQ: subst_has_no_fv M Hin.
  rewrite EQ.
  auto.
Qed.

Lemma inversion_eq_arrow : forall Σ Δ TA1 TB1 TA2 TB2,
    entails_semantic Σ Δ ((TA1 ==> TB1) ≡ (TA2 ==> TB2)) ->
    entails_semantic Σ Δ (TA1 ≡ TA2) /\
    entails_semantic Σ Δ (TB1 ≡ TB2).
  introv Sem; cbn in *.
  split~;
       introv M;
    lets EQ: Sem M;
    repeat rewrite subst_tt_prime_reduce_arrow in EQ;
    inversion~ EQ.
Qed.

Lemma inversion_eq_tuple : forall Σ Δ TA1 TB1 TA2 TB2,
    entails_semantic Σ Δ ((TA1 ** TB1) ≡ (TA2 ** TB2)) ->
    entails_semantic Σ Δ (TA1 ≡ TA2) /\
    entails_semantic Σ Δ (TB1 ≡ TB2).
  introv Sem; cbn in *.
  split~;
       introv M;
    lets EQ: Sem M;
    repeat rewrite subst_tt_prime_reduce_tuple in EQ;
    inversion~ EQ.
Qed.

Lemma inversion_eq_typ_all : forall Σ Δ T U,
    entails_semantic Σ Δ (typ_all T ≡ typ_all U) ->
    entails_semantic Σ Δ (T ≡ U).
  introv Sem; cbn in *.
  introv M;
    lets EQ: Sem M;
    repeat rewrite subst_tt_prime_reduce_typ_all in EQ;
    inversion~ EQ.
Qed.

Lemma inversion_eq_typ_gadt : forall Σ Δ Ts Us N,
    List.length Ts = List.length Us ->
    entails_semantic Σ Δ (typ_gadt Ts N ≡ typ_gadt Us N) ->
    List.Forall2 (fun T U => entails_semantic Σ Δ (T ≡ U)) Ts Us.
  introv Len Sem.
  apply F2_iff_In_zip.
  split~.
  intros T U In.
  cbn in *.
  introv M.
  lets EQ: Sem M.
  repeat rewrite subst_tt_prime_reduce_typ_gadt in EQ.
  inversion EQ as [EQ2].
  lets~ : lists_map_eq EQ2 In.
Qed.

Lemma equations_from_lists_map : forall F F1 F2 Ts Us,
    List.length Ts = List.length Us ->
    (forall T U, List.In (T,U) (zip Ts Us) -> F (tc_eq (T ≡ U)) = tc_eq (F1 T ≡ F2 U)) ->
    List.map F (equations_from_lists Ts Us)
    =
    equations_from_lists (List.map F1 Ts) (List.map F2 Us).
  induction Ts as [| T Ts]; destruct Us as [| U Us];
    introv Len;  try solve [inversion~ Len].
  introv EQ.
  cbn.
  fold (equations_from_lists Ts Us).
  fold (equations_from_lists (List.map F1 Ts) (List.map F2 Us)).
  f_equal.
  - apply EQ. cbn. auto.
  - apply* IHTs.
    introv In.
    apply EQ. cbn. auto.
Qed.