(* [mono_nat] must go first otherwise the default scope becomes nat. *)
From iris.base_logic Require Import mono_nat.
From Perennial.program_proof Require Import
     mvcc_prelude mvcc_ghost mvcc_inv
     txnmgr_repr txnmgr_mk txnmgr_new txnmgr_activate_gc
     txn_repr txn_get txn_put txn_delete txn_do_txn.
From Goose.github_com.mit_pdos.go_mvcc Require Import examples.
From Perennial.goose_lang Require Import grove_ffi_adequacy.

Section program.
Context `{!heapGS Σ, !mvcc_ghostG Σ}.

Definition P_Hello (r : dbmap) := ∃ v, r = {[ (U64 0) := v ]}.
Definition Q_Hello (r w : dbmap) := w = {[ (U64 0) := Nil ]}.

Theorem wp_hello txn tid r γ τ :
  {{{ own_txn txn tid r γ τ ∗ ⌜P_Hello r⌝ ∗ txnmap_ptstos τ r }}}
    hello #txn
  {{{ (ok : bool), RET #ok;
      own_txn txn tid r γ τ ∗
      if ok
      then ∃ w, ⌜Q_Hello r w ∧ dom r = dom w⌝ ∗
                txnmap_ptstos τ w
      else True
  }}}.
Proof.
  iIntros (Φ) "(Htxn & %HP & Hpt) HΦ".
  wp_call.
  unfold txnmap_ptstos.
  destruct HP as [v HP].
  rewrite HP.
  rewrite big_sepM_singleton.

  (***********************************************************)
  (* txn.Put(0, "hello")                                     *)
  (* txn.Get(0)                                              *)
  (* txn.Delete(0)                                           *)
  (* return true                                             *)
  (***********************************************************)
  wp_apply (wp_txn__Put with "[$Htxn $Hpt]").
  iIntros "[Htxn Hpt]".
  wp_apply (wp_txn__Get with "[$Htxn $Hpt]").
  iIntros (u found) "[Htxn [Hpt %Hu]]".
  wp_pures.
  wp_apply (wp_txn__Delete with "[$Htxn $Hpt]").
  iIntros (ok) "[Htxn Hpt]".
  wp_pures.
  iApply "HΦ".
  iFrame.
  iModIntro.
  iExists {[ (U64 0) := Nil ]}.
  rewrite big_sepM_singleton.
  iFrame.
  iPureIntro.
  unfold Q_Hello.
  set_solver.
Qed.

Theorem wp_Hello (txn : loc) γ :
  ⊢ {{{ own_txn_uninit txn γ }}}
    <<< ∀∀ (v : dbval), dbmap_ptsto γ (U64 0) 1 v >>>
      Hello #txn @ ↑mvccN
    <<< ∃∃ (ok : bool), if ok then dbmap_ptsto γ (U64 0) 1 Nil else dbmap_ptsto γ (U64 0) 1 v >>>
    {{{ RET #(); own_txn_uninit txn γ }}}.
Proof.
  iIntros "!>".
  iIntros (Φ) "Htxn HAU".
  wp_call.

  (***********************************************************)
  (* body := func(txn *txn.Txn) bool {                       *)
  (*     return hello(txn)                                   *)
  (* }                                                       *)
  (* ok := t.DoTxn(body)                                     *)
  (***********************************************************)
  wp_apply (wp_txn__DoTxn_xres _ _ P_Hello Q_Hello with "[$Htxn]").
  { unfold Q_Hello. apply _. }
  { unfold spec_body_xres.
    clear Φ.
    iIntros (tid r τ Φ) "(Htxn & %HP & Htxnpt) HΦ".
    wp_pures.
    wp_apply (wp_hello with "[$Htxn $Htxnpt]"); first done.
    iApply "HΦ".
  }
  iMod "HAU".
  iModIntro.
  iDestruct "HAU" as (v) "[Hdbpt HAU]".
  iExists {[ (U64 0) := v ]}.
  iSplitL "Hdbpt".
  { unfold dbmap_ptstos.
    rewrite big_sepM_singleton.
    iFrame.
    iPureIntro.
    unfold P_Hello.
    by eauto.
  }
  iIntros (ok w) "Hdbpt".
  iFrame.
  destruct ok eqn:E.
  { (* Case COMMIT. *)
    unfold Q_Hello.
    iDestruct "Hdbpt" as "[%HQ Hdbpt]".
    rewrite HQ /dbmap_ptstos big_sepM_singleton.
    iMod ("HAU" $! true with "Hdbpt") as "HΦ".
    iIntros "!> Htxn".
    wp_pures.
    by iApply "HΦ".
  }
  { (* Case ABORT. *)
    rewrite /dbmap_ptstos big_sepM_singleton.
    iMod ("HAU" $! false with "Hdbpt") as "HΦ".
    iIntros "!> Htxn".
    wp_pures.
    by iApply "HΦ".
  }
Qed.

Theorem wp_CallHello :
  {{{ True }}}
    CallHello #()
  {{{ RET #(); True }}}.
Proof using heapGS0 mvcc_ghostG0 Σ.
  iIntros (Φ) "_ HΦ".
  wp_call.

  (***********************************************************)
  (* db := txn.MkTxnMgr()                                    *)
  (* db.ActivateGC()                                         *)
  (* txn := db.New()                                         *)
  (* Hello(txn)                                              *)
  (***********************************************************)
  wp_apply wp_MkTxnMgr.
  iIntros (γ mgr) "[#Hmgr Hdbpts]".
  wp_pures.
  wp_apply (wp_txnMgr__ActivateGC with "Hmgr").
  wp_pures.
  wp_apply (wp_txnMgr__New with "Hmgr").
  iIntros (txn) "Htxn".
  wp_pures.
  wp_apply (wp_Hello with "Htxn").
  iApply ncfupd_mask_intro; first set_solver.
  iIntros "Hmask".
  iDestruct (big_sepM_lookup _ _ (U64 0) with "Hdbpts") as "Hdbpt".
  { rewrite lookup_gset_to_gmap_Some.
    split; [set_solver | reflexivity].
  }
  iExists Nil.
  iFrame.
  iIntros (ok) "Hdbpt".
  iMod "Hmask" as "_".
  iIntros "!> Htxn".
  wp_pures.
  by iApply "HΦ".
Qed.

End program.

Module closed_proof.

  Import adequacy.

  Definition helloΣ := #[heapΣ; mvcc_ghostΣ].

  Lemma hello_adequate σ g :
    σ.(world).(grove_node_files) = ∅ →
    g.(global_world).(grove_net) = ∅ →
    recovery_adequacy.adequate_failstop (CallHello #()) σ g (λ v _ _, v = #()).
  Proof.
    intros Hfiles Hnet. eapply (grove_ffi_single_node_adequacy_failstop helloΣ).
    { rewrite Hnet. done. }
    { rewrite Hfiles. done. }
    iIntros (hHeap) "_ _ !>". iApply wp_CallHello; auto.
  Qed.
End closed_proof.


(*******************************************************************
 * Este archivo especifica el estado.
 *
 ******************************************************************)

(* Shortcut notation for partial functions *)
Definition partial a b := a -> option b.
Notation "a ⇸ b" := (partial a b) (at level 51, right associativity).

Section State.

  (** Identificadores de OSs e Hypercalls *)
  Parameter os_ident : Set.
  Parameter os_ident_eq : forall oi1 oi2 : os_ident, {oi1 = oi2} + {oi1 <> oi2}.

  Parameter Hyperv_call : Set.

  (* Memoria y direcciones *)

  (** Direcciones Virtuales. **)
  Parameter vadd : Set.
  Parameter vadd_eq : forall va1 va2 : vadd, {va1 = va2} + {va1 <> va2}.

  (** Direcciones de Máquina. **)
  Parameter madd :  Set.
  Parameter madd_eq : forall ma1 ma2 : madd, {ma1 = ma2} + {ma1 <> ma2}.

  (** Direcciones Físicas **)
  Parameter padd : Set.
  Parameter padd_eq : forall pa1 pa2 : padd, {pa1 = pa2} + {pa1 <> pa2}.

  (** Memory values. **)
  Parameter value : Set.
  Parameter value_eq : forall val1 val2 : value, {val1 = val2} + {val1 <> val2}.

  (* Environment *)
  Record context : Set :=
    Context {
        (** una dirección virtual es accesible, no está reserveda por el HV **)
        ctxt_vadd_accessible: vadd -> bool;
        (** guest Oss (Confiable/No Confiable) **)
        ctxt_oss : os_ident -> bool
      }.

  (* Operative Systems *)
  Record os := mk_os { curr_page : padd; hcall : option Hyperv_call }.

  Definition oss_map := os_ident ⇸ os.

  (* Execution Modes *)
  Inductive exec_mode := usr | svc.
  Inductive os_activity := running | waiting.

  (* Memory Mappings *)
  Definition hypervisor_map := os_ident ⇸ padd ⇸ madd.

  Inductive content :=
  | RW (v : option value)
  | PT (va_to_ma : vadd ⇸ madd)
  | Other.

  Definition is_RW c :=
    match c with
    | RW _ => True
    | _ => False
    end.

  Inductive page_owner :=
  | Hyp
  | Os (osi : os_ident)
  | No_Owner.

  Record page := mk_page { page_content : content; page_owned_by : page_owner }.

  Definition system_memory := madd ⇸ page.

  Definition update mem addr page : system_memory :=
    fun addr' => if madd_eq addr' addr
                 then Some page
                 else mem addr'.

  (* States *)
  Record State :=
    mk_State {
        active_os : os_ident;
        aos_exec_mode : exec_mode;
        aos_activity : os_activity;
        oss : oss_map;
        hypervisor : hypervisor_map;
        memory : system_memory
      }.

  Definition va_mapped_to_ma (s : State) (va : vadd) (ma : madd) :=
    exists (curr_os : os)           (* SO actual *)
           (ph_map : padd ⇸ madd)  (* mappings del HV para el SO actual *)
           (curr_pt_addr : madd)    (* dirección  de la PT del SO actual *)
           (pt : page)              (* PT del SO actual *)
           (vt_map : vadd ⇸ madd), (* mappings de la PT del SO actual *)
      oss s (active_os s) = Some curr_os
      /\ hypervisor s (active_os s) = Some ph_map
      /\ ph_map (curr_page curr_os) = Some curr_pt_addr
      /\ memory s curr_pt_addr = Some pt
      /\ page_content pt = PT vt_map
      /\ vt_map va = Some ma.

  Definition trusted_os (ctxt : context) (s : State) : Prop :=
    ctxt_oss ctxt (active_os s) = true.

End State.


From Perennial.program_proof Require Import grove_prelude.
From Goose.github_com.mit_pdos.gokv Require Import aof.
From Perennial.algebra Require Import mlist.
From iris.algebra Require Import mono_nat.
From Perennial.Helpers Require Import ModArith.
From Perennial.program_proof.fencing Require Import map.
From Perennial.goose_lang Require Import crash_borrow.

From Perennial.program_proof Require Import marshal_stateless_proof.

Section aof_proof.

Class aofG Σ := AofG {
  aof_flistG :> fmlistG u8 Σ ;
  aof_mnatG :> inG Σ mono_natUR ;
  aof_mapG :> mapG Σ u64 unit ;
  aof_tokG :> inG Σ (exclR unitO) ;
  aof_stagedG :> stagedG Σ ; (* for crash borrows? *)
  aof_ghostG :> ghost_varG Σ unit ;
  aof_curdataG :> ghost_varG Σ (list u8) ;
}.

Definition aofΣ := #[
  fmlistΣ u8 ; GFunctor (mono_natUR) ;
  mapΣ u64 unit ;
  GFunctor (exclR unitO) ;
  stagedΣ ;
  ghost_varΣ unit ;
  ghost_varΣ (list u8)
].

Global Instance subG_aofΣ {Σ} : subG aofΣ Σ → aofG Σ.
Proof. solve_inG. Qed.

Context `{!heapGS Σ}.
Context `{!filesysG Σ}.

Record aof_vol_names := mk_aof_vol_names {
  logdata : gname ;
  predurabledata : gname ;
  durabledata : gname ;
  len : gname ;
  len_toks : gname ;
  close_tok: gname ;
  close_req_tok: gname ;
  curdata : gname ;
  crashtok: gname ;
  initdata : list u8 ;
}.

Context `{aofG Σ}.

Implicit Types γ : aof_vol_names.
Implicit Types P: (list u8) → iProp Σ.

Definition aof_lenN := nroot .@ "aof_len".

Definition aof_len_invariant γ : iProp Σ :=
  ∃ (l:u64),
    own γ.(len) (●MN{#1/2} (int.nat l)) ∗
    [∗ set] x ∈ (fin_to_set u64), x ⤳[γ.(len_toks)] () ∨ ⌜int.nat x > int.nat l⌝
.

Definition aof_length_lb γ (l:u64) : iProp Σ :=
  own γ.(len) (mono_nat_lb (int.nat l)).

Definition list_safe_size (l:list u8) := int.nat (length l) = length l.

Definition aof_log_own γ data : iProp Σ :=
  fmlist γ.(logdata) (DfracOwn (1/2)) data ∗
  ghost_var γ.(close_req_tok) 1 () ∗
  ghost_var γ.(close_tok) 1 ()
.

Definition aof_durable_lb γ data : iProp Σ :=
  fmlist_lb γ.(durabledata) data
.

(* TODO: make make this a parameter to the library? *)
Definition aofN := nroot .@ "aof".
Definition aofN1 := aofN .@ "1".
Definition aofN2 := aofN .@ "2".
Definition aofNlk := aofN .@ "aoflk".

Definition is_aof_ctx_inv γ P :=
  inv aofN1 (C ∗ ghost_var γ.(crashtok) 1 () ∨ (* either the node has crashed, *)
      ∃ (data:list u8),
        (fmlist γ.(logdata) DfracDiscarded data) ∗ ghost_var γ.(curdata) 1 data ∗ ghost_var γ.(close_req_tok) 1 ()
        ∨ (* or there's a witness that the user closed the file *)
      (* the fmlist_lb and the 1/2 durabledata ownership are to help prove a strong accessP lemma *)
      fmlist_lb γ.(logdata) data ∗ fmlist γ.(durabledata) (DfracOwn (1/2)) data ∗
      ghost_var γ.(curdata) (1/2) data ∗ P data) (* or P is available *)
.

Definition aof_close_resources (aof_ptr:loc) γ P Pcrash fname : iProp Σ :=
  ∃ (isClosed closeRequested:bool),
  "HcloseRequested" ∷ aof_ptr ↦[AppendOnlyFile :: "closeRequested"] #closeRequested ∗
  "Hclosed" ∷ aof_ptr ↦[AppendOnlyFile :: "closed"]{1/2} #isClosed ∗ (* other half owned by background thread *)
  "#HexpectedData" ∷ (if closeRequested then ∃ expectedData, (fmlist γ.(logdata) (DfracDiscarded) expectedData) else True) ∗
  "Hreq_tok" ∷ (if closeRequested && negb isClosed then ghost_var γ.(close_req_tok) 1 () else True) ∗
  "HfileEscrow" ∷ (if isClosed then
              inv aofN2 (∃ data, crash_borrow (fname f↦ data ∗ P data) (|C={⊤}=> ∃ data', fname f↦ data' ∗ ▷ Pcrash data') ∗
                      fmlist γ.(logdata) DfracDiscarded data ∨
                      ghost_var γ.(close_tok) 1 ()
                     )
            else
                    True)
.

(* FIXME: the membuf fupd will need to be run while is_aof_ctx_inv is open, so
   it can't use aofN. Its mask needs adjustment. *)
Definition aof_mu_invariant (aof_ptr:loc) mu γ fname P Pcrash : iProp Σ :=
  ∃ membuf_sl membufC predurableC (durlen:u64) (durCond_ptr:loc),
  let memlen := length (predurableC ++ membufC) in
  "#Hcrash_wand" ∷ □ (∀ data, ▷ P data ={⊤}=∗ ▷ Pcrash data) ∗
  "Hmembuf" ∷ aof_ptr ↦[AppendOnlyFile :: "membuf"] (slice_val membuf_sl) ∗
  "HdurableLength" ∷ aof_ptr ↦[AppendOnlyFile :: "durableLength"]{1/2} #durlen ∗
  "Hlength" ∷ aof_ptr ↦[AppendOnlyFile :: "length"] #(U64 memlen) ∗
  "Hmembuf_sl" ∷ typed_slice.is_slice membuf_sl byteT 1 membufC ∗

  "Hpredurable" ∷ fmlist γ.(predurabledata) (DfracOwn (1/2)) (γ.(initdata) ++ predurableC) ∗
  "Hlogdata" ∷ fmlist γ.(logdata) (DfracOwn (1/2)) (γ.(initdata) ++ predurableC ++ membufC) ∗
  "%Hlengthsafe" ∷ ⌜list_safe_size (predurableC ++ membufC)⌝ ∗
  "Hlen_toks" ∷ ([∗ set] x ∈ (fin_to_set u64), x ⤳[γ.(len_toks)] () ∨ ⌜int.nat x ≤ memlen⌝) ∗
  "Hmembuf_fupd" ∷ (P (γ.(initdata) ++ predurableC) -∗ fmlist_lb γ.(durabledata) (γ.(initdata) ++ predurableC ++ membufC)
                    ={⊤∖↑aofN}=∗ P (γ.(initdata) ++ predurableC ++ membufC)
     ∗ (own γ.(len) (●MN{#1/2} (length predurableC)) ={⊤}=∗ own γ.(len) (●MN{#1/2} memlen)
       )
  ) ∗
  "#Hdurlen_lb" ∷ aof_length_lb γ durlen ∗
  "Hclose" ∷ aof_close_resources aof_ptr γ P Pcrash fname ∗
  "HdurableCond" ∷ aof_ptr ↦[AppendOnlyFile :: "durableCond"] #durCond_ptr ∗
  "#HdurCond" ∷ is_cond durCond_ptr mu
.

Definition is_aof aof_ptr γ fname (P : (list u8) → iProp Σ) Pcrash : iProp Σ :=
  ∃ mu_ptr (lenCond_ptr cloCond_ptr:loc),
  "#Hmu" ∷ readonly (aof_ptr ↦[AppendOnlyFile :: "mu"] mu_ptr) ∗
  "#HlengthCond" ∷ readonly (aof_ptr ↦[AppendOnlyFile :: "lengthCond"] #lenCond_ptr) ∗
  "#HclosedCond" ∷ readonly (aof_ptr ↦[AppendOnlyFile :: "closedCond"] #cloCond_ptr) ∗
  "#HlenCond" ∷ is_cond lenCond_ptr mu_ptr ∗
  "#HcloCond" ∷ is_cond cloCond_ptr mu_ptr ∗
  "#Hmu_inv" ∷ is_lock aofNlk mu_ptr (aof_mu_invariant aof_ptr mu_ptr γ fname P Pcrash) ∗
  "#Haof_len_inv" ∷ inv aof_lenN (aof_len_invariant γ) ∗
  "#Hctx_inv" ∷ is_aof_ctx_inv γ P
.

Lemma ctx_inv_crash γ P data :
  is_aof_ctx_inv γ P -∗
  ghost_var γ.(curdata) (1 / 2) data -∗ ghost_var γ.(crashtok) 1 () -∗
  |C={⊤}=> ▷ P data.
Proof.
  iIntros "#Hinv Hcurdata Hcrashtok".

  iInv "Hinv" as "Hctx" "Hctx_close".
  iDestruct "Hctx" as "[[_ >Hbad]|Hctx]".
  { iDestruct (ghost_var_valid_2 with "Hcrashtok Hbad") as %Hbad.
    exfalso.
    naive_solver. }
  iDestruct "Hctx" as (?) "Hctx".
  iDestruct "Hctx" as "[[_ [>Hbad _]]|Hctx]".
  { iDestruct (ghost_var_valid_2 with "Hcurdata Hbad") as %Hbad.
    exfalso.
    naive_solver. }

  iDestruct "Hctx" as "(_ & _ & >Hcurdata2 & Hctx)".
  iDestruct (ghost_var_agree with "Hcurdata Hcurdata2") as %->.
  iIntros "#Hc".
  iMod ("Hctx_close" with "[Hcrashtok]").
  {
    iLeft. iFrame "∗#".
  }
  iFrame. done.
Qed.

Lemma ctx_inv_update γ P data data' Q :
prefix data data' →
  is_aof_ctx_inv γ P -∗
  £ 1 -∗
  fmlist_lb γ.(logdata) data' -∗
  (P data -∗ fmlist_lb γ.(durabledata) data' ={⊤∖↑aofN}=∗ P data' ∗ Q) -∗
  fmlist γ.(durabledata) (DfracOwn (1/2)) data -∗
  ghost_var γ.(curdata) (1/2) data -∗
  ghost_var γ.(crashtok) 1 () ={⊤}=∗
  ghost_var γ.(curdata) (1 / 2) data' ∗ ghost_var γ.(crashtok) 1 () ∗
  fmlist γ.(durabledata) (DfracOwn (1/2)) data' ∗ Q
.
Proof.
  intros.
  iIntros "#Hinv Hlc #Hloglb Hupd Hdurdata Hcurdata Hcrashtok".
  iInv "Hinv" as "Hctx" "Hctx_close".
  iMod (lc_fupd_elim_later with "Hlc Hctx") as "Hctx".
  iDestruct "Hctx" as "[[_ Hbad]|Hctx]".
  { iDestruct (ghost_var_valid_2 with "Hcrashtok Hbad") as %Hbad.
    exfalso.
    naive_solver. }
  iDestruct "Hctx" as (?) "Hctx".
  iDestruct "Hctx" as "[[_ [Hbad _]]|Hctx]".
  { iDestruct (ghost_var_valid_2 with "Hcurdata Hbad") as %Hbad.
    exfalso.
    naive_solver. }

  iDestruct "Hctx" as "(_ & Hdurdata2 & Hcurdata2 & Hctx)".
  iDestruct (ghost_var_agree with "Hcurdata Hcurdata2") as %<-.
  iCombine "Hdurdata Hdurdata2" as "Hdurdata".
  iMod (fmlist_update with "Hdurdata") as "[[Hdurdata Hdurdata2] Hdurdata_lb]".
  { done. }

  iMod (fmlist_get_lb with "Hdurdata") as "[Hdurdata #Hlog_lb]".
  iApply (fupd_mask_weaken (⊤ ∖ ↑aofN)); first by solve_ndisj.
  iIntros "Hfupd_clo".
  iMod ("Hupd" with "Hctx Hlog_lb") as "(Hctx & HQ)".
  iMod (ghost_var_update_2 with "Hcurdata Hcurdata2") as "[Hcurdata Hcurdata2]".
  { by rewrite Qp.half_half. }

  iMod "Hfupd_clo".
  iMod ("Hctx_close" with "[Hctx Hcurdata2 Hdurdata2]").
  {
    iRight. iExists _.
    iRight. iFrame "∗#".
  }
  iFrame.
  done.
Qed.

Lemma ctx_inv_close γ P data :
  is_aof_ctx_inv γ P -∗
  £ 1 -∗
  fmlist γ.(logdata) DfracDiscarded data -∗
  ghost_var γ.(curdata) (1 / 2) data -∗
  ghost_var γ.(close_req_tok) 1 () -∗
  ghost_var γ.(crashtok) 1 ()
  ={⊤}=∗
  P data ∗ ghost_var γ.(crashtok) 1 ()
.
Proof.
  iIntros "#Hinv Hlc Hclosed Hcurdata Hclose_req Hcrashtok".
  iInv "Hinv" as "Hctx" "Hctx_close".
  iMod (lc_fupd_elim_later with "Hlc Hctx") as "Hctx".
  iDestruct "Hctx" as "[[_ Hbad]|Hctx]".
  { iDestruct (ghost_var_valid_2 with "Hcrashtok Hbad") as %Hbad.
    exfalso.
    naive_solver. }
  iDestruct "Hctx" as (?) "Hctx".
  iDestruct "Hctx" as "[[_ [Hbad _]]|Hctx]".
  { iDestruct (ghost_var_valid_2 with "Hcurdata Hbad") as %Hbad.
    exfalso.
    naive_solver. }

  iDestruct "Hctx" as "(_ & _ & Hcurdata2 & Hctx)".
  iDestruct (ghost_var_agree with "Hcurdata Hcurdata2") as %->.
  iCombine "Hcurdata Hcurdata2" as "Hcurdata".

  iFrame.
  iMod ("Hctx_close" with "[-]").
  {
    iNext.
    iRight.
    iExists _; iLeft.
    iFrame.
  }
  done.
Qed.

Lemma wp_CreateAppendOnlyFile (fname:string) data P Pcrash :
□(∀ data, ▷ P data ={⊤}=∗ ▷ Pcrash data) -∗
  {{{
       crash_borrow (fname f↦ data ∗ P data)
                    (|C={⊤}=> ∃ data', fname f↦ data' ∗ ▷ Pcrash data')
  }}}
    CreateAppendOnlyFile #(str fname)
  {{{
       aof_ptr γ, RET #aof_ptr; is_aof aof_ptr γ fname P Pcrash ∗ aof_log_own γ data ∗ aof_durable_lb γ data
  }}}.
Proof.
  iIntros "#Hcrash_wand !#" (Φ) "Hpre HΦ".
  wp_lam.

  wp_apply (wp_allocStruct).
  { Transparent slice.T. repeat econstructor. Opaque slice.T. }
  iIntros (l) "Hl".
  iDestruct (struct_fields_split with "Hl") as "Hl".
  iNamed "Hl".

  wp_pures.
  wp_apply (wp_new_free_lock).
  iIntros (mu) "Hmu_free".

  wp_pures.
  wp_storeField.

  wp_loadField.
  wp_apply (wp_newCond' with "Hmu_free").
  iIntros (lengthCond) "[Hmu_free #HlenCond]".
  wp_storeField.

  wp_loadField.
  wp_apply (wp_newCond' with "Hmu_free").
  iIntros (durableCond) "[Hmu_free #HdurCond]".
  wp_storeField.

  wp_loadField.
  wp_apply (wp_newCond' with "Hmu_free").
  iIntros (closedCond) "[Hmu_free #HcloCond]".

  (* Allocate ghost state and invariants *)
  iMod (fmlist_alloc data) as (γlogdata) "[Hlogdata Hlogdata2]".
  iMod (fmlist_get_lb with "Hlogdata2") as "[Hlogdata2 #Hlog_lb]".
  iMod (fmlist_alloc data) as (γpredurabledata) "[Hpredurable Hpredurable2]".
  iMod (fmlist_alloc data) as (γdurabledata) "[Hdurabledata Hdurabledata2]".
  iMod (fmlist_get_lb with "Hdurabledata") as "[Hdurabledata #Hdurable_lb]".
  iMod (ghost_map_alloc_fin ()) as (γlen_toks) "Hlen_toks".
  iMod (own_alloc (●MN 0)) as (γlen) "[Hlen Hlen2]".
  { apply mono_nat_auth_valid. }

  iDestruct (own_mono _ _ (◯MN 0) with "Hlen2") as "#Hdurlen_lb".
  { apply mono_nat_included. }
  iDestruct "durableLength" as "[HdurableLength HdurableLength2]".
  iMod (ghost_var_alloc ()) as (γclose_tok) "Hclose_tok".
  iMod (ghost_var_alloc ()) as (γclose_req_tok) "Hclose_req_tok".
  iMod (ghost_var_alloc data) as (γcurdata) "[Hcurdata Hcurdata2]".
  iMod (ghost_var_alloc ()) as (γcrashtok) "Hcrashtok".
  set (γ:=mk_aof_vol_names γlogdata γpredurabledata γdurabledata γlen γlen_toks γclose_tok γclose_req_tok γcurdata γcrashtok data).

  iDestruct (crash_borrow_wpc_nval _ _ _ (fname f↦data ∗ ghost_var γcurdata (1/2) data ∗ ghost_var γ.(crashtok) 1 ())
                                   (is_aof_ctx_inv γ P) with "Hpre [Hcurdata2 Hcurdata Hcrashtok Hdurabledata2]") as "Hnval_pre".
  {
    iNext.
    iIntros "[Hf HP]".
    iMod (inv_alloc with "[HP Hcurdata2 Hdurabledata2]") as "#Hctx_inv"; last iFrame "Hctx_inv".
    {
      iNext. iRight.
      iExists data.
      iRight.
      iFrame "∗#".
    }
    iFrame.
    instantiate (1:=⊤).
    iModIntro.
    iModIntro.
    iIntros "(Hf & Hcurdata & Htok)".
    iMod (ctx_inv_crash with "Hctx_inv Hcurdata Htok") as "HP".
    iMod ("Hcrash_wand" with "HP") as "HP".
    iModIntro.
    iExists _; iFrame.
  }

  wp_bind (struct.storeF _ _ _ _).
  iApply (wpc_wp _ _ _ _ True).
  wpc_apply (wpc_nval_elim with "Hnval_pre").
  { done. }
  { done. }
  iApply wp_wpc.
  wp_storeField.
  iIntros "[#Hctx_inv Hpre]".
  iDestruct "closed" as "(closed1&closed2)".

  iAssert ((|={⊤}=> is_aof l γ fname P Pcrash ∗
                      fmlist γ.(predurabledata) (DfracOwn (1/2)) γ.(initdata) ∗
                      fmlist γ.(durabledata) (DfracOwn (1/2)) γ.(initdata) ∗
                      l ↦[AppendOnlyFile :: "durableLength"]{1/2} #0 ∗
                      own γ.(len) (●MN{#1/2} 0) ∗
                      aof_log_own γ γ.(initdata) ∗
                      ⌜data = γ.(initdata)⌝
                          )
          )%I with "[-Hpre closed2 HΦ]" as ">HH".
  {
    iAssert (
    ([∗ set] x ∈ fin_to_set u64,
      (x ⤳[γlen_toks] () ∨ ⌜int.nat x ≤ 0%nat⌝) ∗
      (x ⤳[γlen_toks] () ∨ ⌜int.nat x > 0%nat⌝))
      )%I with "[Hlen_toks]" as "HH".
    {
      iApply (big_sepS_impl with "Hlen_toks").
      iModIntro.
      iIntros.
      destruct (decide (int.nat x <= 0%nat)).
      {
        iSplitR; iFrame.
        iRight. iPureIntro. done.
      }
      assert (int.nat x > 0%nat) by word.
      iSplitL; iFrame.
      iRight. iPureIntro. done.
    }
    iDestruct (big_sepS_sep with "HH") as "[Hlen_toks Hlen_toks2]".

    iMod (inv_alloc aof_lenN _ (aof_len_invariant γ) with "[Hlen2 Hlen_toks2]") as "#Hinv".
    {
      iNext.
      iExists (U64 0).
      iFrame.
    }
    iMod (readonly_alloc_1 with "mu") as "#Hmu".
    iMod (readonly_alloc_1 with "lengthCond") as "#HlengthCond".
    iMod (readonly_alloc_1 with "closedCond") as "#HclosedCond".

    iMod (alloc_lock _ _ _ (aof_mu_invariant l (#mu) γ fname P Pcrash) with "Hmu_free [-Hlogdata2 HdurableLength2 Hpredurable2 Hdurabledata Hlen Hclose_tok Hclose_req_tok]") as "#HmuInv".
    {
      iNext.
      iExists (Slice.nil), [], [], (U64 0), _.
      iDestruct is_slice_zero as "$".
      simpl.
      rewrite app_nil_r.
      iFrame "∗#".
      iSplitR; first done.
      iSplitR.
      { by iIntros "$ _ !> $ !>". }
      iExists false, false.
      iFrame.
      done.
    }
    iModIntro.
    iFrame.
    iSplitL; last done.
    repeat iExists _.
    iFrame "#".
  }
  iDestruct "HH" as "(#His_aof & Hpredur & Hdur & HdurLen & Hlen & Hlog_own & %Hre)".
  rewrite Hre.
  replace (data) with (γ.(initdata)) by done.
  clear Hre.
  rename data into initial_data.
  wp_apply (wp_fork with "[-HΦ Hlog_own]").
  {
    iNext.
    iEval (simpl) in "closed2".
    iClear "HlenCond HdurCond HcloCond Hcrash_wand Hctx_inv".
    iNamed "His_aof".
    wp_loadField.
    wp_apply (acquire_spec with "Hmu_inv").
    iIntros "[Hlocked Haof_own]".
    wp_pures.
    iAssert (∃ data',
              crash_borrow
             (fname f↦(γ.(initdata) ++ data') ∗ ghost_var γcurdata (1 / 2) (γ.(initdata) ++ data') ∗
                ghost_var γ.(crashtok) 1 ())
             (|C={⊤}=> ∃ data' : list u8, fname f↦data' ∗ ▷ Pcrash data') ∗

              fmlist γ.(predurabledata) (DfracOwn (1/2)) (γ.(initdata) ++ data') ∗
              fmlist γ.(durabledata) (DfracOwn (1/2)) (γ.(initdata) ++ data') ∗
              l ↦[AppendOnlyFile :: "durableLength"]{1 / 2} #(U64 (length data')) ∗
              own γ.(len) (●MN{#1/2} (length (data')))
            )%I with "[Hpre Hdur Hpredur HdurLen Hlen]" as "Hfile_ctx".
    { iExists []; iFrame. rewrite app_nil_r. iFrame. }
    wp_forBreak.
    wp_pure1_credit "Hlc".

    iClear "Hdurlen_lb".
    iNamed "Haof_own".
    wp_loadField.
    wp_apply (wp_slice_len).
    wp_pure1_credit "Hlc2".

    iNamed "Hclose".
    wp_apply (wp_and with "[HcloseRequested]").
    { iNamedAccu. }
    {
      wp_pures.
      done.
    }
    {
      iIntros.
      wp_loadField.
      wp_pures.
      iFrame.
      instantiate (2:=(closeRequested = false)).
      instantiate (1:=decide_rel eq _ _).
      iPureIntro.
      f_equal.
      destruct closeRequested.
      { rewrite bool_decide_false; done. }
      { rewrite bool_decide_true; done. }
    }
    iNamed 1.

    wp_if_destruct.
    {
      wp_loadField.
      wp_apply (wp_condWait with "[- closed2 Hfile_ctx]").
      { iFrame "#∗". repeat iExists _; iFrame "∗#". iSplitR; first done.
        iExists _, _; iFrame "∗#".
      }
      iIntros "[Hlocked Haof_own]".
      wp_pures.
      iLeft.
      iFrame.
      done.
    }

    wp_loadField.

    (* Prepare ghost state for writing to file; whether we close the file or
       not, we're going to do the FileAppend *)
    iDestruct "Hfile_ctx" as (data') "(Hfile_ctx & Hpredur & Hdur & HdurLen & Hlen)".
    iDestruct (fmlist_agree_1 with "Hpredur Hpredurable") as %Hpredur.
    apply app_inv_head in Hpredur.
    rewrite Hpredur.
    iCombine "Hpredur Hpredurable" as "Hpredur".
    iMod (fmlist_update (γ.(initdata) ++ predurableC ++ membufC) with "Hpredur") as "[Hpredur _]".
    { rewrite app_assoc. apply prefix_app_r. done. }
    iDestruct "Hpredur" as "[Hpredur Hpredurable]".

    iClear "Hlog_lb".
    iMod (fmlist_get_lb with "Hlogdata") as "[Hlogdata #Hlog_lb]".

    wp_if_destruct.
    { (* case: close aof; write the remaining stuff first, using the same
         arugment as when we write with the lock *)
      wp_loadField.

      wp_bind (FileAppend _ _).
      iApply (wpc_wp _ _ _ _ True).
      wpc_apply (wpc_crash_borrow_open_modify with "Hfile_ctx").
      { done. }
      iSplit; first done.
      iIntros "(Hfile & Hcurdata & Hcrashtok)".
      iApply wpc_fupd.

      iDestruct (is_slice_to_small with "Hmembuf_sl") as "Hmembuf_sl".
      wpc_apply (wpc_FileAppend with "[$Hfile $Hmembuf_sl]").
      iSplit.
      { (* This is the case in which the node crashes during the FileAppend. *)
        iIntros "[Hbefore|Hafter]".
        {
          iSplitR; first done.
          iMod (ctx_inv_crash with "Hctx_inv Hcurdata Hcrashtok") as "HP".
          iMod ("Hcrash_wand" with "HP") as "HP".
          iModIntro.
          iExists _. iFrame.
        }
        {
          iSplitR; first done.

          repeat rewrite -app_assoc.
          iMod (ctx_inv_update with "Hctx_inv Hlc Hlog_lb [Hmembuf_fupd] Hdur Hcurdata Hcrashtok") as "(Hcurdata & Hcrashtok & _)".
          {
            rewrite app_assoc.
            apply prefix_app_r.
            done.
          }
          {
            instantiate (1:=True%I).
            iIntros "HP Hlb".
            iMod ("Hmembuf_fupd" with "HP Hlb") as "[$ _]".
            done.
          }
          iMod (ctx_inv_crash with "Hctx_inv Hcurdata Hcrashtok") as "HP".
          iMod ("Hcrash_wand" with "HP") as "HP".
          iModIntro.
          iExists _. iFrame.
        }
      }
      iNext.
      iIntros "[Hfile _]".

      (* commit remaining operations before we close the file. *)
      iMod (ctx_inv_update with "Hctx_inv Hlc Hlog_lb [Hmembuf_fupd] Hdur Hcurdata Hcrashtok") as "(Hcurdata & Hcrashtok & Hdur & Hlen_fupd)".
      { rewrite app_assoc. apply prefix_app_r. done. }
      {
        iIntros "HP Hlb".
        iMod ("Hmembuf_fupd" with "HP Hlb") as "[$ Hlen_fupd]".
        iModIntro.
        iExact "Hlen_fupd".
      }

      iMod ("Hlen_fupd" with "Hlen") as "Hlen".
      iEval (rewrite mono_nat_auth_lb_op) in "Hlen".
      iDestruct "Hlen" as "[Hlen #Hlenlb]".

      (* Going to return the crash borrow to the user, so get it back into the
         form they want. *)
      iNamed "Hclose".
      iDestruct "HexpectedData" as (?) "HexpectedData".
      iDestruct (fmlist_agree_1 with "HexpectedData Hlogdata") as %->.
      iDestruct (struct_field_mapsto_agree with "Hclosed closed2") as %Heq.
      inversion Heq.

      iMod (ctx_inv_close with "Hctx_inv Hlc2 HexpectedData Hcurdata Hreq_tok Hcrashtok") as "[HP Hcrashtok]".

      rewrite -app_assoc.
      iModIntro.
      iExists _.
      iSplitL "Hfile HP".
      { iAccu. }
      iSplit.
      {
        iModIntro. iIntros "(Hfile & HP)".
        iMod ("Hcrash_wand" with "HP") as "HP".
        iModIntro.
        iExists _. iFrame.
      }

      iIntros "Hfile_ctx".
      iSplit; first done.
      wp_pures.

      wp_apply (wp_NewSlice).
      iIntros (empty_membuf_sl) "Hmembuf_empty".
      wp_storeField.

      wp_loadField.

      iDestruct (struct_field_mapsto_agree with "HdurLen HdurableLength") as %Heq'.
      rewrite Heq'.
      iCombine "HdurLen HdurableLength" as "HdurLen".
      wp_storeField.
      wp_loadField.
      wp_apply (wp_condBroadcast).
      { iFrame "#". }
      wp_pures.
      iCombine "closed2 Hclosed" as "Hclosed".
      wp_storeField.
      iDestruct "Hclosed" as "(closed2&Hclosed)".
      wp_loadField.
      wp_apply (wp_condBroadcast).
      { iFrame "#". }
      wp_pures.
      wp_loadField.

      iMod (inv_alloc with "[Hfile_ctx]") as "#HfileEscrow2".
      {
        instantiate (1:=(∃ data : list u8,
                       crash_borrow (fname f↦data ∗ P data)
                       (|C={⊤}=> ∃ data'0 : list u8, fname f↦data'0 ∗ ▷ Pcrash data'0) ∗
                       fmlist γ.(logdata) DfracDiscarded data ∨ ghost_var γ.(close_tok) 1 ())%I).
        iNext.
        iExists _.
        iLeft.
        iFrame "∗#".
      }

      wp_apply (release_spec with "[-Hlen closed2]").
      {
        iFrame "#∗".
        iNext.
        iDestruct "HdurLen" as "[HdurableLength HdurLen]".
        iExists _, [], _, _, _.
        rewrite app_nil_r.
        iFrame "∗#%".
        iSplitR.
        { by iIntros "$ _ !> $ !>". }
        unfold aof_length_lb.
        rewrite Hlengthsafe.
        iFrame "#".

        iExists _, _.
        iFrame "Hclosed ∗".
        iFrame "#".
        iExists _; iFrame "#".
      }
      wp_pures.
      iRight.
      done.
    }

    (* case: don't want to close the file, do a FileAppend after letting go of
       mutex and loop *)
    wp_loadField.
    wp_pures.
    wp_loadField.
    wp_pures.

    wp_apply (wp_new_slice).
    { done. }
    iIntros (empty_membuf_sl) "Hmembuf_empty".
    wp_apply (wp_storeField with "Hmembuf").
    { unfold AppendOnlyFile. unfold field_ty. simpl. apply slice_val_ty. }
    iIntros "Hmembuf".

    wp_pures.
    wp_loadField.
    wp_pures.
    wp_loadField.
    wp_apply (wp_newCond with "Hmu_inv").
    iIntros (newcond) "#Hnewcond".
    wp_storeField.
    wp_loadField.

    wp_apply (release_spec with "[-Hfile_ctx Hpredur Hdur Hmembuf_fupd Hmembuf_sl HdurLen Hlen closed2]").
    { iFrame "#∗". iNext. iExists _, [], (predurableC ++ membufC),_, _. iFrame "∗#".
      rewrite app_nil_r.
      iFrame.
      iSplitL ""; first done.
      iSplitR.
      { iIntros "$ _ !> $ !> //". }
      iExists _, _; iFrame "∗#".
    }

    wp_pure1_credit "Hlc".
    wp_pures.

    iDestruct (typed_slice.is_slice_sz with "Hmembuf_sl") as %Hsz.
    iDestruct (is_slice_to_small with "Hmembuf_sl") as "Hmembuf_sl".

    wp_bind (FileAppend _ _).
    iApply (wpc_wp _ _ _ _ True).
    wpc_apply (wpc_crash_borrow_open_modify with "Hfile_ctx").
    { done. }
    iSplit; first done.
    iIntros "(Hfile & Hcurdata & Hcrashtok)".
    iApply wpc_fupd.

    wpc_apply (wpc_FileAppend with "[$Hfile $Hmembuf_sl]").
    iSplit.
    { (* This is the case in which the node crashes during the FileAppend. *)
      iIntros "[Hbefore|Hafter]".
      {
        iSplitR; first done.
        iMod (ctx_inv_crash with "Hctx_inv Hcurdata Hcrashtok") as "HP".
        iMod ("Hcrash_wand" with "HP") as "HP".
        iModIntro.
        iExists _. iFrame.
      }
      {
        iSplitR; first done.

        repeat rewrite -app_assoc.
        iMod (ctx_inv_update with "Hctx_inv Hlc Hlog_lb [Hmembuf_fupd] Hdur Hcurdata Hcrashtok") as "(Hcurdata & Hcrashtok & _)".
        {
          rewrite app_assoc.
          apply prefix_app_r.
          done.
        }
        {
          instantiate (1:=True%I).
          iIntros "HP Hlb".
          iMod ("Hmembuf_fupd" with "HP Hlb") as "[$ _]".
          done.
        }
        iMod (ctx_inv_crash with "Hctx_inv Hcurdata Hcrashtok") as "HP".
        iMod ("Hcrash_wand" with "HP") as "HP".
        iModIntro.
        iExists _. iFrame.
      }
    }

    iNext.
    iIntros "[Hfile _]".

    (* commit remaining operations before we close the file. *)
    iMod (ctx_inv_update with "Hctx_inv Hlc Hlog_lb [Hmembuf_fupd] Hdur Hcurdata Hcrashtok") as "(Hcurdata & Hcrashtok & Hdur & Hlen_fupd)".
    { rewrite app_assoc. apply prefix_app_r. done. }
    {
      iIntros "HP Hlb".
      iMod ("Hmembuf_fupd" with "HP Hlb") as "[$ Hlen_fupd]".
      iModIntro.
      iExact "Hlen_fupd".
    }

    iMod ("Hlen_fupd" with "Hlen") as "Hlen".
    iEval (rewrite mono_nat_auth_lb_op) in "Hlen".
    iDestruct "Hlen" as "[Hlen #Hlenlb]".

    iModIntro.
    iExists _.

    iSplitL "Hfile Hcurdata Hcrashtok".
    { iNamedAccu. }
    iSplit.
    {
      iModIntro. iNamed 1.
      iMod (ctx_inv_crash with "Hctx_inv Hcurdata Hcrashtok") as "HP".
      iMod ("Hcrash_wand" with "HP") as "HP".
      iModIntro.
      iExists _. rewrite -app_assoc.
      iFrame.
    }

    iIntros "Hfile_ctx".
    iSplit; first done.

    wp_pures.
    wp_loadField.
    wp_apply (acquire_spec with "Hmu_inv").
    iIntros "[Hlocked Haof_own]".
    iRename "Hdurlen_lb" into "Hdurlen_lb_old".
    iClear "Hcrash_wand".
    iRename "HdurCond" into "HoldDurCond".
    iNamed "Haof_own".
    wp_pures.

    iDestruct (struct_field_mapsto_agree with "HdurLen HdurableLength") as %Heq.
    rewrite Heq.
    iCombine "HdurLen HdurableLength" as "HdurLen".
    wp_storeField.

    wp_apply (wp_condBroadcast).
    { iFrame "#". }
    wp_pures.
    iLeft.
    iFrame.
    iSplitL ""; first done.
    iDestruct "HdurLen" as "[HdurableLength HdurLen]".
    iSplitR "Hpredur Hdur HdurLen Hlen Hfile_ctx".
    {
      repeat iExists _; iFrame "∗#".
      unfold aof_length_lb.
      iSplitL ""; first done.
      unfold aof_length_lb.
      rewrite Hlengthsafe.
      iFrame "#".
      done.
    }
    {
      rewrite -Hpredur.
      repeat rewrite -app_assoc.
      iExists _; iFrame.
      iModIntro.
      done.
    }
  }
  wp_pures.
  iApply "HΦ".
  iFrame "∗#".
  done.
Qed.

Lemma wp_AppendOnlyFile__Append Q aof_ptr γ data_sl P Pcrash fname (oldData newData:list u8) q :
length newData > 0 →
list_safe_size newData →
is_aof aof_ptr γ fname P Pcrash -∗
  {{{
       typed_slice.is_slice_small data_sl byteT q newData ∗ aof_log_own γ oldData ∗
       (P oldData ={⊤∖↑aofN}=∗ P (oldData ++ newData) ∗ Q)
  }}}
    AppendOnlyFile__Append #aof_ptr (slice_val data_sl)
  {{{
       (l:u64), RET #l; aof_log_own γ (oldData ++ newData) ∗
                        (aof_length_lb γ l ={⊤}=∗ ▷ Q ∗ aof_durable_lb γ (oldData ++ newData))
  }}}.
Proof.
  intros HnewDataLen HnewDataSafe.
  iIntros "#Haof" (Φ) "!# Hpre HΦ".
  iNamed "Haof".
  wp_lam.
  wp_pures.

  wp_loadField.
  wp_apply (acquire_spec with "Hmu_inv").
  iIntros "[Hlocked Haof]".
  iNamed "Haof".
  iDestruct "Hpre" as "(HnewData & Haof_log & Hfupd)".
  wp_pures.

  wp_loadField.
  iDestruct (is_slice_small_sz with "HnewData") as %Hsz.

  wp_apply (wp_WriteBytes with "[$Hmembuf_sl $HnewData]").
  iIntros (membuf_sl') "[Hmembuf_sl HnewData]".
  wp_apply (wp_storeField with "Hmembuf").
  { unfold AppendOnlyFile. unfold field_ty. simpl. apply slice_val_ty. }
  iIntros "Hmembuf".

  wp_pures.

  (* overflow guard *)
  wp_apply (wp_slice_len).
  wp_loadField.
  wp_apply (std_proof.wp_SumAssumeNoOverflow).
  iIntros (HnoOverflow).
  wp_storeField.

  wp_loadField.
  wp_pures.
  rewrite -HnewDataSafe in Hsz.
  assert (U64 (length newData) = data_sl.(Slice.sz)) as HH.
  {
    apply Z2Nat.inj in Hsz.
    { word_cleanup. naive_solver. }
    { word_cleanup. naive_solver. }
    word.
  }
  rewrite -HH.
  rewrite -HH in HnoOverflow.
  wp_pures.
  wp_loadField.
  wp_apply (wp_condSignal).
  { iFrame "#". }

  wp_pures.

  unfold aof_log_own.
  iDestruct "Haof_log" as "[Haof_log Htok]".
  iDestruct (fmlist_agree_1 with "Haof_log Hlogdata") as %->.
  iCombine "Haof_log Hlogdata" as "Haof_log".

  iMod (fmlist_update ((γ.(initdata) ++ predurableC ++ membufC) ++ newData) with "Haof_log") as "[Haof_log _]".
  { apply prefix_app_r. done. }

  iDestruct "Haof_log" as "[Hlogdata Haof_log]".

  rewrite -app_assoc.
  (* Want to prove membuf_fupd, and the postcondition *)
  set (membufC' := membufC ++ newData) in *.

  iAssert (([∗ set] x ∈ (fin_to_set u64 : gset u64), x ⤳[γ.(len_toks)] () ∨
                      ⌜int.nat x <= length (predurableC ++ membufC)⌝ ∨
                      ⌜length (predurableC ++ membufC') < int.nat x⌝
          ) ∗
          ([∗ set] x ∈ (fin_to_set u64 : gset u64), x ⤳[γ.(len_toks)] () ∨
                      ⌜int.nat x ≤ length (predurableC ++ membufC')⌝
          ))%I
    with "[Hlen_toks]"
    as "HH".
  {
    iApply big_sepS_sep.
    iApply (big_sepS_impl with "Hlen_toks").
    iModIntro.
    iIntros (x ?) "Hx".
    iDestruct "Hx" as "[Hx|%Hineq]".
    {
      destruct (bool_decide (length (predurableC ++ membufC') < int.nat x)) as [|] eqn:Hineq.
      {
        apply bool_decide_eq_true in Hineq.
        iSplitR "Hx".
        { iRight; iRight. done. }
        iLeft. iFrame.
      }
      {
        apply bool_decide_eq_false in Hineq.
        iSplitL "Hx".
        { iFrame. }
        iRight.
        iPureIntro.
        word.
      }
    }
    {
      iSplitL.
      {
        iRight; iLeft. done.
      }
      iRight. iPureIntro.
      replace (membufC') with (membufC ++ newData) by done.
      rewrite app_assoc.
      rewrite app_length.
      word.
    }
  }

  iDestruct "HH" as "[Htoks Hlen_toks]".

  assert (int.nat (U64 (length (predurableC ++ membufC'))) = (length (predurableC ++ membufC'))) as Hsafesize'.
  {
    replace (membufC') with (membufC ++ newData) by done.
    rewrite app_assoc.
    rewrite app_length.
    word_cleanup.
    rewrite -Hlengthsafe.
    repeat (rewrite Nat2Z.inj_add).
    replace (length newData) with (Z.to_nat (Z.of_nat (length newData))) by lia.
    rewrite -Z2Nat.inj_add.
    {
      rewrite Z2Nat.inj_iff.
      {
        rewrite Z2Nat.id.
        {
          rewrite wrap_small; first word.
          split.
          {
            apply Z.add_nonneg_nonneg; word_cleanup; naive_solver.
          }
          {
            rewrite Nat2Z.id.
            rewrite -HnewDataSafe.
            replace (Z.of_nat (int.nat (length newData))) with (int.Z (length newData)); last first.
            { rewrite u64_Z_through_nat. done. }
            destruct (bool_decide (int.Z (length (predurableC ++ membufC)) + (int.Z (length newData)) < 2 ^ 64))%Z eqn:Hnov.
            { apply bool_decide_eq_true in Hnov. done. }
            {
              apply bool_decide_eq_false in Hnov.
              word.
            }
          }
        }
        naive_solver.
      }
      {
        word_cleanup.
        unfold word.wrap.
        by apply Z_mod_lt.
      }
      {
        word_cleanup.
        apply Z.add_nonneg_nonneg; word_cleanup; naive_solver.
      }
    }
    { naive_solver. }
    { lia. }
  }

  iAssert (|={⊤}=> (P (γ.(initdata) ++ predurableC) -∗ fmlist_lb γ.(durabledata) (γ.(initdata) ++ predurableC ++ membufC')
                   ={⊤∖↑aofN}=∗ P (γ.(initdata) ++ predurableC ++ membufC')
                          ∗ (own γ.(len) (●MN{#1/2} (length predurableC))
                             ={⊤}=∗ own γ.(len)
                                      (●MN{#1/2} (length (predurableC ++ membufC'))))
  ) ∗ (aof_length_lb γ (U64 (length (predurableC ++ membufC'))) ={⊤}=∗ ▷ Q ∗ aof_durable_lb γ (γ.(initdata) ++ predurableC ++ membufC')))%I with "[Hmembuf_fupd Hfupd Htoks]" as "HH".
  {
    (* allocate invariant to escrow Q *)
    iMod (own_alloc (Excl ())) as "HQtok".
    { done. }
    iDestruct "HQtok" as (γtok) "Htok".
    iMod (own_alloc (Excl ())) as "HQexcl".
    { done. }
    iDestruct "HQexcl" as (γq) "HQexcl".
    iDestruct (big_sepS_elem_of_acc _ _ (U64 (length (predurableC ++ membufC'))) with "Htoks") as "[Hlen_tok Hlen_toks_rest]".
    { set_solver. }
    iDestruct "Hlen_tok" as "[Hlen_tok|%Hbad]"; last first.
    {
      exfalso.
      rewrite Hsafesize' in Hbad.
      rewrite app_length in Hbad.
      rewrite app_length in Hbad.
      rewrite app_length in Hbad.
      word.
    }
    iMod (inv_alloc aofN _ (own γtok (Excl ()) ∗ aof_length_lb γ (U64 (length (predurableC ++ membufC'))) ∨ (U64 (length (predurableC ++ membufC')) ⤳[γ.(len_toks)] ()) ∨ (Q ∗ aof_durable_lb γ (γ.(initdata) ++ predurableC ++ membufC')) ∗ own γq (Excl ())) with "[Hlen_tok]") as "#HQinv".
    {
      iRight. iLeft.
      iFrame.
    }
    iSplitR "Htok"; last first.
    {
      iModIntro.
      iIntros "Haof_lb".
      iInv "HQinv" as "Hq" "Hqclose".
      iDestruct "Hq" as "[>[Htok2 _]|Hq]".
      { iDestruct (own_valid_2 with "Htok Htok2") as %Hbad. contradiction. }
      iDestruct "Hq" as "[>Hlentok|Hq]".
      {
        iInv "Haof_len_inv" as ">Ha" "Haclose".
        unfold aof_len_invariant.
        iDestruct "Ha" as (l) "[Hlen Ha]".
        iDestruct (own_valid_2 with "Hlen Haof_lb") as %Hineq.
        apply mono_nat_both_dfrac_valid in Hineq as [_ Hineq].
        iDestruct (big_sepS_elem_of_acc _ _ (U64 (length (predurableC ++ membufC'))) with "Ha") as "[Ha Harest]".
        { set_solver. }
        iDestruct "Ha" as "[Hlentok2|%Hbad]"; last first.
        { exfalso. lia. }
        iDestruct (ghost_map_points_to_valid_2 with "Hlentok Hlentok2") as %[Hbad _].
        exfalso.
        rewrite dfrac_op_own in Hbad.
        done.
      }
      iMod ("Hqclose" with "[Htok Haof_lb]").
      { iLeft. iNext. iFrame. }
      iDestruct "Hq" as "[[$ >$] _]".
      by iModIntro.
    }

    iModIntro.
    iIntros "Hctx #Hdur_lb".
    iMod ("Hmembuf_fupd" with "Hctx [Hdur_lb]") as "[Hctx Hmembuf_fupd]".
    {
      iApply (fmlist_lb_mono with "Hdur_lb").
      repeat rewrite app_assoc.
      apply prefix_app_r.
      done.
    }
    rewrite -app_assoc.
    iMod ("Hfupd" with "Hctx") as "[$ HQ]".
    iModIntro.

    (* length stuff *)
    iIntros "Hlen".
    iInv "HQinv" as "Hq" "Hqclose".
    iDestruct "Hq" as "[[_ >Hlb]|Hq]".
    {
      iDestruct (own_valid_2 with "Hlen Hlb") as %Hbad.
      exfalso.
      apply mono_nat_both_dfrac_valid in Hbad as [_ Hbad].
      rewrite Hsafesize' in Hbad.
      rewrite app_length in Hbad.
      rewrite app_length in Hbad.
      lia.
    }
    iDestruct "Hq" as "[>Hlen_tok|[_ >HQexcl2]]"; last first.
    { iDestruct (own_valid_2 with "HQexcl HQexcl2") as %Hbad. contradiction. }

    iDestruct ("Hlen_toks_rest" with "[$Hlen_tok]") as "Hlen_toks".
    iMod ("Hqclose" with "[HQexcl HQ]") as "_".
    { iRight; iRight; iFrame. iFrame "∗#". }

    iMod ("Hmembuf_fupd" with "Hlen") as "Hlen".

    (* Use tokens to update mono_nat counter *)
    iInv "Haof_len_inv" as ">Ha" "Haclose".
    iDestruct "Ha" as (len) "[Hlen2 Ha]".
    iDestruct (own_valid_2 with "Hlen Hlen2") as %Hleneq.
    apply mono_nat_auth_dfrac_op_valid in Hleneq as [_ <-].
    iCombine "Hlen Hlen2" as "Hlen".
    iMod (own_update _ _ (mono_nat_auth _ (length (predurableC ++ membufC'))) with "Hlen") as "Hlen".
    {
      apply mono_nat_update.
      repeat rewrite app_length.
      lia.
    }
    iDestruct "Hlen" as "[Hlen Hlen2]".

    iMod ("Haclose" with "[Ha Hlen_toks Hlen2]") as "_".
    {
      iNext. iExists _. rewrite -Hsafesize'.
      iFrame.
      iApply (big_sepS_impl with "[Ha Hlen_toks]").
      { iApply big_sepS_sep. iFrame. }

      iModIntro.
      iIntros (x ?) "Hx".
      destruct (bool_decide (int.nat (length (predurableC ++ membufC')) < int.nat x)) as [|] eqn:Hineq.
      {
        apply bool_decide_eq_true in Hineq.
        iRight.
        iPureIntro.
        word.
      }
      {
        apply bool_decide_eq_false in Hineq.
        iLeft.
        iDestruct "Hx" as "[[$|%Hbad] [$|%Hineq2]]".
        exfalso.
        word.
      }
    }
    iFrame.
    by iModIntro.
  }

  iMod "HH" as "[Hmembuf_fupd HfupdQ]".

  wp_loadField.
  wp_apply (release_spec with "[-HΦ Haof_log HfupdQ Htok]").
  {
    iFrame "#∗".
    iNext.
    repeat iExists _.
    rewrite -app_assoc.
    iFrame "∗#".
    replace (word.add (length (predurableC ++ membufC)) (length newData)) with
        (U64 (length (predurableC ++ membufC'))); last first.
    {
      repeat rewrite app_length.
      rewrite -word.ring_morph_add.
      word_cleanup.
      repeat (rewrite Nat2Z.inj_add).
      rewrite Z.add_assoc.
      done.
    }
    iFrame.
    done.
  }
  wp_pures.
  iApply "HΦ".
  iFrame.
  iModIntro.
  iIntros "#Hlb".
  rewrite -app_assoc.
  iMod ("HfupdQ" with "[Hlb]") as "$"; last by iModIntro.
  replace (U64 (length (predurableC ++ membufC'))) with
      (word.add (length (predurableC ++ membufC)) (length newData)).
  { iFrame "#". }

  repeat rewrite app_length.
  repeat (rewrite Nat2Z.inj_add).
  rewrite Z.add_assoc.
  rewrite -word.ring_morph_add.
  unfold U64.
  done.
Qed.

Lemma wp_AppendOnlyFile__WaitAppend aof_ptr γ (l:u64) fname P Pcrash :
is_aof aof_ptr γ fname P Pcrash -∗
  {{{
       True
  }}}
    AppendOnlyFile__WaitAppend #aof_ptr #l
  {{{
       RET #(); aof_length_lb γ l
  }}}.
Proof.
  iIntros "#Haof" (Φ) "!# _ HΦ".
  wp_lam.
  wp_pures.
  iNamed "Haof".
  wp_loadField.
  wp_apply (acquire_spec with "Hmu_inv").
  iIntros "[Hlocked Haof_own]".
  wp_pures.
  wp_apply (wp_forBreak_cond' with "[-]").
  {
    iNamedAccu.
  }
  iModIntro.
  iNamed 1.

  wp_pures.
  iNamed "Haof_own".
  wp_loadField.
  wp_pures.
  wp_if_destruct.
  {
    wp_pures.
    wp_loadField.
    wp_apply (wp_condWait with "[- HΦ]").
    {
      iFrame "#∗".
      repeat iExists _. iFrame "#∗".
      done.
    }
    iIntros "[Hlocked Haof_own]".
    wp_pures.
    iLeft.
    iFrame.
    done.
  }
  iSpecialize ("HΦ" with "[Hdurlen_lb]").
  {
    assert (int.nat l ≤ int.nat durlen) as Hineq.
    {
      word.
    }
    unfold aof_length_lb.
    replace (int.nat durlen)%nat with ((int.nat durlen) `max` int.nat l)%nat by word.
    rewrite mono_nat_lb_op.
    iDestruct "Hdurlen_lb" as "[_ $]".
  }
  iRight.
  iSplitL ""; first done.
  iModIntro.
  wp_pures.

  wp_loadField.
  wp_apply (release_spec with "[- HΦ]").
  {
    iFrame "#∗".
    repeat iExists _; iFrame "#∗".
    done.
  }
  wp_pures.
  iApply "HΦ".
Qed.

Lemma wp_AppendOnlyFile__Close aof_ptr γ P Pcrash fname data :
is_aof aof_ptr γ fname P Pcrash -∗
  {{{
       aof_log_own γ data
  }}}
    AppendOnlyFile__Close #aof_ptr
  {{{
       RET #(); crash_borrow (fname f↦ data ∗ P data) (|C={⊤}=> ∃ data', fname f↦ data' ∗ ▷ Pcrash data')
  }}}.
Proof.
  iIntros "#Haof" (Φ) "!# Haof_log HΦ".
  wp_lam.
  wp_pures.
  iNamed "Haof".
  wp_loadField.
  wp_apply (acquire_spec with "Hmu_inv").
  iIntros "[Hlocked Haof_own]".
  wp_pures.
  iNamed "Haof_own".
  iNamed "Hclose".
  wp_storeField.
  wp_loadField.
  wp_apply (wp_condSignal).
  { iFrame "#". }
  wp_pures.

  iDestruct "Haof_log" as "[Haof_log [Hreq_tok Htok]]".
  iMod (fmlist_freeze with "Haof_log") as "#Hexpected".

  iAssert (aof_mu_invariant aof_ptr mu_ptr γ fname P Pcrash) with "[-Htok HΦ Hlocked]" as "Haof_own".
  {
    repeat iExists _; iFrame "∗#%".
    iExists _, _.
    iFrame "HcloseRequested ∗%".
    iDestruct "Hclose" as "[_ [_ $]]".
    iSplit.
    { iExists _; iFrame "#". }
    destruct isClosed; iEval simpl; auto; by iFrame.
  }

  wp_forBreak_cond.

  iClear "Hdurlen_lb Hcrash_wand HdurCond".
  iNamed "Haof_own".
  iNamed "Hclose".
  wp_loadField.
  wp_if_destruct.
  { (* aof not closed yet, keep looping *)
    wp_pures.
    wp_loadField.
    wp_apply (wp_condWait with "[-Htok HΦ]").
    {
      iFrame "#∗".
      repeat iExists _; iFrame "∗#%".
      iExists _, _.
      iFrame "∗#∗".
    }
    iIntros "[Hlocked Haof_own]".
    wp_pures.
    iLeft.
    iSplitR; first done.
    iModIntro.
    iFrame.
  }
  (* aof closed *)
  iRight.
  iModIntro.
  iSplitR; first done.
  iDestruct "Hclose" as "[HcloseRest [Hreq #H]]".
  iNamed "H".

  wp_pure1_credit "Hlc".
  iApply fupd_wp.
  iInv "HfileEscrow" as "Hi" "Hiclose".
  iMod (lc_fupd_elim_later with "Hlc Hi") as "Hi".
  iDestruct "Hi" as (?) "[[Hf #Hdata]|Hbad]"; last first.
  {
    iDestruct (ghost_var_valid_2 with "Htok Hbad") as %Hbad.
    exfalso. naive_solver.
  }
  iMod ("Hiclose" with "[$Htok]").
  { done. }
  iModIntro.

  iDestruct (fmlist_agree_1 with "Hexpected Hdata") as %->.

  wp_pures.
  wp_loadField.
  wp_apply (release_spec with "[-HΦ Hf]").
  {
    iFrame "#∗".
    iNext.
    repeat iExists _; iFrame "∗#%".
    iExists _, _. iFrame "∗#".
    simpl. iFrame.
  }
  wp_pures.
  iModIntro.
  iApply "HΦ".
  iFrame.
Qed.

Lemma accessP aof_ptr fname γ P Pcrash data durablePrefix :
  is_aof aof_ptr γ fname P Pcrash -∗
  aof_durable_lb γ durablePrefix -∗
  aof_log_own γ data -∗
  (|NC={⊤,⊤∖↑aofN}=> ∃ durableData, ⌜prefix durableData data⌝ ∗
                           ⌜prefix durablePrefix durableData⌝ ∗
                           ▷ P durableData ∗ (▷ P durableData -∗ |NC={⊤∖↑aofN,⊤}=> aof_log_own γ data)
  )
  .
Proof.
  iIntros "#Hinv #Hlb Hlog".
  iNamed "Hinv".

  iInv "Hctx_inv" as "Hctx" "Hctx_close".
  iDestruct "Hctx" as "[[>Hbad _]|Hctx]".
  {
    rewrite ncfupd_eq.
    unfold ncfupd_def.
    iIntros (?) "Hnc".
    iDestruct (NC_C with "Hnc Hbad") as %Hbad.
    by exfalso.
  }
  iDestruct "Hctx" as (?) "Hctx".
  iDestruct "Hctx" as "[[>Hbad [_ >Hbad']]|Hctx]".
  {
    iDestruct "Hlog" as "[Hlog [Hlog' Hreq]]".
    iDestruct (ghost_var_valid_2 with "[$] [$]") as %Hbad.
    exfalso.
    naive_solver.
  }
  iDestruct "Hctx" as "(>Hlb1 & >Hl & >Hcurdata2 & Hctx)".
  iDestruct "Hlog" as "(Hl'&?)".
  iDestruct (fmlist_agree_2 with "Hl' [$]") as %Hpref.
  rewrite ncfupd_eq.
  unfold ncfupd_def.
  iIntros (q) "HNC".
  iApply (fupd_mask_weaken (⊤ ∖ ↑aofN)).
  { solve_ndisj. }
  iIntros "Hclo".
  iModIntro. iFrame "HNC".
  iExists _. iFrame.
  iSplit; auto.
  iDestruct (fmlist_agree_2 with "Hl Hlb") as %Hprefix.
  iSplit.
  { iPureIntro.
    destruct Hprefix as [??].
    destruct Hpref as [??].
    eexists _.
    rewrite H0.
    repeat rewrite -app_assoc.
    done.
  }
  iIntros "HP". iIntros (?) "HNC".
  iMod "Hclo".
  iMod ("Hctx_close" with "[-HNC]"); last by eauto.
  iRight. iExists _. iNext. iFrame.
  iRight. iFrame.
Qed.

Lemma accessP_weak aof_ptr fname γ P Pcrash data :
  is_aof aof_ptr γ fname P Pcrash -∗
  aof_log_own γ data -∗
  (|NC={⊤,⊤∖↑aofN}=> ∃ durableData, ⌜prefix durableData data⌝ ∗
                           ▷ P durableData ∗ (▷ P durableData -∗ |NC={⊤∖↑aofN,⊤}=> aof_log_own γ data)
  )
  .
Proof.
  iIntros "#Hinv Hlog".
  iNamed "Hinv".

  iInv "Hctx_inv" as "Hctx" "Hctx_close".
  iDestruct "Hctx" as "[[>Hbad _]|Hctx]".
  {
    rewrite ncfupd_eq.
    unfold ncfupd_def.
    iIntros (?) "Hnc".
    iDestruct (NC_C with "Hnc Hbad") as %Hbad.
    by exfalso.
  }
  iDestruct "Hctx" as (?) "Hctx".
  iDestruct "Hctx" as "[[>Hbad [_ >Hbad']]|Hctx]".
  {
    iDestruct "Hlog" as "[Hlog [Hlog' Hreq]]".
    iDestruct (ghost_var_valid_2 with "[$] [$]") as %Hbad.
    exfalso.
    naive_solver.
  }
  iDestruct "Hctx" as "(>Hlb1 & >Hl & >Hcurdata2 & Hctx)".
  iDestruct "Hlog" as "(Hl'&?)".
  iDestruct (fmlist_agree_2 with "Hl' [$]") as %Hpref.
  rewrite ncfupd_eq.
  unfold ncfupd_def.
  iIntros (q) "HNC".
  iApply (fupd_mask_weaken (⊤ ∖ ↑aofN)).
  { solve_ndisj. }
  iIntros "Hclo".
  iModIntro. iFrame "HNC".
  iExists _. iFrame.
  iSplit; auto.
  iIntros "HP". iIntros (?) "HNC".
  iMod "Hclo".
  iMod ("Hctx_close" with "[-HNC]"); last by eauto.
  iRight. iExists _. iNext. iFrame.
  iRight. iFrame.
Qed.

End aof_proof.


From iris.program_logic Require Export language ectx_language ectxi_language.
From st.prelude Require Export autosubst generic lang_base.

(** The syntax of expressions *)
Inductive expr :=
| Var (x : var)
| LetIn (e1 : expr) (e2 : {bind 1 of expr})
| Lam (e : {bind 1 of expr})
(* | Fix (e : expr) *)
(* | Rec (e : {bind 2 of expr}) *)
| App (e1 e2 : expr)
(* Base Types *)
| Lit (l : base_lit)
| BinOp (op : bin_op) (e1 e2 : expr)
| If (e0 e1 e2 : expr)
| Seq (e1 e2 : expr)
(* Products *)
| Pair (e1 e2 : expr)
| Fst (e : expr)
| Snd (e : expr)
(* Sums *)
| InjL (e : expr)
| InjR (e : expr)
| Case (e0 : expr) (e1 : {bind expr}) (e2 : {bind expr})
(* Recursive Types *)
| Fold (e : expr)
| Unfold (e : expr)
(** Polymorphic Types *)
(* | TLam (e : expr) *)
(* | TApp (e : expr). *)
(* Virt Step *)
| VirtStep (e : expr).

Coercion LitInt : Z >-> base_lit.
Coercion LitBool : bool >-> base_lit.
Coercion Lit : base_lit >-> expr.
Coercion App : expr >-> Funclass.
Coercion Var : var >-> expr.

Declare Scope expr_no_st_scope.
Delimit Scope expr_no_st_scope with Eₙₒ.
Notation "% x" := (Var x%nat) (at level 8, format "% x") : expr_no_st_scope.

Notation "()" := (Lit LitUnit) : expr_no_st_scope.
Notation "( e1 , e2 , .. , en )" := (Pair .. (Pair e1 e2) .. en) : expr_no_st_scope.

Notation "e1 + e2" := (BinOp PlusOp e1%Eₙₒ e2%Eₙₒ) : expr_no_st_scope.
Notation "e1 - e2" := (BinOp MinusOp e1%Eₙₒ e2%Eₙₒ) : expr_no_st_scope.
Notation "e1 ≤ e2" := (BinOp LeOp e1%Eₙₒ e2%Eₙₒ) : expr_no_st_scope.
Notation "e1 < e2" := (BinOp LtOp e1%Eₙₒ e2%Eₙₒ) : expr_no_st_scope.
Notation "e1 = e2" := (BinOp EqOp e1%Eₙₒ e2%Eₙₒ) : expr_no_st_scope.

Instance Var_Inj : Inj eq eq Var. intros x1 x2 eq. by inversion eq. Qed.

Instance Ids_expr : Ids expr. derive. Defined.
Instance Rename_expr : Rename expr. derive. Defined.
Instance Subst_expr : Subst expr. derive. Defined.
Instance SubstLemmas_expr : SubstLemmas expr. derive. Qed.

Lemma Var_closed_n_lt (x : var) n (p : Closed_n n (Var x)) : x < n.
Proof. apply ids_lt_Closed_n. apply p. Qed.

(** Values for STLang *)
Inductive val :=
| LamV (e : {bind 1 of expr})
(* | RecV (e : {bind 2 of expr}) *)
(* | TLamV (e : {bind 1 of expr}) *)
| LitV (v : base_lit)
| PairV (v1 v2 : val)
| InjLV (v : val)
| InjRV (v : val)
| FoldV (v : val).

Coercion LitV : base_lit >-> val.

Declare Scope val_no_st_scope.
Delimit Scope val_no_st_scope with Vₙₒ.

Notation "()" := (LitV LitUnit) : val_no_st_scope.
Notation "( v1 , v2 , .. , vn )" := (PairV .. (PairV v1 v2) .. vn) : val_no_st_scope.

Fixpoint of_val (v : val) : expr :=
 match v with
 | LamV e => Lam e
 (* | RecV e => Rec e *)
 (* | TLamV e => TLam e *)
 | LitV v => Lit v
 | PairV v1 v2 => Pair (of_val v1) (of_val v2)
 | InjLV v => InjL (of_val v)
 | InjRV v => InjR (of_val v)
 | FoldV v => Fold (of_val v)
 end.

(* Notation "# v" := (of_val v%Vₙₒ) (at level 8, format "# v") : expr_no_st_scope. *)
Coercion of_val : val >-> expr.

Definition subst_list_val (vs : list val) : var → expr := subst_list (map of_val vs).

Lemma subst_list_val_cons v vs : of_val v .: subst_list_val vs = subst_list_val (v :: vs).
Proof. intros. by asimpl. Qed.

Lemma subst_list_val_snoc vs v : subst_list_val (vs ++ [v]) = (upn (length vs) (of_val v .: ids)) >> (subst_list_val vs).
Proof. by rewrite /subst_list_val map_app subst_list_snoc map_length. Qed.

(* Lemma var_subst_list_val_lt_length (vs : list val) (x : var) (p : x < length vs) : *)
(*   (exists v : val, vs !! x = Some v ∧ (Var x).[subst_list_val vs] = v). *)
(* Proof. *)
(*   destruct (vs !! x) eqn:eq. exists v. split; auto. apply ids_subst_list_lookup. by rewrite list_lookup_fmap eq /=. *)
(*   assert (length vs ≤ x). by apply lookup_ge_None. lia. *)
(* Qed. *)
Lemma Var_subst_list_closed_n_length (vs : list val) (x : var) (p : Closed_n (length vs) (Var x)) :
  (exists v : val, vs !! x = Some v ∧ (Var x).[subst_list_val vs] = v).
Proof.
  destruct (vs !! x) eqn:eq. exists v. split; auto. apply ids_subst_list_lookup. by rewrite list_lookup_fmap eq /=.
  assert (length vs ≤ x). by apply lookup_ge_None.
  assert (x < length vs). by apply ids_lt_Closed_n. lia.
Qed.

Lemma Var_subst_list_val_lookup (x : var) (ts : list val) t (H : ts !! x = Some t) :
  (ids x).[subst_list_val ts] = t.
Proof. rewrite /subst_list_val. apply ids_subst_list_lookup. by rewrite list_lookup_fmap H. Qed.

(* Lemma var_subst_list_val (vs : list val) (x : var) : *)
(*   (exists v : val, vs !! x = Some v ∧ (Var x).[subst_list_val vs] = v) ∨ (vs !! x = None). *)
(* Proof. *)
(*   destruct (vs !! x) eqn:eq. *)
(*   - left. exists v. split; auto. apply ids_subst_list_lookup. by rewrite list_lookup_fmap eq /=. *)
(*   - by right. *)
(* Qed. *)

Fixpoint to_val (e : expr) : option val :=
 match e with
 | Lam e => Some (LamV e)
 (* | Rec e => Some (RecV e) *)
 (* | TLam e => Some (TLamV e) *)
 | Lit e => Some (LitV e)
 | Pair e1 e2 => v1 ← to_val e1; v2 ← to_val e2; Some (PairV v1 v2)
 | InjL e => InjLV <$> to_val e
 | InjR e => InjRV <$> to_val e
 | Fold e => v ← to_val e; Some (FoldV v)
 | _ => None
 end.

Fixpoint val_subst (v : val) (σ : var → expr) : val :=
  match v with
  | LamV e => LamV (e.[up σ])
  | LitV v => LitV v
  | PairV v1 v2 => PairV (val_subst v1 σ) (val_subst v2 σ)
  | InjLV v => InjLV (val_subst v σ)
  | InjRV v => InjRV (val_subst v σ)
  | FoldV v => FoldV (val_subst v σ)
  end.

Notation "v .{ sigma }" := (val_subst v sigma)
  (at level 2, sigma at level 200, left associativity,
   format "v .{ sigma }" ).

Notation "v .{ t /}" := (val_subst v (t .: ids))
  (at level 2, t at level 200, left associativity,
   format "v .{ t /}") : subst_scope.

Lemma val_subst_valid (v : val) (σ : var → expr) : (of_val v).[σ] = (val_subst v σ).
Proof. induction v; asimpl; try done; (by rewrite IHv1 IHv2) || by rewrite IHv. Qed.

Lemma val_subst_comp (v : val) (σ σ' : var → expr) : v.{σ}.{σ'} = v.{σ >> σ'}.
Proof. induction v; asimpl; try done; (by rewrite IHv1 IHv2) || by rewrite IHv. Qed.

Lemma to_of_val v : to_val (of_val v) = Some v.
Proof.
 by induction v; try simplify_option_eq; repeat f_equal; try apply (proof_irrel _).
Qed.
Lemma of_to_val e v : to_val e = Some v → of_val v = e.
Proof.
 revert v; induction e; intros v ?; simplify_option_eq; auto with f_equal.
Qed.

(** Equality and other typeclass stuff *)
Instance of_val_inj : Inj (=) (=) of_val.
Proof. by intros ?? Hv; apply (inj Some); rewrite -!to_of_val Hv. Qed.

Instance base_lit_eq_dec : EqDecision base_lit.
Proof. solve_decision. Defined.
Instance bin_op_eq_dec : EqDecision bin_op.
Proof. solve_decision. Defined.
Instance expr_eq_dec : EqDecision expr.
Proof. solve_decision. Defined.
Instance val_eq_dec : EqDecision val.
Proof.
 refine (λ v v', cast_if (decide (of_val v = of_val v')));
   abstract naive_solver.
Defined.

Global Instance val_inhabited : Inhabited val := populate ()%Vₙₒ.
(* Instance expr_inhabited : Inhabited expr := populate (Lit LitUnit). *)
(* Instance val_inhabited : Inhabited val := populate (LitV LitUnit). *)
(* Canonical Structure stateC := leibnizO state. *)
(* Canonical Structure valC := leibnizO val. *)
(* Canonical Structure eff_valC := leibnizO eff_val. *)
(* Canonical Structure exprC := leibnizO expr. *)

(** Evaluation contexts *)
Inductive ectx_item :=
(* | FixCtx *)
| LetInCtx (e2 : expr)
| AppLCtx (e2 : expr)
| AppRCtx (v1 : val)
(* | TAppCtx *)
| PairLCtx (e2 : expr)
| PairRCtx (v1 : val)
| FstCtx
| SndCtx
| InjLCtx
| InjRCtx
| CaseCtx (e1 : {bind expr}) (e2 : {bind expr})
| IfCtx (e2 : expr) (e3 : expr)
| BinOpLCtx (op : bin_op) (e2 : expr)
| BinOpRCtx (op : bin_op) (v1 : val)
| SeqCtx (e2 : expr)
| FoldCtx
| UnfoldCtx
| VirtStepCtx.

Definition fill_item (Ki : ectx_item) (e : expr) : expr :=
 match Ki with
 (* | FixCtx => Fix e *)
 | LetInCtx e2 => LetIn e e2
 | AppLCtx e2 => App e e2
 | AppRCtx v1 => App (of_val v1) e
 (* | TAppCtx => TApp e *)
 | PairLCtx e2 => Pair e e2
 | PairRCtx v1 => Pair (of_val v1) e
 | FstCtx => Fst e
 | SndCtx => Snd e
 | InjLCtx => InjL e
 | InjRCtx => InjR e
 | CaseCtx e1 e2 => Case e e1 e2
 | IfCtx e1 e2 => If e e1 e2
 | BinOpLCtx op e2 => BinOp op e e2
 | BinOpRCtx op v1 => BinOp op (of_val v1) e
 | SeqCtx e2 => Seq e e2
 | FoldCtx => Fold e
 | UnfoldCtx => Unfold e
 | VirtStepCtx => VirtStep e
 end.

(** The stepping relation *)

Definition bin_op_eval (op : bin_op) (z1 z2 : Z) : val :=
 match op with
 | PlusOp => LitV $ LitInt (z1 + z2)%Z
 | MinusOp => LitV $ LitInt (z1 - z2)
 | LeOp => LitV $ LitBool $ bool_decide (z1 ≤ z2)%Z
 | LtOp => LitV $ LitBool $ bool_decide (z1 < z2)%Z
 | EqOp => LitV $ LitBool $ bool_decide (z1 = z2)
 end.

Definition state : Type := ().

Inductive head_step : expr → state → list Empty_set → expr → state → list expr → Prop :=
(* β *)
  LetIn_head_step e1 v1 e2 σ :
   to_val e1 = Some v1 →
   head_step (LetIn e1 e2) σ [] e2.[e1/] σ []
| App_Lam_head_step e1 e2 v2 σ :
   to_val e2 = Some v2 →
   head_step (App (Lam e1) e2) σ [] e1.[e2/] σ []
(* | App_Rec_head_step e1 e2 v2 σ : *)
   (* to_val e2 = Some v2 → *)
   (* head_step (App (Rec e1) e2) σ [] e1.[(Rec e1), e2/] σ [] *)
(* fix *)
(* | Fix_head_step e σ : *)
    (* head_step (Fix (Lam e)) σ [] e.[Fix (Lam e)/] σ [] *)
(* binary operation *)
| BinOp_head_step op e1 e2 z1 z2 σ :
   to_val e1 = Some (LitV $ LitInt z1) → to_val e2 = Some (LitV $ LitInt z2) →
   head_step (BinOp op e1 e2) σ [] (of_val (bin_op_eval op z1 z2)) σ []
(* if *)
| If_True_head_step e1 e2 σ :
   head_step (If (Lit $ LitBool true) e1 e2) σ [] e1 σ []
| If_False_head_step e1 e2 σ :
   head_step (If (Lit $ LitBool false) e1 e2) σ [] e2 σ []
(* seq *)
| Seq_Unit_head_step e1 e2 σ :
    to_val e1 = Some ()%Vₙₒ →
    head_step (Seq e1 e2) σ [] e2 σ []
(* Products *)
| Fst_Pair_head_step e1 v1 e2 v2 σ :
   to_val e1 = Some v1 → to_val e2 = Some v2 →
   head_step (Fst (Pair e1 e2)) σ [] e1 σ []
| Snd_Pair_head_step e1 v1 e2 v2 σ :
   to_val e1 = Some v1 → to_val e2 = Some v2 →
   head_step (Snd (Pair e1 e2)) σ [] e2 σ []
(* Sums *)
| Case_InjL_head_step e0 v0 e1 e2 σ :
   to_val e0 = Some v0 →
   head_step (Case (InjL e0) e1 e2) σ [] e1.[e0/] σ []
| Case_InjR_head_step e0 v0 e1 e2 σ :
   to_val e0 = Some v0 →
   head_step (Case (InjR e0) e1 e2) σ [] e2.[e0/] σ []
(* Recursive Types *)
| Unfold_Fold_head_step e v σ :
   to_val e = Some v →
   head_step (Unfold (Fold e)) σ [] e σ []
(* Polymorphic Types *)
(* | TBeta e σ : *)
   (* head_step (TApp (TLam e)) σ [] e σ []. *)
| VirtStep_Lam_head_step e σ :
   head_step (VirtStep (Lam e)) σ [] (Lam (VirtStep ((Lam e).[ren (+1)] (VirtStep %0))))%Eₙₒ σ []
| VirtStep_Lit_head_step bl σ :
   head_step (VirtStep (Lit bl)) σ [] (Lit bl) σ []
| VirtStep_Pair_head_step e1 v1 e2 v2 σ :
   to_val e1 = Some v1 →
   to_val e2 = Some v2 →
   head_step (VirtStep (Pair e1 e2)) σ [] (Pair (VirtStep e1) (VirtStep e2)) σ []
| VirtStep_InjL_head_step e v σ :
   to_val e = Some v →
   head_step (VirtStep (InjL e)) σ [] (InjL (VirtStep e)) σ []
| VirtStep_InjR_head_step e v σ :
   to_val e = Some v →
   head_step (VirtStep (InjR e)) σ [] (InjR (VirtStep e)) σ []
| VirtStep_Fold_head_step e v σ :
   to_val e = Some v →
   head_step (VirtStep (Fold e)) σ [] (Fold (VirtStep e)) σ [].

Lemma App_Lam_head_step' (e' e1 e2 : expr) v2 (eq : e1.[e2/] = e') σ (H : to_val e2 = Some v2) :
  head_step (Lam e1 e2) σ [] e' σ [].
Proof. rewrite -eq. by eapply App_Lam_head_step. Qed.

Instance fill_item_inj Ki : Inj (=) (=) (fill_item Ki).
Proof. destruct Ki; intros ???; simplify_eq/=; auto with f_equal. Qed.
Lemma fill_item_val Ki e :
 is_Some (to_val (fill_item Ki e)) → is_Some (to_val e).
Proof. intros [v ?]. destruct Ki; simplify_option_eq; eauto. Qed.
Lemma val_stuck e1 σ1 κ e2 σ2 efs :
 head_step e1 σ1 κ e2 σ2 efs → to_val e1 = None.
Proof. destruct 1; done. Qed.
Lemma head_ctx_step_val Ki e σ1 κ e2 σ2 efs :
 head_step (fill_item Ki e) σ1 κ e2 σ2 efs → is_Some (to_val e).
Proof.
 destruct Ki; inversion_clear 1; simplify_option_eq; eauto.
Qed.
Lemma fill_item_no_val_inj Ki1 Ki2 e1 e2 :
 to_val e1 = None → to_val e2 = None →
 fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2.
Proof.
 destruct Ki1, Ki2; intros; try discriminate; simplify_eq/=;
  repeat match goal with
  | H : to_val (of_val _) = None |- _ => by rewrite to_of_val in H
  end; auto.
Qed.

Lemma st_ectxi_lang_mixin : EctxiLanguageMixin of_val to_val fill_item head_step.
Proof.
  split; eauto using to_of_val, of_to_val,
  val_stuck, fill_item_val, fill_item_no_val_inj,
 head_ctx_step_val, fill_item_inj.
Qed.

Canonical Structure STLCmuVS_ectxi_lang : ectxiLanguage := EctxiLanguage st_ectxi_lang_mixin.
Canonical Structure STLCmuVS_ectx_lang : ectxLanguage := EctxLanguageOfEctxi STLCmuVS_ectxi_lang.
Canonical Structure STLCmuVS_lang : language := LanguageOfEctx STLCmuVS_ectx_lang.

Lemma fill_val (e : expr) (K : list ectx_item):
  is_Some (to_val (fill K e)) -> is_Some (to_val e).
Proof.
  move=> [v h]. destruct (to_val e) eqn:eq.
    by exists v0.
    have fill_not_val: to_val (fill K e) = None. eauto using fill_not_val.
    congruence.
Qed.

Canonical Structure valO := valO STLCmuVS_lang.
Canonical Structure exprO := exprO STLCmuVS_lang.

(* Arguments val_stuck {_ _ _ _ _} _. *)
(* Arguments fill_val {_ _} _. *)

(* Wrapper around prim_step *)

Definition STLCmuVS_step (e1 e2 : expr) : Prop := prim_step e1 tt [] e2 tt [].

(* We do not use forks, nor prophecy variables. *)

Lemma head_step_no_forks e σ κ e' σ' efs : head_step e σ κ e' σ' efs → efs = [].
Proof. intros H. by inversion H. Qed.

Lemma prim_step_no_forks (e : expr) σ κ e' σ' efs : prim_step e σ κ e' σ' efs → efs = [].
Proof. intros H. inversion H. by eapply head_step_no_forks. Qed.

Lemma head_step_no_obs e σ κ e' σ' efs : head_step e σ κ e' σ' efs → κ = [].
Proof. intros H. by inversion H. Qed.

Lemma prim_step_no_obs (e : expr) σ κ e' σ' efs : prim_step e σ κ e' σ' efs → κ = [].
Proof. intros H. inversion H. by eapply head_step_no_obs. Qed.

(* Our language is deterministic *)

Lemma head_step_det e e1 σ1 κ1 σ1' efs1 e2 σ2 κ2 σ2' efs2 : head_step e σ1 κ1 e1 σ1' efs1 → head_step e σ2 κ2 e2 σ2' efs2 → e1 = e2.
Proof. intros H1 H2. inversion H1; inversion H2; ((by simplify_eq) || (try done) || simplify_eq; inversion G2). Qed.

Lemma prim_step_det (e e1 e2 : expr) σ κ : prim_step e σ κ e1 σ [] → prim_step e σ κ e2 σ [] → e1 = e2.
Proof.
  intros H1 H2.
  inversion H1. inversion H2. simplify_eq. simpl in *.
  assert (K = K0) as <-.
  { destruct (step_by_val K K0 _ _ σ κ e2'0 σ [] H4) as [Kred eq] ; try done; try by eapply val_stuck.
    assert (H4' : fill K0 e1'0 = fill K e1'); first done.
    destruct (step_by_val K0 K _ _ σ κ e2' σ [] H4') as [Kred' eq'] ; try done; try by eapply val_stuck.
    rewrite eq in eq'. simpl in *. assert (length K = length (Kred' ++ Kred ++ K)). simpl in *. by rewrite -eq'.
    do 2 rewrite app_length in H. assert (Kred = []) as ->. apply length_zero_iff_nil. lia. by rewrite eq. }
  f_equal. assert (e1' = e1'0) as ->. apply (fill_inj K _ _ H4). by eapply head_step_det.
Qed.

(* Our language is pure *)

Lemma prim_step_pure (e1 e2 : expr) σ1 σ2 κ efs : prim_step e1 σ1 κ e2 σ2 efs → pure_step e1 e2.
Proof.
  intros Hprim.
  assert (efs = []) as ->. by eapply prim_step_no_forks.
  assert (κ = []) as ->. by eapply prim_step_no_obs.
  destruct σ1, σ2.
  split.
  intros σ. destruct σ. rewrite /reducible_no_obs. by exists e2, tt, [].
  intros.
  assert (efs = []) as ->. by eapply prim_step_no_forks.
  assert (κ = []) as ->. by eapply prim_step_no_obs.
  destruct σ1, σ2. by erewrite (prim_step_det _ _ _ _ _ H).
Qed.

(* Wrappers around lemmas *)

Lemma STLCmuVS_pure e1 e2 : STLCmuVS_step e1 e2 <-> pure_step e1 e2.
Proof.
  split. apply prim_step_pure. intro H. inversion H.
  destruct (pure_step_safe tt) as [e2' [σ [efs Hp]]].
  destruct σ. by destruct (pure_step_det _ _ _ _ _ Hp) as [a [b [-> ->]]].
Qed.

Lemma STLCmuVS_step_ctx K `{!LanguageCtx K} e1 e2 : STLCmuVS_step e1 e2 → STLCmuVS_step (K e1) (K e2).
Proof. intro. apply STLCmuVS_pure. apply pure_step_ctx. auto. by apply STLCmuVS_pure. Qed.

Lemma rtc_STLCmuVS_step_ctx K `{!LanguageCtx K} e1 e2 : rtc STLCmuVS_step e1 e2 → rtc STLCmuVS_step (K e1) (K e2).
Proof. eauto using rtc_congruence, STLCmuVS_step_ctx. Qed.

Lemma nsteps_STLCmuVS_step_ctx K `{!LanguageCtx K} n e1 e2 : nsteps STLCmuVS_step n e1 e2 → nsteps STLCmuVS_step n (K e1) (K e2).
Proof. eauto using nsteps_congruence, STLCmuVS_step_ctx. Qed.

Lemma nsteps_PureExec (e1 e2 : expr) n : nsteps STLCmuVS_step n e1 e2 <-> PureExec True n e1 e2.
Proof.
  split. intros s t. eapply nsteps_congruence with (f := id). by apply STLCmuVS_pure. auto.
  intro H. eapply nsteps_congruence with (f := id). apply STLCmuVS_pure. apply pure_exec. auto.
Qed.

Lemma rtc_PureExec (e1 e2 : expr) : rtc STLCmuVS_step e1 e2 <-> ∃ n, PureExec True n e1 e2.
Proof.
  split.
  intro H. assert (H' : rtc pure_step e1 e2).
  eapply rtc_subrel. by apply STLCmuVS_pure. auto. destruct (iffLR (rtc_nsteps _ _) H') as [n H'']. exists n. intros _. done.
  intro d. destruct d as [n H]. eapply rtc_nsteps. exists n. by eapply nsteps_PureExec.
Qed.

Lemma step_PureExec (e1 e2 : expr) : STLCmuVS_step e1 e2 → PureExec True 1 e1 e2.
Proof. intros s t. apply nsteps_once. by apply STLCmuVS_pure. Qed.

Definition STLCmuVS_halts (e : STLCmuVS.lang.expr) : Prop :=
  ∃ (v : STLCmuVS.lang.val), rtc STLCmuVS_step e (STLCmuVS.lang.of_val v).


Reserved Notation "M '[' K ':=' V ']'" (no associativity, at level 91).

Reserved Notation "s '==>' s'" (at level 40).

Reserved Notation "s '==>*' s'" (at level 40).

Reserved Notation "s '=t>' s' '$' tr" (at level 40).

Reserved Notation "s '=t>*' s' '$' tr" (at level 40).

(* for the and/or below, we can't just return c1/c2 cause that makes
the return type of the if dependent on the condition, and we have no
need to do that *)

Notation "c1 '.|' c2" :=
  (if c1 then true else (if c2 then true else false))
    (at level 50, left associativity).

Notation "c1 '.&' c2" :=
  (if c1 then (if c2 then true else false) else false)
    (at level 40, left associativity).

Definition xor (P Q : Prop) : Prop := (P /\ ~ Q) \/ (~ P /\ Q).

Notation "P '\X/' Q" :=
  (xor P Q)
    (at level 85, right associativity).


(* This program is free software; you can redistribute it and/or      *)
(* modify it 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 program 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 Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(*****************************************************************************)
(*          Projet Formel - Calculus of Inductive Constructions V5.10        *)
(*****************************************************************************)
(*									     *)
(*	Diagonal Functor (used in the definition of Cartesian) 		     *)
(*									     *)
(*****************************************************************************)
(*									     *)
(*                     A. SAIBI	  May 95                  		     *)
(*									     *)
(*****************************************************************************)

Require Export PROD.
Require Export Functor.

Set Implicit Arguments.
Unset Strict Implicit.

Section diag.

Variable C : Category.

Definition Diag_ob (c : C) := Build_POb c c.

 Section diag_map_def.

 Variable a b : C.

 Definition Diag_mor (f : a --> b) :=
   Build_Pmor (u:=Diag_ob a) (t:=Diag_ob b) f f.

 Lemma Diag_map_law : Map_law Diag_mor.
 Proof.
 unfold Map_law, Diag_mor in |- *; simpl in |- *.
 intros f g H; unfold Equal_Pmor in |- *; simpl in |- *.
 split; trivial.
 Qed.

 Canonical Structure Diag_map := Build_Map Diag_map_law.

 End diag_map_def.

Lemma Diag_comp_law : Fcomp_law Diag_map.
Proof.
unfold Fcomp_law, Diag_map, Diag_mor in |- *; simpl in |- *.
unfold Equal_Pmor in |- *; simpl in |- *.
intros a b c f g; split; apply Refl.
Qed.

Lemma Diag_id_law : Fid_law Diag_map.
Proof.
unfold Fid_law, Diag_map, Diag_mor in |- *; simpl in |- *.
unfold Equal_Pmor, Id_PROD in |- *; simpl in |- *.
intro a; split; apply Refl.
Qed.

Canonical Structure Diag := Build_Functor Diag_comp_law Diag_id_law.

End diag.


(** * Functors to cat are pseudofunctors *)
Require Import Category.Core Functor.Core NaturalTransformation.Core.
Require Import Functor.Composition.Core NaturalTransformation.Composition.Core NaturalTransformation.Composition.Laws.
Require Import Functor.Identity.
Require Import Pseudofunctor.Core.
Require Import Cat.Core.
Require Import FunctorCategory.Core.
Require Import FunctorCategory.Morphisms NaturalTransformation.Isomorphisms.
Require Import Category.Morphisms NaturalTransformation.Paths.
Require Import Basics.PathGroupoids Basics.Trunc.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope path_scope.
Local Open Scope morphism_scope.

(** Every functor to Cat is a pseudofunctor *)
Section of_functor.
  Context `{Funext}.
  Variable C : PreCategory.
  Context `{HP : forall C D, P C -> P D -> IsHSet (Functor C D)}.

  Local Notation cat := (@sub_pre_cat _ P HP).

  Variable F : Functor C cat.

  Definition path_functor_helper A B (F1 F2 : Functor A B) (pf1 pf2 : F1 = F2)
  : P A -> P B -> pf1 = pf2
    := fun PA PB => @path_ishprop _ (@HP A B PA PB F1 F2) _ _.

  Local Hint Extern 0 (P ?x.1) => exact x.2 : core.

  Local Tactic Notation "transitivity_idtoiso" open_constr(hyp) :=
    lazymatch goal with
      | [ |- ?f (Category.Morphisms.idtoiso ?C _) = _ ] => etransitivity (f (Category.Morphisms.idtoiso C hyp));
                                       [ do 2 refine (ap _ _); (* https://coq.inria.fr/bugs/show_bug.cgi?id=3626 *)
                                         apply path_functor_helper;
                                         simpl; trivial
                                       | path_natural_transformation ]
    end.

  Local Ltac pseudofunctor_t :=
    intros;
    unfold natural_transformation_of_natural_isomorphism;
    rewrite ?idtoiso_whisker_r, ?idtoiso_whisker_l;
    repeat (
        let C := match goal with |- @paths (@NaturalTransformation ?C ?D ?F ?G) _ _ => constr:((C -> D)%category) end in
        first [ eapply (@iso_moveL_pV C)
              | eapply (@iso_moveL_Vp C)
              | eapply (@iso_moveL_pM C)
              | eapply (@iso_moveL_Mp C) ];
        simpl
      );
    rewrite ?idtoiso_inv;
    simpl;
    change @NaturalTransformation.Composition.Core.compose
    with (fun C D F G H => Category.Core.compose (C := C -> D) (s := F) (d := G) (d' := H));
    cbv beta;
    rewrite ?idtoiso_comp;
    first [ transitivity_idtoiso (Functor.Composition.Laws.left_identity _)
          | transitivity_idtoiso ((Functor.Composition.Laws.left_identity _)^)
          | transitivity_idtoiso (Functor.Composition.Laws.right_identity _)
          | transitivity_idtoiso ((Functor.Composition.Laws.right_identity _)^)
          | transitivity_idtoiso (Functor.Composition.Laws.associativity _ _ _)
          | transitivity_idtoiso ((Functor.Composition.Laws.associativity _ _ _)^) ];
    rewrite eta_idtoiso;
    simpl;
    rewrite ?ap_V, ?Functor.Composition.Laws.left_identity_fst, ?Functor.Composition.Laws.right_identity_fst, ?Functor.Composition.Laws.associativity_fst;
    try reflexivity.

  (* The following helpers were generated with
<<
intros.
    repeat match goal with
             | [ |- context[idtoiso ?C (?f ?x)] ] => generalize (f x); intro
             | [ |- context[MorphismOf ?F ?f] ] => generalize dependent (MorphismOf F f); repeat (let x := fresh "x" in intro x)
             | [ |- context[ObjectOf ?F ?f] ] => generalize dependent (ObjectOf F f); repeat (let x := fresh "x" in intro x)
           end.
    simpl in *.
    unfold SubPreCatCat.
    simpl in *.
    clear.
    destruct_head_hnf @sig.
    simpl in *.
    repeat match goal with
             | [ H : _ |- _ ] => revert H
           end.
    intros H P.
>> *)

  Lemma pseudofunctor_of_functor__composition_of
        {x0 x1 x2 x : PreCategory}
        {x7 x11 : Functor x0 x1}
        {x12 : x7 = x11}
        {x6 : Functor x0 x2} {x9 : Functor x2 x1}
        {x14 : x11 = (x9 o x6)%functor}
        {x4 : Functor x0 x} {x5 : Functor x x1}
        {x8 : x7 = (x5 o x4)%functor} {x10 : Functor x x2}
        {x13 : x6 = (x10 o x4)%functor} {x15 : x5 = (x9 o x10)%functor}
        (H0' : P x0) (H1' : P x1) (H2' : P x2) (H' : P x)
  : ((associator_1 x9 x10 x4)
       o ((idtoiso (x -> x1) x15 : morphism _ _ _)
            oR x4
            o (idtoiso (x0 -> x1) x8 : morphism _ _ _)))%natural_transformation
    = (x9
         oL (idtoiso (x0 -> x2) x13 : morphism _ _ _)
         o ((idtoiso (x0 -> x1) x14 : morphism _ _ _)
              o (idtoiso (x0 -> x1) x12 : morphism _ _ _)))%natural_transformation.
  Proof.
    clear F.
    symmetry; simpl; pseudofunctor_t.
  Qed.

  Lemma pseudofunctor_of_functor__left_identity_of
        {x0 x : PreCategory}
        {x2 : Functor x x} {x3 : x2 = 1%functor}
        {x4 x5 : Functor x0 x} {x6 : x4 = x5} {x7 : x4 = (x2 o x5)%functor}
        (H0' : P x0) (H' : P x)
  : ((Category.Morphisms.idtoiso (x -> x) x3 : morphism _ _ _)
       oR x5
       o (Category.Morphisms.idtoiso (x0 -> x) x7 : morphism _ _ _))%natural_transformation
    = ((NaturalTransformation.Composition.Laws.left_identity_natural_transformation_2 x5)
         o (Category.Morphisms.idtoiso (x0 -> x) x6 : morphism _ _ _))%natural_transformation.
  Proof.
    clear F.
    simpl; pseudofunctor_t.
  Qed.

  Lemma pseudofunctor_of_functor__right_identity_of
        {x0 x : PreCategory}
        {x4 : Functor x0 x0} {x5 : x4 = 1%functor}
        {x2 x3 : Functor x0 x} {x6 : x2 = x3} {x7 : x2 = (x3 o x4)%functor}
        (H0' : P x0) (H' : P x)
  : (x3
       oL (Category.Morphisms.idtoiso (x0 -> x0) x5 : morphism _ _ _)
       o (Category.Morphisms.idtoiso (x0 -> x) x7 : morphism _ _ _))%natural_transformation
    = ((NaturalTransformation.Composition.Laws.right_identity_natural_transformation_2 x3)
         o (Category.Morphisms.idtoiso (x0 -> x) x6 : morphism _ _ _))%natural_transformation.
  Proof.
    clear F.
    simpl; pseudofunctor_t.
  Qed.

  Definition pseudofunctor_of_functor : Pseudofunctor C
    := Build_Pseudofunctor
         C
         (fun x => pr1 (F x))
         (fun s d m => F _1 m)
         (fun s d d' m0 m1 => Category.Morphisms.idtoiso (_ -> _) (composition_of F _ _ _ m1 m0))
         (fun x => Category.Morphisms.idtoiso (_ -> _) (identity_of F x))
         (fun w x y z _ _ _ => pseudofunctor_of_functor__composition_of (F w).2 (F z).2 (F y).2 (F x).2)
         (fun x y _ => pseudofunctor_of_functor__left_identity_of (F x).2 (F y).2)
         (fun x y _ => pseudofunctor_of_functor__right_identity_of (F x).2 (F y).2).
End of_functor.

Definition FunctorToCat `{Funext} {C} `{HP : forall C D, P C -> P D -> IsHSet (Functor C D)}
  := Functor C (@sub_pre_cat _ P HP).
Identity Coercion functor_to_cat_id : FunctorToCat >-> Functor.
Definition pseudofunctor_of_functor_to_cat `(F : @FunctorToCat H C P HP)
  := @pseudofunctor_of_functor _ C P HP F.


(** * Axioms used in the ITree library. *)

(** Other ITree modules should import this to avoid accidentally using more
   axioms elsewhere. *)

From Coq Require Import
  Logic.Classical_Prop
  Logic.ClassicalChoice
  Logic.EqdepFacts
  Logic.FunctionalExtensionality
.

(* Must be imported to use [ddestruction] *)
From Coq Require Export
  Program.Equality
.

Set Implicit Arguments.

(* The following tactics may be used:
   - [dependent destruction]
   - [dependent induction] *)
Ltac ddestruction :=
  repeat lazymatch goal with | H : existT _ _ _ = _ |- _ => dependent destruction H end.

(* Consequence of UIP; used by tactic [dependent destrcution] *)
Definition eq_rect_eq := Eqdep.Eq_rect_eq.eq_rect_eq.

Definition classic := Classical_Prop.classic.

Definition choice := ClassicalChoice.choice.

Definition functional_extensionality := @FunctionalExtensionality.functional_extensionality.

(* From Coq.Logic.ChoiceFacts *)
Definition GuardedFunctionalChoice_on {A B} :=
  forall P : A -> Prop, forall R : A -> B -> Prop,
    inhabited B ->
    (forall x : A, P x -> exists y : B, R x y) ->
    (exists f : A->B, forall x, P x -> R x (f x)).
Axiom guarded_choice : forall {A B}, @GuardedFunctionalChoice_on A B.

Inductive mwitness : Type :=
| Witness (P : Type) (_ : P)
| NoWitness.

Lemma classicT_inhabited : inhabited (forall (P : Type), P + (P -> False)).
Proof.
  destruct (choice (fun (P : Type) (b : mwitness) =>
    match b with @Witness Q _ => P = Q | NoWitness => P -> False end)) as [f H].
  { intros P; destruct (classic (inhabited P)) as [[x] | ];
      [exists (Witness x) | exists NoWitness]; auto. }
  constructor. intros P; specialize (H P); destruct (f P); [subst | ]; auto.
Qed.