(* Sequent Calculus for First- and Second-Order Additive Linear Logic *)

From Coq Require Import Wf_nat Lia.
From Quantifiers Require Import formulas.

Set Implicit Arguments.

Parameter vatom : DecType.
Parameter tatom : Type.
Parameter satom : DecType.
Parameter fatom : Type.
Inductive Ncon := top_con.
Inductive Bcon := wth_con.
Inductive Qcon := frl_con.

Notation term := (@term vatom tatom nat).
Notation tclosed t := (tvars t = nil).
Notation rtclosed r := (forall n, tclosed (r n)).
Notation "↑ r" := (felift (evar 0) r) (at level 25, format "↑ r").
Notation "↑2 r" := (feslift (sevar _ 0) r) (at level 25, format "↑2 r").
Notation "v ⇓" := (fesubs v) (at level 18, format "v ⇓").
Notation "F ⇓2" := (fessubs F) (at level 18, format "F ⇓2").
Notation "A ⟦ r ⟧" := (esubs r A) (at level 8, left associativity, format "A ⟦ r ⟧").
Notation "A ⟦ r ⟧2" := (essubs r A) (at level 8, left associativity, format "A ⟦ r ⟧2").
Notation "A [ u // x ]" := (subs x u A) (at level 8, format "A [ u // x ]").
Notation "A [ F // X ]2" := (ssubs X F A) (at level 8, format "A [ F // X ]2").
Notation "⇑" := fup.
Notation "⇑2" := (sfup nat).
Notation "A ↑" := (A⟦⇑⟧) (at level 8, format "A ↑").
Notation "A ↑2" := (A⟦⇑2⟧2) (at level 8, format "A ↑2").
Notation fclosed A := (freevars A = nil).
Notation rfclosed r := (forall n, fclosed (r n)).
Notation sclosed A := (sfreevars A = nil).
Notation rsclosed r := (forall n, sclosed (r n)).

Notation formula := (@formula vatom tatom satom fatom Ncon Nocon Bcon Qcon Qcon nat nat).
Notation top := (fnul nat nat top_con).
Notation wth := (fbin wth_con).
Notation frl := (fqtf frl_con).
Notation frl2 := (sqtf frl_con).
Definition evar_nat := (@evar vatom tatom nat).
Coercion evar_nat : nat >-> term.
Definition sevar_nat := (@sevar vatom tatom satom fatom Ncon Nocon Bcon Qcon Qcon nat nat).
Coercion sevar_nat : nat >-> formula.
Notation sevar := (sevar nat).

#[local] Hint Resolve closed_fesubs : term_db.
#[local] Hint Resolve closed_felift : term_db.
#[local] Hint Resolve fclosed_fessubs : term_db.
#[local] Hint Resolve sclosed_fessubs : term_db.
#[local] Hint Resolve fclosed_feslift : term_db.
#[local] Hint Resolve sclosed_feslift : term_db.

#[local] Hint Rewrite (@felift_esubs vatom tatom satom fatom Ncon Nocon Bcon Qcon Qcon) : term_db.
#[local] Hint Rewrite (@feslift_esubs vatom tatom satom fatom Ncon Nocon Bcon Qcon Qcon) : term_db.
#[local] Hint Rewrite (@felift_essubs vatom tatom satom fatom Ncon Nocon Bcon Qcon Qcon) : term_db.
#[local] Hint Rewrite (@feslift_essubs vatom tatom satom fatom Ncon Nocon Bcon Qcon Qcon) : term_db.
#[local] Hint Rewrite (@esubs_fup vatom tatom satom fatom Ncon Nocon Bcon Qcon Qcon) : term_db.
#[local] Hint Rewrite (@essubs_fup vatom tatom satom fatom Ncon Nocon Bcon Qcon Qcon) : term_db.
#[local] Hint Rewrite (@subs_esubs vatom tatom satom fatom Ncon Nocon Bcon Qcon Qcon)
                        using try tauto; auto with term_db : term_db.
#[local] Hint Rewrite (@ssubs_esubs vatom tatom satom fatom Ncon Nocon Bcon Qcon Qcon)
                        using try tauto; auto with term_db : term_db.
#[local] Hint Rewrite (@subs_essubs vatom tatom satom fatom Ncon Nocon Bcon Qcon Qcon)
                        using try tauto; auto with term_db : term_db.
#[local] Hint Rewrite (@ssubs_essubs vatom tatom satom fatom Ncon Nocon Bcon Qcon Qcon)
                        using try tauto; auto with term_db : term_db.
#[local] Hint Rewrite (@freevars_fup vatom tatom satom fatom Ncon Nocon Bcon Qcon Qcon) : term_db.
#[local] Hint Rewrite (@sfreevars_fup vatom tatom satom fatom Ncon Nocon Bcon Qcon Qcon) : term_db.

(** * Proofs *)

(** Proofs *)
(** two-sided sequent calculus for (additive) linear logic with connectives: top, with, forall, forall2 *)
Inductive prove : formula -> formula -> Type :=
| ax A : prove A A
| topr C : prove C top
| wdgr C A B : prove C A -> prove C B -> prove C (wth A B)
| wdgll A C B : prove A C -> prove (wth A B) C
| wdglr A C B : prove A C -> prove (wth B A) C
| frlr [x C A] : prove (C↑) A↑[0//x] -> prove C (frl x A)
| frll [x A C] u : tclosed u -> prove A[u//x] C -> prove (frl x A) C
| frl2r [X C A] : prove (C↑2) A↑2[0//X]2 -> prove C (frl2 X A)
| frl2l [X A C] F : fclosed F -> sclosed F -> prove A[F//X]2 C -> prove (frl2 X A) C.
#[local] Hint Constructors prove : term_db.

(** height of proofs *)
Fixpoint psize A B (pi : prove A B) : nat :=
match pi with
| ax _ | topr _ => 1
| wdgr pi1 pi2 => S (max (psize pi1) (psize pi2))
| wdgll _ pi1 | wdglr _ pi1 => S (psize pi1)
| frlr pi1 | frll _ _ pi1 | frl2r pi1 | frl2l _ _ _ pi1 => S (psize pi1)
end.

(** proofs with atomic axioms *)
Fixpoint atomic_proof A B (pi : prove A B) : Prop :=
match pi with
| ax A => atomic A
| topr _ => True
| wdgr pi1 pi2 => atomic_proof pi1 /\ atomic_proof pi2
| wdgll _ pi1 | wdglr _ pi1 | frlr pi1 | frll _ _ pi1 | frl2r pi1 | frl2l _ _ _ pi1 => atomic_proof pi1
end.

(** apply [r] in proof [pi] *)
Theorem pesubs r (Hc : rtclosed r) C A (pi : prove C A) : { pi' : prove C⟦r⟧ A⟦r⟧ & psize pi' = psize pi }.
Proof.
induction pi in r, Hc |- *;
  try (destruct (IHpi r) as [pi' Hs]);
  try (destruct (IHpi1 r) as [pi1' Hs1]);
  try (destruct (IHpi2 r) as [pi2' Hs2]); trivial.
- now exists (ax _).
- now exists (topr _).
- exists (wdgr pi1' pi2'). cbn. auto.
- exists (wdgll _ pi'). cbn. auto.
- exists (wdglr _ pi'). cbn. auto.
- clear pi' Hs. destruct (IHpi (↑r)) as [pi' Hs]; [ intuition | ].
  cbn. rewrite <- Hs. clear Hs.
  rnow revert pi'.
  exists (frlr pi'). reflexivity.
- cbn. rewrite <- Hs. clear Hs.
  rnow revert pi'.
  rewrite <- (tvars_tesubs_closed r _ Hc) in e.
  exists (frll _ e pi'). reflexivity.
- clear pi' Hs. destruct (IHpi r) as [pi' Hs]; [ intuition | ].
  cbn. rewrite <- Hs. clear Hs.
  rnow revert pi'.
  exists (frl2r pi'). reflexivity.
- cbn. rewrite <- Hs. clear Hs.
  rnow revert pi'.
  rewrite <- (freevars_esubs_closed r) in e by assumption.
  rewrite <- (sfreevars_esubs r) in e0.
  exists (frl2l _ e e0 pi'). reflexivity.
Qed.

Theorem pessubs r (Hcf : rfclosed r) (Hcs : rsclosed r) C A (pi : prove C A) :
  { pi' : prove C⟦r⟧2 A⟦r⟧2 & psize pi' = psize pi }.
Proof.
induction pi in r, Hcf, Hcs |- *;
  try (destruct (IHpi r) as [pi' Hs]);
  try (destruct (IHpi1 r) as [pi1' Hs1]);
  try (destruct (IHpi2 r) as [pi2' Hs2]); trivial.
- now exists (ax _).
- now exists (topr _).
- exists (wdgr pi1' pi2'). cbn. auto.
- exists (wdgll _ pi'). cbn. auto.
- exists (wdglr _ pi'). cbn. auto.
- clear pi' Hs. destruct (IHpi (fun n => (r n)↑)) as [pi' Hs]; rcauto.
  cbn. rewrite <- Hs. clear Hs.
  rnow (rnow revert pi').
  exists (frlr pi'). reflexivity.
- cbn. rewrite <- Hs. clear Hs.
  rnow revert pi'.
  exists (frll _ e pi'). reflexivity.
- clear pi' Hs. destruct (IHpi (↑2r)) as [pi' Hs]; [ rcauto | rcauto | ].
  cbn. rewrite <- Hs. clear Hs.
  rnow revert pi'.
  exists (frl2r pi'). reflexivity.
- cbn. rewrite <- Hs. clear Hs.
  rnow revert pi'.
  rewrite <- (freevars_essubs_closed _ _ Hcf) in e.
  rewrite <- (sfreevars_essubs_closed _ _ Hcs) in e0.
  exists (frl2l _ e e0 pi'). reflexivity.
Qed.

(** * Cut Elimination *)

Theorem cutr A B C : prove A B -> prove B C -> prove A C.
Proof.
enough (forall n, forall A B C (pi1 : prove A B) (pi2 : prove B C), n = psize pi1 + psize pi2 -> prove A C) as IH
  by (intros pi1 pi2; apply (IH _ _ _ _ pi1 pi2 eq_refl)). clear A B C.
induction n as [n IH0] using lt_wf_rect; intros; subst.
assert (forall A B C (pi1' : prove A B) (pi2' : prove B C),
          psize pi1' + psize pi2' < psize pi1 + psize pi2 -> prove A C) as IH
  by (intros; eapply IH0; [ eassumption | reflexivity ]); clear IH0.
destruct pi2; intuition.
- apply wdgr.
  + apply (IH _ _ _ pi1 pi2_1). cbn. lia.
  + apply (IH _ _ _ pi1 pi2_2). cbn. lia.
- enough (forall A D (pi1 : prove A D) A0 B C (pi2 : prove A0 C)
              (IH : forall A1 B0 C0 (pi1' : prove A1 B0) (pi2' : prove B0 C0),
                psize pi1' + psize pi2' < psize pi1 + psize (wdgll B pi2) -> prove A1 C0),
         D = wth A0 B -> prove A C) as IH2
    by (eapply IH2; [ eassumption | reflexivity ]); clear.
  intros A D pi1; destruct pi1; intros; inversion H; subst;
    try (constructor; apply (IH _ _ _ pi1 (wdgll _ pi2)); cbn; lia).
  + now apply wdgll.
  + apply (IH _ _ _ pi1_1 pi2). cbn. lia.
  + apply (frll u); [ assumption | ].
    apply (IH _ _ _ pi1 (wdgll _ pi2)). cbn. lia.
  + apply (frl2l F); [ assumption | assumption | ].
    apply (IH _ _ _ pi1 (wdgll _ pi2)). cbn. lia.
- enough (forall A D (pi1 : prove A D) A0 B C (pi2 : prove A0 C)
              (IH : forall A1 B0 C0 (pi1' : prove A1 B0) (pi2' : prove B0 C0),
                 psize pi1' + psize pi2' < psize pi1 + psize (wdglr B pi2) -> prove A1 C0),
         D = wth B A0 -> prove A C) as IH2
    by (eapply IH2 ; [ eassumption | reflexivity ]); clear.
  intros A D pi1; destruct pi1; intros; inversion H; subst;
    try (constructor; apply (IH _ _ _ pi1 (wdglr _ pi2)); cbn; lia).
  + now apply wdglr.
  + apply (IH _ _ _ pi1_2 pi2). cbn. lia.
  + apply (frll u); [ assumption | ].
    apply (IH _ _ _ pi1 (wdglr _ pi2)). cbn. lia.
  + apply (frl2l F); [ assumption | assumption | ].
    apply (IH _ _ _ pi1 (wdglr _ pi2)). cbn. lia.
- destruct (pesubs ⇑ closed_fup pi1) as [pi1' Hs].
  apply frlr, (IH _ _ _ pi1' pi2). cbn. lia.
- enough (forall A D (pi1 : prove A D) x A0 C u e (pi2 : prove A0[u//x] C)
              (IH : forall A1 B C0 (pi1' : prove A1 B) (pi2' : prove B C0),
                 psize pi1' + psize pi2' < psize pi1 + psize (frll u e pi2) -> prove A1 C0),
         D = frl x A0 -> prove A C) as IH2
    by (eapply IH2; [ eassumption | reflexivity ]); clear.
  intros A D pi1; destruct pi1; intros; inversion H; subst;
    try (constructor; apply (IH _ _ _ pi1 (frll _ e pi2)); cbn; lia).
  + now apply (frll u).
  + destruct (pesubs (u⇓) (closed_fesubs _ e) pi1) as [pi1' Hs].
    simpl in IH. rewrite <- Hs in IH. clear Hs.
    rnow revert pi1' IH.
    apply (IH _ _ _ pi1' pi2). lia.
  + apply (frll u); [ assumption | ].
    apply (IH _ _ _ pi1 (frll _ e0 pi2)). cbn. lia.
  + apply (frl2l F); [ assumption | assumption | ].
    apply (IH _ _ _ pi1 (frll _ e1 pi2)). cbn. lia.
- destruct (pessubs ⇑2 fclosed_sfup sclosed_sfup pi1) as [pi1' Hs].
  apply frl2r, (IH _ _ _ pi1' pi2). cbn. lia.
- enough (forall A D (pi1 : prove A D) X A0 C F e e' (pi2 : prove A0[F//X]2 C)
              (IH : forall A1 B C0 (pi1' : prove A1 B) (pi2' : prove B C0),
                 psize pi1' + psize pi2' < psize pi1 + psize (frl2l F e e' pi2) -> prove A1 C0),
         D = frl2 X A0 -> prove A C) as IH2
    by (eapply IH2; [ eassumption | reflexivity ]); clear.
  intros A D pi1; destruct pi1; intros; inversion H; subst;
    try (constructor; apply (IH _ _ _ pi1 (frl2l _ e e' pi2)); cbn; lia).
  + now apply (frl2l F).
  + apply (frll u); [ assumption | ].
    apply (IH _ _ _ pi1 (frl2l _ e0 e' pi2)). cbn. lia.
  + destruct (pessubs (F⇓2) (fclosed_fessubs _ e) (sclosed_fessubs _ e') pi1) as [pi1' Hs].
    simpl in IH. rewrite <- Hs in IH. clear Hs.
    rnow revert pi1' IH.
    apply (IH _ _ _ pi1' pi2). lia.
  + apply (frl2l F); [ assumption | assumption | ].
    apply (IH _ _ _ pi1 (frl2l _ e1 e' pi2)). cbn. lia.
Qed.

(** * Axiom expansion *)

Lemma ax_gen_size A : { pi : prove A A | atomic_proof pi & psize pi < 2 * fsize A }.
Proof.
enough (Hn : forall n A, fsize A = n -> { pi : prove A A | atomic_proof pi & psize pi < 2 * fsize A })
  by (eapply Hn; reflexivity).
clear A. intro n. induction n as [n IH] using lt_wf_rect. intros A <-.
destruct A; [ | | | destruct n | destruct n | destruct b | destruct q | destruct q ].
- exists (ax _); [ constructor | cbn; lia ].
- exists (ax _); [ constructor | cbn; lia ].
- exists (ax _); [ constructor | cbn; lia ].
- exists (topr _); [ constructor | cbn; lia ].
- assert (fsize A1 < fsize (wth A1 A2)) as Hs1 by (cbn; lia).
  destruct (IH _ Hs1 _ eq_refl) as [pi1 Hat1 Hsize1].
  assert (fsize A2 < fsize (wth A1 A2)) as Hs2 by (cbn; lia).
  destruct (IH _ Hs2 _ eq_refl) as [pi2 Hat2 Hsize2].
  exists (wdgr (wdgll A2 pi1) (wdglr A1 pi2)); [ constructor; assumption | cbn; lia ].
- assert (fsize (A↑[0//c]) < fsize (frl c A)) as Hs.
  { rewrite fsize_subs, fsize_esubs. cbn. lia. }
  destruct (IH _ Hs _ eq_refl) as [pi Hat Hsize].
  exists (frlr (frll 0 eq_refl pi : prove ((frl c A)↑) _)); [ assumption | cbn in *; lia ].
- assert (fsize (A↑2[0//c]2) < fsize (frl2 c A)) as Hs.
  { rewrite fsize_ssubs_atomic, fsize_sfup by constructor. cbn. lia. }
  destruct (IH _ Hs _ eq_refl) as [pi Hat Hsize].
  exists (frl2r (frl2l 0 eq_refl eq_refl pi : prove ((frl2 c A)↑2) _)); [ assumption | cbn in *; lia ].
Qed.

Lemma ax_gen A : prove A A.
Proof. apply (ax_gen_size A). Qed.

Lemma ax_exp A B : prove A B -> { pi : prove A B | atomic_proof pi }.
Proof.
intros pi0. induction pi0.
- destruct (ax_gen_size A) as [pi Hat _].
  exists pi. exact Hat.
- exists (topr _). constructor.
- destruct IHpi0_1 as [pi1 Hat1], IHpi0_2 as [pi2 Hat2].
  exists (wdgr pi1 pi2). constructor; assumption.
- destruct IHpi0 as [pi Hat].
  exists (wdgll B pi). assumption.
- destruct IHpi0 as [pi Hat].
  exists (wdglr B pi). assumption.
- destruct IHpi0 as [pi Hat].
  exists (frlr pi). assumption.
- destruct IHpi0 as [pi Hat].
  exists (frll _ e pi). assumption.
- destruct IHpi0 as [pi Hat].
  exists (frl2r pi). assumption.
- destruct IHpi0 as [pi Hat].
  exists (frl2l _ e e0 pi). assumption.
Qed.

(** * Hilbert style properties *)

Lemma frl_elim A u x : tclosed u -> prove (frl x A) A[u//x].
Proof. intros Hc. apply (frll u), ax_gen. exact Hc. Qed.

Lemma frl_wth A B x : prove (frl x (wth A B)) (wth (frl x A) (frl x B)).
Proof. repeat constructor; cbn; apply (frll 0); cbn; constructor; apply ax_gen. Qed.

Lemma frl_nfree A x : ~ In x (freevars A) -> prove A (frl x A).
Proof. intros Hnf. apply frlr. rewrite nfree_subs; [ apply ax_gen | rcauto ]. Qed.


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

(** Finite sets of integer intervals *)

(** "Raw", non-dependent implementation.  A set of intervals is a
  list of nonempty semi-open intervals [(lo, hi)],
  sorted in increasing order of the low bound,
  and with no overlap nor adjacency between elements.
  In particular, if the list contains [(lo1, hi1)] followed by [(lo2, hi2)],
  we have [lo1 < hi1 < lo2 < hi2]. *)

Require Import String.
Require Import ZArith.
Require Import Znumtheory.
Require Import List.
Require Import Bool.
Require Import Lia.

Require Import MirrorSolve.FirstOrder.

Require Import MirrorSolve.BV.
Require Import MirrorSolve.SMT.
Require Import MirrorSolve.UF.

Require Import MirrorSolve.Reflection.Core.
Require Import MirrorSolve.Reflection.FM.
Require Import MirrorSolve.Reflection.Tactics.
Require Import MirrorSolve.Automation.Equations.
From Hammer Require Import Hammer.

Require Import MirrorSolve.Crush.

Ltac hammer' := timeout 60 hammer.
Ltac crush' := timeout 60 crush.

Section IntvSets.

  (*** MS BEGIN {"type": "definition"} *)
  Inductive t := Nil | Cons (lo hi: Z) (tl: t).

  Hint Constructors t.

  Fixpoint In (x: Z) (s: t) :=
    match s with
    | Nil => False
    | Cons l h s' => l <= x < h \/ In x s'
    end.

  Inductive ok: t -> Prop :=
    | ok_nil: ok Nil
    | ok_cons: forall l h s
        (BOUNDS: l < h)
        (BELOW: forall x, In x s -> h < x)
        (OK: ok s),
        ok (Cons l h s).

  Hint Constructors ok.

  Equations mem (x: Z) (s: t) : bool := {
    mem _ Nil := false;
    mem x (Cons l h s') := ite (Z.ltb x h) (Z.leb l x) (mem x s');
  }.

  Equations contains (L H: Z) (s: t) : bool := {
    contains _ _ Nil := false;
    contains L H (Cons l h s') := (Z.leb H h && Z.leb l L) || contains L H s';
  }.

  Equations add (L H: Z) (s: t) : t := {
    add L H Nil := Cons L H Nil;
    add L H (Cons l h s') :=
      ite (Z.ltb h L) (Cons l h (add L H s')) (
      ite (Z.ltb H l) (Cons L H (Cons l h s'))
        (add (Z.min l L) (Z.max h H) s'));
  }.

  Equations remove (L H: Z) (s: t) : t := {
    remove _ _ Nil := Nil ;
    remove L H (Cons l h s') :=
      ite (Z.ltb h L) (Cons l h (remove L H s'))
      (ite (Z.ltb H l) (Cons l h s')
      (ite (Z.ltb l L)
        (ite (Z.ltb H h) (Cons l L (Cons H h s')) (Cons l L (remove L H s')))
        (ite (Z.ltb H h) (Cons H h s') (remove L H s'))))
  }.

  Fixpoint inter (s1 s2: t) {struct s1} : t :=
    let fix intr (s2: t) : t :=
      match s1, s2 with
      | Nil, _ => Nil
      | _, Nil => Nil
      | Cons l1 h1 s1', Cons l2 h2 s2' =>
          if Z.leb h1 l2 then inter s1' s2
          else if Z.leb h2 l1 then intr s2'
          else if Z.leb l1 l2 then
            if Z.leb h2 h1 then Cons l2 h2 (intr s2') else Cons l2 h1 (inter s1' s2)
          else
            if Z.leb h1 h2 then Cons l1 h1 (inter s1' s2) else Cons l1 h2 (intr s2')
      end
    in intr s2.

  MetaCoq Run (infer_equations inter).

  Equations union (s1 s2: t) : t := {
    union Nil s2 := s2;
    union s1 Nil := s1;
    union (Cons l1 h1 s1') (Cons l2 h2 s2') := add l1 h1 (add l2 h2 (union s1' s2'))
  }.

  Equations beq (s1 s2: t) : bool := {
    beq Nil Nil := true;
    beq (Cons l1 h1 t1) (Cons l2 h2 t2) := Z.eqb l1 l2 && Z.eqb h1 h2 && beq t1 t2;
    beq _ _ := false;
  }.
  (*** MS END {"type": "definition"} *)

  MetaCoq Run (infer_equations In).

  (*** MS EFFORT {"type": "lemma"} *)
  Lemma ok_nil':
    ok Nil <-> True.
  Proof.
    intuition eauto.
  Qed.

  (*** MS EFFORT {"type": "lemma"} *)
  Lemma ok_cons':
    forall l h t,
      (l < h /\ (forall x, In x t -> h < x) /\ ok t) <->
      ok (Cons l h t).
  Proof.
    intuition eauto;
    match goal with
    | H: ok _ |- _ =>
      inversion H; subst; clear H
    end;
    intuition eauto.
  Qed.

  Local Declare ML Module "mirrorsolve".

  From MetaCoq.Template Require Import All Loader.
  Import MCMonadNotation.
  Require Import MirrorSolve.Config.
  Open Scope bs.

  (* Unset Universe Polymorphism. *)

  (* MirrorSolve's automation needs this later. *)
  Universe foo.
  MetaCoq Quote Definition typ_term := Type@{foo}.

  Notation pack x := (existT _ _ x).

  Definition fun_syms : list Config.packed := ([
      pack IntvSets.mem
    ; pack IntvSets.contains
    ; pack IntvSets.add
    ; pack IntvSets.remove
    ; pack IntvSets.union
    ; pack IntvSets.beq
    ; pack IntvSets.t
    ; pack Z.ltb
    ; pack Z.leb
    ; pack (@ite t)
    ; pack Z.max
    ; pack Z.min
    ; pack orb
    ; pack andb
    ; pack (@ite Z)
    ; pack (@ite bool)
    ; pack inter
    ; pack Z.eqb
  ])%type.

  Definition rel_syms : list Config.packed := ([
      pack IntvSets.In
    ; pack IntvSets.ok
    ; pack Z.lt
    ; pack Z.gt
    ; pack Z.le
  ])%type.

  Definition prim_syms : list (Config.packed * String.string) := [
      (pack Z.lt, "<"%string)
    ; (pack Z.gt, ">"%string)
    ; (pack Z.ltb, "<"%string)
    ; (pack Z.gtb, ">"%string)
    ; (pack Z.le, "<="%string)
    ; (pack Z.leb, "<="%string)
    ; (pack Z.eqb, "="%string)
    ; (pack (@ite Z), "ite"%string)
    ; (pack (@ite t), "ite"%string)
    ; (pack (@ite bool), "ite"%string)
    ; (pack orb, "or"%string)
    ; (pack andb, "and"%string)
  ].

  MetaCoq Run (
    xs <- add_funs typ_term fun_syms rel_syms ;;
    xs' <- tmQuote xs ;;
    tmMkDefinition "trans_tbl" xs'
  ).

  MetaCoq Run (
    gen_sig typ_term sorts fol_funs fol_rels
  ).
  MetaCoq Run (
    gen_interp_funs sorts interp_sorts fol_funs trans_tbl
  ).
  MetaCoq Run (
    gen_interp_rels sorts interp_sorts fol_rels trans_tbl
  ).
  Definition fm_model := Build_model sig interp_sorts interp_funs interp_rels.
  MetaCoq Run (
    match Utils.find _ _ smt_fun_base_beq IntLit (Utils.flip trans_tbl.(mp_consts)) with
    | Some v => add_const_wf_instance sig fm_model v IntLit
    | None => tmReturn tt
    end
  ).
  MetaCoq Run (
    match Utils.find _ _ smt_fun_base_beq BoolLit (Utils.flip trans_tbl.(mp_consts)) with
    | Some v => add_const_wf_instance sig fm_model v BoolLit
    | None => tmReturn tt
    end
  ).
  MetaCoq Run (
    add_matches sig fm_model trans_tbl
  ).
  MetaCoq Run (
    ctx <- build_printing_ctx sig sort_Prop trans_tbl prim_syms;;
    ctx' <- tmEval all ctx ;;
    rhs <- tmQuote ctx' ;;
    tmMkDefinition "fol_theory" rhs
  ).

  Require Import MirrorSolve.Reflection.Tactics.

  Transparent denote_tm.
  Require Import MirrorSolve.Axioms.

  (* We make use of the verification trick of negating the goal and checking for unsat.
    The check_unsat_neg tactic behaves like idtac if the negated goal is unsat and otherwise fails.
    *)
  Ltac check_goal_unsat :=
    match goal with
    | |- ?G => check_unsat_neg_func fol_theory G; eapply UnsoundAxioms.interp_true
    end.

  Create HintDb intvsets_eqns.

  Ltac prep_proof :=
    hints_foreach (fun x => pose proof x) "intvsets_eqns";
    Utils.revert_all;
    unfold "<->" in *.

  Scheme Equality for sorts.

  Ltac quote_reflect_intvsets := quote_reflect sig fm_model sorts_eq_dec match_tacs match_sorts.

  Ltac mirrorsolve :=
    timeout 60 (prep_proof;
    quote_reflect_intvsets;
    check_goal_unsat).

  (*** MS EFFORT {"type": "lemma"} *)
  Lemma z_max_eq:
    forall x y, Z.max x y = ite (Z.ltb x y) y x.
  Proof.
    intros.
    destruct (_ <? _)%Z eqn:?;
    simpl;
    lia.
  Qed.
  (*** MS EFFORT {"type": "lemma"} *)
  Lemma z_min_eq:
    forall x y, Z.min x y = ite (Z.ltb x y) x y.
  Proof.
    intros.
    destruct (_ <? _)%Z eqn:?;
    simpl;
    lia.
  Qed.

  Hint Immediate z_max_eq : intvsets_eqns.
  Hint Immediate z_min_eq : intvsets_eqns.

  Hint Immediate mem_equation_1 : intvsets_eqns.
  Hint Immediate mem_equation_2 : intvsets_eqns.

  Hint Immediate In_equation_1 : intvsets_eqns.
  Hint Immediate In_equation_2 : intvsets_eqns.

  Hint Immediate ok_nil' : intvsets_eqns.
  Hint Immediate ok_cons': intvsets_eqns.

  Set MirrorSolve Solver "cvc5".

  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 2, "ms": 2, "hammer": 1, "crush": 1} *)
  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma mem_In:
    forall x s,
      ok s ->
      (mem x s = true <-> IntvSets.In x s).
  (*** MS END {"type": "proof_definition"} *)
  Proof.
    induction s;
    try hammer'.
    Restart.
    induction s.
    - try crush'.
    - crush';
      admit.
    Restart.
    induction s;
    mirrorsolve.
  Qed.

  Hint Immediate mem_In : intvsets_eqns.
  Hint Resolve mem_In.

  Hint Immediate contains_equation_1 : intvsets_eqns.
  Hint Immediate contains_equation_2 : intvsets_eqns.

  Set MirrorSolve Solver "z3".

  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 2, "ms": 2, "hammer": 0, "crush": 1} *)
  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma contains_In:
    forall l0 h0,
      l0 < h0 ->
      forall s, ok s ->
    (contains l0 h0 s = true <-> (forall x, l0 <= x < h0 -> IntvSets.In x s)).
  (*** MS END {"type": "proof_definition"} *)
  Proof.
    induction 2;
    try hammer'.
    Restart.
    induction 2.
    - crush'.
    - crush';
      admit.
    Restart.
    induction 2;
    mirrorsolve.
  Qed.

  Hint Immediate contains_In : intvsets_eqns.
  Hint Resolve contains_In.
  Hint Immediate add_equation_1 : intvsets_eqns.
  Hint Immediate add_equation_2 : intvsets_eqns.

  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 2, "ms": 2, "hammer": 1, "crush": 0} *)
  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma In_add:
    forall x s,
      ok s ->
      forall l0 h0,
        (IntvSets.In x (add l0 h0 s) <-> l0 <= x < h0 \/ IntvSets.In x s).
  (*** MS END {"type": "proof_definition"} *)
  Proof.
    induction s;
    try hammer'.
    Restart.
    induction s.
    - crush';
      admit.
    - crush';
      admit.
    Restart.
    induction s;
    mirrorsolve.
  Qed.

  Hint Immediate In_add : intvsets_eqns.
  Hint Resolve In_add.

  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 2, "ms": 2, "hammer": 0, "crush": 0} *)
  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma add_ok:
    forall s,
      ok s ->
      forall l0 h0,
        l0 < h0 ->
        ok (add l0 h0 s).
  (*** MS END {"type": "proof_definition"} *)
  Proof.
    induction s;
    try hammer'.
    Restart.
    induction s.
    - crush'.
      admit.
    - crush';
      admit.
    Restart.
    Set MirrorSolve Solver "cvc5".
    induction s;
    try mirrorsolve.
  Qed.

  Hint Immediate add_ok : intvsets_eqns.
  Hint Resolve add_ok.

  Hint Immediate remove_equation_1 : intvsets_eqns.
  Hint Immediate remove_equation_2 : intvsets_eqns.

  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 2, "ms": 2, "hammer": 1, "crush": 1} *)
  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma In_remove:
    forall x l0 h0 s,
      ok s ->
      (IntvSets.In x (IntvSets.remove l0 h0 s) <-> ~(l0 <= x < h0) /\ IntvSets.In x s).
  (*** MS END {"type": "proof_definition"} *)
  Proof.
    induction s;
    try hammer'.
    Restart.
    induction s.
    - crush'.
    - crush';
      admit.
    Restart.
    induction s;
    try mirrorsolve.
  Qed.

  Hint Immediate In_remove : intvsets_eqns.
  Hint Resolve In_remove.

  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 2, "ms": 2, "hammer": 1, "crush": 1} *)
  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma remove_ok:
    forall l0 h0,
      l0 < h0 ->
        forall s,
          ok s ->
          ok (IntvSets.remove l0 h0 s).
  (*** MS END {"type": "proof_definition"} *)
  Proof.
    induction s;
    try hammer'.
    Restart.
    induction s.
    - crush'.
    - crush';
      admit.
    Restart.
    induction s;
    try mirrorsolve.
  Qed.

  (*** MS EFFORT {"type": "lemma"} *)
  Lemma inter_equation_1 :
    forall x, inter Nil x = Nil.
  Proof.
    induction x;
    intuition eauto.
  Qed.
  (*** MS EFFORT {"type": "lemma"} *)
  Lemma inter_equation_2 :
    forall x, inter x Nil = Nil.
  Proof.
    induction x;
    intuition eauto.
  Qed.

  Hint Immediate inter_equation_1 : intvsets_eqns.
  Hint Immediate inter_equation_2 : intvsets_eqns.

  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": False, "ho": False, "goals": 4, "ms": 3, "hammer": 3, "crush": 3} *)
  Lemma In_inter:
    forall x s1, ok s1 -> forall s2, ok s2 ->
    (IntvSets.In x (inter s1 s2) <-> IntvSets.In x s1 /\ IntvSets.In x s2).
  Proof.
    induction 1;
    induction 1;
    try hammer'.
    Restart.
    induction 1;
    induction 1.
    - crush'.
    - crush'.
    - crush'.
    - crush';
      admit.
    Restart.
    induction 1;
    induction 1;
    try mirrorsolve.
  Admitted.

  Hint Immediate In_inter : intvsets_eqns.
  Hint Resolve In_inter.

  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": False, "ho": False, "goals": 4, "ms": 3, "hammer": 3, "crush": 3} *)
  Lemma inter_ok:
    forall s1, ok s1 -> forall s2, ok s2 -> ok (inter s1 s2).
  Proof.
    induction 1;
    induction 1;
    try hammer'.
    Restart.
    induction 1;
    induction 1.
    - crush'.
    - crush'.
    - crush'.
    - crush';
      admit.
    Restart.
    induction 1;
    induction 1;
    try mirrorsolve.
  Admitted.

  Hint Immediate inter_ok : intvsets_eqns.
  Hint Resolve inter_ok.

  Hint Immediate union_equation_1 : intvsets_eqns.
  Hint Immediate union_equation_2 : intvsets_eqns.
  Hint Immediate union_equation_3 : intvsets_eqns.

  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 4, "ms": 4, "hammer": 3, "crush": 1} *)

  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma In_ok_union:
    forall s1,
      ok s1 ->
      forall s2,
        ok s2 ->
        ok (union s1 s2) /\
        (forall x, IntvSets.In x s1 \/ IntvSets.In x s2 <-> IntvSets.In x (union s1 s2)).
  (*** MS END {"type": "proof_definition"} *)
  Proof.
    induction 1;
    induction 1;
    try hammer'.
    Restart.
    induction 1;
    induction 1.
    - crush'.
    - crush';
      admit.
    - crush';
      admit.
    - crush';
      admit.
    Restart.
    induction 1;
    induction 1;
    try mirrorsolve.
  Qed.

  Hint Immediate In_ok_union : intvsets_eqns.
  Hint Resolve In_ok_union.
  Hint Immediate beq_equation_1 : intvsets_eqns.
  Hint Immediate beq_equation_2 : intvsets_eqns.
  Hint Immediate beq_equation_3 : intvsets_eqns.
  Hint Immediate beq_equation_4 : intvsets_eqns.

  (*** MS LEMMA {"original": False, "sfo": True, "tsfo": True, "ho": False, "goals": 4, "ms": 4, "hammer": 3, "crush": 3} *)
  Lemma beq_eq :
    forall x y, beq x y = true <-> x = y.
  Proof.
    induction x;
    induction y;
    try hammer'.
    Restart.
    induction x;
    induction y.
    - try crush'.
    - try crush'.
    - crush'.
    -
      (* crush'. *)
      admit.
    Restart.
    induction x;
    induction y;
    try mirrorsolve.
  Qed.

  Hint Immediate beq_eq : intvsets_eqns.
  Hint Resolve beq_eq.

  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 4, "ms": 3, "hammer": 1, "crush": 3} *)

  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma beq_spec:
    forall s1,
      ok s1 ->
      forall s2,
        ok s2 ->
        (beq s1 s2 = true <-> (forall x, IntvSets.In x s1 <-> IntvSets.In x s2)).
  (*** MS END {"type": "proof_definition"} *)
  Proof.

    induction 1;
    induction 1.
    - mirrorsolve.
    - Set MirrorSolve Solver "z3".
      mirrorsolve.
    - Set MirrorSolve Solver "cvc5".
      mirrorsolve.
    - admit.
    Restart.
    induction 1;
    induction 1;
    try hammer'.
    Restart.
    induction 1;
    induction 1.
    - crush'.
    - crush'.
    - crush'.
    -
      (* crush'. *)
      admit.
  Admitted.

End IntvSets.


Require Import Coq.Relations.Relations.
Require Import "Calculus/Sets".

Open Scope type_scope.

(** * Calculus *)
Module Type Calculus.

  Parameter var : Type.
  Parameter expr : Type.

  Parameter beq_var : var -> var -> bool.

  Declare Module MemoryType : MemoryType.
  Module Memory := Memory MemoryType.

  Parameter value : expr -> Prop.
  Parameter sticks : expr -> Prop.

  Definition state : Type := Memory.t * expr.

  Parameter subst : var -> expr -> expr -> expr.
  Parameter step : relation state.

  Notation "'⟨' M ',' e '⟩'" := (M, e) (at level 40).

  Notation "s1 '⇒' s2" := (step s1 s2) (at level 40).
  Notation "s1 '⇒*' s2" :=
    (clos_trans_1n state step s1 s2) (at level 40).
  Notation "s1 '⇒+' s2" :=
    (clos_refl_trans state step s1 s2) (at level 40).

End Calculus.

(** * Staged Calculus *)
Module Type StagedCalculus.

  Parameter var : Type.
  Parameter expr : Type.

  Parameter beq_var : var -> var -> bool.

  Module MemoryType <: MemoryType.
    Definition data := expr.
    Parameter default : expr.
  End MemoryType.
  Module Memory := Memory MemoryType.

  Parameter svalue : nat -> expr -> Prop.
  Parameter ssticks : nat -> expr -> Prop.

  Definition state : Type := Memory.t * expr.

  Parameter ssubst : nat -> StageSet.t -> var -> expr -> expr -> expr.
  Parameter sstep : nat -> relation state.

  Notation "'⟨' M ',' e '⟩'" := (M, e) (at level 40).

  Notation "s1 '⊨' n '⇒' s2" := (sstep n s1 s2) (at level 40).
  Notation "s1 '⊨' n '⇒*' s2" :=
    (clos_trans_1n state (sstep n) s1 s2) (at level 40).
  Notation "s1 '⊨' n '⇒+' s2" :=
    (clos_refl_trans state (sstep n) s1 s2) (at level 40).

End StagedCalculus.

(** * Calculus Builder *)
Module MakeCalculus (S:StagedCalculus) <: Calculus <: StagedCalculus.

  Include S.

  Definition value := svalue 0.
  Definition sticks := ssticks 0.

  Definition subst := ssubst 0 StageSet.empty.
  Definition step := sstep 0.

End MakeCalculus.


(**

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

Author: Bowen Zhang.

Date : 2022.08.03
*)

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 (bp:bloc) (ll:list int) : hbprop :=
  fun h => (h = Fmap.single bp ll /\ bp <> bnull).

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

Notation "bp '~b~>' ll" := (hbsingle bp ll) (at level 32) : hprop_scope.
Notation "fp '~f~>' lb" := (hfsingle fp 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.