(** ** lB-systems to precategories.

by Vladimir Voevodsky, started on Jan. 22, 2015 *)

Require Import UniMath.Foundations.All.

Require Import TypeTheory.Csystems.hSet_ltowers.
Require Export TypeTheory.Bsystems.T_fun.
Require Export TypeTheory.Bsystems.S_fun.

Require Export TypeTheory.Bsystems.lB0 .

(** *** The first construction of the types Mor_from_B *)

(** We first define for Z in an lB-system and m <= ll Z the type
( iterated_sections m Z ) that corresponds to the sections of the projection Z -> ft^m Z
in the associated lC-system. We do it for non-unital prelBsystems but the only structure that
is actually required is an [lBsystem_carrier] and an operation of type [S_ops_type] satisfying
axiom ax0. *)

Lemma Tilden_dd_inn { BB : prelBsystem_non_unital }
      { n' : nat } { X : BB } ( s : Tilde_dd ( ftn ( S n' ) X ) ) : S_dom s X .
Proof.
  unfold S_dom .
  destruct s as [ s' eq ].
  assert ( gt0 : ll ( ftn ( S n' ) X ) > 0 ) by (rewrite <- eq; apply ll_dd).
  simpl.
  rewrite eq.
  split.
  + rewrite ll_ftn.
    rewrite ll_ftn in gt0.
    apply natminuslthn.
    * assert ( gt := minusgth0inv _ _ gt0 ).
      apply ( istransnatgth _ _ _ gt ( natgthsn0 _ ) ).
    * apply natgthsn0.
  + apply ( isover_X_ftnX _ _ ).
Defined.

Opaque Tilden_dd_inn.

Fixpoint Tilden_dd { BB : prelBsystem_non_unital } ( n : nat )  ( X : BB )  : UU :=
  match n with
    | 0 => unit
    | S n' => match n' with
                | 0 => Tilde_dd X
                | S n'' => ∑ s1 : Tilde_dd ( ftn ( S n'' ) X ),
                                      Tilden_dd n' ( S_op s1 X ( Tilden_dd_inn s1 ) )
              end
  end .

(*

Lemma iter_sec_inn { BB : prelBsystem_non_unital }
      { m : nat } { Z : BB } ( gt0 : m > 0 ) ( lesm : S m <= ll Z )
      ( s : Tilde_dd ( ftn m Z ) ) : S_dom s Z .
Proof.
  intros.
  unfold S_dom .
  set ( eq := pr2 s : dd s = ftn m Z ) . simpl in eq .
  rewrite eq .

  apply ( isabove_X_ftnX gt0 ) .
  apply ( natgehgthtrans _ _ _ lesm ( natgthsn0 _ ) ) .

Defined.

Lemma iter_sec_le { BB : prelBsystem_non_unital }
      { m : nat } { Z : BB } ( gt0 : m > 0 ) ( lesm : S m <= ll Z )
      ( s : Tilde_dd ( ftn m Z ) ) : m <= ll ( S_op s Z ( iter_sec_inn gt0 lesm s ) ) .
Proof.
  intros.
  rewrite S_ax0 .
  assert ( leint := natgehandminusr _ _ 1 lesm ) .
  simpl in leint .
  rewrite natminuseqn in leint .
  exact leint .

Defined.

Definition iter_sec { BB : prelBsystem_non_unital }
           ( m : nat ) ( Z : BB ) ( le : m <= ll Z ) : UU .
Proof.
  intros until m . set ( S := @S_op BB ) . set ( sax0 := @S_ax0 BB ) .
  induction m as [ | m IHm ] .
  intros. exact unit .

  intros Z le .
  destruct ( natgehchoice _ _ ( natgehn0 m ) ) as [ gt0 | eq0 ] .
  set ( inn := iter_sec_inn gt0 le ) .
  set ( le' := iter_sec_le gt0 le ) .
  exact ( total2 ( fun s : Tilde_dd ( ftn m Z ) => IHm ( S s Z ( inn s ) ) (le' s) ) ) .

  exact ( Tilde_dd Z ) .

Defined.

(* Definition iter_sec_m_eq_sn { BB : prelBsystem_non_unital }
           { m n : nat } ( eq : m = S n )
           ( Z : BB ) ( lem : m <= ll Z ) ( lesn : S n <= ll Z ) :
  iter_sec m Z lem =
  total2 ( fun s : Tilde_dd ( ftn m Z ) => iter_sec n ( S s Z ( inn s ) ))*)

*)

(** We now define morphisms X --> Y as iterated sections of the projection Tprod X Y --> X *)

Definition Mor_from_B { BB : lB0system_non_unital } ( X Y : BB ) : UU :=
  Tilden_dd ( ll Y ) ( Tprod X Y )  .

(** Here is another definition of morphisms that defines them together with the corresponding
operation f_star *)

Definition Mor_and_fstar { BB : lB0system_non_unital }
           ( X1 : BB ) ( n : nat ) ( A : BB ) ( eq : ll A = n ) :
  ∑ Mor_X1_A : UU,
             forall f : Mor_X1_A ,
               ltower_fun ( ltower_over A ) ( ltower_over X1 ) .

(** Notice that [f] is vacuously bound. *)
Proof .
  revert A eq. induction n as [ | n IHn ] .
  + intros .
    split with unit .
    intro .
    exact ( Tj_fun ( @isoverll0 BB _ eq X1 ) ) .
  + intros .
    assert ( eqft : ll ( ft A ) = n ) by
        (rewrite ll_ft ; rewrite eq ; simpl ; rewrite natminuseqn ; apply idpath).
    set ( Mor_X1_ftA := pr1 ( IHn ( ft A ) eqft ) ) .
    set ( Mor_X1_A :=
          ∑ ftf : Mor_X1_ftA,
                     Tilde_dd ( pocto ( ( pr2 ( IHn ( ft A ) eqft ) ftf ) ( X_over_ftX A ) ) ) ).
    split with Mor_X1_A .
    intro f .
    set ( ftf := pr1 f : Mor_X1_ftA ) .
    set ( s_f := pr1 ( pr2 f ) : Tilde BB ) .
    set ( ftf_star := pr2 ( IHn ( ft A ) eqft ) ftf :
                      ltower_fun ( ltower_over ( ft A ) ) ( ltower_over X1 ) ) .
    set ( ftf_star_A := pocto ( ftf_star ( X_over_ftX A ) : ltower_over X1 ) ) .
    set ( eq_s_f := pr2 ( pr2 f ) : dd ( s_f ) = ftf_star_A ) .
    assert ( fun1 : ltower_fun ( ltower_over A ) ( ltower_over ftf_star_A ) )
    by apply ( ltower_fun_second ftf_star ( X_over_ftX A ) ) .
    assert ( fun2 : ltower_fun ( ltower_over ftf_star_A ) ( ltower_over ( ft ftf_star_A ) ) ) by
         (rewrite <- eq_s_f ; apply ( S_fun s_f )) .
    assert ( gt0 : ll (ftf_star (X_over_ftX A)) > 0 ) .
      rewrite (@ll_ltower_fun (pltower_over ( ft A ) )).
      change ( ll (X_over_ftX A) > 0 ) .
      rewrite ll_X_over_ftX .
      apply idpath .
      rewrite eq .
      apply natgthsn0 .

    assert ( eq' : ft ftf_star_A = X1 ) .
    * unfold ftf_star_A .
      rewrite ft_pocto .
      - assert ( eq1 : ft (ftf_star (X_over_ftX A)) = X_over_X X1 ) .
        -- assert ( eq2 : ll ( ft (ftf_star (X_over_ftX A)) ) = 0 ) .
           ++ rewrite ll_ft .
              rewrite (@ll_ltower_fun (pltower_over (ft A))).
              change ( ll (X_over_ftX A) - 1 = 0 ) .
              rewrite ll_X_over_ftX .
              ** apply idpath .
              ** rewrite eq . apply natgthsn0 .
           ++ apply ( @noparts_ispointed  ( pltower_over _ ) _ _ eq2 ( ll_X_over_X X1 ) ) .
        -- rewrite eq1 .
           apply idpath .
      - apply gt0 .
    * set ( fun12 := ltower_funcomp fun1 fun2 ) .
      rewrite eq' in fun12 .
      exact fun12 .
Defined.

(* End of the file lB_to_precat.v *)


(*

  Copyright 2014 Cornell University

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

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

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

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

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

*)

Require Export list.

(** generalization of Substitution*)
Definition lmap (A B : tuniv): tuniv := list (A * B).

Lemma lmap_find :
  forall {A B: tuniv}
         (eqdec: Deq A) (sub: lmap A B) (a : A) ,
    { b: B & LIn (a,b) sub}
    + !(LIn a (fst (split sub))).
Proof.
   induction sub as [| (a', b') sub Hind]; intro a.
   - right.  sp.
   - destruct (eqdec a' a) as [Hc|Hc]; subst.
      + left. exists b'. left; refl.
      + destruct (Hind a) as [Hl | Hr]; exrepnd ;[left | right].
          * exists b. right; auto.
          * intro Hf. apply Hr. simpl in Hf. destruct (split sub).
              dorn Hf; sp.
Defined.

Definition dom_lmap {A B: tuniv} (sub : lmap A B) : list A := map (fun x => fst x) sub.

(**same as above, but the impelemtation is guaranteed to return the first match*)
Lemma lmap_find_first: forall {A B: tuniv}
  (eqdec: Deq A) (sub: lmap A B) (a : A) ,
    { b: B & {n:nat & n < length sub
            # nth n sub (a,b) = (a,b)
            # (forall m, m<n ->  (nth m (dom_lmap sub) a) <> a) } }
       + !LIn a (dom_lmap sub).
Proof.
   induction sub as [| (a', b') sub Hind]; intro a.
   - right.  sp.
   - destruct (eqdec a' a) as [Hc|Hc]; subst.
      + left. exists b'. exists 0. split; simpl; auto. apply  lt_0_Sn.
        split; auto. introv Hm; inverts Hm.
      + destruct (Hind a) as [Hl | Hr]; exrepnd ;[left | right].
          * exists b. exists (S n). repeat(split); auto; simpl. apply lt_n_S. auto.
            introv Hlt. destruct m; auto. apply Hl1. apply lt_S_n; auto.
          * introv Hf. apply Hr. simpl in Hf.
              dorn Hf; sp.
Defined.

(*
Lemma lmap_find_sub_find_some: forall (lvi lvo: list NVar)
  (v b : NVar) (ev: LIn (v, b) (combine lvi lvo)),
  lmap_find deq_nvar (combine lvi lvo) v = inl (existT _ b ev)
   -> sub_find (var_ren lvi lvo) v = Some (vterm b).
AXdmitted.

Lemma lmap_find_sub_find_none: forall (lvi lvo: list NVar)
  (v: NVar) r,
  lmap_find deq_nvar (combine lvi lvo) v = inr r
   -> sub_find (var_ren lvi lvo) v = None.
AXdmitted.

Lemma lmap_apply_cons :
  forall {A : Set} (eqdec: Deq A) (v vi vo: A)
    (sub: lmap A A),
  lmap_apply eqdec ((vi, vo) :: sub) v=
   if eqdec vi v
   then
      vo
   else
      lmap_apply eqdec sub v.
Proof.
 intros.
  unfold lmap_apply.
  simpl. destruct (eqdec vi v); subst; simpl;auto.
  destruct (lmap_find eqdec sub v).
  destruct s; auto. refl.
Qed.

Lemma lmap_apply_filter_eta : forall {A:Set}
  (deq: Deq A) (lvi lvo lv: list A) (v:A),
  !(LIn v lv)
  -> lmap_apply deq
    (lmap_filter deq (combine lvi lvo) lv) v
     = lmap_apply deq (combine lvi lvo) v.
Proof.
  induction lvi as [| vi lvi Hind]; auto.
  introv Hnl. simpl.
  destruct lvo as [|vo lvo]; auto.
  simpl. cases_if_sum Hd; simpl; auto.
  - rewrite Hind; auto. rewrite lmap_apply_cons.
    destruct (deq vi v);
    [subst; sp; fail | ]; auto.
  - repeat (rewrite lmap_apply_cons).
    destruct (deq vi v); auto.
Qed.
*)

(*
Lemma lmap_filter_commute_sub:
  forall lvi lvo lvr v,
    length lvi=length lvo
    -> !(LIn v lvr)
    -> lmap_filter deq_nvar (combine lvi lvo) lvr =
        combine (fst (split (sub_filter (var_ren lvi lvo) lvr)))
          (get_sub_dom_vars (sub_filter (var_ren lvi lvo) lvr)
             ((allvars_sub_filter lvi lvo lvr)) ).
Proof.
  induction lvi as [|vi lvi Hind]; auto.
  introv Hleq Hnl. simpl. destruct lvo as [| vo lvo]; [inverts Hleq;fail | ].
  simpl. cases_if_sum Hd.
  pose proof (snd (assert_memvar _ _) Hd ) as Hrw.
  repnud Hrw. symmetry in Hrw.
  pose proof
  ((allvars_sub_filter (vi :: lvi) (vo :: lvo) lvr)).
  simpl in X.
  pose proof (
fun b : bool =>
 lmap_filter deq_nvar (combine lvi lvo) lvr =
 combine
   (fst
      (split
         (if b
          then sub_filter (combine lvi (map vterm lvo)) lvr
          else (vi, vterm vo) :: sub_filter (combine lvi (map vterm lvo)) lvr)))
   (get_sub_dom_vars
      (if b
       then sub_filter (combine lvi (map vterm lvo)) lvr
       else (vi, vterm vo) :: sub_filter (combine lvi (map vterm lvo)) lvr)
     (

     match b return
     (
allvars_sub
    (if b
     then sub_filter (combine lvi (map vterm lvo)) lvr
     else (vi, vterm vo) :: sub_filter (combine lvi (map vterm lvo)) lvr)
     ) with
  | true => (allvars_sub_filter (vi :: lvi) (vo :: lvo) lvr)
  | false => (allvars_sub_filter (vi :: lvi) (vo :: lvo) lvr)
   end ))).

  rewrite <- Hrw.

  pose proof (@transport _ _ _
   (
fun b : bool =>
 lmap_filter deq_nvar (combine lvi lvo) lvr =
 combine
   (fst
      (split
         (if b
          then sub_filter (combine lvi (map vterm lvo)) lvr
          else (vi, vterm vo) :: sub_filter (combine lvi (map vterm lvo)) lvr)))
   (get_sub_dom_vars
      (if b
       then sub_filter (combine lvi (map vterm lvo)) lvr
       else (vi, vterm vo) :: sub_filter (combine lvi (map vterm lvo)) lvr)
      (match b return
        (allvars_sub
    (if b
     then sub_filter (combine lvi (map vterm lvo)) lvr
     else (vi, vterm vo) ::
       sub_filter (combine lvi (map vterm lvo)) lvr))
         with
       | true => (allvars_sub_filter  lvi lvo lvr)
       | false => (allvars_sub_filter_cons
             lvi lvo lvr vi vo)
        end)
)) Hrw) as Hrrw.
 allsimpl. apply Hrrw.
*)

Lemma lin_combine_injective: forall {A B C D :Type}
  (fa: A->C) (fb: B->D) (pa: injective_fun fa)
  (pb: injective_fun fb) (a:A) (b:B) (la: list A) (lb: list B),
  LIn (a, b) (combine la lb)
  <=> LIn (fa a,fb b) (combine (map fa la) (map fb lb)).
Proof.
  induction la; intros; sp.
  simpl. destruct lb; sp.
  simpl. rw <- IHla. split; intro Hp; dorn Hp; cpx.
  apply pa in H. apply pb in H0. subst.
  sp.
Qed.

Definition proj_as_option {A Q: Type} {P : A->Type} (a': {a : A & (P a)} + Q)
  : option A :=
  match a' with
    | inl (existT _ a' _) => Some a'
    | inr _ => None
  end.

Lemma lmap_find_injection:
  forall {A B C: tuniv} (deqa : Deq A)
  (f: B->C) (p: forall a1 a2, (f a1= f a2) -> a1=a2)
  (a:A) (la: list A)  (lb:list B) ,
  option_map f (proj_as_option (lmap_find deqa (combine la lb) a))
    = proj_as_option (lmap_find deqa (combine la (map f lb)) a).
Proof.
  induction la as [|va la Hind]; intros; auto.
  allsimpl. destruct lb as [| b lb ]; auto.
  simpl. destruct (deqa va a) as [eq | neq]; subst; sp.
  cases (lmap_find deqa (combine la (map f lb)) a); sp; simpl.
  apply (apply_eq proj_as_option) in H. allsimpl.
  rewrite <- Hind in H.
  destruct (lmap_find deqa (combine la lb) a) as [ ex | nex];
   allsimpl; sp.
  destruct (lmap_find deqa (combine la lb) a) as [ex | nex];
   allsimpl; sp.
  allsimpl.  provefalse.
  apply n. rewrite fst_split_as_map.
  apply in_map_iff. exists (a,f b0).
  split;auto. assert (a= (fun x=>x) a) as Hr; auto.
  rewrite <- (map_id  la).
  assert (injective_fun (fun x:A => x)) as Hi
  by (introv; simpl; sp).
  pose proof (tiff_fst (lin_combine_injective (fun x:A => x) f Hi p
  _ _ _ _) l). allsimpl. auto.
Qed.


Require Import Arith Rounding Psatz Omega Eqdep_dec List ListUtils Word Prog.
Require Import AsyncDisk Rec Array.
Import ListNotations.

Module Type RASig.

  Parameter xparams : Type.
  Parameter RAStart : xparams -> addr.
  Parameter RALen   : xparams -> addr.

  (** any restriction to xparams.
      Usually be:  goodSize addrlen ((RAStart xp) + (RALen xp)) **)
  Parameter xparams_ok : xparams -> Prop.

  Parameter itemtype : Rec.type.
  Parameter items_per_val : nat.
  Parameter blocksz_ok : valulen = Rec.len (Rec.ArrayF itemtype items_per_val).

End RASig.

Module RADefs (RA : RASig).

  Import RA.

  Definition item := Rec.data itemtype.
  Definition itemsz := Rec.len itemtype.
  Definition item0 := @Rec.of_word itemtype $0.

  Definition blocktype : Rec.type := Rec.ArrayF itemtype items_per_val.
  Definition blocksz := Rec.len blocktype.
  Definition block := Rec.data blocktype.

  Definition val2word (v : valu) : word (blocksz).
    rewrite blocksz_ok in v; trivial.
  Defined.

  Definition word2val (w : word blocksz) : valu.
    rewrite blocksz_ok; trivial.
  Defined.

  Definition block2val (b : block) := word2val (Rec.to_word b).
  Definition val2block (v : valu) := Rec.of_word (val2word v).
  Definition block0 := val2block $0.

  Definition itemlist := list item.

  Definition nils n := @repeat (list valu) nil n.

  Local Hint Resolve eq_nat_dec : core.

  Theorem val2word2val_id : forall w, val2word (word2val w) = w.
  Proof.
    unfold val2word, word2val, eq_rec_r, eq_rec; simpl; intros.
    rewrite eq_rect_nat_double.
    erewrite eq_rect_eq_dec; auto.
  Qed.

  Theorem word2val2word_id : forall v, word2val (val2word v) = v.
  Proof.
    unfold val2word, word2val, eq_rec_r, eq_rec; simpl; intros.
    rewrite eq_rect_nat_double.
    erewrite eq_rect_eq_dec; auto.
  Qed.

  Local Hint Resolve Rec.of_to_id Rec.to_of_id val2word2val_id word2val2word_id.
  Hint Rewrite val2word2val_id word2val2word_id Rec.of_to_id Rec.to_of_id : core.

  (** crush any small goals.  Do NOT use for big proofs! *)
  Ltac small_t' := intros; autorewrite with core; autorewrite with core in *;
             eauto; simpl in *; intuition; eauto.
  Ltac small_t := repeat small_t'; subst; simpl; eauto.

  Theorem val2block2val_id : forall b,
    Rec.well_formed b -> val2block (block2val b) = b.
  Proof.
    unfold block2val, val2block; small_t.
  Qed.

  Theorem block2val2block_id : forall v,
    block2val (val2block v) = v.
  Proof.
    unfold block2val, val2block; small_t.
  Qed.

  Local Hint Resolve val2block2val_id block2val2block_id Forall_forall: core.
  Local Hint Resolve divup_mono firstn_nil.
  Hint Rewrite val2block2val_id block2val2block_id: core.
  Hint Rewrite combine_length : core.

  Theorem val2block2val_selN_id : forall bl i,
    Forall Rec.well_formed bl
    -> val2block (selN (map block2val bl) i $0) = selN bl i block0.
  Proof.
    induction bl; intros; small_t.
    destruct i; rewrite Forall_forall in *.
    small_t; apply H; intuition.
    apply IHbl; rewrite Forall_forall.
    small_t; apply H; intuition.
  Qed.
  Hint Rewrite val2block2val_selN_id.

  Lemma items_per_val_not_0 : items_per_val <> 0.
  Proof.
    generalize blocksz_ok.
    rewrite valulen_is.
    intros; intro.
    rewrite H0 in H.
    discriminate.
  Qed.

  Lemma items_per_val_gt_0 : items_per_val > 0.
  Proof.
    pose proof items_per_val_not_0; omega.
  Qed.

  Lemma items_per_val_gt_0' : 0 < items_per_val.
  Proof.
    pose proof items_per_val_not_0; omega.
  Qed.

  Local Hint Resolve items_per_val_not_0 items_per_val_gt_0 items_per_val_gt_0'.

  Hint Rewrite firstn_nil : core.
  Hint Rewrite setlen_nil : core.

  Theorem block0_repeat : block0 = repeat item0 items_per_val.
  Proof.
    unfold block0, item0, val2block, blocktype, val2word.
    generalize blocksz_ok.
    rewrite blocksz_ok; intros; simpl.
    unfold eq_rec.
    rewrite <- (eq_rect_eq_dec eq_nat_dec).
    generalize dependent items_per_val.
    induction n; simpl; auto; intros.
    erewrite <- IHn; small_t.
    unfold Rec.of_word at 1 3.
    rewrite split1_zero.
    rewrite split2_zero; auto.
  Qed.
  Hint Resolve block0_repeat.
  Hint Resolve divup_ge.

  Local Hint Resolve Rec.of_word_well_formed.
  Lemma item0_wellformed : Rec.well_formed item0.
  Proof.
    unfold item0; auto.
  Qed.
  Lemma block0_wellformed : Rec.well_formed block0.
  Proof.
    unfold block0, val2block; auto.
  Qed.
  Local Hint Resolve item0_wellformed block0_wellformed.

  Hint Rewrite setlen_length : core.

  Lemma setlen_wellformed : forall l n,
    Forall Rec.well_formed l
    -> Forall (@Rec.well_formed itemtype) (setlen l n item0).
  Proof.
    intros; rewrite Forall_forall in *; intros.
    destruct (setlen_In _ _ _ _ H0); small_t.
  Qed.

  Local Hint Resolve setlen_wellformed : core.
  Local Hint Resolve forall_skipn.

  (* list chunks *)

  Fixpoint list_chunk' {A} (l : list A) (sz : nat) (def : A) (nr : nat) : list (list A) :=
    match nr with
    | S n => setlen l sz def :: (list_chunk' (skipn sz l) sz def n)
    | O => []
    end.

  Fixpoint nopad_list_chunk' {A} (l : list A) (sz : nat) (nr : nat) : list (list A) :=
    match nr with
    | S n => firstn sz l :: (nopad_list_chunk' (skipn sz l) sz n)
    | O => []
    end.

  (** cut list l into chunks of lists of length sz, pad the tailing list with default value def *)
  Definition list_chunk {A} l sz def : list (list A) :=
    list_chunk' l sz def (divup (length l) sz).

  (** cut list l into chunks of lists of length sz, don't pad the tailing list *)
  Definition nopad_list_chunk {A} l sz : list (list A) :=
    nopad_list_chunk' l sz (divup (length l) sz).

  Lemma list_chunk'_length: forall A nr l sz (def : A),
      length (list_chunk' l sz def nr) = nr.
  Proof.
    induction nr; simpl; auto.
  Qed.
  Hint Rewrite list_chunk'_length : core.

  Lemma list_chunk_length: forall A l sz (def : A),
      length (list_chunk l sz def) = divup (length l) sz.
  Proof.
    unfold list_chunk; intros.
    apply list_chunk'_length.
  Qed.
  Hint Rewrite list_chunk_length : core.

  Lemma nopad_list_chunk'_length: forall A nr (l : list A) sz,
    length (nopad_list_chunk' l sz nr) = nr.
  Proof.
    induction nr; simpl; auto.
  Qed.

  Lemma nopad_list_chunk_length : forall A (l : list A) sz,
    length (nopad_list_chunk l sz) = divup (length l) sz.
  Proof.
    unfold nopad_list_chunk; intros.
    apply nopad_list_chunk'_length.
  Qed.
  Hint Rewrite nopad_list_chunk_length : core.

  Theorem list_chunk'_wellformed : forall nr items,
    Forall Rec.well_formed items
    -> Forall (@Rec.well_formed blocktype) (list_chunk' items items_per_val item0 nr).
  Proof.
    induction nr; small_t.
    apply Forall_cons; small_t.
  Qed.

  Theorem list_chunk_wellformed : forall items,
    Forall Rec.well_formed items
    -> Forall (@Rec.well_formed blocktype) (list_chunk items items_per_val item0).
  Proof.
    intros; eapply list_chunk'_wellformed; eauto.
  Qed.
  Local Hint Resolve list_chunk_wellformed.

  (** specialized list_chunk_length that works better with dependent type in Rec *)
  Lemma block_chunk_length: forall l sz,
      @length block (@list_chunk item l sz item0) = divup (length l) sz.
  Proof.
    intros; apply list_chunk_length.
  Qed.
  Hint Rewrite block_chunk_length : core.

  Lemma list_chunk_nil : forall  A sz (def : A),
    list_chunk nil sz def = nil.
  Proof.
    unfold list_chunk; small_t.
    rewrite divup_0; small_t.
  Qed.

  Lemma list_chunk'_Forall_length : forall A nr l sz (i0 : A),
    Forall (fun b => length b = sz) (list_chunk' l sz i0 nr).
  Proof.
    induction nr; small_t.
    apply Forall_cons; small_t.
  Qed.

  Lemma list_chunk_In_length : forall A l sz (i0 : A) x,
    In x (list_chunk l sz i0) -> length x = sz.
  Proof.
    intros until i0; apply Forall_forall.
    unfold list_chunk.
    apply list_chunk'_Forall_length.
  Qed.

  Local Hint Resolve in_selN.
  Hint Rewrite skipn_length.

  Lemma list_chunk_selN_length : forall l i,
    length (selN (list_chunk l items_per_val item0) i block0) = items_per_val.
  Proof.
    intros.
    destruct (lt_dec i (length (list_chunk l items_per_val item0))).
    eapply list_chunk_In_length; eauto.
    rewrite selN_oob by small_t.
    apply block0_wellformed.
  Qed.
  Hint Rewrite list_chunk_selN_length.

  Lemma list_chunk'_spec : forall A nr i l sz (i0 : A) b0,
    i < nr ->
    selN (list_chunk' l sz i0 nr) i b0 = setlen (skipn (i * sz) l) sz i0.
  Proof.
    induction nr; small_t. inversion H.
    destruct i. small_t.
    erewrite IHnr by small_t.
    rewrite skipn_skipn; simpl.
    f_equal; f_equal; omega.
  Qed.

  Lemma list_chunk_spec' : forall A l i n (e0 : A) b0,
    n <> 0 -> b0 = repeat e0 n ->
    selN (list_chunk l n e0) i b0
    = setlen (skipn (i * n) l) n e0.
  Proof.
    unfold list_chunk; intros.
    destruct (lt_dec i (divup (length l) n)).
    apply list_chunk'_spec; auto.
    rewrite selN_oob by small_t.
    rewrite skipn_oob; small_t.
  Qed.

  Lemma list_chunk_spec : forall l i,
    selN (list_chunk l items_per_val item0) i block0
    = setlen (skipn (i * items_per_val) l) items_per_val item0.
  Proof.
    intros; apply list_chunk_spec'; eauto.
  Qed.

  Lemma nopad_list_chunk'_spec: forall A nr i (l : list A) sz (b0 : list A),
    i < nr ->
    selN (nopad_list_chunk' l sz nr) i b0 = firstn sz (skipn (i * sz) l).
  Proof.
    induction nr; cbn; intros.
    omega.
    destruct i; cbn; auto.
    rewrite IHnr by omega.
    rewrite plus_comm.
    rewrite skipn_skipn.
    reflexivity.
  Qed.

  Lemma nopad_list_chunk_spec: forall l i,
    i < divup (length l) items_per_val ->
    selN (nopad_list_chunk l items_per_val) i block0 =
    firstn items_per_val (skipn (i * items_per_val) l).
  Proof.
    unfold nopad_list_chunk.
    intros.
    rewrite nopad_list_chunk'_spec; auto.
  Qed.

  Lemma list_chunk'_skipn_1: forall A n l k (e0 : A),
    list_chunk' (skipn n l) n e0 (k - 1) = skipn 1 (list_chunk' l n e0 k).
  Proof.
    induction k; intros; simpl; auto; rewrite Nat.sub_0_r; auto.
  Qed.

  Lemma list_chunk_skipn_1 : forall A n l (e0 : A),
    list_chunk (skipn n l) n e0 = skipn 1 (list_chunk l n e0).
  Proof.
    unfold list_chunk; intros.
    rewrite skipn_length.
    destruct (Nat.eq_dec n 0).
    subst; simpl; auto.
    destruct (lt_dec (length l) n).
    replace (length l - n) with 0 by omega.
    rewrite divup_0.
    apply Nat.lt_le_incl in l0; apply divup_le_1 in l0.
    destruct (Nat.eq_dec (divup (length l) n) 1).
    rewrite e.
    setoid_rewrite skipn_oob at 2; simpl; auto.
    replace (divup (length l) n) with 0 by omega.
    simpl; auto.
    rewrite divup_sub_1 by omega.
    apply list_chunk'_skipn_1.
  Qed.

  Lemma skipn_list_chunk_skipn_eq : forall A i l n (e0 : A),
    skipn i (list_chunk l n e0) = list_chunk (skipn (i * n) l) n e0.
  Proof.
    induction i; intros.
    simpl; auto.
    simpl (S i * n).
    rewrite <- skipn_skipn'.
    rewrite <- IHi; auto.
    rewrite list_chunk_skipn_1.
    rewrite skipn_skipn.
    replace (S i) with (i + 1) by omega; auto.
  Qed.

  Local Hint Resolve divup_le divup_mul_ge.

  Lemma skipn_repeat_list_chunk : forall A i l n (e0 : A) B (x : B),
    skipn i (repeat x (length (list_chunk l n e0)))
    = repeat x (length (list_chunk (skipn (i * n) l) n e0)).
  Proof.
    intros.
    destruct (Nat.eq_dec n 0).
    subst; simpl; rewrite skipn_nil; auto.
    destruct (lt_dec (length l) (n * i)); autorewrite with core.
    replace (length l - i * n) with 0 by nia.
    rewrite divup_0.
    rewrite skipn_oob; autorewrite with core; simpl; auto.
    autorewrite with lists.
    apply divup_le; nia.
    rewrite divup_sub by nia.
    rewrite skipn_repeat; auto.
  Qed.

  Local Hint Resolve skipn_list_chunk_skipn_eq list_chunk_skipn_1 skipn_repeat_list_chunk.
  Hint Rewrite app_nil_l app_nil_r firstn_length Nat.sub_diag Nat.sub_0_r: core.

  Lemma list_chunk'_firstn' : forall A i n l (e0 : A),
    length l >= i * n ->
    list_chunk' (firstn (i * n) l) n e0 i = list_chunk' l n e0 i.
  Proof.
    induction i; intros; simpl; auto.
    repeat rewrite setlen_inbound by (autorewrite with core lists; nia).
    rewrite firstn_firstn.
    rewrite Nat.min_l by nia.
    setoid_rewrite <- IHi at 2; autorewrite with core; try nia.
    f_equal; f_equal.
    apply skipn_firstn_comm.
  Qed.

  Lemma list_chunk'_firstn : forall A i n l (e0 : A),
    list_chunk' (firstn (i * n) l) n e0 i = list_chunk' l n e0 i.
  Proof.
    intros.
    destruct (le_lt_dec (i * n) (length l)).
    apply list_chunk'_firstn'; auto.
    rewrite firstn_oob; auto.
    nia.
  Qed.

  Lemma firstn_list_chunk' : forall A m n i l (e0 : A),
    n <= m ->
    firstn n (list_chunk' l i e0 m) = list_chunk' l i e0 n.
  Proof.
    induction m; destruct n; small_t.
    inversion H.
    rewrite IHm; small_t.
  Qed.

  Hint Rewrite divup_mul Nat.mul_0_r Nat.mul_0_l.

  Lemma list_chunk_firstn' : forall A i n l (e0 : A),
    n <> 0 -> length l >= i * n ->
    list_chunk (firstn (i * n) l) n e0 = firstn i (list_chunk l n e0).
  Proof.
    unfold list_chunk; small_t.
    rewrite Nat.min_l; small_t.
    rewrite list_chunk'_firstn.
    rewrite firstn_list_chunk'; small_t.
    apply divup_mul_ge; nia.
  Qed.

  Lemma list_chunk_firstn : forall A i n l (e0 : A),
    list_chunk (firstn (i * n) l) n e0 = firstn i (list_chunk l n e0).
  Proof.
    intros.
    destruct (Nat.eq_dec n 0); small_t. small_t.
    destruct (le_lt_dec (i * n) (length l)).
    apply list_chunk_firstn'; small_t.
    rewrite firstn_oob by nia.
    rewrite firstn_oob; small_t.
  Qed.

  Lemma firstn_list_chunk_app : forall l i pre,
    items_per_val + i * items_per_val <= length l
    -> pre = firstn (i * items_per_val) l
    -> firstn (i * items_per_val + items_per_val) l
       = pre ++ (selN (list_chunk l items_per_val item0) i block0).
  Proof.
    small_t; rewrite list_chunk_spec.
    rewrite firstn_sum_split; f_equal.
    rewrite setlen_inbound; small_t.
  Qed.

  Lemma firstn_setlen_firstn : forall A l m n (def : A),
    n <= m -> n <= length l -> firstn n (setlen l m def) = firstn n l.
  Proof.
    unfold setlen; intros.
    rewrite firstn_app_l.
    rewrite firstn_firstn; rewrite Nat.min_l; auto.
    rewrite firstn_length.
    apply Min.min_glb; auto.
  Qed.

  Lemma list_chunk'_app : forall A na sz a b (def : A),
    sz <> 0 ->
    length a = sz * na ->
    list_chunk' (a ++ b) sz def (na + divup (length b) sz) =
    list_chunk' a sz def na ++ list_chunk' b sz def (divup (length b) sz).
  Proof.
    induction na; small_t.
    replace (a ++ b) with b; auto.
    rewrite length_nil with (l := a); auto; omega.
    repeat rewrite setlen_inbound by (autorewrite with lists; nia).
    rewrite firstn_app_l by nia.
    f_equal.
    rewrite skipn_app_l by nia.
    rewrite IHna; auto.
    autorewrite with core; nia.
  Qed.

  Lemma list_chunk_app: forall A na sz a b (def : A),
    sz <> 0 ->
    length a = sz * na ->
    list_chunk (a ++ b) sz def = list_chunk a sz def ++ list_chunk b sz def.
  Proof.
    unfold list_chunk; intros.
    rewrite app_length; autorewrite with core lists.
    repeat (rewrite H0; rewrite Nat.mul_comm; rewrite divup_mul by auto).
    rewrite <- list_chunk'_app; auto.
    f_equal.
    replace (na * sz + length b) with (length b + sz * na) by lia.
    rewrite divup_add by auto; omega.
  Qed.

  (* reps *)
  Definition ipack items := map block2val (list_chunk items items_per_val item0).
  Definition nopad_ipack items := map block2val (nopad_list_chunk items items_per_val).

  Definition iunpack (r : itemlist) (v : valu) : itemlist :=
    r ++ (val2block v).

  Lemma well_formed_app_iff : forall A (a b : list (Rec.data A)) ,
     Forall Rec.well_formed (a ++ b)
     <-> Forall Rec.well_formed a /\ Forall Rec.well_formed b.
  Proof.
    intros; repeat (try split; rewrite Forall_forall in *; small_t).
    destruct (in_app_or a b x); small_t.
  Qed.

  Lemma nils_length : forall n,
    length (nils n) = n.
  Proof.
    unfold nils; intros.
    apply repeat_length.
  Qed.

  Lemma ipack_length : forall items,
    length (ipack items) = divup (length items) items_per_val.
  Proof.
    unfold ipack; intros.
    rewrite map_length.
    setoid_rewrite list_chunk_length; auto.
  Qed.

  Lemma nopad_ipack_length : forall (l : itemlist),
    length (nopad_ipack l) = divup (length l) items_per_val.
  Proof.
    unfold nopad_ipack; cbn.
    intros.
    rewrite map_length.
    rewrite nopad_list_chunk_length; auto.
  Qed.

  Lemma ipack_app: forall na a b,
    length a = na * items_per_val ->
    ipack (a ++ b) = ipack a ++ ipack b.
  Proof.
    unfold ipack; intros.
    rewrite <- map_app; f_equal.
    eapply list_chunk_app; eauto.
    rewrite Nat.mul_comm; eauto.
  Qed.

  Lemma ipack_nil : ipack nil = nil.
  Proof.
    unfold ipack.
    rewrite list_chunk_nil; auto.
  Qed.

  Lemma ipack_one : forall l,
    length l = items_per_val ->
    ipack l = block2val l :: nil.
  Proof.
    unfold ipack, list_chunk; intros.
    rewrite H.
    rewrite divup_same by auto; simpl.
    rewrite setlen_inbound by omega.
    rewrite firstn_oob by omega; auto.
  Qed.

  Lemma iunpack_ipack_one : forall l init,
    Forall Rec.well_formed l ->
    length l = items_per_val ->
    fold_left iunpack (ipack l) init = init ++ l.
  Proof.
    intros; unfold iunpack.
    rewrite ipack_one by auto; simpl.
    autorewrite with core; split; auto.
  Qed.

  Lemma list_chunk'_app_def : forall A n z l k (def : A),
    list_chunk' (l ++ repeat def z) k def n = list_chunk' l k def n.
  Proof.
    induction n; intros; simpl; auto.
    destruct (le_gt_dec k (length l)).
    repeat rewrite setlen_inbound by (auto; rewrite app_length; omega).
    rewrite firstn_app_l, skipn_app_l by auto.
    rewrite IHn; auto.

    rewrite setlen_app_r by omega.
    unfold setlen at 2; rewrite firstn_oob by omega.
    rewrite setlen_repeat.
    f_equal.
    rewrite skipn_app_r_ge by omega.
    setoid_rewrite skipn_oob at 2; try omega.
    destruct (le_gt_dec (k - length l) z).
    rewrite skipn_repeat.
    setoid_rewrite <- app_nil_l at 2.
    apply IHn.
    rewrite skipn_oob by (rewrite repeat_length; omega); auto.
  Qed.

  Lemma ipack_app_item0 : forall l n,
    n <= (roundup (length l) items_per_val - length l) ->
    ipack (l ++ repeat item0 n) = ipack l.
  Proof.
    unfold ipack, list_chunk; intros.
    f_equal.
    rewrite list_chunk'_app_def, app_length.
    rewrite divup_add_small; auto.
    rewrite repeat_length; auto.
  Qed.

  Lemma well_formed_firstn : forall A n (a : list (Rec.data A)),
    Forall Rec.well_formed a
    -> Forall Rec.well_formed (firstn n a).
  Proof.
    intros.
    rewrite Forall_forall in *; intros.
    apply H; eapply in_firstn_in; eauto.
  Qed.

  Lemma well_formed_skipn : forall A n (a : list (Rec.data A)),
    Forall Rec.well_formed a
    -> Forall Rec.well_formed (skipn n a).
  Proof.
    intros.
    rewrite Forall_forall in *; intros.
    apply H; eapply in_skipn_in; eauto.
  Qed.

  Lemma to_word_setlen: forall n (l : Rec.data (Rec.ArrayF itemtype n)),
    length l < n ->
    @Rec.to_word (Rec.ArrayF itemtype n) (setlen l n (Rec.of_word $0)) = Rec.to_word l.
  Proof.
    cbn; intros.
    rewrite setlen_oob by omega.
    generalize dependent itemtype.
    induction n; cbn; intros.
    f_equal. auto using app_nil_r.
    destruct l; cbn in *;
      repeat rewrite Rec.cons_to_word;
      repeat rewrite Rec.to_of_id.
    clear IHn. clear H.
    induction n; cbn.
    unfold Rec.to_word.
    rewrite combine_wzero.
    reflexivity.
    rewrite Rec.cons_to_word, Rec.to_of_id.
    rewrite IHn.
    rewrite combine_wzero.
    reflexivity.
    f_equal.
    apply IHn. omega.
  Qed.

  Local Hint Resolve Forall_append well_formed_firstn well_formed_skipn.

  Lemma iunpack_ipack' : forall nr init items ,
    Forall Rec.well_formed items ->
    length items = nr * items_per_val ->
    fold_left iunpack (ipack items) init = init ++ items.
  Proof.
    induction nr; small_t.
    apply length_nil in H0; rewrite H0.
    rewrite ipack_nil; simpl; small_t.

    erewrite <- firstn_skipn with (n := items_per_val) (l := items).
    rewrite ipack_app with (na := 1).
    rewrite fold_left_app.
    rewrite IHnr; auto.
    rewrite app_assoc.
    f_equal.

    rewrite iunpack_ipack_one; auto.
    rewrite firstn_length_l; lia.
    rewrite skipn_length; nia.
    rewrite firstn_length; lia.
  Qed.

  Lemma iunpack_ipack : forall nr items,
    Forall Rec.well_formed items ->
    length items = nr * items_per_val ->
    fold_left iunpack (ipack items) nil = items.
  Proof.
    intros; eapply iunpack_ipack'; eauto.
  Qed.

  Lemma iunpack_ipack_firstn : forall n nr items,
    Forall Rec.well_formed items ->
    length items = nr * items_per_val ->
    fold_left iunpack (firstn n (ipack items)) nil =
    firstn (n * items_per_val) items.
  Proof.
    induction n; intros.
    simpl; auto.

    destruct (lt_dec n (length (ipack items))).
    rewrite firstn_S_selN with (def := $0) by auto.
    rewrite fold_left_app.
    erewrite IHn; simpl; eauto.

    rewrite ipack_length in l.
    unfold iunpack, ipack; rewrite Nat.add_comm.
    erewrite firstn_list_chunk_app; [ f_equal | | apply eq_refl ].
    erewrite selN_map, val2block2val_id; eauto.
    apply Forall_selN.
    apply list_chunk_wellformed; auto.
    setoid_rewrite list_chunk_length; auto.
    setoid_rewrite list_chunk_length; auto.

    rewrite H0 in *.
    rewrite divup_mul in l by auto.
    apply lt_le_S in l; eapply mult_le_compat_r in l; eauto.

    repeat rewrite firstn_oob; try omega.
    eapply iunpack_ipack; eauto.
    rewrite ipack_length in n0.
    rewrite H0 in *.
    rewrite divup_mul in n0 by auto.
    apply Nat.nlt_ge in n0.
    apply mult_le_compat; omega.
  Qed.

  Lemma ipack_iunpack_one : forall (a : valu),
    [ a ] = ipack (iunpack [] a).
  Proof.
    intros.
    unfold iunpack.
    rewrite app_nil_l.
    rewrite ipack_one, block2val2block_id; auto.
    unfold val2block, blocktype.
    rewrite Rec.array_of_word_length.
    auto.
  Qed.

  Lemma iunpack_length : forall init nr a,
    length init = nr ->
    length (iunpack init a) = nr + items_per_val.
  Proof.
    intros.
    unfold iunpack.
    rewrite app_length, H.
    f_equal.
    unfold val2block, blocktype, item.
    apply Rec.array_of_word_length.
  Qed.

  Lemma fold_left_iunpack_length' : forall l init nr,
    length init = nr ->
    length (fold_left iunpack l init) = nr + (length l) * items_per_val.
  Proof.
    induction l; simpl; intros.
    omega.

    erewrite IHl.
    instantiate (1 := nr + items_per_val). omega.
    apply iunpack_length; auto.
  Qed.

  Lemma fold_left_iunpack_length : forall l,
    length (fold_left iunpack l []) = (length l) * items_per_val.
  Proof.
    intros.
    erewrite fold_left_iunpack_length'; eauto.
    omega.

    Unshelve.
    constructor.
  Qed.

  Lemma ipack_iunpack : forall l,
    (forall l', Forall (@Rec.well_formed itemtype) l') ->
    l = ipack (fold_left iunpack l []).
  Proof.
    induction l; intros; simpl.
    rewrite <- ipack_nil.
    auto.

    rewrite IHl at 2.
    erewrite iunpack_ipack'.
    erewrite ipack_app.
    rewrite <- ipack_iunpack_one.
    rewrite cons_app.
    f_equal; auto.
    unfold iunpack.
    rewrite app_nil_l.
    unfold val2block, blocktype.
    rewrite Rec.array_of_word_length.
    instantiate (1:=1); omega.
    auto.
    instantiate (1:=length l).
    apply fold_left_iunpack_length.
    auto.
  Qed.

  Lemma ipack_nopad_ipack_eq : forall x,
    ipack x = nopad_ipack x.
  Proof.
    unfold ipack, nopad_ipack.
    intros.
    eapply selN_map_eq; cbn; intros.
    destruct (lt_dec i (divup (length x) items_per_val)).
    - rewrite list_chunk_spec.
      rewrite nopad_list_chunk_spec by auto.
      unfold block2val, blocktype in *.
      destruct (lt_dec (length x - i * items_per_val) items_per_val).
      rewrite to_word_setlen.
      rewrite firstn_oob; auto.
      all: rewrite ?skipn_length; auto.
      cbv in *; omega.
      rewrite setlen_inbound; auto.
      rewrite skipn_length; omega.
    - repeat rewrite selN_oob by (autorewrite with core; apply Nat.le_ngt; eauto).
      reflexivity.
    - autorewrite with core. auto.
  Qed.

  Lemma mod_lt_length_firstn_skipn : forall A ix (l : list A),
    ix < length l ->
    ix mod items_per_val < length (firstn items_per_val (skipn (ix / items_per_val * items_per_val) l)).
  Proof.
    intros.
    rewrite firstn_length, skipn_length.
    apply Nat.min_glb_lt.
    apply Nat.mod_upper_bound; auto.
    rewrite Nat.mod_eq, Nat.mul_comm by auto.
    enough (ix >= ix / items_per_val * items_per_val).
    omega.
    rewrite Nat.mul_comm.
    apply Nat.mul_div_le; auto.
  Qed.

  Lemma ipack_selN_divmod : forall items ix,
    (@Forall block) Rec.well_formed (list_chunk items items_per_val item0) ->
    ix < length items ->
    selN (val2block (selN (ipack items) (ix / items_per_val) $0)) (ix mod items_per_val) item0
    = selN items ix item0.
  Proof.
    unfold ipack; intros.
    rewrite val2block2val_selN_id by auto.
    rewrite list_chunk_spec.
    setoid_rewrite selN_app1.
    rewrite selN_firstn.
    rewrite skipn_selN.
    rewrite Nat.mul_comm.
    rewrite <- Nat.div_mod; auto.
    apply Nat.mod_upper_bound; auto.
    eapply mod_lt_length_firstn_skipn; auto.
  Qed.

  Lemma list_chunk_updN_divmod : forall items ix e,
    ix < length items ->
    updN (list_chunk items items_per_val item0) (ix / items_per_val)
      (updN (selN (list_chunk items items_per_val item0) (ix / items_per_val) block0)
        (ix mod items_per_val) e) =
    list_chunk (updN items ix e) items_per_val item0.
  Proof.
    intros.
    eapply list_selN_ext; intros.
    rewrite length_updN.
    setoid_rewrite list_chunk_length; rewrite length_updN; auto.
    repeat rewrite list_chunk_spec.

    destruct (Nat.eq_dec pos (ix / items_per_val)); subst.
    rewrite selN_updN_eq; unfold setlen.
    setoid_rewrite skipn_length; rewrite length_updN.
    repeat rewrite updN_app1; [ f_equal | ].
    rewrite <- updN_firstn_comm.
    rewrite updN_skipn; repeat f_equal.
    rewrite Nat.mul_comm, Nat.add_comm, <- Nat.div_mod; auto.
    apply mod_lt_length_firstn_skipn; auto.
    setoid_rewrite list_chunk_length.
    apply div_lt_divup; auto.

    rewrite length_updN, list_chunk_length in H0.
    rewrite selN_updN_ne by auto.
    rewrite list_chunk_spec.
    rewrite setlen_skipn_updN_absorb; auto.
    apply not_eq in n; destruct n.
    right; apply lt_div_mul_add_le; auto.
    left; apply div_lt_mul_lt; auto.
  Qed.

  Lemma ipack_updN_divmod : forall items ix e,
    (@Forall block) Rec.well_formed (list_chunk items items_per_val item0) ->
    ix < length items ->
    updN (ipack items) (ix / items_per_val) (block2val
      (updN (val2block (selN (ipack items) (ix / items_per_val) $0)) (ix mod items_per_val) e)) =
    ipack (updN items ix e).
  Proof.
    unfold ipack; intros.
    rewrite val2block2val_selN_id by auto.
    rewrite <- map_updN; f_equal.
    apply list_chunk_updN_divmod; auto.
  Qed.

  Lemma block2val_repeat_item0 :
    block2val (repeat item0 items_per_val) = $0.
  Proof.
    unfold block2val, item0.
    rewrite <- Rec.of_word_zero_list.
    rewrite Rec.to_of_id.
    unfold word2val, eq_rec_r, eq_rect, eq_rec, eq_rect.
    case_eq (eq_sym blocksz_ok); intros; auto.
  Qed.

  Lemma repeat_ipack_item0 : forall n,
    repeat $0 n = ipack (repeat item0 (n * items_per_val)).
  Proof.
    induction n; simpl; intros.
    rewrite ipack_nil; auto.
    rewrite <- repeat_app.
    erewrite ipack_app with (na := 1) by (rewrite repeat_length; omega).
    rewrite cons_app, IHn; f_equal.
    rewrite ipack_one by (rewrite repeat_length; auto); f_equal.
    rewrite block2val_repeat_item0; auto.
  Qed.

  Lemma Forall_wellformed_updN : forall (items : list item) a v,
    Forall Rec.well_formed items ->
    Rec.well_formed v ->
    Forall Rec.well_formed (updN items a v).
  Proof.
    intros.
    rewrite Forall_forall in *; intuition.
    apply in_updN in H1; destruct H1; subst; eauto.
  Qed.

  Lemma synced_list_ipack_length_ok : forall len i items,
    i < len ->
    length items = len * items_per_val ->
    i < length (synced_list (ipack items)).
  Proof.
    intros.
    rewrite synced_list_length, ipack_length.
    setoid_rewrite H0.
    rewrite divup_mul; auto.
  Qed.

  Lemma ipack_length_eq : forall len a b,
    length a = len * items_per_val ->
    length b = len * items_per_val ->
    length (ipack a) = length (ipack b).
  Proof.
    intros.
    repeat rewrite ipack_length.
    setoid_rewrite H; setoid_rewrite H0; auto.
  Qed.

  (* finding an element inside a block *)
  Definition ifind_block (cond : item -> addr -> bool) (vs : block) start : option (addr * item ) :=
    ifind_list cond vs start.

  Lemma ifind_result_inbound :  forall len bn items cond r,
    Forall Rec.well_formed items ->
    bn < len ->
    ifind_block cond (val2block (fst (selN (synced_list (ipack items)) bn ($0, nil))))
      (bn * items_per_val) = Some r ->
    length items = len * items_per_val ->
    fst r < length items.
  Proof.
    intros.
    apply ifind_list_ok_facts with (d := item0) in H1 as [Hm [ Hb [ Hc Hi ] ] ].
    apply list_chunk_wellformed in H.
    rewrite synced_list_selN in Hb; simpl in Hb.
    unfold ipack in *; rewrite val2block2val_selN_id in * by auto.
    rewrite list_chunk_spec, setlen_length in *.

    rewrite H2.
    eapply lt_le_trans; eauto.
    setoid_rewrite <- Nat.mul_1_l at 5.
    rewrite <- Nat.mul_add_distr_r.
    apply Nat.mul_le_mono_r; omega.
  Qed.

  Lemma ifind_result_item_ok : forall len bn items cond r,
    Forall Rec.well_formed items ->
    bn < len ->
    ifind_block cond (val2block (fst (selN (synced_list (ipack items)) bn ($0, nil))))
      (bn * items_per_val) = Some r ->
    length items = len * items_per_val ->
    (snd r) = selN items (fst r) item0.
  Proof.
    intros.
    apply ifind_list_ok_facts with (d := item0) in H1 as [Hm [ Hb [ Hc Hi ] ] ].
    rewrite <- Hi.
    rewrite synced_list_selN; simpl.
    apply list_chunk_wellformed in H.
    rewrite synced_list_selN in Hb; simpl in Hb.
    unfold ipack in *; rewrite val2block2val_selN_id in * by auto.
    rewrite list_chunk_spec, setlen_length in *.
    unfold setlen; rewrite selN_app1.
    rewrite selN_firstn, skipn_selN, le_plus_minus_r by omega; auto.
    rewrite firstn_length, skipn_length.
    apply Nat.min_glb_lt; try omega.
    setoid_rewrite H2.
    apply lt_add_lt_sub in Hb; auto.
    eapply lt_le_trans; eauto.
    rewrite <- Nat.mul_sub_distr_r, <- Nat.mul_1_l at 1.
    apply Nat.mul_le_mono_r; omega.
  Qed.

  Lemma ifind_block_none_progress : forall i ix items v cond len,
    (forall ix, ix < i * items_per_val ->
         cond (selN items ix item0) ix = false) ->
    ifind_block cond (val2block v) (i * items_per_val) = None ->
    v = fst (selN (synced_list (ipack items)) i ($0, nil)) ->
    ix < items_per_val + i * items_per_val ->
    i < len ->
    length items = len * items_per_val ->
    Forall Rec.well_formed items ->
    cond (selN items ix item0) ix = false.
  Proof.
    intros.
    destruct (lt_dec ix (i * items_per_val)); [ eauto | subst ].

    assert (ix < length items).
    setoid_rewrite H4.
    eapply lt_le_trans; eauto.
    setoid_rewrite Nat.mul_comm.
    rewrite Nat.add_comm, mult_n_Sm.
    apply Nat.mul_le_mono_pos_l; auto.

    rewrite <- ipack_selN_divmod; auto.
    rewrite Nat.div_mod with (x := ix) (y := items_per_val) at 3 by auto.
    apply ifind_list_none.
    replace (ix / items_per_val) with i.
    rewrite Nat.mul_comm.
    rewrite synced_list_selN in H0; simpl in H0; auto.

    destruct (lt_eq_lt_dec i (ix / items_per_val)).
    destruct s; auto.
    apply lt_div_mul_add_le in l; auto; omega.
    contradict n.
    apply div_lt_mul_lt; auto.

    unfold ipack; erewrite selN_map.
    rewrite val2block2val_id.
    rewrite list_chunk_spec, setlen_length.
    apply Nat.mod_upper_bound; auto.
    apply Forall_selN.
    apply list_chunk_wellformed; auto.
    setoid_rewrite list_chunk_length; apply div_lt_divup; auto.
    setoid_rewrite list_chunk_length; apply div_lt_divup; auto.
  Qed.

  Definition selN_val2block v idx :=
    Rec.of_word (@Rec.word_selN' itemtype items_per_val idx (val2word v)).
  Definition block2val_updN_val2block v idx item :=
    word2val (@Rec.word_updN' itemtype items_per_val idx (val2word v) (Rec.to_word item)).

  Theorem selN_val2block_equiv : forall v idx item0,
    idx < items_per_val ->
    selN_val2block v idx = selN (val2block v) idx item0.
  Proof.
    unfold selN_val2block; intros.
    erewrite Rec.word_selN'_equiv by auto.
    reflexivity.
  Qed.

  Theorem block2val_updN_val2block_equiv : forall v idx item,
    idx < items_per_val ->
    block2val_updN_val2block v idx item =
    block2val (updN (val2block v) idx item).
  Proof.
    unfold block2val_updN_val2block; intros.
    erewrite Rec.word_updN'_equiv by auto.
    reflexivity.
  Qed.

End RADefs.


Require Import FcEtt.utils.
Require Import FcEtt.imports.

Require Export FcEtt.fset_facts.
Require Export FcEtt.ett_inf.
Require Export FcEtt.tactics.

(* This file contains:

   - Syntactic stuff that should be defined by lngen
     (and that we should get LNgen to generate in the future).

   - Induction principles for the relations.

   - Other tactics that are specialized to the relations.

 *)

Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.

Lemma tm_subst_tm_tm_var : forall a x, tm_subst_tm_tm a x (a_Var_f x) = a.
Proof. intros. simpl. destruct (x == x). auto. done. Qed.

Lemma co_subst_co_co_var : forall a x, co_subst_co_co a x (g_Var_f x) = a.
Proof. intros. simpl. destruct (x == x). auto. done. Qed.

Lemma tm_subst_tm_tm_var_neq : forall a x y, x <> y ->
    tm_subst_tm_tm a y (a_Var_f x) = (a_Var_f x).
Proof. intros. simpl. destruct (x == y). contradiction. auto. Qed.

Lemma co_subst_co_co_var_neq : forall a x y, x <> y ->
    co_subst_co_co a y (g_Var_f x) = (g_Var_f x).
Proof. intros. simpl. destruct (x == y). contradiction. auto. Qed.

Hint Rewrite tm_subst_tm_tm_var co_subst_co_co_var.

(* ----------------------------------------------------- *)

(*
   Some rewriting hints so that we don't have to remember
   all of the various names of the functions/lemmas
   (and so that we can make the tactics more generic).

*)

Hint Rewrite tm_subst_tm_tm_open_tm_wrt_tm_var : subst_open_var.
Hint Rewrite tm_subst_tm_tm_open_tm_wrt_co_var : subst_open_var.
Hint Rewrite tm_subst_tm_co_open_co_wrt_tm_var : subst_open_var.
Hint Rewrite tm_subst_tm_co_open_co_wrt_co_var : subst_open_var.
Hint Rewrite co_subst_co_co_open_co_wrt_co_var : subst_open_var.
Hint Rewrite co_subst_co_co_open_co_wrt_tm_var : subst_open_var.
Hint Rewrite co_subst_co_tm_open_tm_wrt_co_var : subst_open_var.
Hint Rewrite co_subst_co_tm_open_tm_wrt_tm_var : subst_open_var.

Hint Rewrite <- tm_subst_tm_tm_open_tm_wrt_tm_var : open_subst_var.
Hint Rewrite <- co_subst_co_tm_open_tm_wrt_tm_var : open_subst_var.
Hint Rewrite <- tm_subst_tm_tm_open_tm_wrt_co_var : open_subst_var.
Hint Rewrite <- co_subst_co_co_open_co_wrt_co_var : open_subst_var.

Hint Rewrite tm_subst_tm_tm_open_tm_wrt_tm : subst_open.
Hint Rewrite tm_subst_tm_tm_open_tm_wrt_co : subst_open.
Hint Rewrite tm_subst_tm_co_open_co_wrt_tm : subst_open.
Hint Rewrite tm_subst_tm_co_open_co_wrt_co : subst_open.
Hint Rewrite co_subst_co_co_open_co_wrt_co : subst_open.
Hint Rewrite co_subst_co_co_open_co_wrt_tm : subst_open.
Hint Rewrite co_subst_co_tm_open_tm_wrt_co : subst_open.
Hint Rewrite co_subst_co_tm_open_tm_wrt_tm : subst_open.

Hint Rewrite <- tm_subst_tm_tm_open_tm_wrt_tm : open_subst.
Hint Rewrite <- tm_subst_tm_tm_open_tm_wrt_co : open_subst.
Hint Rewrite <- tm_subst_tm_co_open_co_wrt_tm : open_subst.
Hint Rewrite <- tm_subst_tm_co_open_co_wrt_co : open_subst.
Hint Rewrite <- co_subst_co_co_open_co_wrt_co : open_subst.
Hint Rewrite <- co_subst_co_co_open_co_wrt_tm : open_subst.
Hint Rewrite <- co_subst_co_tm_open_tm_wrt_co : open_subst.
Hint Rewrite <- co_subst_co_tm_open_tm_wrt_tm : open_subst.

(* ----------------------------------------------------- *)

(* lc support

   These are some general purpose tactics for solving local closure
   goals. The are used in the lc_mutual proofs, but may also
   be useful elsewhere in the development.

   These tactics generally support forward reasoning which is
   useful for exploratory proof development.

*)

(* Apply a lc constructor for a term with binding. *)
Ltac apply_lc_exists x :=
  pick fresh x;
  ( apply lc_a_Abs_exists      with (x1 := x)
  || apply lc_a_Pi_exists       with (x1 := x)
  || apply lc_a_CPi_exists      with (c1 := x)
  || apply lc_a_CAbs_exists     with (c1 := x)
  || apply lc_a_UAbs_exists     with (x1:= x)
  || apply lc_a_UCAbs_exists    with (c1 := x)
  || apply lc_g_PiCong_exists   with (x1 := x)
  || apply lc_g_AbsCong_exists  with (x1 := x)
  || apply lc_g_CPiCong_exists  with (c1 := x)
  || apply lc_g_CAbsCong_exists with (c1 := x)
  || fail "invalid case for apply_lc_exists" );
  eauto 2.

(* This tactic assists local closure goals when
   we have a 'binds' assumption in the context. *)

(* TODO: replace basic_solve with something more primitive? *)
Ltac lc_solve_binds :=
  match goal with
  (* binds nil case *)
  | [ H : binds ?x ?s nil |- _ ] => inversion H; clear H
  (* binds cons case *)
  | [ H : binds _ ?s (_ ++ _) |- _ ?s] =>
      destruct (binds_cons_1 _ _ _ _ _ _ H); basic_solve; eauto
  (* variable cases *)
  | [ b : binds ?x _ ?G, H : ∀ (x' : atom) _, binds x' _ ?G → _ |- _] =>
      by apply H in b; inversion b; try done;
          match goal with
            | [H' : lc_constraint _ |- _] => inversion H' ; clear H'
            | [H' : lc_tm         _ |- _] => inversion H' ; clear H'
          end
  end.

(* Invert all lc assumptions in the context, using the variable name
   "c" for any lc assumptions about the bodies of binders.  *)
(* TODO: remove split_hyp? *)
(* generalize first case to include context *)
Ltac lc_inversion c :=
  repeat match goal with
    (* inversion for binders *)
  | [ H : forall x, (x `in` ?L -> False) -> lc_tm _ /\ _ |- _ ] =>
    destruct (H c ltac:(auto)); split_hyp; clear H
  (* simple inversions *)
  | [ H : lc_constraint (_ _) |- _ ] =>
    inversion H; clear H
  | [ H : lc_tm (a_Abs _ _ _) |- _ ] =>
    inversion H; clear H
  | [ H : lc_tm (a_UAbs _ _) |- _ ] =>
    inversion H; clear H
  | [ H : lc_tm (a_App _ _ _) |- _ ] =>
    inversion H; clear H
  | [ H : lc_tm (a_Pi _ _ _) |- _ ] =>
    inversion H; clear H
  | [ H : lc_tm (a_Conv _ _ _) |- _ ] =>
    inversion H; clear H
  | [ H : lc_tm (a_CPi _ _) |- _ ] =>
    inversion H; clear H
  | [ H : lc_tm (a_CAbs _ _) |- _ ] =>
    inversion H; clear H
  | [ H : lc_tm (a_UCAbs _) |- _ ] =>
    inversion H; clear H
  | [ H : lc_tm (a_CApp _ _) |- _ ] =>
    inversion H; clear H
  | [ H : lc_tm (a_Pattern _ _ _ _ _) |- _ ] =>
    inversion H; clear H
  | [ H : lc_tm (a_Case _ _) |- _ ] =>
    inversion H; clear H
 end.

Ltac apply_lc_body :=
  match goal with
  | |- lc_tm (open_tm_wrt_tm ?a ?b) => eapply lc_body_tm_wrt_tm; auto
  | |- lc_tm (open_tm_wrt_co ?a ?b) => eapply lc_body_tm_wrt_co; auto
  end.

(* --------------------------------------------------------------------- *)

(* This lemma is an inverse to

    co_subst_co_tm_lc_tm : ∀ (a1 : tm) (g1 : co) (c1 : covar),
       lc_tm a1 → lc_co g1 → lc_tm (co_subst_co_tm g1 c1 a1)

   It shows:

    co_subst_co_tm_lc_tm_inverse : ∀ (a1 : tm) (g1 : co) (c1 : covar),
       lc_co g1 -> lc_tm (co_subst_co_tm g1 c1 a1) -> tc_tm a1

    (Note, the other way around is not true because the variable c1
    may not actually appear in a1, so we cannot conclude anything
    about g1.)
 *)

Lemma co_subst_co_tm_lc_tm_inverse
  : ∀ (g1 : co) (c1 : covar),
      lc_co g1 ->
      (forall A,
          lc_tm A -> forall XX, A = (co_subst_co_tm g1 c1 XX) -> lc_tm XX)
      /\
      (forall b1,
          lc_brs b1 -> forall XX, b1 = (co_subst_co_brs g1 c1 XX) -> lc_brs XX)
      /\
      (forall co,
          lc_co co -> forall XX, co = (co_subst_co_co g1 c1 XX) -> lc_co XX)
      /\
      (forall phi,
          lc_constraint phi -> forall XX, phi = (co_subst_co_constraint g1 c1 XX) ->
          lc_constraint XX).
Proof.
  intros.
  apply lc_tm_lc_brs_lc_co_lc_constraint_mutind.
  all: intros.
  (* simple destruct and inversion. *)
  all: match goal with
       | [H0 : _ = _ ?g1 ?c1 ?XX |- _] =>
         destruct XX; simpl in H0; inversion H0; clear H0; subst; auto
       end.
  all: apply_lc_exists xc;
    match goal with
    | [ H1 : ∀ x XX,
          _ (_ ?g1 ?c1 ?XX2) (_ x) = _ ?g1 ?c1 XX → _ XX |- _ ] =>
      eapply (H1 xc); autorewrite with subst_open; auto
    end.
  all: rewrite co_subst_co_co_var_neq; auto.
Qed.

(* --------------------------------------------------------- *)

Ltac invert_syntactic_equality :=
  repeat match goal with
  | [ H : a_Var_f _  = a_Var_f _ |- _ ] =>
    inversion H; subst; clear H
  | [ H : a_Abs _ _ _ = a_Abs _ _ _ |- _ ] =>
    inversion H; subst; clear H
  | [ H : a_UAbs _ _ = a_UAbs _ _ |- _ ] =>
    inversion H; subst; clear H
  | [ H : a_Pi _ _ _ = a_Pi _ _ _ |- _ ] =>
    inversion H; subst; clear H
  | [ H : a_App _ _ _ = a_App _ _ _ |- _ ] =>
    inversion H; subst; clear H
  | [ H : a_Fam _  = a_Fam _ |- _ ] =>
    inversion H; subst; clear H
  | [ H : a_Conv _ _ _ = a_Conv _ _ _ |- _ ] =>
    inversion H; subst; clear H
  | [ H : a_UCAbs _ = a_UCAbs _ |- _ ] =>
    inversion H; subst; clear H
  | [ H : a_CAbs + _ = a_CAbs _ _ |- _ ] =>
    inversion H; subst; clear H
  | [ H : a_CApp _ _  = a_CApp _ _ |- _ ] =>
    inversion H; subst; clear H
  | [ H : a_CPi _ _ = a_CPi _ _ |- _ ] =>
    inversion H; subst; clear H
  | [ H : a_Pattern _ _ _ _ _ _ = a_Pattern _ _ _ _ _ _ |- _ ] =>
    inversion H; subst; clear H
  | [ H : Eq _ _ _ _ = Eq _ _ _ _ |- _ ] =>
    inversion H; subst; clear H
  end.

(* Invert an "interesting" assumption in the typing context *)
(* TODO: tactics.v -> it should already be subsumed by another tactic (many not for all cases => extend) *)
Ltac ann_invert_clear :=
  match goal with
  | H : AnnTyping _ a_Star _ _ |- _ => inversion H; subst; clear H
  | H : AnnTyping _ (_ _) _ _ |- _ =>  inversion H; subst; clear H
  | H : AnnPropWff _ _ |- _ => inversion H; subst; clear H
  | H : AnnIso _ _ (_ _) _ _ |- _ => inversion H; subst; clear H
  | H : AnnDefEq _ _ (_ _) _ _ _ |- _ => inversion H; subst; clear H
  | H : AnnCtx ([(_,_)] ++ _) |- _ => inversion H; subst; clear H
  | H : AnnCtx (_ :: _) |- _ => inversion H; subst; clear H
  end.

(* ----------------------------- *)

(* By default, swaps apply to tm variables. *)

Lemma lc_swap : forall x x0 a,
    x `notin` fv_tm_tm_tm a ->
    lc_tm (open_tm_wrt_tm a (a_Var_f x)) ->
    lc_tm (open_tm_wrt_tm a (a_Var_f x0)).
Proof.
  intros. rewrite (tm_subst_tm_tm_intro x); auto with lngen.
Qed.

Lemma fv_swap : forall x x0 a,
    x `notin` fv_tm_tm_tm a ->
    x0 `notin` fv_tm_tm_tm a ->
    x `notin` fv_tm_tm_tm (open_tm_wrt_tm a (a_Var_f x)) ->
    x0 `notin` fv_tm_tm_tm (open_tm_wrt_tm a (a_Var_f x0)).
Proof.
  intros.
  destruct (x == x0); subst; auto;
  rewrite (tm_subst_tm_tm_intro x); autorewrite with lngen; auto;
  rewrite fv_tm_tm_tm_open_tm_wrt_tm_upper;
  simpl; fsetdec.
Qed.

(* --------------------------------------------------- *)
(* --------------------------------------------------- *)

(* Induction schemes *)

Scheme typing_ind' := Induction for Typing Sort Prop
   with wff_ind'   := Induction for PropWff Sort Prop
   with iso_ind'   := Induction for Iso Sort Prop
   with defeq_ind' := Induction for DefEq Sort Prop
   with ctx_ind'   := Induction for Ctx Sort Prop.

Combined Scheme typing_wff_iso_defeq_mutual
  from typing_ind',
       wff_ind',
       iso_ind',
       defeq_ind',
       ctx_ind'.

(* --------------------------------------------------- *)

(* Apply the mutual induction hypothesis and add a marker to the
   context indicating the current case (and also making the associated
   data constructor for that case available) as the name 'CON'. *)
Ltac ext_induction CON :=
    apply typing_wff_iso_defeq_mutual;
    [ pose CON :=  E_Star       |
      pose CON :=  E_Var        |
      pose CON :=  E_Pi         |
      pose CON :=  E_Abs        |
      pose CON :=  E_App        |
      pose CON :=  E_TApp       |
      pose CON :=  E_IApp       |
      pose CON :=  E_Conv       |
      pose CON :=  E_CPi        |
      pose CON :=  E_CAbs       |
      pose CON :=  E_CApp       |
      pose CON :=  E_Const      |
      pose CON :=  E_Fam        |
      pose CON :=  E_Case       |
      pose CON :=  E_Wff        |
      pose CON :=  E_PropCong   |
      pose CON :=  E_IsoConv    |
      pose CON :=  E_CPiFst     |
      pose CON :=  E_Assn       |
      pose CON :=  E_Refl       |
      pose CON :=  E_Sym        |
      pose CON :=  E_Trans      |
      pose CON :=  E_Sub        |
      pose CON :=  E_Beta       |
      pose CON :=  E_PiCong     |
      pose CON :=  E_AbsCong    |
      pose CON :=  E_AppCong    |
      pose CON :=  E_TAppCong   |
      pose CON :=  E_IAppCong   |
      pose CON :=  E_PiFst      |
      pose CON :=  E_PiSnd      |
      pose CON :=  E_CPiCong    |
      pose CON :=  E_CAbsCong   |
      pose CON :=  E_CAppCong   |
      pose CON :=  E_CPiSnd     |
      pose CON :=  E_Cast       |
      pose CON :=  E_EqConv     |
      pose CON :=  E_IsoSnd     |
      pose CON :=  E_PatCong    |
      pose CON :=  E_LeftRel    |
      pose CON :=  E_LeftIrrel  |
      pose CON :=  E_Right      |
      pose CON :=  E_CLeft      |
      pose CON :=  E_Empty      |
      pose CON :=  E_ConsTm     |
      pose CON :=  E_ConsCo     ].

Ltac ensure_case C :=
  match goal with [ CON := C |- _ ] => idtac end.

(* --------------------------------------------------- *)

(* Tactic support for freshness *)
(*  What does "fresh" mean for variables? *)

Definition fv_tm_tm_pattern_args (xs:list (pattern_arg)) :=
  fold_right (fun p s => fv_tm_tm_pattern_arg p \u s) empty xs.

Definition fv_tm_tm_pattern_args_rng (xs:list (atom*pattern_arg)) :=
  fv_tm_tm_pattern_args (map snd xs).

Definition fv_co_co_pattern_args (xs:list (pattern_arg)) :=
  fold_right (fun p s => fv_co_co_pattern_arg p \u s) empty xs.

Definition fv_co_co_pattern_args_rng (xs:list (atom*pattern_arg)) :=
  fv_co_co_pattern_args (map snd xs).

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : vars => x) in
  let B := gather_atoms_with (fun x : var => {{ x }}) in
  let C1 := gather_atoms_with (fun x : context => dom x) in
  let C2 := gather_atoms_with (fun x : role_context => dom x) in
  let D1 := gather_atoms_with (fun x => fv_tm_tm_tm x) in
  let D2 := gather_atoms_with (fun x => fv_tm_tm_co x) in
  let D3 := gather_atoms_with (fun x => fv_tm_tm_constraint x) in
  let D4 := gather_atoms_with (fun x => fv_tm_tm_sort x) in
  let D5 := gather_atoms_with (fun x => fv_tm_tm_brs x) in
  let D6 := gather_atoms_with (fun x => fv_co_co_tm x) in
  let D7 := gather_atoms_with (fun x => fv_co_co_co x) in
  let D8 := gather_atoms_with (fun x => fv_co_co_constraint x) in
  let D9 := gather_atoms_with (fun x => fv_co_co_sort x) in
  let D10 := gather_atoms_with (fun x => fv_co_co_brs x) in
  let D11 := gather_atoms_with (fun x => fv_tm_tm_pattern_args_rng x) in
  let D12 := gather_atoms_with (fun x => fv_tm_tm_pattern_args x) in
  let D13 := gather_atoms_with (fun x => fv_co_co_pattern_args_rng x) in
  let D14 := gather_atoms_with (fun x => fv_co_co_pattern_args x) in
  let D15 := gather_atoms_with (fun x => fv_tm_tm_pattern_arg x) in
  let D16 := gather_atoms_with (fun x => fv_co_co_pattern_arg x) in

  constr:(A \u B \u C1 \u C2 \u D1 \u D2 \u D3 \u D4 \u D5 \u D6 \u D7 \u D8 \u D9 \u D10 \u D11 \u D12 \u D13 \u D14 \u D15 \u D16).

(* ----------------------------------------------------- *)

(* Rewrite the goal based on a equation in the context
   (i.e. using an equation from an eta-equivalence rule or from
   one of the Cong rules)
 *)

Ltac rewrite_body :=
  match goal with
  | [ e : ∀ x : atom, (x `in` ?L → False)
      → open_tm_wrt_tm _ (a_Var_f x) = open_tm_wrt_tm _ (_ (a_Var_f x) _) |- _ ] =>
     rewrite e; auto
  | [ e : ∀ x : atom, (x `notin` ?L)
      → open_tm_wrt_tm _ (a_Var_f x) = open_tm_wrt_tm _ (_ (a_Var_f x) _) |- _ ] =>
    rewrite e; auto
  | [ e : ∀ c : atom, (c `notin` ?L)
      → open_tm_wrt_co _ (g_Var_f c) =
        open_tm_wrt_co _ (g_Cast (g_Var_f c) (g_Sym _)) |- _ ] =>
    rewrite e; auto
  | [ e : ∀ x : atom, (x `in` ?L → False) →  _ _ (a_Var_f x) = _ _ _ (a_Var_f x) |- _ ] =>
    rewrite e; auto
  | [ e : ∀ x : atom, (x `notin` ?L) →  _ _ (a_Var_f x) = _ _ _ (a_Var_f x) |- _ ] =>
    rewrite e; auto

  end.

(* Solver for the two lc_mutual proofs. *)
Ltac lc_solve :=
  let c := fresh in
  try lc_solve_binds;
  try apply_lc_exists c;
  lc_inversion c; auto;
  try rewrite_body;
  try apply_lc_body;
  eauto with lc.

(* without these two lines, ext_consist.v fails. *)
Hint Resolve lc_a_Pi_exists
     lc_a_CPi_exists lc_a_Abs_exists lc_a_CAbs_exists lc_a_UAbs_exists.
(* This hint is restricted to lngen in ett_inf. *)
Hint Resolve lc_body_tm_wrt_tm lc_body_tm_wrt_co. (* binds_cons_1 *)

(* ----------------------------- *)

Lemma rho_swap : forall rho x x0 a,
    x `notin` fv_tm_tm_tm a ->
    x0 `notin` fv_tm_tm_tm a ->
    RhoCheck rho x (open_tm_wrt_tm a (a_Var_f x)) ->
    RhoCheck rho x0 (open_tm_wrt_tm a (a_Var_f x0)).
Proof.
  intros rho x x0 a F1 F2 H0.
  inversion H0; subst; constructor.
  +  auto.
  +  eapply fv_swap with (x:=x); eauto.
Qed.

Lemma eta_swap: forall x y a' b rho,
    x `notin` fv_tm_tm_tm a' \u fv_tm_tm_tm b ->
    open_tm_wrt_tm a' (a_Var_f x) = a_App b (Rho rho) (a_Var_f x) ->
    open_tm_wrt_tm a' (a_Var_f y) = a_App b (Rho rho) (a_Var_f y).
Proof.
  intros.
  rewrite (tm_subst_tm_tm_intro x); auto.
  rewrite H0.
  simpl.
  rewrite tm_subst_tm_tm_fresh_eq; auto.
  destruct eq_dec. auto. done.
Qed.

(* ----------------------------------------------------- *)

(* Tactics for working with context in weakening proof *)

Ltac auto_rew_env :=
  multimatch goal with
    | [ |- context [([(?x, ?T)] ++ ?G1 ++ ?G2 ++ ?G3)] ] => rewrite_env (((x ~ (T)) ++ G1) ++ G2 ++ G3)
    | [ |- context [((?x ~ ?T) ++ ?G1 ++ ?G2 ++ ?G3)] ]  => rewrite_env (((x ~ (T)) ++ G1) ++ G2 ++ G3)
  end.

(* -------------- Pick fresh and apply for judgements with binding ----- *)

Ltac E_pick_fresh x :=
  match goal with
    | [ |- Typing _ ?shape _] =>
      let v := match shape with
            | a_Pi _ _ _ => E_Pi
            | a_UAbs _ _ => E_Abs
            | a_CPi _ _  => E_CPi
            | a_CAbs _ _ => E_CAbs
            | a_UCAbs _  => E_CAbs
           end
      in pick fresh x and apply v
    | [ |- DefEq _ _ ?shape ?s2 _ _] =>
      let v := match shape with
               | a_Pi _ _ _ => E_PiCong
               | a_UAbs Rel _ => match s2 with
                                | a_UAbs _ _ => E_AbsCong
                                end
               | a_UAbs _ _ => E_AbsCong
               | a_CPi _ _  => E_CPiCong
               | a_CAbs _ _ => E_CAbsCong
               | a_UCAbs _  => E_CAbsCong
               end
      in pick fresh x and apply v
    | [ |- BranchTyping _ _ _ _ _ _ _ ?shape _ _ ] =>
      let v := multimatch shape with
               (* FIXME: right now, to disambiguate rel/role, we use the
                  simplest strategy - use the first one to work. We could
                  be smarter by trying to match other arguments *)
               | a_Pi Rel _ _ => BranchTyping_PiRel
               | a_Pi Rel _ _ => BranchTyping_PiRole
               | a_Pi Irrel _ _ => BranchTyping_PiIrrel
               | a_CPi _ _ => BranchTyping_CPi
               end
      in pick fresh x and apply v
  end.

Ltac Par_pick_fresh x :=
  match goal with
    | [ |- Par _ ?shape ?s2 ?R ] =>
      let v := match shape with
            | a_Pi _ _ _ => Par_Pi
            | a_UAbs _ _ =>  match s2 with
                                | a_UAbs _ _ => Par_Abs
                                end
            | a_CPi _ _  => Par_CPi
            | a_CAbs _ _ => Par_CAbs
            | a_UCAbs _  => Par_CAbs
           end
      in pick fresh x and apply v
  end.

(* --------------------------------------------------------- *)

Ltac RhoCheck_inversion y :=
  match goal with
  | [ K : ∀ x : atom, x `notin` ?L → RhoCheck ?rho x ?b |- _ ] =>
    move: (K y ltac:(auto)); inversion 1; subst; clear K
  | [ K : ∀ x : atom, (x `in` ?L -> False) → RhoCheck ?rho x ?b |- _ ] =>
    move: (K y ltac:(auto)); inversion 1; subst; clear K
  end.

(* --------------------------------------------------------- *)

Lemma lc_open_switch_co :
  forall g t, lc_co g ->
  lc_tm (open_tm_wrt_co t g_Triv) ->
  lc_tm (open_tm_wrt_co t g).
Proof.
  intros.
  pick fresh c.
  rewrite (co_subst_co_tm_intro c); auto.
  eapply co_subst_co_tm_lc_tm; auto.
  rewrite (co_subst_co_tm_intro c) in H0. fsetdec.
  eapply (@co_subst_co_tm_lc_tm_inverse g_Triv c); eauto 2.
Qed.

Hint Resolve lc_open_switch_co.

Lemma tm_subst_cast : forall a x R g,
    tm_subst_tm_tm a x (a_Conv (a_Var_f x) R g) = a_Conv a R (tm_subst_tm_co a x g).
Proof.
  intros. simpl.
  destruct (x == x). auto.
  done.
Qed.

Hint Rewrite tm_subst_cast.

Lemma nom_bot : forall R, SubRole R Nom -> R = Nom.
Proof. intros. dependent induction H; auto.
Qed.

Lemma rep_top : forall R, SubRole Rep R -> R = Rep.
Proof. intros. dependent induction H; auto.
Qed.

Lemma rep_nsub_nom : ~ SubRole Rep Nom.
Proof. intro. apply nom_bot in H. inversion H.
Qed.

Lemma sub_dec : forall R1 R2, SubRole R1 R2 \/ ~(SubRole R1 R2).
Proof. intros. destruct R1, R2; auto. right. apply rep_nsub_nom.
Qed.

Lemma nsub_sub : forall R1 R2, ~(SubRole R1 R2) -> SubRole R2 R1.
Proof. intros. destruct R1, R2; auto. assert False. apply H; auto.
       inversion H0.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import BinNat.
Local Open Scope N_scope.

(** Obsolete file, see [BinNat] now,
    only compatibility notations remain here. *)

Definition Pdiv_eucl a b := N.pos_div_eucl a (Npos b).

Definition Pdiv_eucl_correct a b :
  let (q,r) := Pdiv_eucl a b in Npos a = q * Npos b + r
 := N.pos_div_eucl_spec a (Npos b).

Lemma Pdiv_eucl_remainder a b :
  snd (Pdiv_eucl a b) < Npos b.
Proof. now apply (N.pos_div_eucl_remainder a (Npos b)). Qed.

Notation Ndiv_eucl := N.div_eucl (compat "8.6").
Notation Ndiv := N.div (compat "8.6").
Notation Nmod := N.modulo (only parsing).

Notation Ndiv_eucl_correct := N.div_eucl_spec (only parsing).
Notation Ndiv_mod_eq := N.div_mod' (only parsing).
Notation Nmod_lt := N.mod_lt (compat "8.6").


Require Import Bedrock.IL Bedrock.Memory Coq.Strings.String.
Require Import Bedrock.Platform.Cito.SyntaxExpr.

Set Implicit Arguments.

Fixpoint eval vs expr :=
  match expr with
    | Var str => vs str
    | Const w => w
    | Binop op a b => evalBinop op (eval vs a) (eval vs b)
    | TestE op a b =>  if evalTest op (eval vs a) (eval vs b) then $1 else $0
  end.


Inductive order :=
    | LESSER
    | EQUAL
    | GREATER.


(**

This file describes the representation and properties of inner-heap predicates.

Author: Bowen Zhang.

Date : 2022.01.06
*)

Set Implicit Arguments.
From SLF (* TLC *) Require Export LibCore TLCbuffer.
From SLF (* CBS *) Require Export Language.

(*** =========== Definition of inner-heap predicates =====================  ***)

(** Core file-heap predicates, and their associated notations:
    - [\f[]] denotes the empty file-heap predicate
    - [\f[P]] denotes a pure file fact
    - [p ~f~> v] denotes a singleton file-heap
    - [H1 \f* H2] denotes the file-heap predicates separating conjunction
    - [\existsf x, H] denotes an existential (about file)
    - [\forallf x, H] denotes a universal (about file)
    - [ Hf \f-* Hf' ] denotes magic wand in file-heap predicates
*)

(** Core block-heap predicates, and their associated notations:
    - [\b[]] denotes the empty block-heap predicate
    - [\b[P]] denotes a pure block fact
    - [p ~b~> v] denotes a singleton block-heap
    - [H1 \b* H2] denotes the block-heap predicates separating conjunction
    - [\existsb x, H] denotes an existential (about block)
    - [\forallb x, H] denotes a universal (about block)
    - [ Hb \b-* Hb' ] denotes magic wand in block-heap predicates
*)

Definition hbprop := heapb -> Prop.
Definition hfprop := heapf -> Prop.

Implicit Types P : Prop.
Implicit Types Hb : hbprop.
Implicit Types Hf : hfprop.
Implicit Types Qb : val->hbprop.
Implicit Types Qf : val->hfprop.

(*** =============================================== ***)
Definition hbempty : hbprop :=
  fun h => (h = Fmap.empty).

Definition hfempty : hfprop :=
  fun h => (h = Fmap.empty).

Notation "\b[]" := (hbempty)
  (at level 0) : hprop_scope.
Notation "\f[]" := (hfempty)
  (at level 0) : hprop_scope.

(* singleton *)

Definition hbsingle (b:bloc) (ln:list int) : hbprop :=
  fun h => (h = Fmap.single b ln /\ b <> bnull).

Definition hfsingle (f:floc) (lb:list bloc) : hfprop :=
  fun h => (h = Fmap.single f lb /\ f <> fnull).

Notation "b '~b~>' ln" := (hbsingle b ln) (at level 32) : hprop_scope.
Notation "f '~f~>' lb" := (hfsingle f lb) (at level 32) : hprop_scope.

(* sep star *)

Definition hbstar (H1 H2 : hbprop) : hbprop :=
  fun h => exists h1 h2, H1 h1
                              /\ H2 h2
                              /\ Fmap.disjoint h1 h2
                              /\ h = Fmap.union h1 h2.

Definition hfstar (H1 H2 : hfprop) : hfprop :=
  fun h => exists h1 h2, H1 h1
                              /\ H2 h2
                              /\ Fmap.disjoint h1 h2
                              /\ h = Fmap.union h1 h2.

Notation "H1 '\b*' H2" := (hbstar H1 H2)
  (at level 41, right associativity) : hprop_scope.
Notation "H1 '\f*' H2" := (hfstar H1 H2)
  (at level 41, right associativity) : hprop_scope.

Notation "Q \b*+ H" := (fun x => hbstar (Q x) H)
  (at level 40) : hprop_scope.

Notation "Q \f*+ H" := (fun x => hfstar (Q x) H)
  (at level 40) : hprop_scope.

(* sep exists *)
Definition hbexists {A:Type} (J:A->hbprop) : hbprop :=
  fun h => exists x, J x h.

Definition hfexists {A:Type} (J:A->hfprop) : hfprop :=
  fun h => exists x, J x h.

Notation "'\existsb' x1 .. xn , H" :=
  (hbexists (fun x1 => .. (hbexists (fun xn => H)) ..))
  (at level 39, x1 binder, H at level 50, right associativity,
   format "'[' '\existsb' '/ '  x1  ..  xn , '/ '  H ']'") : hprop_scope.

Notation "'\existsf' x1 .. xn , H" :=
  (hfexists (fun x1 => .. (hfexists (fun xn => H)) ..))
  (at level 39, x1 binder, H at level 50, right associativity,
   format "'[' '\existsf' '/ '  x1  ..  xn , '/ '  H ']'") : hprop_scope.

(* sep forall *)

Definition hbforall {A : Type} (J : A -> hbprop) : hbprop :=
  fun h => forall x, J x h.

Definition hfforall {A : Type} (J : A -> hfprop) : hfprop :=
  fun h => forall x, J x h.

Notation "'\forallb' x1 .. xn , H" :=
  (hbforall (fun x1 => .. (hbforall (fun xn => H)) ..))
  (at level 39, x1 binder, H at level 50, right associativity,
   format "'[' '\forallb' '/ '  x1  ..  xn , '/ '  H ']'") : hprop_scope.

Notation "'\forallf' x1 .. xn , H" :=
  (hfforall (fun x1 => .. (hfforall (fun xn => H)) ..))
  (at level 39, x1 binder, H at level 50, right associativity,
   format "'[' '\forallf' '/ '  x1  ..  xn , '/ '  H ']'") : hprop_scope.

(* sep pure *)
Open Scope hprop_scope.

Definition hbpure (P:Prop) : hbprop :=
  \existsb (p:P), \b[].

Definition hfpure (P:Prop) : hfprop :=
  \existsf (p:P), \f[].

Notation "\b[ P ]" := (hbpure P)
  (at level 0, format "\b[ P ]") : hprop_scope.

Notation "\f[ P ]" := (hfpure P)
  (at level 0, format "\f[ P ]") : hprop_scope.

(* ================================================================= *)
(** ** Basic properties of Inner-heap predicates operators *)

(* ----------------------------------------------------------------- *)
(** *** Tactic for automation *)

Hint Extern 1 (_ = _ :> heap) => fmap_eq.

Import Fmap.DisjointHints.

Tactic Notation "fmap_disjoint_pre" :=
  subst; rew_disjoint; jauto_set.

Hint Extern 1 (Fmap.disjoint _ _) => fmap_disjoint_pre.

(* ----------------------------------------------------------------- *)
(** the entailment relation *)

Definition hbimpl (H1 H2:hbprop) : Prop :=
  forall h, H1 h -> H2 h.
Definition hfimpl (H1 H2:hfprop) : Prop :=
  forall h, H1 h -> H2 h.

Notation "H1 =b=> H2" := (hbimpl H1 H2) (at level 55) : hprop_scope.
Notation "H1 =f=> H2" := (hfimpl H1 H2) (at level 55) : hprop_scope.

Definition qbimpl {A} (Q1 Q2:A->hbprop) : Prop :=
  forall (v:A), Q1 v =b=> Q2 v.
Definition qfimpl {A} (Q1 Q2:A->hfprop) : Prop :=
  forall (v:A), Q1 v =f=> Q2 v.

Notation "Q1 =b==> Q2" := (qbimpl Q1 Q2) (at level 55) : hprop_scope.
Notation "Q1 =f==> Q2" := (qfimpl Q1 Q2) (at level 55) : hprop_scope.

(*------------magic wand---------------*)
Definition hbwand (Hb1 Hb2:hbprop) : hbprop :=
  \existsb (Hb0:hbprop), Hb0 \b* \b[(Hb1 \b* Hb0) =b=> Hb2].

Definition hfwand (Hf1 Hf2:hfprop) : hfprop :=
  \existsf (Hf0:hfprop), Hf0 \f* \f[(Hf1 \f* Hf0) =f=> Hf2].

Notation "H1 \b-* H2" := (hbwand H1 H2) (at level 43, right associativity).
Notation "H1 \f-* H2" := (hfwand H1 H2) (at level 43, right associativity).

Definition qfwand (Q1 Q2:val->hfprop) : hfprop :=
  \existsf H0, H0 \f* \f[ Q1 \f*+ H0 =f==> Q2 ].

Definition qbwand (Q1 Q2:val->hbprop) : hbprop :=
  \existsb H0, H0 \b* \b[ Q1 \b*+ H0 =b==> Q2 ].

Notation "Q1 \f--* Q2" := (qfwand Q1 Q2) (at level 43).
Notation "Q1 \b--* Q2" := (qbwand Q1 Q2) (at level 43).

(*------the order relation in the set of inner-heap predicate--------*)
(* refl *)
Lemma hbimpl_refl : forall H,
  H =b=> H.
Proof using. introv M. auto. Qed.

Lemma hfimpl_refl : forall H,
  H =f=> H.
Proof using. introv M. auto. Qed.

Hint Resolve hbimpl_refl.
Hint Resolve hfimpl_refl.

(* trans *)

Lemma hbimpl_trans : forall H2 H1 H3,
  (H1 =b=> H2) ->
  (H2 =b=> H3) ->
  (H1 =b=> H3).
Proof using. introv M1 M2. unfolds* hbimpl. Qed.

Lemma hfimpl_trans : forall H2 H1 H3,
  (H1 =f=> H2) ->
  (H2 =f=> H3) ->
  (H1 =f=> H3).
Proof using. introv M1 M2. unfolds* hfimpl. Qed.

Lemma hbimpl_trans_r : forall H2 H1 H3,
   H2 =b=> H3 ->
   H1 =b=> H2 ->
   H1 =b=> H3.
Proof using. introv M1 M2. applys* hbimpl_trans M2 M1. Qed.

Lemma hfimpl_trans_r : forall H2 H1 H3,
   H2 =f=> H3 ->
   H1 =f=> H2 ->
   H1 =f=> H3.
Proof using. introv M1 M2. applys* hfimpl_trans M2 M1. Qed.

(* antisym *)

Lemma hbimpl_antisym : forall H1 H2,
  (H1 =b=> H2) ->
  (H2 =b=> H1) ->
  (H1 = H2).
Proof using. introv M1 M2. applys pred_ext_1. intros h. iff*. Qed.

Lemma hfimpl_antisym : forall H1 H2,
  (H1 =f=> H2) ->
  (H2 =f=> H1) ->
  (H1 = H2).
Proof using. introv M1 M2. applys pred_ext_1. intros h. iff*. Qed.

Lemma hbprop_op_comm : forall (op:hbprop->hbprop->hbprop),
  (forall H1 H2, op H1 H2 =b=> op H2 H1) ->
  (forall H1 H2, op H1 H2 = op H2 H1).
Proof using. introv M. intros. applys hbimpl_antisym; applys M. Qed.

Lemma hfprop_op_comm : forall (op:hfprop->hfprop->hfprop),
  (forall H1 H2, op H1 H2 =f=> op H2 H1) ->
  (forall H1 H2, op H1 H2 = op H2 H1).
Proof using. introv M. intros. applys hfimpl_antisym; applys M. Qed.

Lemma qbimpl_refl : forall A (Q:A->hbprop),
   Q =b==> Q.
Proof using. intros. unfolds*. Qed.

Lemma qfimpl_refl : forall A (Q:A->hfprop),
   Q =f==> Q.
Proof using. intros. unfolds*. Qed.

Hint Resolve qbimpl_refl.
Hint Resolve qfimpl_refl.

(*++++++++++ Some properties +++++++++++++*)
(* ----------------------------------------------------------------- *)
(** *** Properties of [hempty] *)

Lemma hb_empty_intro :
  \b[] hb_empty.
Proof using. unfolds*. Qed.

Lemma hb_empty_inv : forall h,
  \b[] h ->
  h = hb_empty.
Proof using. auto. Qed.

Lemma hf_empty_intro :
  \f[] hf_empty.
Proof using. unfolds*. Qed.

Lemma hf_empty_inv : forall h,
  \f[] h ->
  h = hf_empty.
Proof using. auto. Qed.

(* ----------------------------------------------------------------- *)
(** *** Properties of [hstar] *)

Lemma hbstar_intro : forall (H1 H2:hbprop) h1 h2,
  H1 h1 ->
  H2 h2 ->
  Fmap.disjoint h1 h2 ->
  (H1 \b* H2) (Fmap.union h1 h2).
Proof using. intros. exists~ h1 h2. Qed.

Lemma hbstar_inv : forall H1 H2 h,
  (H1 \b* H2) h ->
  exists h1 h2, H1 h1 /\ H2 h2 /\ Fmap.disjoint h1 h2 /\ h = Fmap.union h1 h2.
Proof using. introv M. applys M. Qed.

Lemma hfstar_intro : forall (H1 H2:hfprop) h1 h2,
  H1 h1 ->
  H2 h2 ->
  Fmap.disjoint h1 h2 ->
  (H1 \f* H2) (Fmap.union h1 h2).
Proof using. intros. exists~ h1 h2. Qed.

Lemma hfstar_inv : forall H1 H2 h,
  (H1 \f* H2) h ->
  exists h1 h2, H1 h1 /\ H2 h2 /\ Fmap.disjoint h1 h2 /\ h = Fmap.union h1 h2.
Proof using. introv M. applys M. Qed.

Lemma hbstar_comm : forall H1 H2,
   H1 \b* H2 = H2 \b* H1.
Proof using.
  applys hbprop_op_comm. unfold hbprop, hbstar. intros H1 H2.
  intros h (h1&h2&M1&M2&D&U). rewrite~ Fmap.union_comm_of_disjoint in U.
  exists* h2 h1.
Qed.

Lemma hfstar_comm : forall H1 H2,
   H1 \f* H2 = H2 \f* H1.
Proof using.
  applys hfprop_op_comm. unfold hbprop, hfstar. intros H1 H2.
  intros h (h1&h2&M1&M2&D&U). rewrite~ Fmap.union_comm_of_disjoint in U.
  exists* h2 h1.
Qed.

Lemma hbstar_assoc : forall H1 H2 H3,
  (H1 \b* H2) \b* H3 = H1 \b* (H2 \b* H3).
Proof using.
  intros H1 H2 H3. applys hbimpl_antisym; intros h.
  { intros (h'&h3&(h1&h2&M3&M4&D'&U')&M2&D&U). subst h'.
    exists h1 (h2 \+ h3). splits~. { applys* hbstar_intro. } rewrite~ union_assoc in U. }
  { intros (h1&h'&M1&(h2&h3&M3&M4&D'&U')&D&U). subst h'.
    exists (h1 \+ h2) h3. splits~. { applys* hbstar_intro. } rewrite <- union_assoc in U. auto. }
Qed.

Lemma hfstar_assoc : forall H1 H2 H3,
  (H1 \f* H2) \f* H3 = H1 \f* (H2 \f* H3).
Proof using.
  intros H1 H2 H3. applys hfimpl_antisym; intros h.
  { intros (h'&h3&(h1&h2&M3&M4&D'&U')&M2&D&U). subst h'.
    exists h1 (h2 \+ h3). splits~. { applys* hfstar_intro. } rewrite~ union_assoc in U. }
  { intros (h1&h'&M1&(h2&h3&M3&M4&D'&U')&D&U). subst h'.
    exists (h1 \+ h2) h3. splits~. { applys* hfstar_intro. } rewrite <- union_assoc in U. auto. }
Qed.

Lemma hbstar_hempty_l : forall H,
  \b[] \b* H = H.
Proof using.
  intros. applys hbimpl_antisym; intros h.
  { intros (h1&h2&M1&M2&D&U). forwards E: hb_empty_inv M1. subst.
    rewrite~ Fmap.union_empty_l. }
  { intros M. exists hb_empty h. splits~. { applys hb_empty_intro. } rewrite~ union_empty_l. }
Qed.

Lemma hfstar_hempty_l : forall H,
  \f[] \f* H = H.
Proof using.
  intros. applys hfimpl_antisym; intros h.
  { intros (h1&h2&M1&M2&D&U). forwards E: hf_empty_inv M1. subst.
    rewrite~ Fmap.union_empty_l. }
  { intros M. exists hf_empty h. splits~. { applys hf_empty_intro. } rewrite~ union_empty_l. }
Qed.

Lemma hbstar_hempty_r : forall (H:hbprop),
  H \b* \b[] = H.
Proof using.
  applys neutral_r_of_comm_neutral_l. applys~ hbstar_comm. applys~ hbstar_hempty_l.
Qed.

Lemma hfstar_hempty_r : forall (H:hfprop),
  H \f* \f[] = H.
Proof using.
  applys neutral_r_of_comm_neutral_l. applys~ hfstar_comm. applys~ hfstar_hempty_l.
Qed.

Lemma hbimpl_frame_l : forall (H2 H1 H1':hbprop) ,
  H1 =b=> H1' ->
  (H1 \b* H2) =b=> (H1' \b* H2).
Proof using. introv W (h1&h2&?). exists* h1 h2. Qed.

Lemma hfimpl_frame_l : forall (H2 H1 H1':hfprop) ,
  H1 =f=> H1' ->
  (H1 \f* H2) =f=> (H1' \f* H2).
Proof using. introv W (h1&h2&?). exists* h1 h2. Qed.

Lemma hbimpl_frame_r : forall H1 H2 H2',
  H2 =b=> H2' ->
  (H1 \b* H2) =b=> (H1 \b* H2').
Proof using.
  introv M. do 2 rewrite (@hbstar_comm H1). applys~ hbimpl_frame_l.
Qed.

Lemma hfimpl_frame_r : forall H1 H2 H2',
  H2 =f=> H2' ->
  (H1 \f* H2) =f=> (H1 \f* H2').
Proof using.
  introv M. do 2 rewrite (@hfstar_comm H1). applys~ hfimpl_frame_l.
Qed.

Lemma hbimpl_frame_lr : forall H1 H1' H2 H2',
  H1 =b=> H1' ->
  H2 =b=> H2' ->
  (H1 \b* H2) =b=> (H1' \b* H2').
Proof using.
  introv M1 M2. applys hbimpl_trans. applys~ hbimpl_frame_l M1. applys~ hbimpl_frame_r.
Qed.

Lemma hfimpl_frame_lr : forall H1 H1' H2 H2',
  H1 =f=> H1' ->
  H2 =f=> H2' ->
  (H1 \f* H2) =f=> (H1' \f* H2').
Proof using.
  introv M1 M2. applys hfimpl_trans. applys~ hfimpl_frame_l M1. applys~ hfimpl_frame_r.
Qed.

Lemma hbimpl_hstar_trans_l : forall H1 H2 H3 H4,
  H1 =b=> H2 ->
  H2 \b* H3 =b=> H4 ->
  H1 \b* H3 =b=> H4.
Proof using.
  introv M1 M2. applys hbimpl_trans M2. applys hbimpl_frame_l M1.
Qed.

Lemma hfimpl_hstar_trans_l : forall H1 H2 H3 H4,
  H1 =f=> H2 ->
  H2 \f* H3 =f=> H4 ->
  H1 \f* H3 =f=> H4.
Proof using.
  introv M1 M2. applys hfimpl_trans M2. applys hfimpl_frame_l M1.
Qed.

Lemma hbimpl_hstar_trans_r : forall H1 H2 H3 H4,
  H1 =b=> H2 ->
  H3 \b* H2 =b=> H4 ->
  H3 \b* H1 =b=> H4.
Proof using.
  introv M1 M2. applys hbimpl_trans M2. applys hbimpl_frame_r M1.
Qed.

Lemma hfimpl_hstar_trans_r : forall H1 H2 H3 H4,
  H1 =f=> H2 ->
  H3 \f* H2 =f=> H4 ->
  H3 \f* H1 =f=> H4.
Proof using.
  introv M1 M2. applys hfimpl_trans M2. applys hfimpl_frame_r M1.
Qed.

Lemma hbstar_hexists : forall A (J:A->hbprop) H,
  (hbexists J) \b* H = hbexists (fun x => (J x) \b* H).
Proof using.
  intros. applys hbimpl_antisym; intros h.
  { intros (h1&h2&(x&M1)&M2&D&U). exists~ x h1 h2. }
  { intros (x&(h1&h2&M1&M2&D&U)). exists h1 h2. splits~. { exists~ x. } }
Qed.

Lemma hfstar_hexists : forall A (J:A->hfprop) H,
  (hfexists J) \f* H = hfexists (fun x => (J x) \f* H).
Proof using.
  intros. applys hfimpl_antisym; intros h.
  { intros (h1&h2&(x&M1)&M2&D&U). exists~ x h1 h2. }
  { intros (x&(h1&h2&M1&M2&D&U)). exists h1 h2. splits~. { exists~ x. } }
Qed.

Lemma hbstar_hforall : forall H A (J:A->hbprop),
  (hbforall J) \b* H =b=> hbforall (J \b*+ H).
Proof using.
  intros. intros h M. destruct M as (h1&h2&M1&M2&D&U). intros x. exists~ h1 h2.
Qed.

Lemma hfstar_hforall : forall H A (J:A->hfprop),
  (hfforall J) \f* H =f=> hfforall (J \f*+ H).
Proof using.
  intros. intros h M. destruct M as (h1&h2&M1&M2&D&U). intros x. exists~ h1 h2.
Qed.

(* ----------------------------------------------------------------- *)
(** ***  Properties of [hpure] *)

Lemma hbpure_intro : forall P,
  P ->
  \b[P] hb_empty.
Proof using. introv M. exists M. unfolds*. Qed.

Lemma hfpure_intro : forall P,
  P ->
  \f[P] hf_empty.
Proof using. introv M. exists M. unfolds*. Qed.

Lemma hbpure_inv : forall P h,
  \b[P] h ->
  P /\ h = hb_empty.
Proof using. introv (p&M). split~. Qed.

Lemma hfpure_inv : forall P h,
  \f[P] h ->
  P /\ h = hf_empty.
Proof using. introv (p&M). split~. Qed.

Lemma hbstar_hpure : forall P H h,
  (\b[P] \b* H) h = (P /\ H h).
Proof using.
  intros. apply prop_ext. unfold hbpure.
  rewrite hbstar_hexists. rewrite* hbstar_hempty_l.
  iff (p&M) (p&M). { split~. } { exists~ p. }
Qed.

Lemma hfstar_hpure : forall P H h,
  (\f[P] \f* H) h = (P /\ H h).
Proof using.
  intros. apply prop_ext. unfold hfpure.
  rewrite hfstar_hexists. rewrite* hfstar_hempty_l.
  iff (p&M) (p&M). { split~. } { exists~ p. }
Qed.

Lemma hbstar_hpure_iff : forall P H h,
  (\b[P] \b* H) h <-> (P /\ H h).
Proof using. intros. rewrite* hbstar_hpure. Qed.

Lemma hfstar_hpure_iff : forall P H h,
  (\f[P] \f* H) h <-> (P /\ H h).
Proof using. intros. rewrite* hfstar_hpure. Qed.

Lemma hbimpl_hstar_hpure_r : forall P H H',
  P ->
  (H =b=> H') ->
  H =b=> (\b[P] \b* H').
Proof using. introv HP W. intros h K. rewrite* hbstar_hpure. Qed.

Lemma hfimpl_hstar_hpure_r : forall P H H',
  P ->
  (H =f=> H') ->
  H =f=> (\f[P] \f* H').
Proof using. introv HP W. intros h K. rewrite* hfstar_hpure. Qed.

Lemma hbpure_inv_hempty : forall P h,
  \b[P] h ->
  P /\ \b[] h.
Proof using.
  introv M. rewrite <- hbstar_hpure. rewrite~ hbstar_hempty_r.
Qed.

Lemma hfpure_inv_hempty : forall P h,
  \f[P] h ->
  P /\ \f[] h.
Proof using.
  introv M. rewrite <- hfstar_hpure. rewrite~ hfstar_hempty_r.
Qed.

Lemma hbpure_intro_hempty : forall P h,
  \b[] h ->
  P ->
  \b[P] h.
Proof using.
  introv M N. rewrite <- (hbstar_hempty_l \b[P]).
  rewrite hbstar_comm. rewrite~ hbstar_hpure.
Qed.

Lemma hfpure_intro_hempty : forall P h,
  \f[] h ->
  P ->
  \f[P] h.
Proof using.
  introv M N. rewrite <- (hfstar_hempty_l \f[P]).
  rewrite hfstar_comm. rewrite~ hfstar_hpure.
Qed.

Lemma hbimpl_hempty_hpure : forall P,
  P ->
  \b[] =b=> \b[P].
Proof using. introv HP. intros h Hh. applys* hbpure_intro_hempty. Qed.

Lemma hfimpl_hempty_hpure : forall P,
  P ->
  \f[] =f=> \f[P].
Proof using. introv HP. intros h Hh. applys* hfpure_intro_hempty. Qed.

Lemma hbimpl_hstar_hpure_l : forall P H H',
  (P -> H =b=> H') ->
  (\b[P] \b* H) =b=> H'.
Proof using.
  introv W Hh. rewrite hbstar_hpure in Hh. applys* W.
Qed.

Lemma hfimpl_hstar_hpure_l : forall P H H',
  (P -> H =f=> H') ->
  (\f[P] \f* H) =f=> H'.
Proof using.
  introv W Hh. rewrite hfstar_hpure in Hh. applys* W.
Qed.

Lemma hbempty_eq_hpure_true :
  \b[] = \b[True].
Proof using.
  applys hbimpl_antisym; intros h M.
  { applys* hbpure_intro_hempty. }
  { forwards*: hbpure_inv_hempty M. }
Qed.

Lemma hfempty_eq_hpure_true :
  \f[] = \f[True].
Proof using.
  applys hfimpl_antisym; intros h M.
  { applys* hfpure_intro_hempty. }
  { forwards*: hfpure_inv_hempty M. }
Qed.

Lemma hbfalse_hstar_any : forall H,
  \b[False] \b* H = \b[False].
Proof using.
  intros. applys hbimpl_antisym; intros h; rewrite hbstar_hpure; intros M.
  { false*. } { lets: hbpure_inv_hempty M. false*. }
Qed.

Lemma hffalse_hstar_any : forall H,
  \f[False] \f* H = \f[False].
Proof using.
  intros. applys hfimpl_antisym; intros h; rewrite hfstar_hpure; intros M.
  { false*. } { lets: hfpure_inv_hempty M. false*. }
Qed.

(* ----------------------------------------------------------------- *)
(** *** Properties of [hexists] *)

Lemma hbexists_intro : forall A (x:A) (J:A->hbprop) h,
  J x h ->
  (hbexists J) h.
Proof using. intros. exists~ x. Qed.

Lemma hfexists_intro : forall A (x:A) (J:A->hfprop) h,
  J x h ->
  (hfexists J) h.
Proof using. intros. exists~ x. Qed.

Lemma hbexists_inv : forall A (J:A->hbprop) h,
  (hbexists J) h ->
  exists x, J x h.
Proof using. intros. destruct H as [x H]. exists~ x. Qed.

Lemma hfexists_inv : forall A (J:A->hfprop) h,
  (hfexists J) h ->
  exists x, J x h.
Proof using. intros. destruct H as [x H]. exists~ x. Qed.

Lemma hbimpl_hexists_l : forall A H (J:A->hbprop),
  (forall x, J x =b=> H) ->
  (hbexists J) =b=> H.
Proof using. introv W. intros h (x&Hh). applys* W. Qed.

Lemma hbimpl_hexists_r : forall A (x:A) H J,
  (H =b=> J x) ->
  H =b=> (hbexists J).
Proof using. introv W. intros h. exists x. apply~ W. Qed.

Lemma hfimpl_hexists_l : forall A H (J:A->hfprop),
  (forall x, J x =f=> H) ->
  (hfexists J) =f=> H.
Proof using. introv W. intros h (x&Hh). applys* W. Qed.

Lemma hfimpl_hexists_r : forall A (x:A) H J,
  (H =f=> J x) ->
  H =f=> (hfexists J).
Proof using. introv W. intros h. exists x. apply~ W. Qed.

(* ----------------------------------------------------------------- *)
(** *** Properties of [hforall] *)

Lemma hbforall_intro : forall A (J:A->hbprop) h,
  (forall x, J x h) ->
  (hbforall J) h.
Proof using. introv M. applys* M. Qed.

Lemma hfforall_intro : forall A (J:A->hfprop) h,
  (forall x, J x h) ->
  (hfforall J) h.
Proof using. introv M. applys* M. Qed.

Lemma hbforall_inv : forall A (J:A->hbprop) h,
  (hbforall J) h ->
  forall x, J x h.
Proof using. introv M. applys* M. Qed.

Lemma hfforall_inv : forall A (J:A->hfprop) h,
  (hfforall J) h ->
  forall x, J x h.
Proof using. introv M. applys* M. Qed.

Lemma hbimpl_hforall_r : forall A (J:A->hbprop) H,
  (forall x, H =b=> J x) ->
  H =b=> (hbforall J).
Proof using. introv M. intros h Hh x. apply~ M. Qed.

Lemma hbimpl_hforall_l : forall A x (J:A->hbprop) H,
  (J x =b=> H) ->
  (hbforall J) =b=> H.
Proof using. introv M. intros h Hh. apply~ M. Qed.

Lemma hfimpl_hforall_r : forall A (J:A->hfprop) H,
  (forall x, H =f=> J x) ->
  H =f=> (hfforall J).
Proof using. introv M. intros h Hh x. apply~ M. Qed.

Lemma hfimpl_hforall_l : forall A x (J:A->hfprop) H,
  (J x =f=> H) ->
  (hfforall J) =f=> H.
Proof using. introv M. intros h Hh. apply~ M. Qed.

Lemma hbforall_specialize : forall A (x:A) (J:A->hbprop),
  (hbforall J) =b=> (J x).
Proof using. intros. applys* hbimpl_hforall_l x. Qed.

Lemma hfforall_specialize : forall A (x:A) (J:A->hfprop),
  (hfforall J) =f=> (J x).
Proof using. intros. applys* hfimpl_hforall_l x. Qed.

(* ----------------------------------------------------------------- *)
(** *** Properties of [hsingle] *)

Lemma hbsingle_intro : forall p (v:list int),
  p <> bnull ->
  (p ~b~> v) (Fmap.single p v).
Proof using. introv N. hnfs*. Qed.

Lemma hfsingle_intro : forall p (v:list bloc),
  p <> fnull ->
  (p ~f~> v) (Fmap.single p v).
Proof using. introv N. hnfs*. Qed.

Lemma hfsingle_inv: forall p (v:list bloc) h,
  (p ~f~> v) h ->
  h = Fmap.single p v /\ p <> fnull.
Proof using. auto. Qed.

Lemma hbsingle_inv: forall p (v:list int) h,
  (p ~b~> v) h ->
  h = Fmap.single p v /\ p <> bnull.
Proof using. auto. Qed.

Lemma hbsingle_not_null : forall p (v:list int),
  (p ~b~> v) =b=> (p ~b~> v) \b* \b[p <> bnull].
Proof using.
  introv. intros h (K&N). rewrite hbstar_comm, hbstar_hpure.
  split*. subst. applys* hbsingle_intro.
Qed.

Lemma hfsingle_not_null : forall p (v:list bloc),
  (p ~f~> v) =f=> (p ~f~> v) \f* \f[p <> fnull].
Proof using.
  introv. intros h (K&N). rewrite hfstar_comm, hfstar_hpure.
  split*. subst. applys* hfsingle_intro.
Qed.

Lemma hbstar_hsingle_same_loc : forall p (v1 v2:list int),
  (p ~b~> v1) \b* (p ~b~> v2) =b=> \b[False].
Proof using.
  intros. unfold hbsingle. intros h (h1&h2&E1&E2&D&E). false.
  subst. applys* Fmap.disjoint_single_single_same_inv.
Qed.

Lemma hfstar_hsingle_same_loc : forall p (v1 v2:list bloc),
  (p ~f~> v1) \f* (p ~f~> v2) =f=> \f[False].
Proof using.
  intros. unfold hfsingle. intros h (h1&h2&E1&E2&D&E). false.
  subst. applys* Fmap.disjoint_single_single_same_inv.
Qed.
Arguments hbstar_hsingle_same_loc : clear implicits.
Arguments hfstar_hsingle_same_loc : clear implicits.

(*-------------------Properties of magic wand-----------------------*)
Lemma hfwand_equiv : forall Hf0 Hf1 Hf2,
  (Hf0 =f=> Hf1 \f-* Hf2) <-> (Hf1 \f* Hf0 =f=> Hf2).
Proof using.
  unfold hfwand. iff M.
  - intros h.
    intros (h1&h2&NA&NB&NC&ND).
    apply M in NB.
    destruct NB as (Hf&NB).
    rewrite hfstar_comm in NB.
    apply hfstar_hpure_iff in NB as (NB1&NB2).
    apply NB1. rewrite ND.
    applys~ hfstar_intro.
  - intros h N.
    exists Hf0.
    rewrite hfstar_comm, hfstar_hpure_iff.
    splits~.
Qed.

Lemma hbwand_equiv : forall Hb0 Hb1 Hb2,
  (Hb0 =b=> Hb1 \b-* Hb2) <-> (Hb1 \b* Hb0 =b=> Hb2).
Proof using.
  unfold hfwand. iff M.
  - intros h.
    intros (h1&h2&NA&NB&NC&ND).
    apply M in NB.
    destruct NB as (Hf&NB).
    rewrite hbstar_comm in NB.
    apply hbstar_hpure_iff in NB as (NB1&NB2).
    apply NB1. rewrite ND.
    applys~ hbstar_intro.
  - intros h N.
    exists Hb0.
    rewrite hbstar_comm, hbstar_hpure_iff.
    splits~.
Qed.

Lemma hfimpl_hwand_r : forall Hf0 Hf1 Hf2,
  (Hf1 \f* Hf0) =f=> Hf2 ->
  Hf0 =f=> (Hf1 \f-* Hf2).
Proof.
  introv M. applys hfwand_equiv. applys M.
Qed.

Lemma hbimpl_hwand_r : forall Hb0 Hb1 Hb2,
  (Hb1 \b* Hb0) =b=> Hb2 ->
  Hb0 =b=> (Hb1 \b-* Hb2).
Proof.
  introv M. applys hbwand_equiv. applys M.
Qed.

Lemma hfimpl_hwand_r_inv : forall Hf0 Hf1 Hf2,
  Hf0 =f=> (Hf1 \f-* Hf2) ->
  (Hf1 \f* Hf0) =f=> Hf2.
Proof. introv M. applys hfwand_equiv. applys M. Qed.

Lemma hbimpl_hwand_r_inv : forall Hb0 Hb1 Hb2,
  Hb0 =b=> (Hb1 \b-* Hb2) ->
  (Hb1 \b* Hb0) =b=> Hb2.
Proof. introv M. applys hbwand_equiv. applys M. Qed.

Lemma hfwand_cancel : forall Hf1 Hf2,
  Hf1 \f* (Hf1 \f-* Hf2) =f=> Hf2.
Proof. intros. applys hfimpl_hwand_r_inv. applys hfimpl_refl. Qed.

Lemma hbwand_cancel : forall Hb1 Hb2,
  Hb1 \b* (Hb1 \b-* Hb2) =b=> Hb2.
Proof. intros. applys hbimpl_hwand_r_inv. applys hbimpl_refl. Qed.

Arguments hfwand_cancel : clear implicits.
Arguments hbwand_cancel : clear implicits.

Lemma qfwand_equiv : forall Hf Q1 Q2,
  Hf =f=> (Q1 \f--* Q2)  <->  (Q1 \f*+ Hf) =f==> Q2.
Proof.
  unfold qfwand. iff M.
  - intros v h.
    intros (h1&h2&NA&NB&NC&ND).
    apply M in NB.
    destruct NB as (Hf'&NB).
    rewrite hfstar_comm in NB.
    apply hfstar_hpure_iff in NB as (NB1&NB2).
    apply NB1. rewrite ND.
    applys~ hfstar_intro.
  - intros h N.
    exists Hf.
    rewrite hfstar_comm, hfstar_hpure_iff.
    splits~.
Qed.

Lemma qbwand_equiv : forall Hb Q1 Q2,
  Hb =b=> (Q1 \b--* Q2)  <->  (Q1 \b*+ Hb) =b==> Q2.
Proof.
  unfold qbwand. iff M.
  - intros v h.
    intros (h1&h2&NA&NB&NC&ND).
    apply M in NB.
    destruct NB as (Hf'&NB).
    rewrite hbstar_comm in NB.
    apply hbstar_hpure_iff in NB as (NB1&NB2).
    apply NB1. rewrite ND.
    applys~ hbstar_intro.
  - intros h N.
    exists Hb.
    rewrite hbstar_comm, hbstar_hpure_iff.
    splits~.
Qed.

Lemma qfwand_cancel : forall Q1 Q2,
  Q1 \f*+ (Q1 \f--* Q2) =f==> Q2.
Proof. intros. rewrite <- qfwand_equiv. applys qfimpl_refl. Qed.

Lemma qbwand_cancel : forall Q1 Q2,
  Q1 \b*+ (Q1 \b--* Q2) =b==> Q2.
Proof. intros. rewrite <- qbwand_equiv. applys qbimpl_refl. Qed.

Lemma qfwand_specialize : forall (v:val) (Q1 Q2:val->hfprop),
  (Q1 \f--* Q2) =f=> (Q1 v \f-* Q2 v).
Proof.
  intros. unfold qfwand, hfwand.
  intros h M.
  destruct M as (Hf&M).
  rewrite hfstar_comm in M.
  apply hfstar_hpure_iff in M as (MA&MB).
  exists Hf.
  rewrite hfstar_comm, hfstar_hpure_iff.
  splits~.
Qed.

Lemma qbwand_specialize : forall (v:val) (Q1 Q2:val->hbprop),
  (Q1 \b--* Q2) =b=> (Q1 v \b-* Q2 v).
Proof.
  intros. unfold qbwand, hbwand.
  intros h M.
  destruct M as (Hb&M).
  rewrite hbstar_comm in M.
  apply hbstar_hpure_iff in M as (MA&MB).
  exists Hb.
  rewrite hbstar_comm, hbstar_hpure_iff.
  splits~.
Qed.