From RecordUpdate Require Import RecordSet.
From Perennial.goose_lang Require Import crash_modality.

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

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 disk_prelude.
From Perennial.goose_lang.lib Require Import typed_slice.
From Perennial.Helpers Require Import List.
From Perennial.program_proof Require Import marshal_block disk_lib.

Definition maxDirect: Z := 500.
Definition maxIndirect: Z := 10.
Definition indirectNumBlocks: Z := 512.
Definition MaxBlocks: Z := maxDirect + maxIndirect*indirectNumBlocks.
Definition roundUpDiv (x k: Z) := (x + (k-1)) / k.
Definition lastBlockFiller (blkLen : Z) (x : list (list u64)) : nat :=
   Z.to_nat ((blkLen - (length (concat x) `mod` blkLen)) `mod` blkLen).

Ltac Zify.zify_post_hook ::= Z.div_mod_to_equations.

Lemma roundUpDiv_lt_succ (x k: Z) : x >= 0 -> k > 0 -> (x / k) < roundUpDiv x k -> (x / k) + 1 = roundUpDiv x k.
Proof.
  intros. unfold roundUpDiv in *.
  destruct (bool_decide (x `mod` k = 0)) eqn:Hx.
  + apply bool_decide_eq_true in Hx.
    rewrite (Z.div_mod x k) in H1; [|lia].
    rewrite Hx Z.add_0_r Z.mul_comm in H1.
    rewrite (Z.div_mul (x `div` k) k) in H1; [|lia].
    rewrite (Z.div_add_l (x `div` k) k (k-1)) in H1; [|lia].
    rewrite (Z.div_small (k-1) k) in H1; [|split; lia].
    lia.
  + apply bool_decide_eq_false in Hx.
    rewrite (Z.div_mod x k); [|lia].
    rewrite Z.mul_comm.
    rewrite (Z.div_add_l (x `div` k) k (x `mod` k)); [|lia].
    rewrite (Z.div_small (x `mod` k) k); [|lia].
    rewrite Z.add_0_r.
    rewrite -Z.add_assoc.
    rewrite (Z.div_add_l (x `div` k) k (x `mod` k + (k-1))); [|lia].
    assert ((x `mod` k + (k-1)) `div` k = 1) as Hone.
    {
      pose proof (Z_mod_lt x k H0) as [Hpos Hlt].
      assert (1*k <= x `mod` k + (k-1)) as Hlb by lia.
      assert (x `mod` k + (k-1) < 2*k) as Hub by lia.
      assert (0 < k) as Hk by lia.
      pose (Zdiv_lt_upper_bound _ _ _ Hk Hub).
      pose (Zdiv_le_lower_bound _ _ _ Hk Hlb).
      lia.
    }
    by rewrite Hone.
Qed.

Lemma roundUpDiv_gt_0 (x k : Z) :
  k > 0 -> roundUpDiv x k > 0 -> x > 0.
Proof.
  intros.
  unfold roundUpDiv in *.
Admitted.

Lemma roundUpDiv_mul_le (x k z: Z) :
  x >= 0 -> k > 0 -> z < roundUpDiv x k -> k * z <= x.
Proof.
  intros.
  unfold roundUpDiv in *.
  assert (∃ c, c > 0 ∧ z = (x + (k-1)) `div` k - c) as [c [Hc Hz]].
  {
    exists ((x + (k-1)) `div` k - z).
    word.
  }
  rewrite Hz.
  rewrite Z.mul_add_distr_l.
Admitted.

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) ≤ MaxBlocks.
  Definition size σ := length σ.(blocks).
End inode.

Module impl_s.
  Record t :=
    mk { (* addresses consumed by this inode *)
        hdr: Block;
        numInd: nat;
        dirAddrs: list u64;
        indAddrs: list u64;
        indBlkAddrsList: list (list u64);
      }.
  Global Instance _eta: Settable _ := settable! mk <hdr; numInd; dirAddrs; indAddrs; indBlkAddrsList>.
  Global Instance _witness: Inhabited t := populate!.
End impl_s.

Hint Unfold inode.wf MaxBlocks indirectNumBlocks maxDirect maxIndirect: word.

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

Context (inodeN allocN: namespace).

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

Definition is_indirect (a: u64) (indBlkAddrs: list u64) (indBlock : Block)
           (specBlocks : list Block) : iProp Σ :=
  "diskAddr" ∷ int.Z a d↦ indBlock ∗
  "%HindBlockLen" ∷ ⌜length (indBlkAddrs ++ replicate (Z.to_nat ((indirectNumBlocks - (length indBlkAddrs)) `mod` indirectNumBlocks)) (U64 0)) = Z.to_nat indirectNumBlocks
  ∧ length indBlkAddrs <= 512
  ∧ length indBlkAddrs > 0⌝ ∗
  "%Hencoded" ∷ ⌜block_encodes indBlock (EncUInt64 <$> (indBlkAddrs) ++ replicate (Z.to_nat ((indirectNumBlocks - (length indBlkAddrs)) `mod` indirectNumBlocks)) (U64 0))⌝ ∗
  "%Hlen" ∷ ⌜length(indBlkAddrs) = length(specBlocks)⌝ ∗
  "Hdata" ∷ ([∗ list] a;b ∈ indBlkAddrs;specBlocks, int.Z a d↦ b)
.

Definition ind_blocks_at_index σ index : list Block :=
  let begin := Z.to_nat (maxDirect + (index * indirectNumBlocks)) in
  List.subslice begin (begin + (Z.to_nat indirectNumBlocks)) σ.(inode.blocks).

Definition is_inode_durable_data σ (ds: impl_s.t) : iProp Σ :=
    (* direct addresses correspond to data blocks in inode spec *)
    "HdataDirect" ∷ (let len := Nat.min (Z.to_nat maxDirect) (length σ.(inode.blocks)) in
                     [∗ list] a;b ∈ take len ds.(impl_s.dirAddrs);take len σ.(inode.blocks), int.Z a d↦ b) ∗
    (* indirect addresses correspond to a block's worth of data blocks in inode spec *)
    "HdataIndirect" ∷ ∃ indBlocks,
    ⌜length indBlocks = length (take (ds.(impl_s.numInd)) ds.(impl_s.indAddrs))⌝ ∗
    ([∗ list] index↦a;indBlock ∈ take (ds.(impl_s.numInd)) ds.(impl_s.indAddrs);indBlocks,
    ∃ indBlkAddrs, ⌜ds.(impl_s.indBlkAddrsList) !! index = Some indBlkAddrs⌝ ∗
                    is_indirect a indBlkAddrs indBlock (ind_blocks_at_index σ index)).

Definition is_inode_durable_hdr σ (addr: u64) (ds: impl_s.t) : iProp Σ :=
  "%Hencoded" ∷ ⌜block_encodes ds.(impl_s.hdr) ([EncUInt64 (length σ.(inode.blocks))]
                                                 ++ (EncUInt64 <$> ds.(impl_s.dirAddrs))
                                                 ++ (EncUInt64 <$> ds.(impl_s.indAddrs))
                                                 ++ [EncUInt64 ds.(impl_s.numInd)])⌝ ∗
  "Hhdr" ∷ (int.Z addr d↦ ds.(impl_s.hdr)).

Definition is_inode_durable_facts σ (addr: u64) (ds: impl_s.t)
  : iProp Σ  :=
    "%Hwf" ∷ ⌜inode.wf σ⌝ ∗
    "%Haddrs_set" ∷ ⌜list_to_set (take (length σ.(inode.blocks)) ds.(impl_s.dirAddrs)
                                       ++ (take (ds.(impl_s.numInd)) ds.(impl_s.indAddrs))
                                       ++ concat ds.(impl_s.indBlkAddrsList))
    = σ.(inode.addrs)⌝ ∗
    "%HdirAddrs" ∷ ⌜ ∃ daddrs, ds.(impl_s.dirAddrs) = daddrs ++ (replicate (Z.to_nat (maxDirect) - (min (length σ.(inode.blocks)) (Z.to_nat maxDirect))) (U64 0))⌝ ∗
    "%HindAddrs" ∷ ⌜ ∃ indaddrs, ds.(impl_s.indAddrs) = indaddrs ++ (replicate (Z.to_nat (maxIndirect) - ds.(impl_s.numInd)) (U64 0))⌝ ∗
    "%Hlen" ∷ (⌜
      maxDirect = length(ds.(impl_s.dirAddrs)) ∧
      maxIndirect = length(ds.(impl_s.indAddrs)) ∧
      (Z.of_nat (length σ.(inode.blocks))) <= MaxBlocks⌝) ∗
    "%HnumInd" ∷ ⌜Z.of_nat ds.(impl_s.numInd)
                                 = roundUpDiv (Z.of_nat (((Z.to_nat maxDirect) `max` length σ.(inode.blocks))%nat) - maxDirect) indirectNumBlocks⌝ ∗

    "%HindBlkAddrsListLen" ∷ ⌜length(ds.(impl_s.indBlkAddrsList)) = ds.(impl_s.numInd)⌝.

Definition is_inode_durable_with σ addr ds : iProp Σ  :=
    "Hfacts" ∷ is_inode_durable_facts σ addr ds ∗
    "Hhdr" ∷ is_inode_durable_hdr σ addr ds ∗
    "Hdata" ∷ is_inode_durable_data σ ds
.

Definition is_inode_volatile_with l σ addr direct_s indirect_s ds : iProp Σ :=
    "addr" ∷ l ↦[Inode :: "addr"] #addr ∗
    "size" ∷ l ↦[Inode :: "size"] #(length σ.(inode.blocks)) ∗
    "direct" ∷ l ↦[Inode :: "direct"] (slice_val direct_s) ∗
    "indirect" ∷ l ↦[Inode :: "indirect"] (slice_val indirect_s) ∗
    "Hdirect" ∷ is_slice direct_s uint64T 1 (take (length σ.(inode.blocks)) ds.(impl_s.dirAddrs)) ∗
    "Hindirect" ∷ is_slice indirect_s uint64T 1 (take (ds.(impl_s.numInd)) ds.(impl_s.indAddrs))
.

Definition inode_linv_with (l:loc) σ addr direct_s indirect_s ds : iProp Σ :=
    "Hdurable" ∷ is_inode_durable_with σ addr ds ∗
    "Hvolatile" ∷ is_inode_volatile_with l σ addr direct_s indirect_s ds.

Definition inode_linv (l:loc) σ addr : iProp Σ :=
  ∃ (direct_s indirect_s: Slice.t) (ds: impl_s.t),
    inode_linv_with l σ addr direct_s indirect_s ds.

Definition inode_cinv σ addr: iProp Σ :=
  ∃ ds, is_inode_durable_with σ addr ds.

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

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

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

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

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

Lemma indirect_block_middle_full σ index :
  index < roundUpDiv (length σ.(inode.blocks) - maxDirect) indirectNumBlocks ->
  length (ind_blocks_at_index σ index) = Z.to_nat indirectNumBlocks.
Proof.
Admitted.

Lemma indBlkAddrsList_blocks_middle_full σ (i:nat) indAddrs indBlkAddrsList indBlocks:
  ⌜length indBlocks >= i⌝ -∗
  ⌜indirectNumBlocks * i <= length σ.(inode.blocks)⌝ -∗
  ([∗ list] index↦a;indBlock ∈ take i indAddrs;take i indBlocks,
  ∃ indBlkAddrs,
    ⌜indBlkAddrsList !! index = Some indBlkAddrs⌝
    ∗ is_indirect a indBlkAddrs indBlock (ind_blocks_at_index σ index)) -∗
  ⌜(length (concat (take i indBlkAddrsList)) `mod` indirectNumBlocks) = 0⌝.
Admitted.

Theorem init_inode addr :
  int.Z addr d↦ block0 -∗ inode_cinv (inode.mk ∅ []) addr.
Proof.
  iIntros "Hhdr".
  unfold inode_cinv.
  iExists (impl_s.mk block0 0%nat (replicate (Z.to_nat maxDirect) (U64 0)) (replicate (Z.to_nat maxIndirect) (U64 0)) []).
  unfold is_inode_durable_with.
  repeat iSplit; auto.
  + iExists []; auto.
  + iExists []; auto.
  + iSplitL "Hhdr".
    -- unfold is_inode_durable_hdr. repeat iSplit; auto.
    -- unfold is_inode_durable_data. repeat iSplit; auto.
       iExists []. auto.
Qed.

Theorem wp_Open k {d:loc} {addr σ P} :
  {{{ inode_cinv σ addr ∗ P σ }}}
    indirect_inode.Open #d #addr
    {{{ l, RET #l; is_inode l k P addr}}}.
Proof.
  iIntros (Φ) "(Hinode&HP) HΦ"; unfold inode_cinv;
    iNamed "Hinode"; iNamed "Hdata"; iNamed "Hfacts"; iNamed "Hhdr".
  iDestruct (big_sepL2_length with "HdataDirect") as %Hblocklen.
  destruct Hlen as [HdirLen [HindirLen HszMax]].

  wp_call.
  wp_apply (wp_Read with "Hhdr").
  iIntros (s) "(Hhdr&Hs)".
  wp_pures.
  iDestruct (slice.is_slice_to_small with "Hs") as "Hs".
  wp_apply (wp_new_dec with "Hs"); first by eauto.
  iIntros (dec) "Hdec".

  wp_apply (wp_Dec__GetInt with "Hdec"); iIntros "Hdec".
  wp_pures.
  wp_apply (wp_Dec__GetInts with "Hdec"); first by len.
  iIntros (diraddr_s) "[Hdec Hdiraddrs]".
  wp_pures.

  wp_apply (wp_Dec__GetInts with "Hdec"); first by len.
  iIntros (indaddr_s) "[Hdec Hindaddrs]".
  wp_pures.

  wp_apply (wp_Dec__GetInt with "Hdec"); iIntros "Hdec".
  wp_pures.

  wp_call.
  iDestruct "Hdiraddrs" as "[[HdirPtsto %Hdirs_len'] Hdirs_cap]".
  iDestruct "Hindaddrs" as "[[HindPtsto %Hinds_len'] Hinds_cap]".
  assert (length ds.(impl_s.dirAddrs) = int.nat diraddr_s.(Slice.sz) ∧
         length ds.(impl_s.indAddrs) = int.nat indaddr_s.(Slice.sz)) as [Hdirs_len Hinds_len].
  {
    split; [rewrite -Hdirs_len' | rewrite -Hinds_len']; rewrite fmap_length; len.
  }
  iAssert (is_slice diraddr_s uint64T 1 ds.(impl_s.dirAddrs)) with "[HdirPtsto Hdirs_cap]" as "Hdiraddrs".
  {
    unfold is_slice. iFrame.
    iPureIntro; auto.
  }
  iAssert (is_slice indaddr_s uint64T 1 ds.(impl_s.indAddrs)) with "[HindPtsto Hinds_cap]" as "Hindaddrs".
  {
    unfold is_slice. iFrame.
    iPureIntro; auto.
  }

  destruct (bool_decide (int.Z (length σ.(inode.blocks)) <= maxDirect)) eqn:HnumDir; unfold maxDirect in HnumDir; rewrite HnumDir; wp_pures.
  all: rewrite -wp_fupd; wp_apply wp_new_free_lock.
  all: iIntros (lref) "Hlock".
  {
    apply bool_decide_eq_true in HnumDir.
    replace (int.Z (U64 (Z.of_nat (length σ.(inode.blocks))))) with (Z.of_nat (length σ.(inode.blocks))) in HnumDir by word.
    assert (Z.of_nat ds.(impl_s.numInd) = 0) as HnumInd0.
    {
      rewrite HnumInd.
      unfold roundUpDiv, MaxBlocks, maxDirect, maxIndirect, indirectNumBlocks in *; try word.
    }
    wp_apply (wp_SliceTake (length σ.(inode.blocks))).
    {
      assert (int.Z maxDirect = int.Z (diraddr_s.(Slice.sz))).
      { unfold maxDirect in *. word. }
      replace (int.Z (U64 (Z.of_nat (length σ.(inode.blocks))))) with (Z.of_nat (length σ.(inode.blocks))) in H; word.
    }
    wp_apply (wp_SliceTake (ds.(impl_s.numInd))).
    {
      word.
    }
    wp_apply wp_allocStruct; auto.
    iIntros (l) "Hinode".
    iDestruct (struct_fields_split with "Hinode") as "(d&m&addr&sz&direct&indirect&_)".
    iMod (readonly_alloc_1 with "d") as "#d".
    iMod (readonly_alloc_1 with "m") as "#m".
    (*TODO needs to be crash lock*)
    iMod (alloc_lock inodeN ⊤ _
                    (∃ σ addr, "Hlockinv" ∷ inode_linv l σ addr ∗ "HP" ∷ P σ)%I
            with "[$Hlock] [-HΦ]") as "#Hlock".
    { iExists _, _; iFrame.
      iExists (slice_take diraddr_s (length σ.(inode.blocks))), _, ds.
      iFrame.
      iSplit; iFrame.
      - iFrame "∗ %".
        iPureIntro. repeat (split; auto).
      - iSplitL "Hdiraddrs"; unfold is_slice; rewrite /list.untype fmap_take//.
        {
          unfold maxDirect in *.
          change (into_val.to_val <$> ds.(impl_s.dirAddrs)) with (u64val <$> ds.(impl_s.dirAddrs)).
          iPoseProof (is_slice_take_cap _ _ (u64val <$> ds.(impl_s.dirAddrs)) (U64 (Z.of_nat (length σ.(inode.blocks)))) with "Hdiraddrs") as "H".
          { len. }
          replace (int.nat (U64 (Z.of_nat (length σ.(inode.blocks))))) with (length σ.(inode.blocks)); auto.
          word.
        }
        {
          rewrite HnumInd0.
          assert (ds.(impl_s.numInd) = 0%nat) by word; rewrite H.
          iApply (is_slice_take_cap indaddr_s uint64T (u64val <$> ds.(impl_s.indAddrs)) (0) with "Hindaddrs"); word.
        }
    }
    iAssert (is_crash_lock inodeN k #lref (∃ σ, inode_linv l σ addr ∗ P σ) True) as "#Hcrash_lock".
    { admit. }
    iModIntro.
    iApply "HΦ".
    iExists _, _; iFrame "#".
  }
  {
    assert (length σ.(inode.blocks) > maxDirect) as HszBound.
    {
      case_bool_decide.
      - discriminate.
      - unfold MaxBlocks, maxDirect, maxIndirect, indirectNumBlocks in *.
        replace (int.Z (U64 (Z.of_nat (length σ.(inode.blocks))))) with (Z.of_nat (length σ.(inode.blocks))) in H; word.
    }
    assert (Z.of_nat ds.(impl_s.numInd) = (roundUpDiv ((Z.of_nat (length σ.(inode.blocks))) - maxDirect) indirectNumBlocks))
    as HnumIndGt. {
      rewrite HnumInd Nat.max_r; word.
    }
    assert ((roundUpDiv ((Z.of_nat (length σ.(inode.blocks))) - maxDirect) indirectNumBlocks) < maxIndirect + 1)
      as HmaxCmp. {
      unfold MaxBlocks, roundUpDiv, indirectNumBlocks, maxDirect, indirectNumBlocks, maxIndirect in *.
      apply Zdiv_lt_upper_bound; eauto; lia.
    }

    wp_apply (wp_SliceTake maxDirect).
    {
      assert (maxDirect = int.Z (diraddr_s.(Slice.sz))).
      {
        unfold maxDirect in Hdirs_len, HdirLen. unfold maxDirect. by word.
      }
      rewrite -H; word.
    }
    wp_apply (wp_SliceTake (ds.(impl_s.numInd))).
    {
      rewrite HnumIndGt.
      unfold roundUpDiv, maxIndirect, maxDirect, indirectNumBlocks in *.
      replace (int.Z indaddr_s.(Slice.sz)) with 10 by word.
      word.
    }
    wp_apply wp_allocStruct; auto.
    iIntros (l) "Hinode".
    iDestruct (struct_fields_split with "Hinode") as "(d&m&addr&sz&direct&indirect&_)".
    iMod (readonly_alloc_1 with "d") as "#d".
    iMod (readonly_alloc_1 with "m") as "#m".
    iMod (alloc_lock inodeN ⊤ _
                    (∃ σ addr, "Hlockinv" ∷ inode_linv l σ addr∗ "HP" ∷ P σ)%I
            with "[$Hlock] [-HΦ]") as "#Hlock".
    { iExists _, _; iFrame.
      iExists _, _, ds.
      iFrame.
      iSplit; iFrame.
      - iFrame "∗ %".
        iPureIntro. repeat (split; auto).
      - iSplitL "Hdiraddrs"; unfold is_slice; rewrite /list.untype fmap_take//.
        {
          change (to_val <$> ds.(impl_s.dirAddrs)) with (u64val<$> ds.(impl_s.dirAddrs)).
          unfold maxDirect in HdirLen, HszBound.
          rewrite take_ge; last by len.
          iEval (rewrite -(firstn_all (u64val <$> ds.(impl_s.dirAddrs))) fmap_length /maxDirect).
          replace (length ds.(impl_s.dirAddrs)) with 500%nat by word.
          iApply (is_slice_take_cap with "Hdiraddrs").
          rewrite fmap_length; word.
        }
        {
          iPoseProof (is_slice_take_cap indaddr_s uint64T (u64val <$> ds.(impl_s.indAddrs)) (ds.(impl_s.numInd)) with "Hindaddrs")
            as "H".
          {
            unfold roundUpDiv, MaxBlocks, maxDirect, maxIndirect, indirectNumBlocks in *. len.
          }
          by replace (int.nat (U64 (Z.of_nat ds.(impl_s.numInd)))) with (ds.(impl_s.numInd)) by word.
        }
    }
    iAssert (is_crash_lock inodeN k #lref (∃ σ, inode_linv l σ addr ∗ P σ) True) as "#Hcrash_lock".
    { admit. }
    iModIntro.
    iApply "HΦ".
    iExists _, _; iFrame "#".
  }
Admitted.

Theorem is_inode_durable_size σ addr ds :
  is_inode_durable_with σ addr ds -∗ ⌜(length ((take (length σ.(inode.blocks)) (ds.(impl_s.dirAddrs))) ++ concat ds.(impl_s.indBlkAddrsList))
                                               = length σ.(inode.blocks))%nat⌝.
Proof.
  iNamed 1.
  iNamed "Hfacts"; iNamed "Hhdr"; iNamed "Hdata".
  destruct Hlen as [HdirAddrsLen [HindAddrsMax HnumIndBound]].
  iDestruct (big_sepL2_length with "HdataDirect") as "%H1".
  iDestruct "HdataIndirect" as (indBlocks) "[HindBlocksLen HdataIndirect]".
  iDestruct (big_sepL2_length with "HdataIndirect") as "%H2".
  destruct (bool_decide (maxDirect < length (σ.(inode.blocks)))) eqn:Hdir;
    rewrite app_length;
    unfold MaxBlocks, maxDirect, maxIndirect, indirectNumBlocks in *.
  + apply bool_decide_eq_true in Hdir.
    repeat rewrite take_length in H1.
    admit.
  + apply bool_decide_eq_false in Hdir.
    repeat rewrite take_length in H1.
Admitted.

Definition slice_subslice A n m s := slice_skip (slice_take s m) A n.

Definition is_alloced_blocks_slice σ s (direct_s indirect_s : Slice.t)
           numInd (dirAddrs indAddrs : list u64) (indBlkAddrsList: list (list u64)) : iProp Σ :=
      "direct" ∷ is_slice direct_s uint64T 1 (take (length σ.(inode.blocks)) dirAddrs) ∗
      "indirect" ∷ is_slice indirect_s uint64T 1 (take (numInd) indAddrs) ∗
      "indblocks" ∷ is_slice (slice_subslice uint64T
                               ((int.nat direct_s.(Slice.sz)) + (int.nat indirect_s.(Slice.sz)))%nat
                               s.(Slice.sz) s)
      uint64T 1 (concat indBlkAddrsList ++
                        replicate (lastBlockFiller indirectNumBlocks indBlkAddrsList) (U64 0)).

Theorem wp_indNum {off: u64} :
  {{{
       ⌜int.Z off >= maxDirect⌝
  }}}
    indNum #off
  {{{(v: u64), RET #v;
      ⌜int.Z v = (int.Z off - maxDirect) `div` indirectNumBlocks⌝
  }}}.
Proof.
  iIntros (ϕ) "%H Hϕ".
  wp_call.
  iApply "Hϕ".
  iPureIntro.
  unfold indirectNumBlocks. unfold maxDirect in *.
  word_cleanup.
  word.
Qed.

Theorem wp_indOff {off: u64} :
  {{{
       ⌜int.Z off >= maxDirect⌝
  }}}
    indOff #off
  {{{(v: u64), RET #v;
     ⌜int.Z v = (int.Z off - maxDirect) `mod` indirectNumBlocks⌝
  }}}.
Proof.
  iIntros (ϕ) "%H Hϕ".
  wp_call.
  iApply "Hϕ".
  iPureIntro.
  unfold indirectNumBlocks. unfold maxDirect in *.
  word_cleanup.
  word.
Qed.

Theorem wp_readIndirect {l σ}
        ds indirect_s (indBlk: Block) (indBlkAddrs : list u64) (index: nat) (d : loc) (a : u64):
  {{{
    "%Hwf" ∷ ⌜inode.wf σ⌝ ∗
    "%Hsize" ∷ ⌜length σ.(inode.blocks) <= MaxBlocks⌝ ∗
    "%HindexMax" ∷ ⌜(index < ds.(impl_s.numInd))⌝ ∗
    "%Hlen" ∷ ⌜Z.of_nat (length(ds.(impl_s.indAddrs))) = int.Z maxIndirect
    ∧ ds.(impl_s.numInd) <= maxIndirect⌝ ∗
    "#d" ∷ readonly (l ↦[Inode :: "d"] #d) ∗
    "%Haddr" ∷ ⌜Some a = (take (ds.(impl_s.numInd)) ds.(impl_s.indAddrs)) !! index⌝ ∗
    "indirect" ∷ l ↦[Inode :: "indirect"] (slice_val indirect_s) ∗
    "HindBlkAddrs" ∷ is_indirect a indBlkAddrs indBlk (ind_blocks_at_index σ index)
  }}}
     readIndirect #d #a
  {{{ indBlkAddrs_s, RET slice_val indBlkAddrs_s;
    "HindBlkIndirect" ∷ is_indirect a indBlkAddrs indBlk (ind_blocks_at_index σ index) ∗
    "HindBlkAddrs" ∷ is_slice indBlkAddrs_s uint64T 1
                      (indBlkAddrs ++ replicate (Z.to_nat ((indirectNumBlocks - (length indBlkAddrs)) `mod` indirectNumBlocks)) (U64 0)) ∗
    "indirect" ∷ l ↦[Inode :: "indirect"] (slice_val indirect_s)
  }}}.
Proof.
  iIntros (ϕ) "H Hϕ". iNamed "H". iNamed "HindBlkAddrs".
  destruct Hlen as [HindAddrsMax HnumIndBound].
  wp_call.

  wp_apply ((wp_Read a 1 indBlk) with "[diskAddr]"); auto.
  iIntros (s) "[diskAddr Hs]".
  wp_let.
  unfold is_block_full.
  iDestruct (slice.is_slice_to_small with "Hs") as "Hs".

  wp_apply (wp_new_dec with "Hs"); first by eauto.
  iIntros (dec) "Hdec".
  wp_pures.

  wp_apply (wp_Dec__GetInts_complete with "Hdec").
  {
    (* rewrite app_length replicate_length /indirectNumBlocks. *)
    unfold ind_blocks_at_index, MaxBlocks, maxIndirect, maxDirect, indirectNumBlocks in *.
    destruct HindBlockLen as [HindBlockLen [HindBlkAddrsLenUB HLB]].
    rewrite Zmod_small; try word.
    by replace (Z.to_nat (512 - Z.of_nat (length indBlkAddrs)))
      with (Z.to_nat ((512 - Z.of_nat (length indBlkAddrs)) `mod` 512)) by word.
  }
  iIntros (indBlkAddrsPadding_s) "[_ HindBlks]".

  iApply "Hϕ"; iFrame; auto.
Qed.

Theorem wp_Inode__UsedBlocks {l γ P addr σ} :
  {{{ pre_inode l P σ addr }}}
    Inode__UsedBlocks #l
    {{{ (s direct_s indirect_s :Slice.t) (ds: impl_s.t),
        RET (slice_val s);
        ⌜list_to_set ((take (length σ.(inode.blocks)) ds.(impl_s.dirAddrs))
                   ++ (take (ds.(impl_s.numInd)) (ds.(impl_s.indAddrs)))
                   ++ concat ds.(impl_s.indBlkAddrsList))
        = σ.(inode.addrs)⌝ ∗
      is_alloced_blocks_slice σ s direct_s indirect_s ds.(impl_s.numInd) ds.(impl_s.dirAddrs) ds.(impl_s.indAddrs) ds.(impl_s.indBlkAddrsList) ∗
      (is_alloced_blocks_slice σ s direct_s indirect_s ds.(impl_s.numInd) ds.(impl_s.dirAddrs) ds.(impl_s.indAddrs) ds.(impl_s.indBlkAddrsList) -∗
                               pre_inode l P σ addr) }}}.
Proof using allocG0 allocN heapG0 inodeN stagedG0 Σ.
  iIntros (Φ) "Hinode HΦ"; iNamed "Hinode".
  wp_call.
  iNamed "Hlockinv".
  iNamed "Hvolatile"; iNamed "Hdurable"; iNamed "Hfacts"; iNamed "Hhdr"; iNamed "Hdata".
  destruct Hlen as [HdirLen [HindirLen HszMax]].
  wp_apply wp_ref_of_zero; auto.
  iIntros (l0) "Hl0".
  wp_let.
  wp_apply (wp_NewSlice _ _ (uint64T)).
  iIntros (s) "Hs".
  wp_store.
  wp_loadField; wp_let.
  wp_loadField; wp_let.

  iDestruct (is_slice_sz with "Hdirect") as %HDirlen.
  iDestruct (is_slice_sz with "Hindirect") as %HIndlen.
  iDestruct (is_slice_split with "Hdirect") as "[Hdirect_small Hdirect]".
  iDestruct (is_slice_split with "Hindirect") as "[Hindirect_small Hindirect]".

  wp_apply (wp_forSlicePrefix
              (fun done todo =>
               ∃ s usedBlksList,
                 "%" ∷ ⌜ done ++ todo = (take (length σ.(inode.blocks)) ds.(impl_s.dirAddrs)) ⌝ ∗
                 "%" ∷ ⌜ done = usedBlksList ⌝ ∗
                 "Hl0" ∷ (l0 ↦[slice.T uint64T] (slice_val s)) ∗
                 "HusedSlice" ∷ is_slice s uint64T 1 usedBlksList
      )%I
  with "[] [Hl0 Hdirect_small Hs]").
  { iIntros (i a done todo _).
    iModIntro.
    iIntros (lϕ) "Hinv HΦ"; iNamed "Hinv".
    wp_pures.
    wp_load.
    iDestruct (is_slice_sz with "HusedSlice") as %HusedSlicelen.
    wp_apply (wp_SliceAppend (V:=u64) with "[$HusedSlice]").

    iIntros (direct_s') "Hdirect".
    wp_store.
    iApply "HΦ".
    iExists direct_s', (usedBlksList ++ [a]).
    repeat iSplit; auto.
    - iPureIntro.
      replace ((done ++ [a]) ++ todo) with (done ++ a :: todo); auto.
      rewrite cons_middle -app_assoc; auto.
    - iPureIntro; rewrite H0; auto.
    - iFrame.
  }
  {
    iFrame.
    iExists s, [].
    iFrame.
    repeat iSplit; auto.
  }

  iIntros "[Hdirect_small HdirLoop]". iNamed "HdirLoop".
  wp_pures.
  wp_apply (wp_forSlicePrefix
              (fun done todo =>
               ∃ s usedIndBlks,
                 "%" ∷ ⌜ done ++ todo = (take (ds.(impl_s.numInd)) ds.(impl_s.indAddrs)) ⌝ ∗
                 "%" ∷ ⌜ done = usedIndBlks ⌝ ∗
                 "Hl0" ∷ (l0 ↦[slice.T uint64T] (slice_val s)) ∗
                 "indirect" ∷ (l ↦[Inode :: "indirect"] (slice_val indirect_s)) ∗
                 "HusedSlice" ∷ is_slice s uint64T 1 (usedBlksList ++ usedIndBlks)
      )%I
  with "[] [Hl0 Hindirect_small indirect HusedSlice]").
  { iIntros (i a done todo _).
    iModIntro.
    iIntros (lϕ) "Hinv HΦ"; iNamed "Hinv".
    wp_pures.
    wp_load.

    iDestruct (is_slice_sz with "HusedSlice") as %HusedSlicelen.
    wp_apply (wp_SliceAppend (V:=u64) with "[$HusedSlice]").

    iIntros (indirect_s') "Hindirect".
    wp_store.
    iApply "HΦ".
    iExists indirect_s', (usedIndBlks ++ [a]).
    repeat iSplit; auto.
    - iPureIntro.
      replace ((done ++ [a]) ++ todo) with (done ++ a :: todo); auto.
      rewrite cons_middle -app_assoc; auto.
    - iPureIntro. rewrite H2; auto.
    - iFrame. rewrite app_assoc; auto.
  }
  {
    iFrame.
    iExists s0, [].

    rewrite app_nil_l app_nil_r.
    iFrame.
    repeat iSplit; auto.
  }
  iIntros "[Hindirect_small HindLoop]". iNamed "HindLoop".
  wp_pures.

  (*facts for readIndirect*)
  assert (ds.(impl_s.numInd) <= maxIndirect) as HnumIndMax.
  {
    unfold roundUpDiv, MaxBlocks, maxDirect, maxIndirect, indirectNumBlocks in *. lia.
  }
  assert ((int.nat direct_s.(Slice.sz) + int.nat indirect_s.(Slice.sz)) < Z.to_nat MaxBlocks)%nat as HslicesLen.
  {
    rewrite -HDirlen -HIndlen.
    repeat rewrite take_length.
    word.
  }

  iNamed "Hro_state".
  iDestruct "HdataIndirect" as (indBlocks) "[%HindBlocksLen HdataIndirect]".
  wp_apply (wp_forSlicePrefix
              (fun done todo =>
               ∃ s,
                 "%" ∷ ⌜ done ++ todo = (take (ds.(impl_s.numInd)) ds.(impl_s.indAddrs)) ⌝ ∗
                 "Hl0" ∷ (l0 ↦[slice.T uint64T] (slice_val s)) ∗
                 "indirect" ∷ (l ↦[Inode :: "indirect"] (slice_val indirect_s)) ∗
                 "HusedSlice" ∷
                  is_slice s uint64T 1
                           (usedBlksList
                              ++ usedIndBlks
                              ++ concat (take (length done) ds.(impl_s.indBlkAddrsList))
                              ++ (replicate (lastBlockFiller indirectNumBlocks
                                                            (take (length done) ds.(impl_s.indBlkAddrsList)))
                                                            (U64 0))) ∗
                 "HindBlks" ∷ [∗ list] i↦a;indBlk ∈ done ++ todo;indBlocks, ∃ indBlkAddrs,
                                                ⌜ ds.(impl_s.indBlkAddrsList) !! i = Some indBlkAddrs ⌝ ∗
                                                is_indirect a indBlkAddrs indBlk (ind_blocks_at_index σ i)
      )%I
  with "[] [Hindirect_small Hl0 HusedSlice indirect HdataIndirect]").
  { iIntros (i a done todo _).
    iModIntro.
    iIntros (lϕ) "Hinv HΦ"; iNamed "Hinv".
    wp_pures.
    wp_loadField.
    replace (indBlocks) with ((take (length done) indBlocks) ++ (drop (length done) indBlocks))
      by (rewrite take_drop; auto).
    iApply (big_sepL2_app_inv _ done (a :: todo) (take (length done) indBlocks) (drop (length done) indBlocks)) in "HindBlks"; auto.
    {
      rewrite take_length HindBlocksLen -H3. len.
    }
    iDestruct "HindBlks" as "[HindBlksDone HindBlksTodo]".
    assert (∃ indblk, indblk :: (drop (length done + 1)) indBlocks = (drop (length done)) indBlocks)
      as [indblk Hindblk].
    {
      assert (∃ indblk, indBlocks !! length done = Some indblk) as [indblk Htmp].
      + apply lookup_lt_is_Some. rewrite HindBlocksLen -H3. len.
      + exists indblk.
        replace (length done + 1)%nat with (S (length done))%nat by word.
        rewrite -drop_S; auto.
    }
    rewrite -Hindblk.
    iDestruct (big_sepL2_cons with "HindBlksTodo") as "[Ha HindBlksTodo]".
    iEval (rewrite -plus_n_O) in "Ha".
    iDestruct "Ha" as (indBlkAddrs) "[%HindBlkAddrsLookup Ha]".
    wp_apply (wp_readIndirect ds indirect_s indblk indBlkAddrs (length done) d a with "[Ha indirect]").
    {
      iFrame.
      repeat (iSplitR; [iPureIntro; eauto|]).
      { assert (length (done ++ a :: todo) = length (take ds.(impl_s.numInd) ds.(impl_s.indAddrs))) as tmp by (rewrite H3; auto).
        rewrite app_length take_length cons_length min_l in tmp; lia.
      }
      iSplitR; iFrame; eauto.
      + by rewrite -H3 list_lookup_middle.
    }
    iIntros (indBlkAddrs_s) "H".
    iNamed "H".
    wp_load.
    wp_apply (wp_SliceAppendSlice (V:=u64) with "[HusedSlice HindBlkAddrs]"); iFrame.
    iIntros (s') "Hs'".
    wp_store.
    iApply "HΦ".

    iExists s'.
    iNamed "HindBlkIndirect".
    iFrame.
    iSplitR; [iPureIntro; rewrite -app_assoc; simpl; eauto|].
    rewrite app_length.
    iAssert (∀ i, ⌜(i <= length done)%nat⌝ -∗
                   ⌜(length (concat (take i ds.(impl_s.indBlkAddrsList))) `mod` indirectNumBlocks) = 0⌝)%I
      with "[HindBlksDone]" as "%Hfull".
    {
      iIntros.
      destruct (bool_decide (ds.(impl_s.numInd) > 0)) eqn:Hloop0.
      { apply bool_decide_eq_true in Hloop0.
        assert (length done < length indBlocks) as HdoneLen by (rewrite HindBlocksLen -H3; len).
        iApply (indBlkAddrsList_blocks_middle_full σ i0 ds.(impl_s.indAddrs) ds.(impl_s.indBlkAddrsList) indBlocks);
          [iPureIntro; lia | iPureIntro |]; auto.
        {
          apply (Z.le_trans _ (length σ.(inode.blocks) - maxDirect) _); try word.
          assert (((Z.to_nat maxDirect `max` length σ.(inode.blocks))%nat - maxDirect) > 0)
              by (apply (roundUpDiv_gt_0 ((Z.to_nat maxDirect `max` length σ.(inode.blocks))%nat - maxDirect) indirectNumBlocks); word).
          apply (roundUpDiv_mul_le (length σ.(inode.blocks) - maxDirect) indirectNumBlocks i0); try word.
          rewrite max_r in HnumInd.
          - rewrite -HnumInd.
            rewrite HindBlocksLen take_length in HdoneLen.
            rewrite min_l in HdoneLen; word.
          - destruct (bool_decide (Z.to_nat maxDirect > length σ.(inode.blocks))) eqn:Hgt; word.
        }
        rewrite -(take_drop i0 (take (length done) indBlocks)).
        rewrite -(take_drop i0 done).
        iApply big_sepL2_app_inv in "HindBlksDone"; [len|].
        iDestruct "HindBlksDone" as "[Hi0 _]".
        len.
        rewrite take_take.
        rewrite min_l; [|word].
        replace (take i0 ds.(impl_s.indAddrs)) with (take i0 done); auto.
        replace (take (i0) ds.(impl_s.indAddrs))
            with (take (i0) (take ds.(impl_s.numInd) ds.(impl_s.indAddrs))).
          - rewrite -H3. rewrite take_app_le; auto.
          - rewrite take_take min_l; auto.
            rewrite HindBlocksLen take_length in HdoneLen.
            len.
      }
      {
        apply bool_decide_eq_false in Hloop0.
        assert (ds.(impl_s.numInd) = 0%nat) as His0 by word.
        rewrite His0 in HindBlkAddrsListLen.
        replace (ds.(impl_s.indBlkAddrsList)) with (@nil (list u64)).
        + rewrite take_nil. simpl. auto.
        + by apply nil_length_inv in HindBlkAddrsListLen.
      }
    }
    iSplitL "Hs'".
    {
      assert ((take (length done + length [a]) ds.(impl_s.indBlkAddrsList))
        = (take (length done) ds.(impl_s.indBlkAddrsList)) ++ [indBlkAddrs]) as Ha.
      { simpl.
        replace (take (length done+1) ds.(impl_s.indBlkAddrsList))
          with ((take (length done) ds.(impl_s.indBlkAddrsList)) ++ [indBlkAddrs]).
        2: {
          replace (length done + 1)%nat with (S (length done)%nat) by word.
          rewrite -take_S_r; auto.
        }
        auto.
      }
      rewrite Ha.
      rewrite concat_app.
      assert (concat [indBlkAddrs] = indBlkAddrs) as HconcatSingleton by (simpl; rewrite app_nil_r; auto).
      replace ((lastBlockFiller indirectNumBlocks (take (length done) ds.(impl_s.indBlkAddrsList)))) with (0%nat).
      2: {
        rewrite /lastBlockFiller Hfull; simpl; auto.
      }
      repeat rewrite app_assoc.
      rewrite replicate_0 app_nil_r.
      rewrite app_nil_r.
      unfold lastBlockFiller.
      rewrite concat_app HconcatSingleton.
      len.
      replace (Z.of_nat (length (concat (take (length done) ds.(impl_s.indBlkAddrsList))) + length indBlkAddrs) `mod` indirectNumBlocks)
        with ((Z.of_nat (length (concat (take (length done) ds.(impl_s.indBlkAddrsList)))) + (Z.of_nat (length indBlkAddrs))) `mod` indirectNumBlocks) by word.
      rewrite Z.add_mod; [|simpl; auto].
      rewrite Hfull; auto.
      rewrite Z.add_0_l.
      repeat rewrite Zminus_mod_idemp_r.
      rewrite Z.mod_small; try word.
      auto.
    }
    rewrite -app_assoc.
    iApply (big_sepL2_app with "[HindBlksDone]"); [by simpl|].
    simpl.

    iSplitL "diskAddr Hdata"; simpl; auto.
    {
      iExists indBlkAddrs.
      rewrite -plus_n_O.
      iFrame.
      repeat (iSplitR; iPureIntro; auto).
    }
  }
  {
    rewrite app_nil_l.
    iFrame.
    iExists s1.
    iFrame.
    iSplitR; auto.
    simpl; rewrite app_nil_r; auto.
  }
  iIntros "[Hindirect_small H]".
  iNamed "H".
  iDestruct (is_slice_sz with "HusedSlice") as %Hs2len.

  wp_pures.
  wp_load.
  iApply ("HΦ" $! s2 direct_s indirect_s ds); eauto.
  iSplitR; [iPureIntro; eauto|].
  iFrame.
  iSplitL "HusedSlice".
  + unfold slice_subslice.
    iDestruct "HusedSlice" as "[Hsmall Hcap]".
    rewrite app_assoc.
    iApply (slice_small_split s2 (int.Z (int.nat direct_s.(Slice.sz) + int.nat indirect_s.(Slice.sz))) uint64T 1) in "Hsmall".
    {
      rewrite -H0 -H2 -HDirlen -HIndlen.
      repeat rewrite app_length take_length.
      word.
    }
    iDestruct "Hsmall" as "[HsmallTake HsmallSkip]".
    unfold MaxBlocks, maxDirect, maxIndirect, indirectNumBlocks in *.
    replace (slice_take s2 s2.(Slice.sz)) with s2 by (destruct s2; simpl; auto).
    assert ((int.nat direct_s.(Slice.sz) + int.nat indirect_s.(Slice.sz)) = length (usedBlksList ++ usedIndBlks))
      as HrewriteMe.
    {
      rewrite app_length -H0 -H2 HDirlen HIndlen.
      word.
    }
    rewrite HrewriteMe.
    replace (int.nat (int.Z (length (usedBlksList ++ usedIndBlks)))) with (length (usedBlksList ++ usedIndBlks)) by word.
    rewrite drop_app take_length min_l; try word.
    rewrite -HindBlkAddrsListLen.
    rewrite firstn_all.
    iApply is_slice_split.
    iSplitL "HsmallSkip".
    {
      by replace
        (U64 (int.Z (U64 (Z.of_nat (length (usedBlksList ++ usedIndBlks))))))
        with (U64 (Z.of_nat (int.nat direct_s.(Slice.sz) + int.nat indirect_s.(Slice.sz)))) by word.
    }
    iApply (is_slice_cap_skip with "Hcap").
    replace (int.Z (U64 (Z.of_nat (int.nat direct_s.(Slice.sz) + int.nat indirect_s.(Slice.sz)))))
      with (Z.of_nat (int.nat direct_s.(Slice.sz)) + Z.of_nat (int.nat indirect_s.(Slice.sz))) by word.
    rewrite HrewriteMe.
    assert (Z.of_nat (length
          (usedBlksList ++
          usedIndBlks ++
          concat (take (length (take ds.(impl_s.numInd) ds.(impl_s.indAddrs))) ds.(impl_s.indBlkAddrsList)) ++
          replicate
            (lastBlockFiller (Z.to_nat 512)
                (take (length (take ds.(impl_s.numInd) ds.(impl_s.indAddrs))) ds.(impl_s.indBlkAddrsList)))
            (U64 0))) = int.Z s2.(Slice.sz)) as HrewriteMe2 by word.
    rewrite -HrewriteMe2.
    len.
  + iIntros "Halloced".
    iExists d, lref.
    unfold inode_state; iSplitR; [iSplit; auto|].
    iFrame.
    iExists direct_s, indirect_s, ds.
    iFrame.
    iNamed "Halloced".
    iFrame.
    iSplitR; [iPureIntro; repeat split; auto|].
    iSplitR; [iPureIntro; auto|].
    iExists indBlocks.
    iSplitR; [iPureIntro; auto|].
    rewrite app_nil_r.
    iFrame.
Qed.

Theorem wp_Inode__Read {l P k addr} {off: u64} Q :
  {{{ "Hinode" ∷ is_inode l k 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 }}}.
Proof.
  iIntros (Φ) "Hpre HΦ"; iNamed "Hpre".
  iNamed "Hinode". iNamed "Hro_state".
  wp_call.
  wp_loadField.
  wp_apply (crash_lock.acquire_spec with "Hlock"); auto.
  iIntros "His_locked".
  wp_pures.

  iAssert ((∃ σ , inode_linv l σ addr ∗ P σ)%I) as (σ) "(-#Hlockinv & -#HP)". { admit. }
  iNamed "Hlockinv".
  iNamed "Hvolatile"; iNamed "Hdurable"; iNamed "Hfacts"; iNamed "Hhdr"; iNamed "Hdata".
  destruct Hlen as [HdirLen [HindirLen HszMax]].
  wp_loadField.
  wp_op.
  wp_if_destruct;
    replace (int.Z (U64 (Z.of_nat (length σ.(inode.blocks))))) with (Z.of_nat (length σ.(inode.blocks))) in Heqb
    by (unfold MaxBlocks, maxDirect, maxIndirect, indirectNumBlocks in *; word).
  - iMod ("Hfupd" $! σ σ None with "[$HP]") as "[HP HQ]".
    { iPureIntro.
      rewrite lookup_ge_None_2 //.
      word.
    }
    wp_loadField.
    wp_apply (crash_lock.release_spec with "His_locked"); auto.
    wp_pures.
    change slice.nil with (slice_val Slice.nil).
    iApply "HΦ"; iFrame; auto.
  - wp_op.
    assert (int.Z off < length σ.(inode.blocks)) as Hszoff by lia.
    unfold maxDirect in *.
    wp_if_destruct.

    (* Is direct block *)
    {
      wp_loadField.
      destruct (list_lookup_lt _ ds.(impl_s.dirAddrs) (int.nat off)) as [a Hlookup].
      { rewrite /maxDirect. word. }
      iDestruct (is_slice_split with "Hdirect") as "[Hdirect_small Hdirect]".
      wp_apply (wp_SliceGet _ _ _ _ _ (take (length (σ.(inode.blocks))) ds.(impl_s.dirAddrs)) _ a with "[Hdirect_small]").
      { iSplit; auto.
        unfold maxDirect in *.
        iPureIntro.
        rewrite lookup_take; auto.
        word.
      }
      iIntros "Hdirect_small".
      wp_pures.
      iDestruct (big_sepL2_lookup_1_some _ _ _ (int.nat off) a with "HdataDirect") as "%Hblock_lookup"; eauto.
      { rewrite lookup_take; [auto | word]. }
      destruct Hblock_lookup as [b0 Hlookup2].
      iDestruct (is_slice_split with "[$Hdirect_small $Hdirect]") as "Hdirect".
      iDestruct (big_sepL2_lookup_acc _ _ _ _ a with "HdataDirect") as "[Hb HdataDirect]"; eauto.
      { rewrite lookup_take; [auto | word]. }
      wp_apply (wp_Read with "Hb"); iIntros (s) "[Hb Hs]".
      iSpecialize ("HdataDirect" with "Hb").
      wp_loadField.
      iMod ("Hfupd" $! σ σ with "[$HP]") as "[HP HQ]".
      { iPureIntro; eauto. }
      wp_apply (crash_lock.release_spec with "His_locked"); auto.
      wp_pures.
      iApply "HΦ"; iFrame.
      rewrite lookup_take in Hlookup2; [ | word ].
      rewrite Hlookup2.
      iDestruct (is_slice_split with "Hs") as "[Hs _]".
      iFrame.
    }

    (* Is indirect block *)
    {
      wp_apply wp_indNum.
      { iPureIntro. auto. }

      iIntros (index) "%Hindex".

      (* Here are a bunch of facts *)
      assert (int.Z off >= int.Z 500) as Hoff500 by word.
      assert (length σ.(inode.blocks) > 500) as Hsz by word.
      assert (ds.(impl_s.numInd) <= maxIndirect) as HnumIndMax.
      {
        unfold roundUpDiv, MaxBlocks, maxDirect, maxIndirect, indirectNumBlocks in *. lia.
      }
      assert (((int.Z off - 500) `div` 512) <= ((length σ.(inode.blocks) - 500) `div` 512)) as Hoff. {
        apply Z.div_le; lia.
      }

      assert (int.Z index < ds.(impl_s.numInd)) as HindexMax. {
        unfold MaxBlocks, maxDirect, maxIndirect, indirectNumBlocks in *.
        unfold roundUpDiv, MaxBlocks, maxDirect, maxIndirect, indirectNumBlocks in *. lia.
      }
      destruct (list_lookup_lt _ (take (ds.(impl_s.numInd)) ds.(impl_s.indAddrs)) (int.nat index)) as [a Hlookup].
      {
        unfold MaxBlocks, maxDirect, maxIndirect, indirectNumBlocks in *.
        rewrite firstn_length Hindex.
        rewrite Nat.min_l; word.
      }

      (* Now we actually step through program the *)
      wp_loadField.
      iDestruct (is_slice_split with "Hindirect") as "[Hindirect_small Hindirect]".
      wp_apply (wp_SliceGet _ _ _ _ 1 (take (ds.(impl_s.numInd)) ds.(impl_s.indAddrs)) _ a with "[Hindirect_small]"); iFrame; auto.

      iIntros "Hindirect_small".
      iDestruct (is_slice_split with "[$Hindirect_small $Hindirect]") as "Hindirect".
      iDestruct "HdataIndirect" as (indBlocks) "[%HindBlocksLen HdataIndirect]".
      assert (∃ indBlock, indBlocks !! int.nat index = Some indBlock) as [indBlk HlookupIndBlock].
      {
        apply lookup_lt_is_Some_2.
        rewrite HindBlocksLen.
        apply (lookup_lt_Some _ _ _ Hlookup).
      }
      iDestruct (big_sepL2_lookup_acc _ (take (ds.(impl_s.numInd)) ds.(impl_s.indAddrs)) _ (int.nat index) a with "HdataIndirect")
        as "[Hb HdataIndirect]"; eauto.

      wp_loadField.
      iDestruct "Hb" as (indBlkAddrs) "[%HaddrLookup HaddrIndirect]".
      wp_apply (wp_readIndirect ds indirect_s indBlk indBlkAddrs (int.nat index) d a
                  with "[indirect Hindirect HaddrIndirect]").
      {
        iFrame. repeat iSplit; eauto.
        iPureIntro; len.
      }
      iIntros (indBlkAddrs_s) "H". iNamed "H". iNamed "HindBlkIndirect".

      wp_let.
      wp_apply wp_indOff.
      { iPureIntro; auto. }
      iIntros (offset) "%Hoffset".

      (* More facts about offset *)
      assert ((int.Z off - 500) `div` 512 * 512 = (512 * (int.Z off - 500) `div` 512)) as HMulComm by lia.

      assert ((int.Z off - 500) `div` 512 * 512  <= ((512 * (int.Z off - 500)) `div` 512)) as HdivMulLe by lia.

      assert (int.Z index * indirectNumBlocks <= int.Z off -maxDirect ∧
              int.Z off -maxDirect < (int.Z index * indirectNumBlocks) + indirectNumBlocks)
        as [HoffLBound HoffUBound] by word.

      assert (int.Z offset < length indBlkAddrs) as HoffsetInBounds.
      {
        unfold ind_blocks_at_index in Hlen.
        rewrite Hlen.
        rewrite Hoffset.
        unfold maxDirect, indirectNumBlocks in *.
        assert ((512 * int.Z index) + int.Z offset = int.Z off - 500) by word.
        assert (int.Z offset = (int.Z off - 500) - (512 * int.Z index)) as HoffsetVal by word.
        destruct (dec_ge (length σ.(inode.blocks)) ((500 + int.nat index * 512) + 512)) as [HlenGe | HlenNotGe].
        (* Subslice fully contained in blocks *)
        {
          rewrite subslice_length.
          - word.
          - word.
        }
        (* Subslice goes to end of blocks *)
        {
          pose (not_ge _ _ HlenNotGe) as HlenUBound.
          rewrite subslice_to_end; [ | word ].
          rewrite skipn_length.
          word.
        }
      }
      destruct (list_lookup_lt _ (ind_blocks_at_index σ (int.nat index)) (int.nat offset)) as [inodeblkaddr HlookupInodeBlk].
      { rewrite -Hlen. word. }
      destruct (list_lookup_lt _ (indBlkAddrs) (int.nat offset)) as [blkaddr HlookupBlkInd]; try word.
      assert ((σ.(inode.blocks)) !! (int.nat off) = Some inodeblkaddr) as HlookupInodeBlk'.
      {
        rewrite /ind_blocks_at_index Hoffset in HlookupInodeBlk.
        unfold subslice in *.
        rewrite lookup_drop in HlookupInodeBlk.
        unfold maxDirect, indirectNumBlocks in *.
        rewrite Hindex in HlookupInodeBlk.
        rewrite -HlookupInodeBlk.
        rewrite -> lookup_take by word.
        f_equal; word. }

      (* Continue through the program *)
      iDestruct (is_slice_split with "HindBlkAddrs") as "[HindBlkAddrs_small HindBlkAddrs]".

      assert ((indBlkAddrs ++ replicate (Z.to_nat ((indirectNumBlocks - length indBlkAddrs) `mod` indirectNumBlocks)) (U64 0)) !! int.nat offset = Some blkaddr) as HlookupBlkIndPadded. {
        rewrite -(lookup_app_l indBlkAddrs
                               (replicate (Z.to_nat ((indirectNumBlocks - length indBlkAddrs) `mod` indirectNumBlocks)) (U64 0)))
       in HlookupBlkInd; auto; try word.
      }
      wp_apply (wp_SliceGet _ _ _ _ 1 (indBlkAddrs++_) _ blkaddr with "[HindBlkAddrs_small]"); iFrame; auto.

      iIntros "HindBlkAddrs_small".
      iDestruct (is_slice_split with "[$HindBlkAddrs_small $HindBlkAddrs]") as "HindBlkAddrs".
      iDestruct (big_sepL2_lookup_acc _ _ _ _ _ with "Hdata") as "[Hb' Hdata]"; eauto.

      wp_apply (wp_Read with "Hb'"); iIntros (s) "[Hb' Hs]".
      wp_let.

      iSpecialize ("Hdata" with "Hb'").
      iAssert (∃ indBlkAddrs,
                  ⌜ds.(impl_s.indBlkAddrsList) !! int.nat index = Some indBlkAddrs⌝ ∗
                  is_indirect a indBlkAddrs indBlk (ind_blocks_at_index σ (int.nat index)))%I
        with "[diskAddr HindBlkAddrs Hdata]" as "HaddrIndirect".
      {
        iExists indBlkAddrs.
        unfold is_indirect.
        iFrame. iSplit; auto.
      }
      iSpecialize ("HdataIndirect" with "HaddrIndirect").

      wp_loadField.
      iMod ("Hfupd" $! σ σ with "[$HP]") as "[HP HQ]".
      { iPureIntro; eauto. }

      wp_apply (crash_lock.release_spec with "His_locked"); auto.
      wp_pures.
      iApply "HΦ"; iFrame.

      rewrite HlookupInodeBlk'.
      iDestruct (is_slice_split with "Hs") as "[Hs_small Hs]"; eauto.
    }
Admitted.

Theorem wp_Inode__Size {l k' P addr} (Q: u64 -> iProp Σ) :
  {{{ "Hinode" ∷ is_inode l k' P addr ∗
      "Hfupd" ∷ (∀ σ σ' sz,
          ⌜σ' = σ ∧ int.nat sz = inode.size σ⌝ ∗
          ▷ P σ ={⊤}=∗ ▷ P σ' ∗ Q sz)
  }}}
    Inode__Size #l
  {{{ sz, RET #sz; Q sz }}}.
Proof.
  iIntros (Φ) "Hpre HΦ"; iNamed "Hpre".
  iNamed "Hinode"; iNamed "Hro_state".
  wp_call.
  wp_loadField.
  wp_apply (crash_lock.acquire_spec with "Hlock"); auto.
  iIntros "His_locked".
  wp_pures.

  iAssert ((∃ σ, inode_linv l σ addr ∗ P σ)%I) as (σ) "(-#Hlockinv & -#HP)". { admit. }
  iNamed "Hlockinv".
  iNamed "Hvolatile"; iNamed "Hdurable"; iNamed "Hfacts"; iNamed "Hhdr"; iNamed "Hdata".
  wp_loadField.
  wp_let.
  wp_loadField.
  iMod ("Hfupd" $! σ σ (length σ.(inode.blocks)) with "[$HP]") as "[HP HQ]".
  { iPureIntro.
    split; auto.
    unfold inode.size. word.
  }
  wp_apply (crash_lock.release_spec with "His_locked"); auto.
  wp_pures.
  iApply ("HΦ" with "[$]").
Admitted.

Theorem wp_padInts {Stk E} enc (n: u64) (encoded : list encodable) (off: Z):
  {{{
    ⌜ int.Z 0 ≤ int.Z n ∧ off >= 8*(int.Z n) ⌝ ∗
    is_enc enc 4096 encoded off
  }}}
    padInts enc #n @Stk ; E
  {{{ RET #()
;
    is_enc enc 4096 (encoded ++ (EncUInt64 <$> replicate (int.nat n) (U64 0))) (off-(8*int.Z n))
  }}}.
Proof.
  iIntros (ϕ) "[%Hi Henc] Hϕ".
  wp_call.
  wp_call.
  wp_apply (wp_ref_of_zero _ _ (baseT uint64BT)); first by auto.
  iIntros (i) "Hi".
  wp_let.

  wp_apply (wp_forUpto (λ i, "%Hiupper_bound" ∷ ⌜int.Z i <= int.Z n⌝ ∗
                       "Henc" ∷ is_enc enc 4096 (encoded ++ (EncUInt64 <$> (replicate (int.nat i) (U64 0))))
                       (off - (8 * int.Z i)))%I _ _
                    0 n
            with "[] [Henc Hi] [-]").
  {
    word.
  }
  {
    iIntros. iModIntro. iIntros (ϕ0) "H Hϕ0".
    iDestruct "H" as "[H [Hi %Hibound]]"; destruct Hi as [Hn Hoff].
    iNamed "H".
    wp_pures.
    wp_apply (wp_Enc__PutInt with "Henc"); [ word | ].

    iIntros "Henc".
    wp_pures.
    iApply "Hϕ0".
    iFrame.
    iSplitR "Henc".
    - iPureIntro. word.
    - replace (int.nat (word.add i0 1)) with (S (int.nat i0)) by word.
      rewrite replicate_S_end.
      rewrite fmap_app; simpl.
      rewrite app_assoc.
      iExactEq "Henc".
      rewrite /named.
      f_equal; word.
  }
  {
    iSplitL "Henc"; iFrame; auto.
    iSplitR "Henc".
    - iPureIntro. word.
    - rewrite replicate_0 fmap_nil app_nil_r.
      iExactEq "Henc".
      rewrite /named.
      f_equal; word.
  }

  iModIntro.
  iIntros "[H Hi]".
  destruct Hi as [Hn Hoff].
  iNamed "H".
  iApply "Hϕ"; iFrame.
Qed.

Theorem wp_Inode__mkHdr {Stk E} l (sz numInd : Z) allocedDirAddrs allocedIndAddrs direct_s indirect_s:
  (length(allocedDirAddrs) <= int.nat maxDirect ∧
   (Z.of_nat (length(allocedIndAddrs))) = numInd ∧
   sz <= MaxBlocks ∧
   numInd <= maxIndirect)
  ->
  {{{
    "direct" ∷ l ↦[Inode :: "direct"] (slice_val direct_s) ∗
    "indirect" ∷ l ↦[Inode :: "indirect"] (slice_val indirect_s) ∗
    "size" ∷ l ↦[Inode :: "size"] #sz ∗
    "Hdirect" ∷ is_slice direct_s uint64T 1 allocedDirAddrs ∗
    "Hindirect" ∷ is_slice indirect_s uint64T 1 allocedIndAddrs
  }}}
    Inode__mkHdr #l @ Stk; E
  {{{ s hdr, RET (slice_val s);
    is_block s 1 hdr ∗
    "%Hencoded" ∷ ⌜block_encodes hdr ([EncUInt64 sz] ++ (EncUInt64 <$> allocedDirAddrs) ++ (EncUInt64 <$> (replicate (int.nat (maxDirect - length allocedDirAddrs)) (U64 0)))
                                     ++ (EncUInt64 <$> allocedIndAddrs) ++ (EncUInt64 <$> (replicate (int.nat (maxIndirect - length allocedIndAddrs)) (U64 0)))
                                     ++ [EncUInt64 numInd])⌝ ∗
    "direct" ∷ l ↦[Inode :: "direct"] (slice_val direct_s) ∗
    "indirect" ∷ l ↦[Inode :: "indirect"] (slice_val indirect_s) ∗
    "size" ∷ l ↦[Inode :: "size"] #sz ∗
    "Hdirect" ∷ is_slice direct_s uint64T 1 allocedDirAddrs ∗
    "Hindirect" ∷ is_slice indirect_s uint64T 1 allocedIndAddrs
  }}}.
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 "Hdirect") as %HDirlen.
  iDestruct (is_slice_sz with "Hindirect") as %HIndlen.
  autorewrite with len in HDirlen.
  autorewrite with len in HIndlen.
  destruct Hbound as [HallocedDirAddrsLen [HallocedIndAddrsLen [Hszmax HnumInd]]].

  wp_apply (wp_Enc__PutInt with "Henc").
  { word. }
  iIntros "Henc".
  rewrite app_nil_l.
  wp_loadField.

  iDestruct (is_slice_split with "Hdirect") as "[Hdirect Hcap]".
  wp_apply (wp_Enc__PutInts with "[$Henc $Hdirect]").
  {
    rewrite /maxDirect in HallocedDirAddrsLen.
    word.
  }

  iIntros "[Henc Hdirect]".
  wp_loadField.
  wp_apply wp_slice_len; wp_pures.

  wp_apply (wp_padInts enc (U64 (500 - int.Z (direct_s.(Slice.sz))))
                       ([EncUInt64 sz] ++ (EncUInt64 <$> allocedDirAddrs))
                       (int.Z 4096 - 8 - 8 * length allocedDirAddrs) with "[Henc]").
  {
    iSplitR "Henc"; auto.
    iPureIntro.
    split.
    - rewrite HDirlen /maxDirect in HallocedDirAddrsLen. word.
    - rewrite HDirlen. rewrite HDirlen /maxDirect in HallocedDirAddrsLen.
      word.
  }

  iIntros "Henc".
  replace  (int.Z (U64 4096) - 8 - 8 * Z.of_nat (length allocedDirAddrs) -
              8 * int.Z (U64 (500 - int.Z direct_s.(Slice.sz))))
    with 88 by word.

  wp_pures.
  wp_loadField.

  iDestruct (is_slice_split with "Hindirect") as "[Hindirect Hcapind]".
  wp_apply (wp_Enc__PutInts with "[$Henc $Hindirect]").
  { rewrite HallocedIndAddrsLen. word. }
  iIntros "[Henc Hindirect]".
  wp_loadField.
  wp_apply wp_slice_len; wp_pures.

  wp_apply (wp_padInts enc (U64 (10 - int.Z (indirect_s.(Slice.sz))))
               ((([EncUInt64 sz] ++ (EncUInt64 <$> allocedDirAddrs) ++
               (EncUInt64 <$> replicate (int.nat (500 - int.Z direct_s.(Slice.sz))) (U64 0))) ++
               (EncUInt64 <$> allocedIndAddrs)))
               (88 - 8 * length allocedIndAddrs) with "[Henc]").
  {
    iSplitR "Henc"; auto.
    iPureIntro.
    split; rewrite HIndlen /maxIndirect in HallocedIndAddrsLen HnumInd; word.
  }
  iIntros "Henc".
  rewrite /maxIndirect in HnumInd.
  replace (int.Z (88 - 8 * length allocedIndAddrs) -
           8 * int.nat (10 - int.Z indirect_s.(Slice.sz))) with 8 by word.

  wp_pures.
  wp_loadField.
  wp_apply wp_slice_len; wp_pures.
  wp_apply (wp_Enc__PutInt with "Henc").
  { word. }
  iIntros "Henc".
  wp_pures.

  wp_apply (wp_Enc__Finish with "Henc").
  iIntros (s b) "[%Hencoded Hs]".
  wp_pures.
  iApply "HΦ".
  iFrame.
  iPureIntro.
  eapply block_encodes_eq; eauto.
  rewrite -!app_assoc.
  repeat (f_equal; try word).
Qed.
End goose.

(* to preserve backwards-compatibility *)
Ltac Zify.zify_post_hook ::= idtac.


(** * PHOAS interpretation function for any retract of [var:=interp_base_type] *)
Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.ExprInversion.
Require Import Crypto.Compilers.SmartMap.

Section language.
  Context {base_type_code : Type}
          {op : flat_type base_type_code -> flat_type base_type_code -> Type}
          {interp_base_type : base_type_code -> Type}
          (interp_op : forall src dst, op src dst -> interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst)
          {var : base_type_code -> Type}
          (var_of_interp : forall t, interp_base_type t -> var t)
          (interp_of_var : forall t, var t -> interp_base_type t)
          (var_is_retract : forall t x, interp_of_var t (var_of_interp t x) = x).

  Fixpoint interpf_retr {t} (e : @exprf base_type_code op var t)
    : interp_flat_type interp_base_type t
    := match e in exprf _ _ t return interp_flat_type interp_base_type t with
       | TT => tt
       | Var t v => interp_of_var _ v
       | Op t1 tR opc args => interp_op _ _ opc (@interpf_retr _ args)
       | LetIn tx ex tC eC
         => let ev := @interpf_retr _ ex in
            @interpf_retr _ (eC (SmartVarfMap var_of_interp ev))
       | Pair tx ex ty ey => (@interpf_retr _ ex, @interpf_retr _ ey)
       end.

  Definition interp_retr {t} (e : @expr base_type_code op var t)
    : interp_type interp_base_type t
    := fun x => interpf_retr (invert_Abs e (SmartVarfMap var_of_interp x)).
End language.

Global Arguments interp_retr _ _ _ _ _ _ _ _ !_ / _ .


(** This file contains record definitions for
 ** type, function and predicate environments.
 **)
Require Import Expr SepExpr.
Require Import Env.

Set Implicit Arguments.
Set Strict Implicit.

Module Type CoreEnv.
  Parameter core : Repr type.
  Parameter pc : tvar.
  Parameter st : tvar.
End CoreEnv.

Module Type Package (ST : SepTheory.SepTheory) (SEP : SepExpr ST).
  Declare Module CE : CoreEnv.

  Record TypeEnv : Type :=
  { Types : Repr type
  ; Funcs : forall ts, Repr (signature (repr CE.core (repr Types ts)))
  ; Preds : forall ts,
    Repr (SEP.predicate (repr CE.core (repr Types ts)))
  }.

  Section Apps.
    Variable TE : TypeEnv.

    Definition applyTypes (ls : list type) : list type :=
      repr CE.core (repr (Types TE) ls).
    Definition applyFuncs ts (ls : functions (applyTypes ts)) : functions (applyTypes ts) :=
      repr (Funcs TE ts) ls.
    Definition applyPreds ts (ls : SEP.predicates (applyTypes ts)) : SEP.predicates (applyTypes ts) :=
      repr (Preds TE ts) ls.
  End Apps.

  (** These are reducible by [simpl] **)
  Definition applyTypes_red TE (ls : list type) : list type :=
    match TE with
      | {| Types := ts |} =>
        repr CE.core (repr ts ls)
    end.
  Definition applyFuncs_red TE ts : functions (applyTypes TE ts) -> functions (applyTypes TE ts) :=
    match TE with
      | {| Types := ts' ; Funcs := fs |} => fun ls =>
        repr (fs ts) ls
    end.
  Definition applyPreds_red TE ts : SEP.predicates (applyTypes TE ts) -> SEP.predicates (applyTypes TE ts) :=
    match TE with
      | {| Types := ts' ; Preds := ps |} => fun ls =>
        repr (ps ts) ls
    end.

  Ltac glue_env l r ret :=
    let res := constr:(
      let types := Env.repr_combine (Types l) (Types r) in
      {| Types := types
       ; Funcs := fun ts => Env.repr_combine (Funcs l (Env.repr types ts)) (Funcs r (Env.repr types ts))
       ; Preds := fun ts => Env.repr_combine (Preds l (Env.repr types ts)) (Preds r (Env.repr types ts))
       |})
    in
    ret res.

End Package.

Module Type AlgoTypes (ST : SepTheory.SepTheory) (SEP : SepExpr ST) (CE : CoreEnv).
  Parameter AlgoImpl  : list type -> Type.
  Parameter AlgoProof : forall ts : list type,
    functions (repr CE.core ts) ->
    SEP.predicates (repr CE.core ts) ->
    AlgoImpl ts -> Type.
End AlgoTypes.

Module Make (ST : SepTheory.SepTheory) (SEP : SepExpr ST) (CE' : CoreEnv)
  <: Package ST SEP with Module CE := CE'.
  Module CE := CE'.

  Section TypeEnv.
    Record TypeEnv : Type :=
    { Types : Repr type
    ; Funcs : forall ts, Repr (signature (repr CE.core (repr Types ts)))
    ; Preds : forall ts, Repr (SEP.predicate (repr CE.core (repr Types ts)))
    }.

    Variable TE : TypeEnv.

    Definition applyTypes (ls : list type) : list type :=
      repr CE.core (repr (Types TE) ls).
    Definition applyFuncs ts (ls : functions (applyTypes ts)) : functions (applyTypes ts) :=
      repr (Funcs TE ts) ls.
    Definition applyPreds ts (ls : SEP.predicates (applyTypes ts)) : SEP.predicates (applyTypes ts) :=
      repr (Preds TE ts) ls.

  End TypeEnv.

  Definition applyTypes_red TE (ls : list type) : list type :=
    match TE with
      | {| Types := ts |} =>
        repr CE.core (repr ts ls)
    end.
  Definition applyFuncs_red TE ts : functions (applyTypes TE ts) -> functions (applyTypes TE ts) :=
    match TE with
      | {| Types := ts' ; Funcs := fs |} => fun ls =>
        repr (fs ts) ls
    end.
  Definition applyPreds_red TE ts : SEP.predicates (applyTypes TE ts) -> SEP.predicates (applyTypes TE ts) :=
    match TE with
      | {| Types := ts' ; Preds := ps |} => fun ls =>
        repr (ps ts) ls
    end.

End Make.

Module AlgoPack (ST : SepTheory.SepTheory) (SEP : SepExpr ST) (P : Package ST SEP) (A : AlgoTypes ST SEP P.CE).

  Record TypedPackage : Type :=
  { Env   : P.TypeEnv
  ; Algos : forall ts, A.AlgoImpl ts
  ; Algos_correct : forall ts (fs : functions (P.applyTypes Env ts)) ps,
    @A.AlgoProof (repr (P.Types Env) ts) (P.applyFuncs Env ts fs) (P.applyPreds Env ts ps) (Algos _)
  }.

  (** given to [TypedPackage]s, combines them and passes the combined [TypedPackage]
   ** to [k].
   ** This tactic will fail if any of the environments are not compatible.
   **)
  Ltac glue_pack composite composite_correct l r ret :=
    P.glue_env (Env l) (Env r) ltac:(fun nenv' =>
      let res := constr:(
        let nenv := nenv' in
        let types := P.Types nenv in
        {| Env   := nenv
         ; Algos := fun ts => composite (Algos l (P.applyTypes nenv ts)) (Algos r (Env.repr types ts))
         ; Algos_correct := fun ts fs ps =>
           composite_correct
             (Algos_correct l (P.applyTypes nenv ts) (P.applyFuncs nenv fs) (P.applyPreds nenv ps))
             (Algos_correct r (P.applyTypes nenv ts) (P.applyFuncs nenv fs) (P.applyPreds nenv ps))
         |})
      in
      ret res).
(*
(**
      let algosL := constr:(fun ts => Algos l (applyTypes nenvEnv.repr ntypesV ts)) in
      let algosR := constr:(fun ts => Algos r (Env.repr ntypesV ts)) in
      let algosCL :=
        constr:(fun ts fs ps =>
          Algos_correct l (Env.repr ntypesV ts)
          (Env.repr (nfuncsV ts) fs)
          (Env.repr (npredsV ts) ps)) in
      let algosCR :=
        constr:(fun ts fs ps =>
          Algos_correct r (Env.repr ntypesV ts)
          (Env.repr (nfuncsV ts) fs)
          (Env.repr (npredsV ts) ps)) in
      let pf := constr:(fun ts fs ps => AllAlgos_correct_composite (algosCL ts fs ps) (algosCR ts fs ps)) in
      opaque pf ltac:(fun pf =>
      let res :=
        constr:{|
          Types := ntypesV;
          Funcs := nfuncsV;
          Preds := npredsV;
          Algos := fun ts => AllAlgos_composite (algosL ts) (algosR ts);
          Algos_correct := pf
        |} in
        ret res)).
**)

  Ltac refine_glue_pack l r :=
    let reduce_repr e := e in
    let opaque v k := k v in
    match eval hnf in l with
      | @Build_TypedPackage ?CT ?PC ?ST ?SAT ?READ ?WRITE ?tl ?fl ?pl ?al ?acl =>
        match eval hnf in r with
        | @Build_TypedPackage _ _ _ _ _ _ ?tr ?fr ?pr ?ar ?acr =>
          refine (
              let types := repr_combine tl tr in
              let funcs := fun ts => repr_combine (fl (repr types ts)) (fr (repr types ts)) in
              let preds := fun ts => repr_combine (pl (repr types ts)) (pr (repr types ts)) in
              @Build_TypedPackage CT PC ST SAT READ WRITE
                types funcs preds
                (fun ts => AllAlgos_composite (al (repr types ts)) (ar (repr types ts)))
                _
               );
          (subst; abstract exact (fun ts fs ps => AllAlgos_correct_composite
                  (acl (repr (repr_combine tl tr) ts)
                       (repr (repr_combine (fl (repr (repr_combine tl tr) ts)) (fr (repr (repr_combine tl tr) ts))) fs)
                       (repr (repr_combine (pl (repr (repr_combine tl tr) ts)) (pr (repr (repr_combine tl tr) ts))) ps))
                  (acr (repr (repr_combine tl tr) ts)
                       (repr (repr_combine (fl (repr (repr_combine tl tr) ts)) (fr (repr (repr_combine tl tr) ts))) fs)
                       (repr (repr_combine (pl (repr (repr_combine tl tr) ts)) (pr (repr (repr_combine tl tr) ts))) ps))))
      end
  end.

(*
Ltac hlist_from_tuple tpl acc :=
  match tpl with
    | tt => acc
    | (?L, ?R) =>
      let acc := hlist_from_tuple R acc in
      hlist_from_tuple L acc
    | _ => constr:(@HCons _ _ _ _ tpl acc)
  end.
*)

(** given a tuple or list of [TypedPackage]s, this tactic combines them all and calls [k] with
 ** the result.
 **)
Ltac glue_packs packs k :=
  match type of packs with
    | TypedPackage _ _ _ _ _ _ => k packs
    | _ =>
      match packs with
        | tt => k BedrockPackage.bedrock_package
        | nil => k BedrockPackage.bedrock_package
        | ?L :: ?R =>
          glue_packs R ltac:(fun R => glue_pack L)
        | (?L, ?R) =>
          glue_packs L ltac:(fun L =>
          glue_packs R ltac:(fun R =>
            glue_pack L R k))
      end
  end.

(** TODO: is there a way to make this more efficient? **)
Ltac opaque_pack pack :=
  match eval hnf in pack with
    | @Build_TypedPackage ?CT ?PC ?ST ?SAT ?READ ?WRITE ?tl ?fl ?pl ?al ?acl =>
      refine ({|
        Types := tl ;
        Funcs := fl ;
        Preds := pl ;
        Algos := al ;
        Algos_correct := _
      |});
      abstract (exact acl)
  end.
*)

End AlgoPack.


From CoqMTL Require Import Control.

(** This module contains proofs that various definitions of monads are
    equivalent. More precisely, we prove that these definitions are
    equivalent in the sense of the ability to construct  an instance of
    each of them from the other:
    - the main definition used throughout the library (from Control.Monad),
      which says that a monad is an [Applicative] functor with [bind],
      satisfying the laws [bind_pure_l], [bind_pure_r], [bind_assoc] and
      [bind_ap], which relates the [Applicative] and [Monad] structure

    - the join-based definition (from Theory.Equivs.MonadJoin), which says
      that a monad is an [Applicative] functor with [join] that satisfies
      the laws [join_fmap_join], [join_pure], [join_fmap_pure],
      [join_fmap_fmap] and [join_ap]
    - the Kleisli Triple definition, which is very similar to that of
      Theory.Equivs.MonadBind, but has different operation names and
      some arguments flipped

    As of now, I can't prove that these are equivalent to the compM-based
    definition (from Theory.Equivs.MonadComp), which says that a monad is
    something that has monadic composition which is associative and has
    a neutral element. *)

(** First we require all the necessary modules and repack them so as to
    refer to them by nonconflicting names. *)

From CoqMTL Require MonadJoin.
From CoqMTL Require MonadBind.
From CoqMTL Require MonadComp.

Module Join.
Include MonadJoin.
End Join.

Module Bind.
Include MonadBind.
End Bind.

Module Comp.
Include MonadComp.
End Comp.

(** Each proof consists of two instances, one deriving [Monad] from the
    definition at hand and the other one deriving an instance for that
    definition from [Monad]. *)

(** * join-based definition *)

#[refine]
#[export]
Instance Join_to_Monad
  (M : Type -> Type) (inst : Join.Monad M) : Monad M :=
{
  is_applicative := @Join.is_applicative M inst;
  bind := @Join.bind M inst
}.
Proof.
  1, 2, 4: MonadJoin.mjoin.
  apply Join.assoc.
Defined.

#[refine]
#[export]
Instance Monad_to_Join (M : Type -> Type) (inst : Monad M)
  : Join.Monad M :=
{
  is_applicative := @is_applicative M inst;
  join := @join M inst
}.
Proof.
  all: intros; unfold join, compose; try ext x.
    rewrite bind_assoc, bind_fmap. unfold compose, id. reflexivity.
    rewrite bind_pure_l. reflexivity.
    rewrite bind_fmap, <- bind_pure_r. f_equal.
    rewrite bind_fmap, fmap_bind. f_equal.
    rewrite !bind_ap. monad.
Defined.

(** * bind-based definition *)

#[refine]
#[export]
Instance MonadBind_to_Monad
  (M : Type -> Type) (inst : Bind.Monad M) : Monad M :=
{
  is_applicative := @MonadBind.Applicative_MonadBind M inst;
  bind := @MonadBind.bind M inst;
}.
Proof. all: MonadBind.mbind. Defined.

#[refine]
#[export]
Instance Monad_to_MonadBind
  (M : Type -> Type) (inst : Monad M) : MonadBind.Monad M :=
{
  pure := @pure M inst;
  bind := @bind M inst;
}.
Proof. all: monad. Defined.

(** * Kleisli triple *)

From CoqMTL Require Import KleisliTriple.

#[refine]
#[export]
Instance Monad_to_KleisliTriple
  (M : Type -> Type) (inst : Monad M) : KleisliTriple M :=
{
  eta := @pure M inst;
  star := fun A B => flip (@bind M inst A B);
}.
Proof.
  all: unfold flip; monad.
Defined.

#[refine]
#[export]
Instance KleisliTriple_to_Monad
  (M : Type -> Type) (inst : KleisliTriple M) : Monad M :=
{
  is_applicative := Applicative_Kleisli M inst;
  bind := @bind_Kleisli M inst;
}.
Proof. all: kleisli. Defined.

(** * compM-based definition *)

#[refine]
#[export]
Instance Monad_to_MonadComp
  (M : Type -> Type) (inst : Monad M) : MonadComp.Monad M :=
{
  is_applicative := is_applicative;
  compM := @compM M inst;
}.
Proof. all: unfold compM; monad. Defined.

(** TODO: MonadComp_to_Monad *)


From aneris.aneris_lang Require Import lang resources.
From stdpp Require Import gmap.
From aneris.prelude Require Import misc.
From aneris.examples.ccddb.spec Require Import base.
From aneris.examples.ccddb.model Require Import model_update_prelude model_lst
     model_gst model_update_lhst model_update_lst.

Section Gst_update.
  Context `{!anerisG Mdl Σ, !DB_params}.

   (** Global and local state coherence *)

  Lemma DBM_gs_ls_coh (i: nat) (gs : Gst) (ls : Lst) :
    i < length DB_addresses →
    DBM_Gst_valid gs →
    DBM_Lst_valid i ls →
    gs.(Gst_hst) !! i = Some ls.(Lst_hst) →
    dom ls.(Lst_mem) ⊆ dom gs.(Gst_mem) ∧
    ∀ k v, k ∈ DB_keys → ls.(Lst_mem) !! k = Some v →
           ∃ a h, gs.(Gst_mem) !! k = Some h ∧ a ∈ h ∧ a.(we_val) = v.
  Proof.
    intros.
    split.
    {  erewrite DBM_GstValid_dom; last done; by eapply DBM_LSTV_dom_keys. }
    intros k v Hk Hkv.
    eapply DBM_LSTV_vals_Some in Hkv as [Hv1 Hkv2]; eauto.
    set (Observe_lhst (restrict_key k (Lst_hst ls))) as e in *.
    apply compute_maximals_correct in Hkv2 as ([He Hem2]%elem_of_filter & Hem').
    eapply DBM_GV_hst_in_mem in Hem2 as (h & Hh & Heh);
      eauto using elem_of_list_lookup_2.
    simplify_eq/=.
    eexists (erase e), h; split_and!;
      [by rewrite -He|done|by rewrite -erase_val].
  Qed.

Lemma DBM_mem_dom_update {A: Type} k (v : A) (d: gmap Key A) :
    k ∈ DB_keys →
    dom d = DB_keys →
    dom (<[k:=v]> d) = DB_keys.
  Proof. by set_solver. Qed.

  Lemma DBM_gs_hst_valid_update gs i s m:
    DBM_Gst_valid gs →
    DBM_lhst_valid i s →
    DBM_gs_hst_valid
      {| Gst_mem := m; Gst_hst := <[i:=s]> (Gst_hst gs) |}.
  Proof.
    intros Hgv Hsv j sj Hgs; simpl.
    destruct (decide (j = i)) as [-> | ].
    - rewrite list_lookup_insert in Hgs.
      + by simplify_eq.
      + pose proof (DBM_GV_hst_size Hgv).
        epose proof DBM_LHV_bound_at.
        erewrite (DBM_GV_hst_size Hgv); eauto.
    - rewrite list_lookup_insert_ne in Hgs; last done.
      eapply DBM_GV_hst_lst_valid; eauto.
  Qed.

Lemma DBM_gs_hst_size_update gs i s m:
    DBM_Gst_valid gs →
    DBM_gs_hst_size
      {| Gst_mem := m; Gst_hst := <[i:=s]> (Gst_hst gs) |}.
  Proof.
    intros Hgv. rewrite /DBM_gs_hst_size //=.
    rewrite insert_length.
    by eapply DBM_GV_hst_size.
  Qed.

  Lemma DBM_system_write_update_gst
        (k : Key) (v : val) (i : nat) (gs : Gst) (ls : Lst) mk :
    k ∈ DB_keys →
    DBM_Lst_valid i ls →
    DBM_Gst_valid gs →
    gs.(Gst_hst) !! i = Some ls.(Lst_hst) →
    gs.(Gst_mem) !! k = Some mk →
    let t := incr_time ls.(Lst_time) i  in
    let e := ApplyEvent k v t i (S (size ls.(Lst_hst))) in
    let s := ls.(Lst_hst) ∪ {[ e ]} in
    let m := (<[ k := mk ∪ {[erase e]} ]> gs.(Gst_mem)) in
    let Ss := <[i := s]> gs.(Gst_hst) in
    DBM_Gst_valid (GST m Ss).
   Proof.
    intros Hk Hvl Hvg Hgs Hgm t e s m Ss.
    pose proof (DBM_LSTV_at Hvl) as Hi.
    pose proof DBM_LSTV_hst_valid Hvl as Hvlh.
    assert (update_condition i e (Lst_time ls)) as Hcond.
    eapply update_condition_write; eauto.
    pose proof Hcond as
            (Hi' & Htlen & Hetlen & Hkey & Heorig & Het & Het' & Het'').
    split.
    - by eapply DBM_mem_dom_update; eauto; eapply DBM_GV_dom.
    - eapply DBM_gs_hst_size_update; eauto.
    - eapply DBM_gs_hst_valid_update; eauto.
      rewrite /DBM_lst_hst_valid in Hvlh.
      eapply DBM_lhst_update.
      + eauto.
      + eauto.
      + eauto.
      + eauto using DBM_Lst_valid_time_le; eauto.
      + rewrite (DBM_LSTV_time Hvl (ae_orig e) Heorig).
        symmetry.
        pose proof (lsec_lsup_length (ae_orig e)); eauto.
      + intros ? j0 Hj0.
        rewrite (DBM_LSTV_time Hvl j0 Hj0).
        symmetry.
        pose proof (lsec_lsup_length (ae_orig e)); eauto.
      + intros j0 Hj0.
        rewrite (DBM_LSTV_time Hvl j0 Hj0).
        pose proof (lsec_lsup_length
                      i j0 (Lst_hst ls) Hvlh Hj0)
          as Hll. rewrite Hll.
        eauto with lia.
    - intros s1 Hs1 e1 He1. simpl in Hs1.
      subst Ss. apply elem_of_list_lookup in Hs1 as (j & Hs1).
      destruct (decide (i = j)) as [<-|Hneqij].
      + rewrite list_lookup_insert in Hs1. inversion Hs1. subst s1.
        clear Hs1. apply elem_of_union in He1 as [He1|?%elem_of_singleton_1].
        * destruct (λ H, DBM_GV_hst_in_mem Hvg (Lst_hst ls) H e1)
            as (h' & Hh' & He''h'); eauto using elem_of_list_lookup_2.
          destruct (decide (k = ae_key e1)) as [->|Hneq].
          ** subst m; setoid_rewrite lookup_insert.
             exists (mk ∪ {[erase e]}); split; first done.
             rewrite Hgm // in Hh'. set_solver.
          ** subst m; setoid_rewrite lookup_insert_ne; last done.
             eexists; eauto.
        * simpl. subst e1 m.
          assert (k = ae_key e) as <- by eauto.
          setoid_rewrite lookup_insert.
          exists (mk ∪ {[erase e]}); split; first done.
          set_solver.
        * rewrite (DBM_GV_hst_size Hvg) //.
      + rewrite list_lookup_insert_ne in Hs1.
        destruct (λ H, DBM_GV_hst_in_mem Hvg s1 H e1)
          as (h' & Hh' & He''h'); eauto using elem_of_list_lookup_2.
        destruct (decide (k = ae_key e1)) as [->|Hneq]; simpl.
        * subst m.
          setoid_rewrite lookup_insert.
          rewrite Hh' in Hgm.
          eexists _. split_and!; eauto with set_solver.
        * exists h'; split_and!; eauto.
          by rewrite lookup_insert_ne; last done.
        * done.
    - intros a h Hm Hah.
      subst m Ss s. simpl in Hm. simpl.
      destruct (decide ((we_key a) = k)) as [ <- | Hneq0 ].
      + rewrite lookup_insert in Hm.
        simplify_eq.
        apply elem_of_union in Hah as[ Hamk| Ha1%elem_of_singleton_1].
        * destruct (DBM_GV_mem_in_hst Hvg a mk Hgm Hamk)
            as (sa & saa & ea & Hsa & Hsaa & Hea & Hear).
          destruct (decide (i = we_orig a)) as [Heq|Hneq].
          ** eexists (Lst_hst ls ∪ {[e]}), (saa ∪ {[e]}), ea.
             split_and!.
             *** subst; rewrite list_lookup_insert; first done.
                 rewrite (DBM_GV_hst_size Hvg) //.
             *** subst; rewrite //. set_solver.
             *** set_solver.
             *** done.
          ** eexists _, _, _.
             split_and!; eauto.
             by rewrite list_lookup_insert_ne.
        * eexists _, _, e.
          split_and!; eauto.
          ** rewrite Ha1. rewrite list_lookup_insert //=.
             rewrite (DBM_GV_hst_size Hvg) //.
          ** rewrite DBM_lsec_union DBM_lsec_singleton_in.
             *** set_solver.
             *** by rewrite Ha1.
      + rewrite lookup_insert_ne //= in Hm.
        destruct (decide (i = we_orig a)) as [Heq|Hneq].
       * assert
         (∃ (s0 si : gset apply_event) (e0 : apply_event),
             Gst_hst gs !! we_orig a =
             Some s0 ∧ DBM_lsec (we_orig a) s0 = si
             ∧ e0 ∈ si ∧ erase e0 = a)
           as (s0 & si & e0 & Hs0 & Hs1 & Hs2 & Hs3)
             by by eapply DBM_GV_mem_in_hst.
         rewrite -!Heq. rewrite -!Heq in Hs0 Hs1.
         rewrite list_lookup_insert.
         ** do 3 eexists. repeat split; eauto.
           rewrite /s0. set_solver.
         ** eapply lookup_lt_is_Some_1; eauto.
       * rewrite //=.
         simpl in Hm.
         rewrite list_lookup_insert_ne; eauto.
         eapply DBM_GV_mem_in_hst; eauto.
    - intros k1 h1 a1 Hh1 Ha1.
      rewrite /m //= in Hh1.
      destruct (decide (k1 = k)) as [-> | ].
      + rewrite lookup_insert //= in Hh1.
        simplify_eq.
        apply elem_of_union in Ha1 as [| ?%elem_of_singleton_1];
          [|set_solver].
        eapply DBM_GV_mem_elements_key; eauto.
      + rewrite lookup_insert_ne //= in Hh1.
        eapply DBM_GV_mem_elements_key; eauto.
   Qed.

   Lemma DBM_system_apply_update_gst
        (i : nat) (gs : Gst) (ls : Lst)
        (a : write_event) (h: gset write_event) :
    DBM_Gst_valid gs →
    DBM_Lst_valid i ls →
    gs.(Gst_hst) !! i = Some ls.(Lst_hst) →
    gs.(Gst_mem) !! a.(we_key) = Some h →
    a ∈ h →
    a.(we_orig) ≠ i →
    let t := incr_time ls.(Lst_time) a.(we_orig) in
    let e := ApplyEvent (we_key a) (we_val a) (we_time a) (we_orig a)
                        (S (size ls.(Lst_hst))) in
    let s := ls.(Lst_hst) ∪ {[ e ]} in
    let d := (<[ a.(we_key) := a.(we_val) ]> ls.(Lst_mem)) in
    let Ss := (<[i := s]> gs.(Gst_hst)) in
    update_condition i e ls.(Lst_time) →
    DBM_Gst_valid (GST gs.(Gst_mem) Ss).
   Proof.
     intros Hvg Hvl Hgsi ?????????.
     split.
     - apply (DBM_GV_dom Hvg); eauto.
     - eapply DBM_gs_hst_size_update; eauto.
     - eapply DBM_gs_hst_valid_update; eauto.
       assert (DBM_Lst_valid i {|Lst_mem := d; Lst_time := t; Lst_hst := s|})
         as Hvlst.
       { apply (DBM_lst_update e i ls Hvl); eauto. }
       eapply (DBM_LSTV_hst_valid Hvlst).
     - intros s1 Hs1 e1 He1. simpl in Hs1.
       subst Ss. apply elem_of_list_lookup in Hs1 as (j & Hs1).
      destruct (decide (i = j)) as [<-|Hneqij].
      + rewrite list_lookup_insert in Hs1. inversion Hs1. subst s1.
        clear Hs1. apply elem_of_union in He1 as [He1|?%elem_of_singleton_1].
        * destruct (λ H, DBM_GV_hst_in_mem Hvg (Lst_hst ls) H e1)
            as (h' & Hh' & He''h'); eauto using elem_of_list_lookup_2.
        * simpl. subst e1.
          assert (a = erase e) as <- by by destruct a.
          eauto.
        * rewrite (DBM_GV_hst_size Hvg)  //.
          by eapply DBM_LSTV_at.
      + rewrite list_lookup_insert_ne in Hs1.
        destruct (λ H, DBM_GV_hst_in_mem Hvg s1 H e1)
          as (h' & Hh' & He''h'); eauto using elem_of_list_lookup_2.
        done.
     - intros a1 h1 Hm Ha1.
       destruct (decide (i = we_orig a1)) as [Heq|Hneq].
       + assert
         (∃ (s0 si : gset apply_event) (e0 : apply_event),
             Gst_hst gs !! we_orig a1 =
             Some s0 ∧ DBM_lsec (we_orig a1) s0 = si
             ∧ e0 ∈ si ∧ erase e0 = a1)
           as (s0 & si & e0 & Hs0 & Hs1 & Hs2 & Hs3)
             by by eapply DBM_GV_mem_in_hst.
         rewrite -!Heq. rewrite -!Heq in Hs0 Hs1.
         rewrite list_lookup_insert.
         * do 3 eexists. repeat split; eauto.
           rewrite /s. set_solver.
         * eapply lookup_lt_is_Some_1; eauto.
       + rewrite /Ss //=.
         simpl in Hm.
         rewrite list_lookup_insert_ne; eauto.
         eapply DBM_GV_mem_in_hst; eauto.
     - rewrite /DBM_gs_gmem_elements_key /=.
       eapply DBM_GV_mem_elements_key; eauto.
   Qed.

End Gst_update.


(**
Creates functorial lemmas that the parametricity translation
behaves like a functor in respect to its parameters

Application: When proving the induction lemma,
one encounters the problem that the parametricity translation argument
listᵗ rose roseᵗ H is given stating that the property roseᵗ holds for all rose
trees in the list. But we want the nested inductive hypothesis
listᵗ rose P H that the property P under consideration in the induction
holds for all trees in the list.
Therefore, we need to translate the proofs of roseᵗ to P.
This is possible for two reasons:
* The inductive proof transforms roseᵗ instances into proofs of P
    (we state that P holds for all roseᵗ)
* Secondly, the parametricity translation of a container simply boundles
    all proofs for the elements in it.
  Therefore, all proofs can be replaced for another property, and thus,
  the parametricity translation of a container behaves like a functor.

Note: The substitution of P for roseᵗ makes it clear why
    the induction does not carry the roseᵗ instances in the predicate
    as such handling for nested types would no longer be possible.
    Additionally, the generates lemma is less cluttered as it is ultimately
    a lemma for rose not roseᵗ.

example:
listᵗ A Aᵗ x
with A:Type, Aᵗ:A->Type, x:list A

the functorial lemma has type:
∀ A (Aᵗ:A->Type) (Aᵗ':A->Type) (F_A: ∀ (a:A), Aᵗ a -> Aᵗ' a)
(x:list A),
listᵗ A Aᵗ x -> listᵗ A Aᵗ' x

Note:
A->Type can be viewed as (Typeᵗ A)

For each pair of parameter and translation another translation as destination
is introduced together with a function stating the translation property for this paramter.
This property will be recursively instantiated in the proofs.
If the parameter has no arguments or does not result in a sort, a dummy value like True
is introduced as each parametricity translated argument contains the same information.

The indices contain no further information needed to be transferred between instances.
They do not possess a functorial nature as they are dictated by inversion.
Therefore, they are carried over.
A special indice is the instance of the original type (list in the example above).
But this instance does not need any special care.

*)
Require Import util.

From MetaCoq.Template Require Import All.

From MetaCoq Require Import All.
Require Import String List.
(* Local Open Scope string. *)
Import ListNotations Nat.
Import MCMonadNotation.

From MetaCoq.PCUIC Require Import
     PCUICAst PCUICAstUtils PCUICInduction
     PCUICLiftSubst PCUICEquality
     PCUICUnivSubst PCUICTyping PCUICGeneration.

From MetaCoq.PCUIC Require Import TemplateToPCUIC.
From MetaCoq.PCUIC Require Import PCUICToTemplate.

Section Functorial.

    Variable
        (inductive:inductive)
        (uinst:Instance.t)
        (mind:mutual_inductive_body)
        (ind:one_inductive_body).

    Definition ind_term := tInd inductive uinst.

    Definition non_uniform_param_count := 0. (* should not matter here *)
    Definition ind_type := ind.(ind_type). (* type of the inductive *)
    Definition ctx_retTy := decompose_prod_assum [] ind_type. (* get params and indices and inner retTy *)
    Definition ctx := ctx_retTy.1.
    Definition retTy := ctx_retTy.2.
        (* for list: ctx=[Type], retTy=Type *)
    Definition indice_ctx := ind_indices ind.
    Definition all_param_ctx := skipn #|indice_ctx| ctx. (* parameters and non-uniform parameter *)
    Definition non_uni_param_ctx := firstn non_uniform_param_count all_param_ctx. (* non-uniform are behind => at the front *)
    Definition param_ctx := skipn #|non_uni_param_ctx| all_param_ctx.

    Definition TrueQ :=
        TemplateToPCUIC.trans [] <% True %>.

    (*
    given an argument Aᵗ generates the functorial property term
    for ∀, copy the binder and remember to apply the arguments
    for Sort, generate Aᵗ args -> Aᵗ' args
    Otherwise generate True
     *)
        (* this is something like parametricity itself *)
    Fixpoint func x y args t :=
        match t with
        | tSort univ =>
            tProd rAnon (mkApps x args) (mkApps (lift0 1 y) (map (lift0 1) args))
        | tProd na a b =>
            tProd na a (
                func (lift0 1 x) (lift0 1 y) (map (lift0 1) args ++ [tRel 0]) b
            )
        | _ => TrueQ
        end.

    Definition app_arg_list num args := map (fun x => x+num) args++mkNums num.

    (* no context but list of params *)
    (*
    for params A, Aᵗ add Aᵗ' and F_A
    takes list of param applications for the original and transformed term
    returns the number of parameter groups, the list of argument applications
    as number for the binder and lastly the list of new arguments (params & indices)
     *)
    Fixpoint augment (params:context) (arg1 arg2:list nat):=
        match params with
        | x::xᵗ::xr =>
            let '((groups,arg1,arg2), aug_args) :=
                augment xr
                    (map (fun x => x+4) arg1++[3;2])
                    (map (fun x => x+4) arg2++[3;1]) in
                ((S groups, arg1,arg2),
                    x::xᵗ::
                    (map_decl (lift0 1) xᵗ)::
                    (vass rAnon (func (tRel 1) (tRel 0) [] (lift0 2 xᵗ.(decl_type))))::
                    (mapi (fun i a => map_decl (lift 2 i) a) aug_args))
        | _ =>
        let indices := rev (indice_ctx) in
        ((0,
            app_arg_list (#|params|+#|indices|) arg1,
            app_arg_list (#|params|+#|indices|) arg2),params++indices)
        end.

        (* computes number of param groups and type of the functorial property *)
    Definition type_ :=
        let '((groups,arg1,arg2),aug_args) := augment (rev param_ctx) [] [] in
        let aug_args_ctx := rev (aug_args) in
        (groups,
        it_mkProd_or_LetIn
            aug_args_ctx
        (tProd rAnon
        (mkApps ind_term (map tRel arg1))
        (lift0 1 (mkApps ind_term (map tRel arg2)))
        ))
        .

    Definition functorial_type_groups :=
        on_snd PCUICToTemplate.trans type_.

    Definition type := snd type_.

    Definition functorial_type :=
    PCUICToTemplate.trans type.

    (*
    Generation of the functorial property
    currently, the properties are only realized
    using obligations
     *)
    (* Definition functorial :=
    tCast
    (PCUICToTemplate.trans
        placeholder
        (* (it_mkLambda_or_LetIn
        lemma_argument_ctx
        ) *)
    )
    Cast
    (PCUICToTemplate.trans type). *)

End Functorial.

Ltac ind_on_last :=
  lazymatch goal with
  | |- forall x y, ?H => intros ?;ind_on_last
  | |- forall y, ?H =>
      let inst := fresh "x" in
      intros inst;induction inst (* using database *)
  | _ => fail "not applicable"
  end.
Global Obligation Tactic := cbn;ind_on_last;econstructor;auto.


(* Do not edit this file, it was generated automatically *)
Require Import VST.floyd.proofauto.
Require Import VST.progs64.message.

#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(* This program, and its verification, are described in Chapter 29
   of _Program Logics for Certified Compilers_, by Appel et al., 2014 *)

Local Open Scope Z.
Local Open Scope logic.

(*   mf_assert msgfmt sh buf len data  := the [data] is formatted into a message
         at most [len] bytes,  stored starting at address [buf] with share [sh] *)

Record message_format (t: type) : Type :=
mf_build {
   mf_size: Z;
   mf_data_assert: forall (data: reptype t), Prop;
   mf_assert: forall (sh: share) (buf: val) (len: Z) (data: reptype t), mpred;
   mf_size_range:  0 <= mf_size <= Int.max_signed;
   mf_bufprop: forall sh buf len data,
           mf_assert sh buf len data |--
                 !!(0 <= len <= mf_size) && memory_block sh len buf;
   mf_restbuf := fun (sh: share) (buf: val) (len: Z) =>
          memory_block sh (mf_size-len) (offset_val len buf)
}.

Arguments mf_build {t}.
Arguments mf_size {t}.
Arguments mf_data_assert {t}.
Arguments mf_assert {t}.
Arguments mf_bufprop {t}.
Arguments mf_size_range {t}.
Arguments mf_restbuf {t}.

Lemma mf_assert_local_facts: forall t (mf: message_format t) sh buf len (data: reptype t),
   mf_assert mf sh buf len data |--
    !! (0 <= len <= mf_size mf /\ isptr buf).
Proof.
intros.
eapply derives_trans;[ apply mf_bufprop | ].
entailer!.
Qed.

#[export] Hint Resolve mf_assert_local_facts : saturate_local.

Definition t_struct_intpair := Tstruct _intpair noattr.
Definition t_struct_message := Tstruct _message noattr.

Program Definition intpair_message: message_format t_struct_intpair :=
  mf_build 8 (fun data => is_int I32 Signed (fst data) /\ is_int I32 Signed (snd data))
             (fun sh buf len data => !!(len=8/\ is_int I32 Signed (fst data) /\ is_int I32 Signed (snd data))
                           && data_at sh (tarray tint 2) [fst data; snd data] buf)
      _ _.
Next Obligation.
compute; split; congruence.
Qed.
Next Obligation.
  entailer!!.
  change 8 with (sizeof (tarray tint 2)).
  apply data_at_memory_block.
Qed.

Definition serialize_spec {t: type} (format: message_format t) :=
  WITH data: reptype t, p: val, buf: val, sh: share, sh': share
  PRE [ tptr tvoid, tptr tuchar ]
          PROP (readable_share sh; writable_share sh';
                mf_data_assert format data;
                align_compatible tint buf)
          PARAMS (p; buf)
          SEP (data_at sh t data p;
                 memory_block sh' (mf_size format) buf)
  POST [ tint ]
         EX len: Z,
          PROP() RETURN (Vint (Int.repr len))
          SEP( data_at sh t data p;
                 mf_assert format sh' buf len data;
                 mf_restbuf format sh' buf len).

Definition deserialize_spec {t: type} (format: message_format t) :=
  WITH data: reptype t, p: val, buf: val, sh: share, sh': share, len: Z
  PRE [ tptr tvoid, tptr tuchar, tint ]
          PROP (readable_share sh'; writable_share sh;
                0 <= len <= mf_size format)
          PARAMS (p; buf; Vint (Int.repr len))
          SEP (mf_assert format sh' buf len data;
                 data_at_ sh t p)
  POST [ tvoid ]
          PROP (mf_data_assert format data)  RETURN ()
          SEP (mf_assert format sh' buf len data;
                 data_at sh t data p).

Definition intpair_serialize_spec :=
 DECLARE _intpair_serialize (serialize_spec intpair_message).

Definition intpair_deserialize_spec :=
 DECLARE _intpair_deserialize (deserialize_spec intpair_message).

Definition main_spec :=
 DECLARE _main
  WITH gv: globals
  PRE  [] main_pre prog tt gv
  POST [ tint ] main_post prog gv.

Definition message (sh: share) {t: type} (format: message_format t) (m: val) : mpred :=
  EX fg: val*val,
          func_ptr' (serialize_spec format) (fst fg) *
          func_ptr' (deserialize_spec format) (snd fg) *
       data_at sh t_struct_message (Vint (Int.repr (mf_size format)), (fst fg, snd fg)) m.

Definition Gprog : funspecs :=   ltac:(with_library prog [
    intpair_serialize_spec; intpair_deserialize_spec; main_spec]).

Lemma body_intpair_serialize: semax_body Vprog Gprog f_intpair_serialize intpair_serialize_spec.
Proof.
unfold intpair_serialize_spec.
unfold serialize_spec.
start_function.
destruct H as [Dx Dy].
destruct data as [[|x1 | | | | ] [|y1 | | | | ]]; try contradiction. clear Dx Dy.

change (mf_size intpair_message) with (sizeof (tarray tint 2)).
assert_PROP (field_compatible (tarray tint 2) [] buf).
  entailer!.
  hnf in H; decompose[and] H; repeat split; auto.
  (* TODO: abstract the following proof. *)
  unfold align_compatible in H0 |- *.
  destruct buf; auto.
  constructor.
  intros.
  eapply align_compatible_rec_by_value_inv in H0; [| reflexivity].
  econstructor; [reflexivity |].
  apply Z.divide_add_r; auto.
  exists i0; rewrite Z.mul_comm; auto.
rewrite memory_block_data_at_; auto.
change (data_at_ sh' (tarray tint 2) buf) with
   (data_at sh' (tarray tint 2) [Vundef;Vundef] buf).
forward. (* x = p->x; *)
forward. (* y = p->y; *)
forward. (*  ((int * )buf)[0]=x; *)
forward. (*  ((int * )buf)[1]=y; *)
forward. (* return 8; *)
Exists 8.
unfold mf_restbuf. simpl.
rewrite memory_block_zero.
entailer!!.
Qed.

Lemma body_intpair_deserialize: semax_body Vprog Gprog f_intpair_deserialize intpair_deserialize_spec.
Proof.
unfold intpair_deserialize_spec, deserialize_spec.
start_function.
hnf in data; simpl in data. (* This speeds things up dramatically *)
simpl. Intros. subst len.
destruct data as [[|x1 | | | | ] [|y1 | | | | ]]; try contradiction.
clear H H1 H2.
forward. (* x = ((int * )buf)[0]; *)
forward. (* y = ((int * )buf)[1]; *)
forward. (* p->x = x; *)
forward. (* p->y = y; *)
entailer!.
split; simpl; auto.
unfold mf_assert.
simpl.
entailer!!.
Qed.

Lemma body_main: semax_body Vprog Gprog f_main main_spec.
Proof.
function_pointers.
start_function.
set (ipm := gv _intpair_message).
fold cc_default noattr.
make_func_ptr _intpair_deserialize.
make_func_ptr _intpair_serialize.
set (des := gv _intpair_deserialize).
set (ser := gv _intpair_serialize).
match goal with
 |- context [mapsto_zeros 4 Ews _] =>
  (* 64-bit mode *)
  sep_apply mapsto_zeros_memory_block; auto;
  gather_SEP (mapsto _ _ _ (offset_val 0 des))
      (mapsto _ _ _ (offset_val 0 ser))
      (memory_block Ews 4 _)
      (data_at _ _ _ ipm)
 | _ => (*32-bit mode *)
  gather_SEP (mapsto _ _ _ (offset_val 0 des))
      (mapsto _ _ _ (offset_val 0 ser))
      (data_at _ _ _ ipm)
end.
replace_SEP 0
    (data_at Ews t_struct_message
      (Vint (Int.repr (mf_size intpair_message)), (ser, des)) ipm). {
 entailer!.
 unfold_data_at (data_at _ t_struct_message _ ipm).
 rewrite (field_at_data_at _ _ _ _ ipm).
rewrite data_at_tuint_tint.
(* rewrite <- (mapsto_field_at _ _ [StructField _bufsize] (Vint (Int.repr 8))) by auto with field_compatible. *)
 rewrite <- (mapsto_field_at _ _ [StructField _deserialize] des) by auto with field_compatible.
 rewrite <- (mapsto_field_at _ _ [StructField _serialize] ser) by auto with field_compatible.
 rewrite !field_compatible_field_address by auto with field_compatible.
 simpl.
 normalize.
 unfold spacer, at_offset; simpl.
 cancel.
}
forward. (* p.x = 1; *)
forward. (* p.y = 2; *)
forward. (* ser = intpair_message.serialize; *)

rewrite <- memory_block_data_at__tarray_tuchar_eq by computable.
change (memory_block Tsh 8 v_buf)
with (memory_block Tsh (mf_size intpair_message) v_buf).

assert_PROP (align_compatible tint v_buf).
  entailer!.
  destruct HPv_buf; subst; simpl.
  econstructor; [reflexivity | apply Z.divide_0_r].
forward_call (* len = ser(&p, buf); *)
      ((Vint (Int.repr 1), Vint (Int.repr 2)), v_p, v_buf, Tsh, Tsh).
  split3; auto.
  repeat split; auto.
Intros rest.
simpl.
Intros. subst rest.

forward. (* des = intpair_message.deserialize; *)
forward_call (* des(&q, buf, 8); *)
        ((Vint (Int.repr 1), Vint (Int.repr 2)), v_q, v_buf, Tsh, Tsh, 8).
  simpl. fold t_struct_intpair. entailer!.
  simpl; computable.
(* after the call *)
forward. (* x = q.x; *)
forward. (* y = q.y; *)
forward. (* return x+y; *)
simpl.
entailer!.
sep_apply (data_at_memory_block Tsh (tarray tint 2) [Vint (Int.repr 1); Vint (Int.repr 2)] v_buf).
unfold sizeof; simpl Ctypes.sizeof.
sep_apply (memory_block_data_at__tarray_tuchar Tsh v_buf 8).
   computable.
entailer!!.
Qed.