Add LoadPath "../general".

Require Import GLS_PSGLS_calcs.
Require Import List.
Export ListNotations.

Require Import existsT.
Require Import PeanoNat.
Require Import Lia.

Delimit Scope My_scope with M.
Open Scope My_scope.
Set Implicit Arguments.

Parameter eq_dec_propvar : forall x y : V, {x = y}+{x <> y}.

Lemma In_dec : forall l (a : MPropF V) , (In a l) + ((In a l) -> False).
Proof.
induction l.
- right. intro. destruct H.
- intro a0. pose (IHl a0). destruct s.
  * left. apply in_cons. assumption.
  * destruct (eq_dec_form a a0).
    + subst. left. apply in_eq.
    + right. intro. inversion H.
      { apply n. assumption. }
      { apply f. assumption. }
Qed.

(* Let us prove some lemmas about remove. *)

Lemma in_not_touched_remove : forall l1 (a0 a1 : MPropF V),
        In a0 l1 -> a0 <> a1 -> In a0 (remove eq_dec_form a1 l1).
Proof.
induction l1.
- intros. inversion H.
- intros. simpl. destruct (eq_dec_form a1 a).
  * subst. apply IHl1. inversion H. exfalso. apply H0. auto. assumption. assumption.
  * inversion H. subst. apply in_eq. apply in_cons. apply IHl1. assumption. assumption.
Qed.

Lemma remove_dist_app {A : Type} (eq_dec : forall x y : A, {x = y} + {x <> y}) :
        forall (a : A) l1 l2, (@remove A eq_dec a (l1 ++ l2)) =
                              (@remove A eq_dec a l1) ++ (@remove A eq_dec a l2).
Proof.
intros a l1. induction l1.
- intro l2. rewrite app_nil_l. simpl. reflexivity.
- intro l2. simpl. destruct (eq_dec a a0).
  * apply IHl1.
  * simpl. rewrite IHl1. reflexivity.
Qed.

Lemma remove_not_in_anymore : forall l (A : MPropF V),
          (In A (remove eq_dec_form A l)) -> False.
Proof.
induction l.
- intros. simpl in H. inversion H.
- intros. simpl in H. destruct (eq_dec_form A a). subst. apply IHl in H. assumption.
  inversion H. apply n. symmetry. assumption. apply IHl in H0. assumption.
Qed.

Lemma in_remove_in_init : forall l A B,
    In A (remove eq_dec_form B l) -> In A l.
Proof.
induction l.
- intros. simpl. inversion H.
- intros. destruct (eq_dec_form A a). subst. apply in_eq. apply in_cons.
  pose (IHl A B). apply i. simpl in H. destruct (eq_dec_form B a).
  * subst. assumption.
  * inversion H. exfalso. apply n. symmetry. assumption. assumption.
Qed.

Lemma remove_preserv_NoDup : forall l (A : MPropF V), NoDup l -> NoDup (remove eq_dec_form A l).
Proof.
induction l.
- intros. simpl. apply NoDup_nil.
- intros. simpl. destruct (eq_dec_form A a).
  * subst. apply IHl. inversion H. assumption.
  * apply NoDup_cons. intro. apply in_remove_in_init in H0. inversion H. apply H3. assumption.
    apply IHl. inversion H. assumption.
Qed.

Lemma NoDup_destr_split : forall l1 l2 (A : MPropF V), NoDup (l1 ++ A :: l2) -> NoDup (l1 ++ l2).
Proof.
induction l1.
- intros. rewrite app_nil_l. rewrite app_nil_l in H. inversion H. assumption.
- intros. simpl. apply NoDup_cons. intro. inversion H. subst. apply H3. apply in_app_or in H0.
  destruct H0. apply in_or_app. left. assumption. apply in_or_app. right. apply in_cons.
  assumption. simpl in H. inversion H. subst. apply IHl1 with (A:=A). assumption.
Qed.

Lemma remove_le_length : forall l (A : MPropF V), length (remove eq_dec_form A l) <= length l.
Proof.
induction l.
- intros. simpl. reflexivity.
- intros. simpl. destruct (eq_dec_form A a).
  * subst. apply le_S. apply IHl.
  * simpl. apply le_n_S. apply IHl.
Qed.

Lemma remove_In_smaller_length : forall l (A : MPropF V),
                                 In A l -> length (remove eq_dec_form A l) < length l.
Proof.
induction l.
- intros. inversion H.
- intros. simpl. destruct (eq_dec_form A a).
  * subst. unfold lt. apply le_n_S. apply remove_le_length.
  * simpl. apply Lt.lt_n_S. apply IHl. inversion H. subst. exfalso. apply n. auto.
    assumption.
Qed.

Lemma double_remove {A : Type} (eq_dec : forall x y : A, {x = y} + {x <> y}) :
      forall a l, (@remove A eq_dec a (@remove A eq_dec a l)) = (@remove A eq_dec a l).
Proof.
intros a l. induction l.
- simpl. reflexivity.
- simpl. destruct (eq_dec a a0).
  * subst. apply IHl.
  * simpl. destruct (eq_dec a a0).
    + exfalso. apply n. assumption.
    + rewrite IHl. reflexivity.
Qed.

Lemma permut_remove {A : Type} (eq_dec : forall x y : A, {x = y} + {x <> y}) :
      forall a0 a1 l, (@remove A eq_dec a0 (@remove A eq_dec a1 l)) =
                      (@remove A eq_dec a1 (@remove A eq_dec a0 l)).
Proof.
intros a0 a1 l. induction l.
- simpl. reflexivity.
- simpl. destruct (eq_dec a1 a).
  * subst. simpl. destruct (eq_dec a0 a).
    + subst. reflexivity.
    + simpl. destruct (eq_dec a a). apply IHl. exfalso. apply n0. reflexivity.
  * simpl. destruct (eq_dec a0 a).
    + subst. assumption.
    + simpl. destruct (eq_dec a1 a). exfalso. apply n. assumption.
      rewrite IHl. reflexivity.
Qed.

Lemma In_remove_diff : forall l (A B : MPropF V), In A (remove eq_dec_form B l) -> A <> B.
Proof.
induction l ; intros.
- intro. simpl in H. assumption.
- simpl in H. destruct (eq_dec_form B a).
  * subst. apply IHl. assumption.
  * inversion H.
    + subst. intro. apply n. symmetry. assumption.
    + apply IHl. assumption.
Qed.

(* Now we define remove_list and prove some lemmas about it. *)

Fixpoint remove_list (l1 l2: list (MPropF V)) : list (MPropF V) :=
match l1 with
  | [] => l2
  | h1 :: t1 => remove eq_dec_form h1 (remove_list t1 l2)
end.

Lemma remove_list_of_nil : forall (l : list (MPropF V)), remove_list l nil = nil.
Proof.
induction l.
- simpl. reflexivity.
- simpl. rewrite IHl. simpl. reflexivity.
Qed.

Lemma app_remove_list : forall (l1 l2 l3 : list (MPropF V)),
        remove_list (l1 ++ l2) l3 = remove_list l1 (remove_list l2 l3).
Proof.
induction l1.
- simpl. firstorder.
- induction l2.
  * intro l3. rewrite app_nil_r. simpl. reflexivity.
  * intro l3. simpl. pose (IHl1 (a0 :: l2) l3). simpl in e.
    rewrite e. reflexivity.
Qed.

Lemma remove_list_preserv_NoDup : forall l1 l2, NoDup l2 -> NoDup (remove_list l1 l2).
Proof.
induction l1.
- intros. simpl. assumption.
- intros. simpl. apply IHl1 in H. apply remove_preserv_NoDup with (A:=a) in H.
  assumption.
Qed.

Lemma remove_list_cont : forall l1 A, In A l1 -> (forall l2, In A (remove_list l1 l2) -> False).
Proof.
induction l1.
- intros. inversion H.
- intros. inversion H.
  * subst. simpl in H0. apply remove_not_in_anymore in H0. assumption.
  * simpl in H0. pose (IHl1 A H1 l2). apply f. apply in_remove_in_init with (B:= a). assumption.
Qed.

Lemma remove_list_dist_app : forall (l1 l2 l3 : list (MPropF V)),
        remove_list l1 (l2 ++ l3) = (remove_list l1 l2) ++ (remove_list l1 l3).
Proof.
induction l1.
- intros. simpl. reflexivity.
- simpl. intros. rewrite IHl1. simpl. rewrite remove_dist_app. reflexivity.
Qed.

Lemma permut_remove_remove_list : forall a (l1 l2 : list (MPropF V)),
      remove eq_dec_form a (remove_list l1 l2) =
      remove_list l1 (remove eq_dec_form a l2).
Proof.
intros a l1. generalize dependent a. induction l1 ; simpl.
- reflexivity.
- intros. rewrite permut_remove. rewrite IHl1. reflexivity.
Qed.

Lemma swap_remove_list : forall (l1 l2 l3 : list (MPropF V)),
      remove_list (l1 ++ l2) l3 = remove_list (l2 ++ l1) l3.
Proof.
induction l1.
- intros. rewrite app_nil_l. rewrite app_nil_r. reflexivity.
- induction l2.
  * rewrite app_nil_l. rewrite app_nil_r. reflexivity.
  * intro l3. simpl. rewrite IHl1. simpl. rewrite permut_remove.
    rewrite <- IHl2. simpl. rewrite IHl1. reflexivity.
Qed.

Lemma redund_remove_remove_list : forall a (l1 l2 : list (MPropF V)),
      remove eq_dec_form a (remove_list (remove eq_dec_form a l1) l2) =
      remove eq_dec_form a (remove_list l1 l2).
Proof.
intro a. induction l1.
- intro l2. simpl. reflexivity.
- intro l2. simpl. destruct (eq_dec_form a a0).
  * rewrite IHl1. subst. rewrite double_remove. reflexivity.
  * simpl. rewrite permut_remove. rewrite IHl1. apply permut_remove.
Qed.

Lemma redund_remove : forall (l1 l2 l3 : list (MPropF V)) a,
      remove eq_dec_form a (remove_list l1 (remove_list (remove eq_dec_form a l2) l3)) =
      remove eq_dec_form a (remove_list l1 (remove_list l2 l3)).
Proof.
intros. repeat rewrite <- app_remove_list. rewrite swap_remove_list.
rewrite app_remove_list. rewrite redund_remove_remove_list. rewrite <- app_remove_list.
rewrite swap_remove_list. reflexivity.
Qed.

Lemma redund_remove_list : forall (l1 l2 l3 : list (MPropF V)),
      remove_list l1 (remove_list (remove_list l1 l2) l3) = remove_list l1 (remove_list l2 l3).
Proof.
induction l1 ; intros ; simpl.
- reflexivity.
- rewrite redund_remove. rewrite IHl1. reflexivity.
Qed.

Lemma remove_list_in_single : forall l1 a, (In a l1) -> remove_list l1 [a] = nil.
Proof.
induction l1.
- intros. inversion H.
- intros. inversion H.
  * subst. simpl. rewrite permut_remove_remove_list. simpl. destruct (eq_dec_form a0 a0).
    apply remove_list_of_nil. exfalso. apply n. reflexivity.
  * apply IHl1 in H0. simpl. rewrite H0. simpl. reflexivity.
Qed.

Lemma not_removed_remove_list : forall l2 l1 A, In A l2 -> (In A l1 -> False) -> In A (remove_list l1 l2).
Proof.
induction l2.
- intros. inversion H.
- induction l1.
  * intros. simpl. assumption.
  * intros. simpl. pose (in_not_touched_remove (remove_list l1 (a :: l2))). pose (i A).
    pose (i0 a0). apply i1. apply IHl1. assumption. intro. apply H0. apply in_cons. assumption.
    clear i1. clear i0. clear i. destruct (eq_dec_form A a0). intro. apply H0. subst. apply in_eq.
    assumption.
Qed.

Lemma add_remove_list_preserve_NoDup : forall (l1 l2 : list (MPropF V)),
            NoDup l1 -> NoDup l2 -> NoDup (l1 ++ (remove_list l1 l2)).
Proof.
induction l1.
- intros. rewrite app_nil_l. simpl. assumption.
- intros. simpl. apply NoDup_cons.
  * intro. apply in_app_or in H1. destruct H1. inversion H. apply H4. assumption.
    apply remove_not_in_anymore in H1. assumption.
  * rewrite permut_remove_remove_list. apply IHl1. inversion H. assumption.
    apply remove_preserv_NoDup. assumption.
Qed.

Lemma remove_list_is_in : forall l1 l2 A, In A l1 -> In A (l2 ++ (remove_list l2 l1)).
Proof.
intros. pose (In_dec l2 A). destruct s.
- apply in_or_app. left. assumption.
- apply in_or_app. right. apply not_removed_remove_list ; assumption.
Qed.

Lemma In_remove_same : forall l1 l2 (A : MPropF V), In A l1 ->
                remove_list l1 (A :: l2) = remove_list l1 l2.
Proof.
induction l1.
- intros. inversion H.
- intros. inversion H.
  * subst. simpl. rewrite permut_remove_remove_list. simpl. destruct (eq_dec_form A A).
    rewrite permut_remove_remove_list. reflexivity. exfalso. apply n. reflexivity.
  * simpl. pose (IHl1 l2 A H0). rewrite e. reflexivity.
Qed.

Lemma In_remove_length_same : forall l1 l2 (A : MPropF V), In A l1 ->
                length (remove_list l1 (A :: l2)) = length (remove_list l1 l2).
Proof.
intros. rewrite In_remove_same. reflexivity. assumption.
Qed.

Lemma length_le_remove_list : forall (l1 l2 : list (MPropF V)), length (remove_list l1 l2) <= length l2.
Proof.
induction l1.
- intros. auto.
- intros. simpl. rewrite permut_remove_remove_list. pose (IHl1 (remove eq_dec_form a l2)).
  apply Nat.le_trans with (m:=length (remove eq_dec_form a l2)). assumption.
  apply remove_le_length.
Qed.

Lemma remove_list_singl_id_or_nil : forall l (A : MPropF V), remove_list l [A] = nil \/ remove_list l [A] = [A].
Proof.
induction l.
- intros. right. auto.
- intros. pose (IHl A). destruct o. left. simpl. rewrite H. auto.
  simpl. rewrite H. destruct (eq_dec_form A a).
  * subst. left. simpl. destruct (eq_dec_form a a). reflexivity. exfalso. apply n.
    reflexivity.
  * right. simpl. destruct (eq_dec_form a A). exfalso. apply n. symmetry. assumption.
    reflexivity.
Qed.

Lemma remove_list_non_empty_inter_smaller_length : forall l2 l1 (A : MPropF V),
                                 In A l1 -> In A l2 -> length (remove_list l1 l2) < length l2.
Proof.
induction l2.
- intros. inversion H0.
- intros. simpl. destruct (eq_dec_form A a).
  * subst. rewrite In_remove_length_same. 2: assumption. unfold lt. apply le_n_S.
    apply length_le_remove_list.
  * inversion H0.
    + exfalso. apply n. symmetry. assumption.
    + assert (a :: l2 = [a] ++ l2). auto. rewrite H2. rewrite remove_list_dist_app.
      rewrite app_length. pose (remove_list_singl_id_or_nil l1 a). destruct o.
      rewrite H3. simpl. apply Nat.lt_lt_succ_r. apply IHl2 with (A:=A) ; assumption.
      rewrite H3. simpl. apply Lt.lt_n_S. apply IHl2 with (A:=A) ; assumption.
Qed.

Lemma remove_list_delete_head : forall l1 l2 l3 A, remove_list (l1 ++ A :: l2) (A :: l3) = remove_list (l1 ++ A :: l2) l3.
Proof.
induction l1 ; intros ; simpl.
- rewrite permut_remove_remove_list. simpl. destruct (eq_dec_form A A). symmetry. apply permut_remove_remove_list.
  exfalso. apply n. reflexivity.
- rewrite IHl1. reflexivity.
Qed.

Lemma remove_list_delete_head_In : forall l1 l2 A, In A l1 -> remove_list l1 (A :: l2) = remove_list l1 l2.
Proof.
intros. pose (In_split A l1 H). destruct e. destruct H0. subst. apply remove_list_delete_head.
Qed.

Lemma remove_list_in_nil : forall l1 l2 l3 A,
        remove_list l1 (l2 ++ A :: l3) = nil ->
        (existsT2 l4 l5, l1 = l4 ++ A :: l5).
Proof.
induction l1.
- intros. simpl in H. destruct l2 ; inversion H.
- induction l2.
  * intros. simpl in H. rewrite permut_remove_remove_list in H. simpl in H. destruct (eq_dec_form a A).
    + subst. exists []. exists l1. auto.
    + pose (IHl1 [] (remove eq_dec_form a l3)). simpl in s. apply s in H. destruct H. destruct s0.
      exists ([a] ++ x). exists x0. subst. auto.
  * intros. simpl in H. rewrite permut_remove_remove_list in H. simpl in H. destruct (eq_dec_form a a0).
    + subst. pose (IHl2 l3 A). apply s. rewrite <- permut_remove_remove_list in H. simpl. assumption.
    + pose (IHl1 [] (remove eq_dec_form a (l2 ++ A :: l3)) a0). pose (s H). repeat destruct s0.
      subst. apply IHl2 with (l3:= l3). simpl. rewrite permut_remove_remove_list.
      rewrite remove_list_delete_head in H. assumption.
Qed.

Lemma remove_list_is_nil : forall l1 l2, (remove_list l1 l2 = nil <-> (forall A, (In A l2) -> (In A l1))).
Proof.
induction l1.
- intro l2. split.
  * intros. simpl in H. rewrite <- H. assumption.
  * intros. simpl. destruct l2.
    + reflexivity.
    + exfalso. pose (H m). assert (In m (m :: l2)). apply in_eq. apply i in H0. inversion H0.
- induction l2.
  * split.
    + intros. inversion H0.
    + intros. apply remove_list_of_nil.
  * split.
    + intros. simpl in H. rewrite permut_remove_remove_list in H. simpl in H. destruct (eq_dec_form a a0).
      subst. inversion H0. subst. apply in_eq. rewrite <- permut_remove_remove_list in H. simpl in IHl2.
      rewrite IHl2 in H. apply H in H1. destruct H1. subst. apply in_eq. apply in_cons. assumption.
      inversion H0. subst. apply in_cons. pose (remove_list_in_nil l1 [] (remove eq_dec_form a l2) A).
      simpl in s. apply s in H. destruct H. destruct s0. subst. apply in_or_app. right. apply in_eq.
      apply IHl2. 2: assumption. simpl. rewrite permut_remove_remove_list.
      pose (app_eq_nil (remove_list l1 [a0]) (remove_list l1 (remove eq_dec_form a l2))). simpl in a1.
      assert (H2: remove_list l1 [a0] ++ remove_list l1 (remove eq_dec_form a l2) = []).
      rewrite <- remove_list_dist_app. simpl. assumption. apply a1 in H2. destruct H2. assumption.
    + intros. simpl. rewrite permut_remove_remove_list. simpl. destruct (eq_dec_form a a0).
      { subst. rewrite <- permut_remove_remove_list. simpl in IHl2. rewrite IHl2. intros.
        pose (H A). apply i. apply in_cons. assumption. }
      { assert (H1: (forall A : MPropF V, In A l2 -> In A (a :: l1))). intros. apply H.
        apply in_cons. assumption. apply IHl2 in H1.
        assert (H2: a0 :: remove eq_dec_form a l2 = [a0] ++ remove eq_dec_form a l2). auto.
        rewrite H2. rewrite remove_list_dist_app. clear H2. rewrite <- permut_remove_remove_list.
        simpl in H1. rewrite H1. rewrite app_nil_r. apply remove_list_in_single. pose (H a0).
        assert (H3: In a0 (a0 :: l2)). apply in_eq. apply i in H3. inversion H3. exfalso. apply n.
        assumption. assumption. }
Qed.

Lemma remove_delete_origin : forall l1 l2 (A B : MPropF V), (A <> B) ->
            length (remove eq_dec_form A (l1 ++ B :: l2)) = S (length (remove eq_dec_form A (l1 ++ l2))).
Proof.
induction l1.
- intros. repeat rewrite app_nil_l. simpl. destruct (eq_dec_form A B). exfalso. apply H. assumption.
  simpl. reflexivity.
- intros. simpl. destruct (eq_dec_form A a).
  * apply IHl1. assumption.
  * simpl. apply eq_S. apply IHl1. assumption.
Qed.

Lemma keep_list_delete_head_not_origin : forall l1 l2 l3 A, ((In A l1) -> False) ->
                length (remove_list l1 (l2 ++ A :: l3)) = S (length (remove_list l1 (l2 ++ l3))).
Proof.
induction l1.
- intros. simpl. rewrite app_length. simpl. rewrite app_length. auto.
- intros. simpl. repeat rewrite remove_list_dist_app. assert (In A l1 -> False).
  intro. apply H. apply in_cons. assumption. assert (A :: l3 = [A] ++ l3).
  auto. rewrite H1. rewrite remove_list_dist_app. pose (remove_list_singl_id_or_nil l1 A).
  destruct o. exfalso. rewrite remove_list_is_nil in H2. apply H0. apply H2.
  apply in_eq. rewrite H2. apply remove_delete_origin. intro. apply H. subst. apply in_eq.
Qed.

Lemma keep_list_delete_head_not_In : forall l1 l2 A, ((In A l1) -> False) ->
                length (remove_list l1 (A :: l2)) = S (length (remove_list l1 l2)).
Proof.
intros. pose (@keep_list_delete_head_not_origin l1 [] l2 A H). repeat rewrite app_nil_l in e.
assumption.
Qed.

Lemma In_remove_In_list : forall (A B : MPropF V) l, In A (remove eq_dec_form B l) -> In A l.
Proof.
induction l ; intros.
- simpl in H. destruct H.
- simpl in H. destruct (eq_dec_form B a).
  * subst. apply in_cons. apply IHl. assumption.
  * inversion H.
    + subst. apply in_eq.
    + apply in_cons. apply IHl. assumption.
Qed.

Lemma In_remove_list_In_list : forall (A : MPropF V) l1 l2, In A (remove_list l1 l2) -> In A l2.
Proof.
intro A. induction l1 ; intros.
- simpl in H. assumption.
- simpl in H. apply In_remove_In_list in H. apply IHl1. assumption.
Qed.

Lemma In_remove_list_In_list_not_In_remove_list : forall (A : MPropF V) l1 l2,
            In A (remove_list l1 l2) -> (In A l2 /\ ((In A l1) -> False)).
Proof.
intro A. induction l1 ; intros.
- simpl in H. split. assumption. intro. inversion H0.
- simpl in H. split. apply In_remove_In_list in H. apply IHl1. assumption. intro.
  inversion H0.
  * subst. apply remove_not_in_anymore in H. assumption.
  * apply In_remove_In_list in H. apply IHl1 in H. destruct H. apply H2. assumption.
Qed.

Lemma remove_list_incr_decr3 : forall (l3 l2 l1 : list (MPropF V)),
              (incl l1 l2) ->
              length (remove_list l2 l3) <= length (remove_list l1 l3).
Proof.
induction l3 ; intros.
- repeat rewrite remove_list_of_nil. auto.
- destruct (In_dec l2 a).
  + rewrite remove_list_delete_head_In. 2: assumption. destruct (In_dec l1 a).
    * rewrite remove_list_delete_head_In. 2: assumption. apply IHl3 ; auto.
    * rewrite keep_list_delete_head_not_In. 2: assumption. apply Nat.le_le_succ_r.
      apply IHl3. assumption.
  + repeat rewrite keep_list_delete_head_not_In. apply le_n_S. apply IHl3 ; auto.
    intro. apply f. apply H. assumption. assumption.
Qed.

Lemma remove_list_incr_decr1 : forall (l3 l1 l2: list (MPropF V)),
              (exists A, In A l2 /\ In A l3 /\ (In A l1 -> False)) ->
              (incl l1 l2) ->
              length (remove_list l2 l3) < length (remove_list l1 l3).
Proof.
induction l3.
- intros. destruct H. destruct H. destruct H1. exfalso. inversion H1.
- intros. destruct H. destruct H. destruct H1. destruct (eq_dec_form a x).
  * subst. rewrite remove_list_delete_head_In. 2: assumption.
    rewrite keep_list_delete_head_not_In. 2: assumption. unfold lt.
    apply le_n_S. apply remove_list_incr_decr3. assumption.
  * inversion H1. exfalso. apply n ; assumption.
    assert (H4: exists A : MPropF V, In A l2 /\ In A l3 /\ (In A l1 -> False)).
    exists x. auto. apply IHl3 in H4. 2 : assumption. unfold lt.
    destruct (In_dec l2 a).
    + rewrite remove_list_delete_head_In. 2: assumption. destruct (In_dec l1 a).
      { rewrite remove_list_delete_head_In. 2: assumption. apply H4. }
      { rewrite keep_list_delete_head_not_In. 2: assumption. apply le_n_S.
        unfold lt in H4. apply Le.le_Sn_le. assumption. }
    + rewrite keep_list_delete_head_not_In. 2: assumption. rewrite keep_list_delete_head_not_In.
      unfold lt in H4. apply le_n_S. assumption. intro. apply f. apply H0. assumption.
Qed.

Lemma remove_list_incr_decr2 : forall (l4 l3 l1 : list (MPropF V)),
              (NoDup l4) ->
              (NoDup l3) ->
              (incl l4 l3) ->
              length (remove_list l1 l4) <= length (remove_list l1 l3).
Proof.
induction l4.
- intros. rewrite remove_list_of_nil. simpl. apply le_0_n.
- intros. destruct (In_dec l1 a).
  * rewrite remove_list_delete_head_In. 2: assumption. apply IHl4 ; try assumption.
    inversion H. assumption. unfold incl. intros. apply H1. apply in_cons. assumption.
  * rewrite keep_list_delete_head_not_In. 2: assumption. assert (H2: In a l3). apply H1.
    apply in_eq. pose (in_split a l3 H2). repeat destruct e. destruct H3. rewrite H3.
    rewrite keep_list_delete_head_not_origin. 2: assumption. apply le_n_S. apply IHl4.
    inversion H. assumption. subst. apply NoDup_destr_split with (A:=a). assumption.
    inversion H. unfold incl. intros. subst. assert (H9 : In a0 (a :: l4)). apply in_cons.
    assumption. pose (H1 a0 H9). apply in_app_or in i. destruct i. apply in_or_app. left.
    assumption. inversion H3. subst. exfalso. apply H6. assumption. apply in_or_app. right.
    assumption.
Qed.

Lemma remove_list_incr_decr4 : forall (l4 l3 l1: list (MPropF V)),
              (NoDup l4) ->
              (NoDup l3) ->
              (incl l4 l3) ->
              ((incl l3 l4) -> False) ->
              (exists A, (In A l3) /\ ((In A l1) -> False) /\ ((In A l4) -> False)) ->
              length (remove_list l1 l4) < length (remove_list l1 l3).
Proof.
induction l4.
- intros. rewrite remove_list_of_nil. simpl. destruct H3. destruct H3. destruct H4. pose (In_split x l3 H3).
  destruct e. destruct H6. subst. rewrite keep_list_delete_head_not_origin. 2: assumption.
  apply Nat.lt_0_succ.
- intros. destruct (In_dec l1 a).
  * rewrite remove_list_delete_head_In. 2: assumption. apply IHl4 ; try assumption.
    inversion H. assumption. unfold incl. intros. apply H1. apply in_cons. assumption.
    intro. apply H2. unfold incl. intros. apply in_cons. apply H4. assumption. destruct H3.
    destruct H3. destruct H4. exists x. repeat split ; try assumption. intro. apply H5.
    apply in_cons. assumption.
  * rewrite keep_list_delete_head_not_In. 2: assumption. assert (In a l3). apply H1.
    apply in_eq. pose (In_split a l3 H4). destruct e. destruct H5. subst.
    rewrite keep_list_delete_head_not_origin. 2 : assumption. apply Lt.lt_n_S.
    apply IHl4. inversion H. assumption. apply NoDup_destr_split with (A:=a). assumption.
    unfold incl. intros. pose (H1 a0). assert (In a0 (a :: l4)). apply in_cons. assumption.
    apply i in H6. apply in_app_or in H6. destruct H6. apply in_or_app. left. assumption.
    inversion H6. subst. inversion H. exfalso. apply H9. assumption. apply in_or_app. right.
    assumption. intro. apply H2. unfold incl. intros. apply in_app_or in H6. destruct H6.
    apply in_cons. apply H5. apply in_or_app. left. assumption. inversion H6. subst. apply in_eq.
    apply in_cons. apply H5. apply in_or_app. right. assumption.
    destruct H3. destruct H3. destruct H5. exists x1. repeat split ; try assumption.
    apply in_app_or in H3. destruct H3. apply in_or_app. left. assumption. inversion H3.
    subst. exfalso. apply H6. apply in_eq. apply in_or_app. right. assumption.
    intro. apply H6. apply in_cons. assumption.
Qed.

Lemma remove_list_incr_decr : forall (l1 l2 l3 l4 : list (MPropF V)),
              (NoDup l4) ->
              (NoDup l3) ->
              (exists A, In A l2 /\ In A l3 /\ (In A l1 -> False)) ->
              (incl l1 l2) ->
              (incl l4 l3) ->
              length (remove_list l2 l4) < length (remove_list l1 l3).
Proof.
intros. unfold lt.
pose (remove_list_incr_decr2 l1 H H0 H3).
repeat destruct H1. destruct H4. destruct (In_dec l4 x).
- assert (H6: (exists A, In A l2 /\ In A l4 /\ (In A l1 -> False))).
  exists x. repeat split ; assumption. pose (@remove_list_incr_decr1 l4 l1 l2 H6 H2).
  unfold lt in l0. apply Nat.le_trans with (m:=length (remove_list l1 l4)) ; assumption.
- assert ((incl l3 l4) -> False). intros. apply f. apply H6. assumption.
  assert ((exists A, (In A l3) /\ ((In A l1) -> False) /\ ((In A l4) -> False))). exists x. auto.
  pose (@remove_list_incr_decr3 l4 l2 l1 H2). pose (@remove_list_incr_decr4 l4 l3 l1 H H0 H3 H6 H7).
  unfold lt in l5. apply le_n_S in l0.
  apply Nat.le_trans with (m:=S (length (remove_list l1 l4))) ; assumption.
Qed.

Lemma In_remove_list_remove_redund : forall l1 l2 a, In a l1 ->
                remove eq_dec_form a (remove_list l1 l2) = remove_list l1 l2.
Proof.
induction l1.
- intros. inversion H.
- intros. simpl. inversion H.
  * subst. rewrite double_remove. reflexivity.
  * pose (IHl1 l2 a0 H0). rewrite permut_remove. rewrite e. reflexivity.
Qed.

Lemma In_matters_remove_list : forall l1 l2, (incl l1 l2 /\ incl l2 l1) -> (forall l0,
                                    remove_list l1 l0 = remove_list l2 l0).
Proof.
induction l1.
- intros. destruct H. destruct l2. auto. unfold incl in H0. pose (H0 m). assert (In m (m :: l2)).
  apply in_eq. apply i in H1. inversion H1.
- intros. destruct H. simpl. pose (H a). assert (In a (a :: l1)). apply in_eq. apply i in H1.
  apply in_split in H1. destruct H1. destruct H1. subst. destruct (In_dec l1 a).
  * rewrite In_remove_list_remove_redund. 2: assumption. apply IHl1. split. intro. intro.
    apply H. apply in_cons. assumption. intro. intro. apply H0 in H1. inversion H1. subst.
    assumption. assumption.
  * rewrite swap_remove_list. simpl. rewrite <- redund_remove_remove_list with (l1:=(x0 ++ x)).
    pose (IHl1 (remove eq_dec_form a (x0 ++ x))). rewrite e.
    auto. split. intro. intro. apply in_not_touched_remove. assert (In a0 (a :: l1)). apply in_cons.
    assumption. apply H in H2. apply in_app_or in H2. destruct H2. apply in_or_app. right. assumption.
    inversion H2. subst. exfalso. apply f. assumption. apply in_or_app. left. assumption.
    intro. subst. apply f. assumption. intro. intro. pose (In_remove_diff (x0 ++ x) H1).
    pose (In_remove_In_list a0 a (x0 ++ x) H1). assert (In a0 (x ++ a :: x0)). apply in_app_or in i0.
    destruct i0. apply in_or_app. right. apply in_cons. assumption. apply in_or_app. left. assumption.
    apply H0 in H2. inversion H2. exfalso. apply n. symmetry. assumption. assumption.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D : Universe, ((wd_ A D /\ (wd_ D B /\ (wd_ B A /\ (wd_ C D /\ (col_ A B C /\ col_ A D B))))) -> col_ C D B)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal8.

Set Printing Depth 1000.
Definition lfind_eval  l n x3 x1:=
drop (Succ x1) (Cons x3 (Cons n l)).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ Zero) (Succ Zero) (Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ Zero)) Nil)) (Zero) (Succ (Succ Zero)) (Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) Nil)) (Zero) (Zero) (Succ Zero).

Compute lfind_eval  (Nil) (Zero) (Succ (Succ Zero)) (Zero).

Compute lfind_eval  (Nil) (Zero) (Zero) (Succ (Succ Zero)).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ (Succ (Succ Zero))) Nil)) (Succ (Succ Zero)) (Zero) (Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ Zero) (Succ Zero) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero Nil)) (Zero) (Succ Zero) (Zero).

Compute lfind_eval  (Nil) (Zero) (Succ (Succ (Succ Zero))) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ Zero) (Cons Zero Nil))) (Zero) (Zero) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ (Succ (Succ (Succ Zero))))) (Succ (Succ Zero)) (Succ Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons Zero (Cons Zero (Cons (Succ Zero) Nil)))) (Succ (Succ Zero)) (Zero) (Succ (Succ Zero)).

Compute lfind_eval  (Cons Zero Nil) (Zero) (Zero) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)) (Zero) (Succ (Succ Zero)).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero Nil)) (Succ Zero) (Zero) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero Nil)) (Succ Zero) (Zero) (Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ Zero) Nil)) (Zero) (Succ (Succ (Succ (Succ Zero)))) (Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil) (Zero) (Zero) (Zero).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) Nil) (Zero) (Succ Zero) (Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil) (Zero) (Succ Zero) (Zero).

Compute lfind_eval  (Cons Zero (Cons Zero Nil)) (Succ Zero) (Zero) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ Zero) (Zero) (Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero Nil)) (Zero) (Zero) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ Zero) (Succ (Succ (Succ Zero))) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ Zero) (Zero) (Succ Zero).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) Nil) (Zero) (Succ (Succ Zero)) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)) (Zero) (Succ (Succ Zero)).

Compute lfind_eval  (Nil) (Succ Zero) (Zero) (Succ Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)) (Succ (Succ Zero)) (Succ Zero).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) Nil) (Zero) (Zero) (Succ Zero).

Compute lfind_eval  (Nil) (Succ Zero) (Succ (Succ Zero)) (Zero).

Compute lfind_eval  (Nil) (Succ Zero) (Zero) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Zero) (Succ Zero) (Succ Zero).

Compute lfind_eval  (Nil) (Succ Zero) (Zero) (Succ Zero).

Compute lfind_eval  (Nil) (Zero) (Succ (Succ Zero)) (Succ (Succ Zero)).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil) (Zero) (Zero) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Nil) (Zero) (Zero) (Succ Zero).

Compute lfind_eval  (Cons Zero (Cons Zero Nil)) (Zero) (Zero) (Succ (Succ Zero)).

Compute lfind_eval  (Nil) (Succ Zero) (Zero) (Zero).

Compute lfind_eval  (Nil) (Zero) (Zero) (Zero).


Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import language.
Require Import state.
Require Import util.
Require Import semantic.
Require Import assertion.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Require Import Coq.Logic.FunctionalExtensionality.
Import ListNotations.

Definition triple
           (P: assertion) (c:command) (Q:assertion) : Prop :=
  forall st opst,
     c / st \\ opst ->
     P st ->
     match opst with
     | St st => Q st
     | Abt => False
     end.

Notation "{{ P }} c {{ Q }}" :=
  (triple P c Q) (at level 90, c at next level).

Definition assn_sub (X: id) (a: aexp) P : assertion :=
  fun st => P ((st_update (fst st) X (aeval (fst st) a)), (snd st)).
Notation "P [ X \ a ]" := (assn_sub X a P) (at level 10).

(* proof rules & soundness *)

(* assign *)
Theorem rule_asgn : forall Q X a,
  {{Q [X \ a]}} (CAss X a) {{Q}}.
Proof.
  intros.
  unfold triple.
  intros. unfold assn_sub in *.
  inversion H. subst. assumption.
Qed.

(* consquence *)
Theorem rule_consequence_pre : forall (P P' Q : assertion) c,
  {{P'}} c {{Q}} ->
  P ==> P' ->
  {{P}} c {{Q}}.
Proof.
  intros.
  unfold triple in *.
  unfold strongerThan in *.
  intros.
  apply H0 in H2.
  apply H in H1.
  -apply H1. -apply H2.
Qed.

Theorem rule_consequence_post : forall (P Q Q' : assertion) c,
  {{P}} c {{Q'}} ->
  Q' ==> Q ->
  {{P}} c {{Q}}.
Proof.
  unfold triple in *.
  unfold strongerThan in *.
  intros. unfold s_imp in *.
  assert (c / st \\ opst /\ P st). -auto.
  -apply H in H1.
   +destruct opst.
    *apply H0. assumption.
    *inversion H1.
   +apply H2.
Qed.

Theorem rule_consequence : forall (P P' Q Q' : assertion) c,
  {{P'}} c {{Q'}} ->
  P ==> P' ->
  Q' ==> Q ->
  {{P}} c {{Q}}.
Proof.
  intros.
  apply rule_consequence_pre with P'.
  -apply rule_consequence_post with Q'.
   +assumption.
   +assumption.
  -assumption.
Qed.

Theorem rule_skip : forall P,
     {{P}} CSkip {{P}}.
Proof.
  unfold triple. intros.
  inversion H. subst. assumption.
Qed.

(* Sequencing *)
Theorem rule_seq : forall P Q R c1 c2,
     {{Q}} c2 {{R}} ->
     {{P}} c1 {{Q}} ->
     {{P}} (CSeq c1 c2) {{R}}.
Proof.
  unfold triple.
  intros.
  inversion H1. subst.
  apply H0 in H5. apply H in H8.
  -assumption. -assumption. -assumption.
  -subst. apply H0 in H7.
   +inversion H7. +apply H2.
Qed.

(* Conditionals *)
(*
      {{P ∧  b}} c1 {{Q}}
      {{P ∧ ~b}} c2 {{Q}}
------------------------------------
{{P}} IFB b THEN c1 ELSE c2 FI {{Q}}
*)
Definition bassn b : assertion :=
  fun st => (beval (fst st) b = true).

Lemma bexp_eval_true : forall b st,
  beval (fst st) b = true -> (bassn b) st.
Proof.
  intros.
  unfold bassn. assumption.
Qed.

Lemma bexp_eval_false : forall b st,
  beval (fst st) b = false -> not ((bassn b) st).
Proof.
  unfold bassn, not.
  intros. rewrite H in H0. inversion H0.
Qed.

Theorem rule_if : forall P Q b c1 c2,
  {{fun st => P st /\ bassn b st}} c1 {{Q}} ->
  {{fun st => P st /\ ~(bassn b st)}} c2 {{Q}} ->
  {{P}} (CIf b c1 c2) {{Q}}.
Proof.
  unfold triple, bassn, not.
  intros. inversion H1. subst.
  -apply H in H9. assumption.
   +split. ++apply H2. ++apply H8.
  -subst. apply H0 in H9.
   +apply H9.
   +split.
    ++apply H2.
    ++intros. simpl in H3.
      rewrite H8 in H3. inversion H3.
Qed.

(* loops *)
Theorem rule_while : forall P b c,
  {{fun st => P st /\ bassn b st}} c {{P}} ->
  {{P}} (CWhile b c) {{fun st => P st /\ not (bassn b st)}}.
Proof.
  intros P b c Hhoare st st' He HP.
  remember (CWhile b c) as wcom eqn:Heqwcom.
  induction He;
    try (inversion Heqwcom); subst; clear Heqwcom.
  - (* E_WhileEnd *)
    split. assumption. apply bexp_eval_false. assumption.
  - (* E_WhileLoop *)
    apply IHHe2. reflexivity. unfold triple in *.
    apply (Hhoare (sto, h) (St st)). assumption.
    split. assumption. apply bexp_eval_true. assumption.
  - unfold triple in *.
    apply (Hhoare (sto, h) Abt).
    +assumption. +split. *assumption.
     *apply bexp_eval_true. simpl. assumption.
Qed.

(* allocation *)
Theorem rule_alloc : forall P X a,
  {{fun st => forall loc, (((ANum loc) |-> a) --* P [X \ (ANum loc)]) st}}
  (CCons X a)
  {{P}}.
Proof.
  intros. unfold triple. intros.
  unfold sep_disj, assn_sub, point_to in *.
  inversion H. subst.
  simpl in *.
  remember (h_update emp_heap l (aeval sto a)) as h'.
  assert ((h_union h h') = (h_update h l (aeval sto a))).
  -unfold h_union, h_update. apply functional_extensionality.
   intros. destruct (in_not_in_dec x h) eqn:Hx.
   +destruct (l =? x) eqn:Hxx.
    *apply beq_nat_true in Hxx. unfold in_dom in i.
     destruct i. subst. rewrite e in H6. inversion H6.
    *reflexivity.
   +destruct (l =? x) eqn:Hxx.
    *apply beq_nat_true in Hxx. unfold not_in_dom in n.
     subst. unfold h_update. destruct (x =? x) eqn:Fk.
     ++reflexivity.
     ++apply beq_nat_false in Fk. destruct Fk. reflexivity.
    *apply beq_nat_false in Hxx. subst. unfold not_in_dom in n.
     unfold h_update. destruct (l =? x) eqn:Fkk.
     ++apply beq_nat_true in Fkk. subst. destruct Hxx. reflexivity.
     ++unfold emp_heap. rewrite n. reflexivity.
  -rewrite <- H1. apply H0.
   +unfold disjoint. intros. destruct (l =? l0) eqn:Hx.
    *apply beq_nat_true in Hx.
     right. unfold not_in_dom. subst. assumption.
    *left. unfold not_in_dom. subst. unfold h_update. rewrite Hx.
     unfold emp_heap. reflexivity.
   +subst. reflexivity.
Qed.

(* mutation *)
Theorem rule_mutate : forall P a1 a2,
  {{fun st => exists loc, ((aeval (fst st) a1) = loc) /\
              exists val, ((snd st) loc) = Some val /\
              P ((fst st), (h_update (snd st) loc (aeval (fst st) a2))) }}
  (CMutat a1 a2)
  {{P}}.
Proof.
  intros. unfold triple. intros. inversion H. subst.
  -inversion H0. simpl in *. destruct H1. destruct H2.
   destruct H2. rewrite H1. assumption.
  -subst. destruct H0. destruct H0. destruct H1. destruct H1.
   simpl in *. rewrite <- H0 in H1. rewrite H1 in H6.
   inversion H6.
Qed.

(* look up *)
Theorem rule_lookup : forall P a x,
  {{fun st => exists loc, ((aeval (fst st) a) = loc) /\
              exists val, ((snd st) loc) = Some val /\
              P ((st_update (fst st) x val), (snd st))
  }}
  (CLookup x a)
  {{P}}.
Proof.
  intros. unfold triple. intros. inversion H. subst.
  -destruct H0. destruct H0. destruct H1. destruct H1.
   simpl in *. rewrite <- H0 in H1. rewrite H1 in H6.
   inversion H6. subst. assumption.
  -subst. destruct H0. destruct H0. destruct H1.
   destruct H1. simpl in *. rewrite H0 in H6.
   rewrite H1 in H6. inversion H6.
Qed.

(* dispose *)
Theorem rule_dispose : forall P a,
  {{fun st => exists loc, ((aeval (fst st) a) = loc) /\
              exists val, ((snd st) loc) = Some val /\
              P ((fst st),
                 (fun l => if (eq_nat_dec l loc) then None else (snd st) l))
  }}
  (CDispose a)
  {{P}}.
Proof.
  intros. unfold triple. intros. inversion H. subst.
  -destruct H0. destruct H0. destruct H1. destruct H1.
   simpl in *. rewrite H0. assumption.
  -subst. destruct H0. destruct H0. destruct H1. destruct H1.
   simpl in *. rewrite <- H0 in H1. rewrite H1 in H3. inversion H3.
Qed.


Require Import Hask.Ltac.
Require Import FunctionalExtensionality.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Program.Basics.
Require Import Data.Functor.
Local Open Scope program_scope.

Set Universe Polymorphism.
Generalizable All Variables.

Polymorphic Class Bifunctor (F : Set -> Set -> Set) : Set := {
  bimap : forall {A B C D : Set}, (A -> C) -> (B -> D) -> F A B -> F C D
}.

Arguments bimap {F _ A B C D} f g x.

Module BifunctorLaws.

(* Lemma bimap_fmap_fuse_right : *)
(*   forall (A B C D X : Set) (F : Set -> Set -> Set) *)
(*   `(Bifunctor F) `(Functor (F X)) *)
(*   (f : A -> C) (g : B -> D) (h : X -> B), *)
(*   bimap f g ∘ fmap[ F X ] h = bimap f (g ∘ h). *)
(* Proof. *)
(*   intros A B C D X f g h. *)
(*   extensionality x. *)
(*   now destruct x. *)
(* Qed. *)

Lemma Either_bimap_mapLeft_fuse :
  forall (A B C D X : Set)
         (f : B -> C) (g : B -> D) (h : C -> X),
  mapLeft h ∘ Either_bimap f g = Either_bimap (h ∘ f) g.
Proof.
  intros A B C D X f g h.
  extensionality x.
  now destruct x.
Qed.

(* (* Bifunctors preserve extensional equality for the applied functions. *)
(*    This is needed to perform setoid rewriting within the function *)
(*    passed to a bifunctor. *) *)
(* Add Parametric Morphism {A B} `{Functor F} : (@fmap F _ A B) *)
(*   with signature (pointwise_relation _ eq ==> eq ==> eq) *)
(*     as mul_isomorphism. *)
(* Proof. *)
(*   intros. *)
(*   f_equal. *)
(*   extensionality e. *)
(*   apply H0. *)
(* Qed. *)

(* Class FunctorLaws (f : Set -> Set) `{Functor f} := { *)
(*   fmap_id   : forall a : Set, fmap (@id a) = id; *)
(*   fmap_comp : forall (a b c : Set) (f : b -> c) (g : a -> b), *)
(*     fmap f \o fmap g = fmap (f \o g) *)
(* }. *)

(* Corollary fmap_id_x `{FunctorLaws f} : forall (a : Set) x, fmap (@id a) x = x. *)
(* Proof. *)
(*   intros. *)
(*   rewrite fmap_id. *)
(*   reflexivity. *)
(* Qed. *)

(* Corollary fmap_comp_x `{FunctorLaws F} : *)
(*   forall (a b c : Set) (f : b -> c) (g : a -> b) x, *)
(*   fmap f (fmap g x) = fmap (fun y => f (g y)) x. *)
(* Proof. *)
(*   intros. *)
(*   replace (fun y : a => f (g y)) with (f \o g). *)
(*     rewrite <- fmap_comp. *)
(*     reflexivity. *)
(*   reflexivity. *)
(* Qed. *)

(* End FunctorLaws. *)


(************************************************************************)
(*         *   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)         *)
(************************************************************************)
(****************************************************************************)
(*                                                                          *)
(*                         Naive Set Theory in Coq                          *)
(*                                                                          *)
(*                     INRIA                        INRIA                   *)
(*              Rocquencourt                        Sophia-Antipolis        *)
(*                                                                          *)
(*                                 Coq V6.1                                 *)
(*									    *)
(*			         Gilles Kahn 				    *)
(*				 Gerard Huet				    *)
(*									    *)
(*									    *)
(*                                                                          *)
(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
(* to the Newton Institute for providing an exceptional work environment    *)
(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
(****************************************************************************)

Require Export Relations_1.

Section Relations_2.
Variable U : Type.
Variable R : Relation U.

Inductive Rstar (x:U) : U -> Prop :=
  | Rstar_0 : Rstar x x
  | Rstar_n : forall y z:U, R x y -> Rstar y z -> Rstar x z.

Inductive Rstar1 (x:U) : U -> Prop :=
  | Rstar1_0 : Rstar1 x x
  | Rstar1_1 : forall y:U, R x y -> Rstar1 x y
  | Rstar1_n : forall y z:U, Rstar1 x y -> Rstar1 y z -> Rstar1 x z.

Inductive Rplus (x:U) : U -> Prop :=
  | Rplus_0 : forall y:U, R x y -> Rplus x y
  | Rplus_n : forall y z:U, R x y -> Rplus y z -> Rplus x z.

Definition Strongly_confluent : Prop :=
  forall x a b:U, R x a -> R x b -> ex (fun z:U => R a z /\ R b z).

End Relations_2.

Hint Resolve Rstar_0: sets.
Hint Resolve Rstar1_0: sets.
Hint Resolve Rstar1_1: sets.
Hint Resolve Rplus_0: sets.


From iVM Require Import Init.

Unset Suggest Proof Using.

(** Decidable subsets can be represented using Boolean predicates. This is
essentially a simplified formalization of "prisms", i.e. a dual lenses. *)

Section DSet_section.

  (** Alas, the scope and notations must be repeated after the section.*)

  Context {X: Type}.

  Definition DSet := X -> bool.

  Declare Scope DSet_scope.
  Bind Scope DSet_scope with DSet.
  Delimit Scope DSet_scope with DSet.

  (** *** Membership and subsets *)

  Definition member x (u: DSet) : Prop := u x.
  Infix "∈" := member (at level 70) : type_scope.

  (* TODO: Is it better to leave this implicit? *)
  Global Instance member_decidable x u : Decidable (member x u).
  Proof.
    typeclasses eauto.
  Defined.

  Proposition extensionality u v (H: forall x, x ∈ u <-> x ∈ v) : u = v.
  Proof.
    extensionality x.
    apply bool_extensionality, H.
  Qed.

  Proposition membership_unique u x (H H': x ∈ u) : H = H'.
  Proof.
    unfold member in *.
    apply is_true_unique.
  Qed.

  Definition subset u v := forall x, x ∈ u -> x ∈ v.
  Infix "⊆" := subset (at level 70) : type_scope.

  Instance subset_reflexive : Reflexive subset.
  Proof.
    intros u x. tauto.
  Qed.

  Corollary antisymmetry u v (Huv: u ⊆ v) (Hvu: v ⊆ u) : u = v.
  Proof.
    apply extensionality.
    intros x.
    split.
    - apply Huv.
    - apply Hvu.
  Qed.

  (* TODO: Make global? *)
  #[global] Instance subset_transitive : Transitive subset.
  Proof.
    intros u v w Huv Hvw
           x Hu.
    apply Hvw.
    apply Huv.
    exact Hu.
  Qed.

  Instance subset_proper : Proper ( subset --> subset ==> impl) subset.
  Proof.
    intros u u' Hu
           v v' Hv
           H.
    unfold flip in Hu.
    transitivity u; [exact Hu |].
    transitivity v; [| exact Hv].
    exact H.
  Qed.

  Instance member_proper : Proper ( eq ==> subset ==> impl) member.
  Proof.
    intros x x' Hx
           u u' Hu
           H.
    subst x'.
    apply Hu.
    exact H.
  Qed.

  (** *** Basics *)

  Definition def (p: X -> Prop) {dec: forall x, Decidable (p x)} : DSet :=
    fun x => as_bool (decide (p x)).

  (** We have dropped the traditional subset notation for now. *)

  Proposition def_spec x p {dec: forall x', Decidable (p x')} : x ∈ def p <-> p x.
  Proof.
    unfold def, member.
    setoid_rewrite <- (asBool_decide (p x) (DP := dec x)) at 2.
    destruct (decide (p x)) as [H|H]; tauto.
  Qed.

  Definition full : DSet := def (fun _ => True).
  Notation "'Ω'" := full : DSet_scope.
  Proposition full_spec {x} : x ∈ Ω.
  Proof. exact I. Qed.

  Corollary full_terminal {u} : u ⊆ Ω.
  Proof.
    intros x _. apply full_spec.
  Qed.

  Definition empty : DSet := def (fun _ => False).
  Notation "∅" := empty : DSet_scope.
  Proposition empty_spec {x} : not ( x ∈ ∅ ).
  Proof. exact id. Qed.

  Corollary empty_initial {u} : ∅ ⊆ u.
  Proof.
    intros x H. exfalso. apply (empty_spec H).
  Qed.

  (** Required to define singleton sets. *)
  Context {H_eqdec: EqDec X}.

  Definition singleton x := def (eq x).
  (** Since [{x}] collides with the standard notations. *)
  Notation "!{  x  }" := (singleton x) (at level 0, x at level 99) : DSet_scope.
  Proposition singleton_spec x x' : x ∈ !{x'} <-> x = x'.
  Proof.
    unfold singleton. rewrite def_spec.
    split; intro H; symmetry; exact H.
  Qed.

  Corollary refl {x} : x ∈ !{x}.
  Proof.
    apply singleton_spec. reflexivity.
  Qed.

  Proposition singleton_subset x u : !{x} ⊆ u <-> x ∈ u.
  Proof.
    unfold subset.
    split.
    - intros H.
      apply (H x refl).
    - intros H x'.
      rewrite singleton_spec.
      intros Hx. subst x'. exact H.
  Qed.

  Definition union (u v : DSet) := def (fun a => a ∈ u \/ a ∈ v).
  Infix "∪" := union (at level 40, left associativity) : DSet_scope.
  Proposition union_spec u v x : x ∈ u ∪ v <-> x ∈ u \/ x ∈ v.
  Proof.
    unfold union.
    rewrite def_spec.
    reflexivity.
  Qed.

  Instance union_proper : Proper (subset ==> subset ==> subset) union.
  Proof.
    intros u u' Hu
           v v' Hv
           x.
    setoid_rewrite union_spec.
    intros [H|H].
    - left. apply Hu. exact H.
    - right. apply Hv. exact H.
  Qed.

  Proposition union_symmetric (u v: DSet) :
    (u ∪ v = v ∪ u)%DSet.
  Proof.
    apply extensionality. intros x.
    setoid_rewrite union_spec. tauto.
  Qed.

  (* TODO: Prove more union facts here? *)

  Definition disjoint u v := forall x, not (x ∈ u /\ x ∈ v).
  Infix "#" := disjoint (at level 50) : type_scope.

  Instance disjoint_symmetric : Symmetric disjoint.
  Proof.
    intros u v H x [Hu Hv].
    apply (H x).
    split; assumption.
  Qed.

  Instance disjoint_proper : Proper (subset --> subset --> impl) disjoint.
  Proof.
    intros u u' Hu
           v v' Hv
           Huv x [Hxu Hxv].
    apply (Huv x).
    split;
      [apply Hu
      |apply Hv];
      assumption.
  Qed.

  Proposition disjoint_not_member a u : !{a} # u <-> not (a ∈ u).
  Proof.
    unfold disjoint.
    setoid_rewrite singleton_spec.
    intuition.
    congruence.
  Qed.

  Corollary disjoint_singeltons a a' : disjoint !{a} !{a'} <-> a <> a'.
  Proof.
    transitivity (not (a ∈ !{a'}));
      [ rewrite disjoint_not_member
      | rewrite singleton_spec ];
      reflexivity.
  Qed.

  Proposition disjoint_union_spec u v w :
    u # v ∪ w <-> u # v /\ u # w.
  Proof.
    unfold disjoint.
    setoid_rewrite union_spec.
    intuition.
    apply (H0 x). (* TODO *)
    intuition.
  Qed.

  Proposition disjoint_not_member' u x : u # !{x} <-> ~ x ∈ u.
  Proof.
    split; intros H.
    - apply disjoint_not_member.
      apply disjoint_symmetric.
      exact H.
    - apply disjoint_symmetric.
      apply disjoint_not_member.
      exact H.
  Qed.

End DSet_section.

Arguments DSet : clear implicits.
Declare Scope DSet_scope.
Bind Scope DSet_scope with DSet.
Delimit Scope DSet_scope with DSet.

Module DSetNotations.

  Infix "∈" := member (at level 70) : type_scope.
  Infix "⊆" := subset (at level 70) : type_scope.
  Infix "#" := disjoint (at level 50) : type_scope.

  Notation "'Ω'" := full : DSet_scope.
  Notation "∅" := empty : DSet_scope.
  Notation "!{  x  }" := (singleton x) (at level 0, x at level 99) : DSet_scope.
  Infix "∪" := union (at level 40, left associativity) : DSet_scope.

  Open Scope DSet.

End DSetNotations.


(** * Separation logic

Using Hoare logic we can derive statements like this, which capture the
specification of the [inc()] function:
<<
 { x = n }
 inc(x)
 { x = n + 1}
>>

We'd like to be able to use such statements to construct proofs of statements
that involve procedures like [inc()].

<<
 {x = n ∧ y = m }
 inc(x);
 inc(y);
 {x = n+1 ∧ y = m + 1}
>>

The problem is that we need an intermediate proposition that is stronger than
what the spec gives us directly: [x = n+1 ∧ y = m]. One approach is to
strengthen the spec of inc
clause

Separation logic says what you are allowed to asccess: both access control and
a specification of what the state is. The clause that says things other than x
aren't modified becomes implicit.
<<
 {x = n ∧ y = m }
 inc(x);
 inc(y);
 {x = n+1 ∧ y = m + 1}
>>

There have been a number of attempts to extend the logic to support modular
reasoning about heaps and procedures. Separation logic is probably the most
popular.

Separation logic has a similar structure to Hoare logic, but the meaning of
{P}c{Q} is different. Semantically, ∀h1, ∀h2, if P(h1), then running c in heap
(h1 ⨄ h2) yields a heap h3 = h4 ⨄ h2 where Q(h4). Note that by + here we
mean disjoint union.

Specifications in separation logic are defined by the following syntax

<<
    emp            the heap is empty
    x ↦ v          the heap contains a single mapping from x to v
    P * Q          * is the _separating conjunction_ of separation logic.
                   Holds on heap h = h1 ⨄ h2 where P(h1) and Q(h2).
    P ∧ Q          Usual semantics
    P -* Q         The "magic wand" implication. Idea: a heap satisfies it
                   if it satisfies Q when extended with some disjoint heap that
                   satisfies P. This is useful for weakest preconditions.
>>

This is nice because the rules for assignment, consequence etc. still hold.

<<
{x ↦ _ } x := v { x ↦ v}
>>

*)

(* begin hide *)

Require Import Eqdep.
Require Import Omega.
Require Import List.
Unset Automatic Introduction.
Set Implicit Arguments.
Axiom proof_irrelevance : forall (P:Prop) (H1 H2:P), H1 = H2.

(* end hide *)

(** With this module, we develop a separation logic for reasoning about
    imperative Coq programs.  Separation logic gives us a crucial principle
    for modularly reasoning about programs — the _frame rule_.
*)
Module FunctionalSepIMP.

  Definition ptr := nat.
  Definition ptr_eq := eq_nat_dec.

  (** Just to demonstrate things, let's fix the universe of storable types by
  giving some type names and an interpretation. *)
  Inductive stype : Set :=
  | Nat_t : stype
  | Pair_t : stype -> stype -> stype
  | Sum_t : stype -> stype -> stype
  | Fn_t : stype -> stype -> stype.

  Definition stype_eq (t1 t2:stype) : {t1=t2} + {t1<>t2}.
    decide equality.
  Defined.

  Fixpoint interp(t:stype) : Set :=
    (match t with
       | Nat_t => nat
       | Pair_t t1 t2 => (interp t1) * (interp t2)
       | Sum_t t1 t2 => (interp t1) + (interp t2)
       | Fn_t t1 t2 => (interp t1) -> (interp t2)
     end)%type.

  (** ** Heaps *)
  (** We're going to store dynamic values -- a pair of an [stype] [t] and
      a value of type [interp t]. *)
  Definition dynamic := sigT interp.

  (** We will continue to use lists of pointers and values as the model for
      heaps.  However, to support an easy definition of disjoint union, we
      will impose the additional constraint that the list is sorted in
      (strictly) increasing order.  It's possible to capture this constraint by
      defining heaps as a sigma type, where we include a proof that the heap
      is sorted.  That makes some things easier (e.g., arguing that disjoint
      union is commutative) but makes other things harder.  For example, equality
      on sigmas would demand we need to compare proofs, and use proof-
      irrelevance.  To avoid this we can put in well-formedness
      constraints in just the right places. *)

  Definition heap := list (ptr * dynamic).

  Definition empty_heap : heap := nil.

  (** Each pointer in h is greater than x *)
  Fixpoint list_greater (x:ptr) (h:heap) : Prop :=
    match h with
      | nil => True
      | (y,v)::h' => x < y /\ list_greater x h'
    end.

  (** A heap is well-formed if each pointer is less than the rest of the heap,
      and the rest of the heap is well-formed. *)
  Fixpoint wf(h:heap) : Prop :=
    match h with
      | nil => True
      | (x,v)::h' => list_greater x h' /\ wf h'
    end.

  Fixpoint indom (x:ptr) (h:heap) : Prop :=
    match h with
      | nil => False
      | (y,_)::h' => if ptr_eq x y then True else indom x h'
    end.

  (** A pointer is fresh for h when it's not in the domain of h. *)
  Definition fresh x (h:heap) : Prop := ~ indom x h.

  Fixpoint lookup (x:ptr) (h:heap) : option dynamic :=
    match h with
      | nil => None
      | (y,v)::h' => if ptr_eq x y then Some v else lookup x h'
    end.

  Fixpoint remove (x:ptr) (h:heap) : heap :=
    match h with
      | nil => nil
      | (y,v)::h' => if ptr_eq x y then h' else (y,v)::(remove x h')
    end.

  (** Two heaps are disjoint when each pointer in [h1] is fresh for [h2]. *)
  Fixpoint disjoint (h1 h2:heap) : Prop :=
    match h1 with
      | nil => True
      | (x,_)::h1' => ~indom x h2 /\ disjoint h1' h2
    end.

  (** Aha!  Insertion sort arises again. *)
  Fixpoint insert x (v:dynamic) (h:heap) : heap :=
    match h with
      | nil => (x,v)::nil
      | (y,w)::h' =>
        if le_gt_dec x y then
          (x,v)::(y,w)::h'
          else
            (y,w)::(insert x v h')
    end.

  (** Merge two heaps using insertion *)
  Definition merge (h1 h2:heap) : heap :=
    List.fold_right (fun p h => insert (fst p) (snd p) h) h2 h1.

  (** ** Commands *)
  (** As before a command takes a heap and returns an optional heap and result *)
  Definition Cmd(t:Type) := heap -> option(heap * t).

  Definition ret t (x:t) : Cmd t := fun h => Some (h,x).

  Definition exit t : Cmd t := fun h => None.

  Definition bind t u (c:Cmd t) (f:t -> Cmd u) : Cmd u :=
    fun h1 => match c h1 with
                | None => None
                | Some (h2,v) => f v h2
              end.

  (** Some notation to approximate Haskell's "do" notation. *)
  Notation "x <- c ; f" := (bind c (fun x => f))
    (right associativity, at level 84, c1 at next level) : cmd_scope.
  Notation "c ;; f" := (bind c (fun _:unit => f))
    (right associativity, at level 84, c1 at next level) : cmd_scope.
  Local Open Scope cmd_scope.

  Definition run(t:Type)(c:Cmd t) := c empty_heap.

  (** Untyped read returns a dynamic. *)
  Definition untyped_read (p:ptr) : Cmd dynamic :=
    fun h => match lookup p h with
               | None => None
               | Some u => Some (h,u)
             end.

  (** This abbreviation may look funny (since we don't use [t]), but
      it will make it easier for Coq to figure out the [stype] at
      which we're using things.  Note that this is a little misleading
      because in general, a [ptr] can map to a value of any stype! *)
  Definition tptr(t:stype) := ptr.

  (** Typed read -- we do an untyped read, and then check that the
      [stype] matches what we expected, failing if not, and returning
      the underlying value otherwise. *)
  Definition read (t:stype) (p:tptr t) : Cmd (interp t).
    refine (fun t p => d <- untyped_read p ;
                       match d with
                         | existT t' v =>
                           match stype_eq t t' with
                             | left Heq => ret _
                             | right _ => exit _
                           end
                       end).
    subst. apply v.
  Defined.

  (** Untyped write *)
  Definition untyped_write (p:ptr) (v:dynamic) : Cmd unit :=
    fun h => match lookup p h with
               | None => None
               | Some _ => Some (insert p v (remove p h), tt)
             end.

  (** Typed write. *)
  Definition write (t:stype) (p:tptr t) (v:interp t) : Cmd unit :=
    untyped_write p (existT interp t v).

  (** When we allocate, we need to pick something fresh for the heap.  So
      we choose the maximum value in the heap plus one. *)
  Definition max (p1 p2:ptr) := if le_gt_dec p1 p2 then p2 else p1.

  Definition max_heap(h:heap) := List.fold_right (fun p n => max (fst p) n) 0 h.

  Definition untyped_new (v:dynamic) : Cmd ptr :=
    fun h => let p := 1 + max_heap h in Some (insert p v h, p).

  Definition new(t:stype)(v:interp t) : Cmd (tptr t) := untyped_new (existT interp t v).

  Definition free (p:ptr) : Cmd unit :=
    fun h => match lookup p h with
               | None => None
               | Some _ => Some(remove p h, tt)
             end.

  (** ** Heap Predicates or hprops *)
  (** An [hprop] is a predicate on heaps. *)
  Definition hprop := heap -> Prop.

  (** [emp] holds only when the heap is empty.  One way to think of [emp]
      is that as a pre-condition, it tells us that we don't have the right
      to access anything in the heap.  [emp] plays the role of a unit for
      [star] which is defined below. *)
  Definition emp : hprop := fun h => h = nil.

  (** [top] holds on any heap. *)
  Definition top : hprop := fun _ => True.

  (** [x ---> d] holds when the heap contains exactly one pointer [x] which
      points to [d].  So we can think of this predicate as permission to
      read or write [x] and if we read it, we'll get out the dynamic value [d].
      However, we're not allowed to read or write any other location if this
      is our only pre-condition. *)
  Definition ptsto (x:ptr) (d:dynamic) : hprop := fun h => h = (x,d)::nil.
  Infix "--->" := ptsto (at level 70) : sep_scope.
  Local Open Scope sep_scope.

  (** [ x --> v] is the same as above, except we make the type explicit. *)
  Definition typed_ptsto (t:stype) (x:tptr t) (v:interp t) : hprop :=
    x ---> (existT interp t v).
  Implicit Arguments typed_ptsto [t].
  Infix "-->" := typed_ptsto (at level 70) : sep_scope.

  (** [P ** Q] holds when the heap can be broken into disjoint heaps
      [h1] and [h2] such that [h1] satisfies [P] and [h2] satisfies [Q].
      For example [x --> v ** y --> v] tells us that we have the right
      to access both [x] and [y], but that [x <> y]. *)
  Definition star (P Q:hprop) : hprop :=
    fun h => exists h1:heap, exists h2:heap,
      wf h1 /\ wf h2 /\ P h1 /\ Q h2 /\ h = merge h1 h2 /\ disjoint h1 h2.
  Infix "**" := star (right associativity, at level 80) : sep_scope.

  (** When [P] is a pure predicate in the sense that it doesn't refer to a
      heap, then we can use [pure P] as a predicate on the heap.  Note that
      we require that the heap that it corresponds to is empty. *)
  Definition pure (P:Prop) : hprop := fun h => emp h /\ P.

  (** [sing h] is the singleton predciate on heaps -- i.e., it holds on [h']
      only when [h'] is equal to h. *)
  Definition sing (h:heap) : hprop := fun h' => h = h'.

  (** This definition lifts an existential quantifier up to a predicate on heaps. *)
  Definition hexists (T:Type) (f:T -> hprop) : hprop := fun h => exists x:T, f x h.

  (** So for instance, we can define [x -->? ] as follows *)
  Local Open Scope sep_scope.
  Definition ptsto_some (x:ptr) := hexists (fun v => x ---> v).
  Notation "x '-->?'" := (ptsto_some x) (at level 70) : sep_scope.

  (** This notation will be useful for reasoning about when one separation
      predicate can be used in lieu of another -- i.e., a form of implication
      over heaps.  Note that this is not the "magic-wand" of separation logic,
      but rather, a meta-level implication. *)
  Definition himp(P Q:hprop) : Prop := forall h, wf h -> P h -> Q h.
  Infix "==>" := himp (at level 90) : sep_scope.

  (** My old friend... *)
  Ltac mysimp := repeat (simpl ;
    match goal with
      | [ p : (_ * _)%type |- _ ] => destruct p
      | [ H : _ /\ _ |- _ ] => destruct H
      | [ H : exists _, _ |- _ ] => destruct H
      | [ |- context[ptr_eq ?x ?y] ] => destruct (ptr_eq x y) ; try subst ; try congruence
      | [ H : context[ptr_eq ?x ?y] |- _ ] =>
        destruct (ptr_eq x y) ; try subst ; try congruence
      | [ |- context[le_gt_dec ?x ?y] ] => destruct (le_gt_dec x y) ; try omega
      | [ H : context[le_gt_dec ?x ?y] |- _ ] => destruct (le_gt_dec x y) ; try omega
      | [ |- _ /\ _ ] => split
      | [ H : (_,_) = (_,_) |- _ ] => injection H ; clear H ; intros ; try subst
      | [ H : Some _ = Some _ |- _ ] => injection H ; clear H ; intros ; try subst
      | [ H : Some _ = None |- _ ] => congruence
      | [ H : None = Some _ |- _ ] => congruence
      | [ H : ?x <> ?x |- _ ] => congruence
      | [ H : ~ True |- _ ] => contradiction H ; auto
      | [ H : False |- _ ] => contradiction H ; auto
      | [ |- forall _, _ ] => intros
      | _ => auto
    end).

  (** We need a ton of lemmas for reasoning about heaps.  The keys ones are
      showing that various operations preserve well-formedness, or that
      merging well-formed heaps is commutative and associative, etc. *)

  (** removing a pointer keeps a heap well-formed *)
  Lemma remove_wf x (h:heap) : wf h -> wf (remove x h).
  Proof.
    induction h ; mysimp. generalize h H ; induction h0 ; mysimp.
  Qed.

  (** disjoint is commutative. *)
  Lemma disjoint_comm h1 h2 : disjoint h1 h2 -> disjoint h2 h1.
    induction h1. induction h2 ; mysimp. intro. mysimp.
    generalize (IHh1 _ H0). generalize h2 H. induction h0 ; mysimp.
  Qed.

  Lemma lg_trans x y : x < y -> forall h, list_greater y h -> list_greater x h.
    induction h ; mysimp. omega.
  Qed.

  (** inserting a fresh pointer keeps a heap well-formed. *)
  Lemma insert_wf h : wf h -> forall x v, fresh x h -> wf (insert x v h).
  Proof.
    unfold fresh ; induction h ; mysimp. omega. eapply (@lg_trans x p) ; auto. omega.
    generalize (IHh H1 x v H0). destruct h ; mysimp. omega.
    eapply (@lg_trans p p0) ; auto. omega. simpl in H. omega. simpl in *.
    assert (p < p0). omega. eapply lg_trans ; eauto.
  Qed.

  Lemma lg_imp_not_indom p h : list_greater p h -> fresh p h.
  Proof.
    unfold fresh ; induction h ; mysimp. omega.
  Qed.

  Lemma not_indom_insert x h :
    fresh x h -> forall y v, y <> x -> fresh x (insert y v h).
  Proof.
    unfold fresh ; induction h ; mysimp.
  Qed.

  Lemma not_indom_merge h1 h2 p : fresh p h1 -> fresh p h2 -> fresh p (merge h1 h2).
  Proof.
    unfold fresh ; induction h1 ; mysimp. apply not_indom_insert ; unfold fresh ; auto.
  Qed.

  (** merging two well-formed, disjoint heaps results in a well-formed heap. *)
  Lemma merge_wf h1 h2 : wf h1 -> wf h2 -> disjoint h1 h2 -> wf (merge h1 h2).
  Proof.
    induction h1 ; mysimp. generalize (IHh1 _ H3 H0 H2). intros.
    eapply insert_wf; auto. generalize (lg_imp_not_indom _ _ H).
    intros. apply not_indom_merge ; auto.
  Qed.

  (** insert is commutative for distinct pointers *)
  Lemma insert_comm h x1 v1 x2 v2 :
    x1 <> x2 -> insert x1 v1 (insert x2 v2 h) = insert x2 v2 (insert x1 v1 h).
  Proof.
    induction h ; unfold ptr. mysimp. destruct a. intros. simpl.
    mysimp ; try (assert False ; [omega|contradiction]). rewrite IHh ; auto.
  Qed.

  (** merge is commutative when the heaps are well-formed and disjoint. *)
  Lemma merge_comm h1 h2 : wf h1 -> wf h2 -> disjoint h1 h2 -> merge h1 h2 = merge h2 h1.
  Proof.
    induction h1 ; mysimp. induction h2 ; simpl in * ; mysimp.
    rewrite <- IHh2 ; auto. destruct h2 ; simpl in * ; mysimp.
    rewrite (IHh1 _ H3 H0 H2). clear IHh1.
    induction h2. mysimp. destruct h1 ; simpl in * ; mysimp.
    mysimp. simpl in * ; mysimp. rewrite <- (IHh2 H4 H1).
    rewrite insert_comm ; auto. generalize (disjoint_comm _ _ H2).
    mysimp. apply disjoint_comm ; auto.
  Qed.

  Lemma disjoint_merge : forall h1 h2 h3, disjoint h1 h3 -> disjoint h2 h3 ->
    disjoint (merge h1 h2) h3.
  Proof.
    induction h1 ; mysimp. generalize (IHh1 _ _ H1 H0).
    generalize (merge h1 h2). induction h ; mysimp.
  Qed.

  (** well-formed merges are associative. *)
  Lemma merge_assoc : forall h1 h2 h3,
    wf h1 -> wf h2 -> wf h3 -> disjoint h1 h2 -> disjoint h1 h3 ->
    disjoint h2 h3 -> merge h1 (merge h2 h3) = merge (merge h1 h2) h3.
  Proof.
    induction h1 ; mysimp.
    rewrite (IHh1 _ _ H7 H0 H1 H6 H5 H4). assert (wf (merge h1 h2)).
    apply merge_wf ; auto. generalize H8 ; clear H8.
    assert (~indom p (merge h1 h2)). apply not_indom_merge ; auto.
    apply lg_imp_not_indom ; auto. generalize H8 ; clear H8.
    assert (disjoint (merge h1 h2) h3). apply disjoint_merge ; auto.
    generalize H8 ; clear H8. generalize (merge h1 h2). induction h ; mysimp.
    rewrite insert_comm ; auto. rewrite IHh ; auto.
  Qed.

  Lemma indom_insert x h y v : x <> y -> fresh x (insert y v h) -> fresh x h.
  Proof.
    unfold fresh ; induction h ; simpl in * ; intros ; mysimp ; simpl in * ; mysimp.
    apply (IHh y v) ; auto.
  Qed.

  (** if [p] is fresh for [merge h1 h2], then it's also fresh for both [h1] and [h2]. *)
  Lemma merge_not_indom h1 h2 p : fresh p (merge h1 h2) -> fresh p h1 /\ fresh p h2.
  Proof.
    unfold fresh ; induction h1 ; simpl ; auto. destruct a. intros ;
    destruct (ptr_eq p0 p). subst. simpl in *. assert False. apply H.
    generalize (merge h1 h2). induction h ; mysimp. contradiction. simpl in *.
    apply IHh1. eapply indom_insert ; eauto.
  Qed.

  Lemma merge_disjoint h1 h2 h3 :
    disjoint h1 (merge h2 h3) -> disjoint h1 h2 /\ disjoint h1 h3.
  Proof.
    induction h1. mysimp. simpl. destruct a. intros. destruct H.
    destruct (merge_not_indom h2 h3 H). generalize (IHh1 _ _ H0). mysimp.
  Qed.

  Lemma max_heap_fresh : forall h n, n > max_heap h -> fresh n h.
  Proof.
    unfold fresh ; induction h ; mysimp ; unfold max in *. mysimp. mysimp. apply IHh.
    simpl in *. omega.
  Qed.

  Lemma remove_not_indom : forall p h, wf h -> fresh p (remove p h).
  Proof.
    unfold fresh ; induction h ; mysimp. apply lg_imp_not_indom ; auto.
  Qed.

  Lemma lookup_insert : forall x v h, lookup x (insert x v h) = Some v.
  Proof.
    induction h ; mysimp. assert False. omega. contradiction.
  Qed.

  Lemma remove_insert : forall x v h, remove x (insert x v h) = h.
  Proof.
    induction h ; mysimp. assert False. omega. contradiction.
  Qed.

  (** * Separation Reasoning *)

  (** Reasoning directly in terms of heaps is painful.  So we will define
      some rules for reasoning directly at the level of the separation logic.
      This list of lemmas is by no means complete... *)
  Lemma emp_star P : P ==> emp ** P.
  Proof.
    unfold himp, star, emp, disjoint ; simpl ; intros. exists empty_heap. exists h.
    mysimp.
  Qed.
  Hint Resolve emp_star : sep_db.

  Lemma star_comm P Q : P ** Q ==> Q ** P.
  Proof.
    unfold himp, star ; mysimp ; exists x0 ; exists x ; simpl in * ; mysimp ;
      try rewrite merge_comm ; auto ; apply disjoint_comm ; simpl ; auto.
  Qed.

  Lemma star_emp P : P ==> P ** emp.
  Proof.
    unfold himp, star, emp ; intros. apply star_comm ; auto. apply emp_star ; auto.
  Qed.
  Hint Resolve star_emp : sep_db.

  Lemma star_assoc P Q R : P ** (Q ** R) ==> (P ** Q) ** R.
  Proof.
    unfold himp, star ; mysimp ; subst.
    generalize (merge_disjoint _ _ _ H5). mysimp.
    exists (merge x x1). exists x2. mysimp. apply merge_wf ; auto.
    exists x. exists x1. mysimp. rewrite merge_assoc ; auto.
    apply disjoint_merge ; auto.
  Qed.

  Lemma pure_elim P R (Q:Prop) : Q -> R ==> P -> R ==> (pure Q) ** P.
  Proof.
    unfold himp, pure, star, emp, disjoint. intros. exists empty_heap. exists h. mysimp.
  Qed.
  Hint Resolve pure_elim : sep_db.

  Lemma comm_conc P Q R : P ==> Q ** R -> P ==> R ** Q.
  Proof.
    intros. intros h Hwf HP. apply star_comm ; auto.
  Qed.

  Lemma himp_id : forall P, P ==> P.
    unfold himp. auto.
  Qed.
  Hint Resolve himp_id : sep_db.

  Lemma ptsto_ptsto_some : forall t (x:tptr t) (v:interp t), x --> v ==> x -->?.
    unfold himp, typed_ptsto, ptsto_some, hexists, ptsto. intros.
    exists (existT interp t v). auto.
  Qed.
  Hint Resolve ptsto_ptsto_some : sep_db.

  Lemma hyp_comm : forall P Q R, P ** Q ==> R -> Q ** P ==> R.
  Proof.
    unfold himp ; mysimp. apply H ; auto. apply star_comm ; auto.
  Qed.

  Lemma hyp_pure : forall (P:Prop) Q R, (P -> Q ==> R) -> (pure P) ** Q ==> R.
  Proof.
    unfold himp, star, pure, emp ; mysimp ; subst ; simpl in *. apply H ; auto.
  Qed.
  Hint Resolve hyp_pure : sep_db.

  Lemma ptsto_hexist : forall t (p:tptr t) (v:interp t),
    p --> v ==> hexists (fun v => p --> v).
  Proof.
    unfold himp, hexists, typed_ptsto, ptsto ; mysimp ; subst ; mysimp. eauto.
  Qed.
  Hint Resolve ptsto_hexist.

  Lemma hyp_hexists : forall t (F:t->hprop) R,
    (forall x:t, F x ==> R) -> hexists F ==> R.
  Proof.
    unfold hexists. intros. intros h Hwf. mysimp. apply (H x h) ; auto.
  Qed.

  Definition himp_split P1 P2 Q1 Q2 : P1 ==> Q1 -> P2 ==> Q2 -> P1**P2 ==> Q1**Q2.
  Proof.
    unfold himp, star ; intros ; mysimp. exists x. exists x0. mysimp.
  Qed.

  (** This little tactic helps prove things are disjoint: *)
  Ltac disj :=
    repeat
      match goal with
        | [ H : disjoint ?x ?y |- disjoint ?y ?x ] => apply disjoint_comm ; auto
        | [ |- disjoint (merge _ _) _ ] => apply disjoint_merge
        | [ |- disjoint _ (merge _ _) ] => apply disjoint_comm
        | [ H : disjoint (merge _ _) _ |- _ ] =>
          generalize (merge_disjoint _ _ _ (disjoint_comm _ _ H)) ; clear H ; mysimp
        | [ H : disjoint _ (merge _ _) |- _ ] =>
          generalize (merge_disjoint _ _ _ H) ; clear H ; mysimp
        | [ |- wf (merge _ _) ] => apply merge_wf ; mysimp
        | [ |- _ ] => assumption
      end.

  Lemma star_assoc_l P Q R : (P ** Q) ** R ==> P ** Q ** R.
  Proof.
    unfold himp, star. mysimp ; disj. subst. exists x1. exists (merge x2 x0).
    mysimp ; disj. exists x2. exists x0. mysimp ; disj. rewrite merge_assoc ;
    auto ; disj.
  Qed.

  (** This lemma will help me simplify some reasoning involving existentials. *)
  Lemma existPull(A:Type)(F:A->Prop)(Y Z:Prop) :
    (exists x:A, F x) -> (Y -> Z) ->
    ((exists x:A, F x) -> Y) -> Z.
    mysimp. apply H0. apply H1. eauto.
  Qed.

  Lemma hyp_assoc_r P1 P2 P3 Q :
    P1 ** P2 ** P3 ==> Q -> (P1 ** P2) ** P3 ==> Q.
  Proof.
    unfold himp ; intros. apply H ; auto with sep_db. apply star_assoc_l ; auto.
  Qed.
  Hint Resolve hyp_assoc_r : sep_db.

  Lemma conc_emp P Q : P ==> Q -> P ==> Q ** emp.
    unfold himp, emp, star. intros. apply star_comm ; auto. unfold star.
    exists nil. exists h. mysimp.
  Qed.
  Hint Resolve conc_emp : sep_db.

  Lemma hyp_emp P Q : P ==> Q -> emp ** P ==> Q.
    unfold himp, emp, star. mysimp. subst. simpl in *. auto.
  Qed.
  Hint Resolve hyp_emp : sep_db.

  Lemma assoc_concl P Q1 Q2 Q3 :
    P ==> Q1 ** Q2 ** Q3 -> P ==> (Q1 ** Q2) ** Q3.
  Proof.
    unfold himp ; intros. apply star_assoc ; auto.
  Qed.

  Lemma himp_mp Q P R : Q ==> R -> P ==> Q -> P ==> R.
  Proof.
    unfold himp ; mysimp.
  Qed.

  (** ** Separation Logic Rules *)

  (** Separation logic total correctness:  [{{ P }} c {{ Q }}] holds iff
      (1) we start with a heap [h] that can be broken into two parts, one that
      satisfies [P] and another satisfying [sing h2] for some h2,
      (2) we run the command [c] on heap [h] and get out [Some] heap
      [h'] and value [v], and (3) the output heap [h'] satisfies
      [Q v ** sing h2].  That is, the output heap can be broken into two
      disjoint heaps, one satisfying [Q v], and one satisfying [sing h2].

      This effectively forces the command to be parametric in some part
      of the heap ([h2]) and leave it alone.  In turn, this means that
      if we have proven a separate property about [h2], this property
      will be preserved when we run [c].
  *)
  Definition sep_tc_triple(t:Type) (P:hprop)(c:Cmd t)(Q:t -> hprop) :=
    forall h h2, (P ** sing h2) h ->
      match c h with
        | None => False
        | Some (h',v) => (Q v ** sing h2) h'
      end.
  Notation "{{ P }} c {{ Q }}" := (sep_tc_triple P c Q) (at level 90) : cmd_scope.

  (** Lots of definitions to be unwound... *)
  Ltac unf := unfold sep_tc_triple, star, hexists, pure, emp, sing.

  (** This says that [ret v] can be run in a heap satisfying [emp] and
      returns a heap satisfying [emp] and the return value is equal to v.
      But remember that this really means that [ret] can be run in any
      heap [h] that can be broken into a portion satisfying [emp] (i.e.,
      the empty heap and some other heap (which must be [h]!) and that
      the other portion will be preserved.  In short, the specification
      captures the fact that [ret] will not change the heap.
   *)
  Lemma ret_tc (t:Type) (v:t) : {{ emp }} ret v {{ fun x => pure (x = v) }}.
  Proof.
    unf ; mysimp ; subst. exists empty_heap. exists x0. mysimp.
  Qed.

  (** [new v] consumes an empty heap, and produces a pointer [x] and
     a heap satisfying [x --> v].  Because of the definition of the
     separation-total-correctness triple, [x] must be fresh for the
     whole heap. *)
  Lemma new_tc (t:stype)(v:interp t) :
    {{ emp }} new t v {{ fun (x:tptr t) => x --> v }}.
  Proof.
    unfold new, typed_ptsto ; unf ; mysimp ; subst.
    exists ((S (max_heap x0),existT interp t v)::nil). exists x0.
    mysimp. unfold ptsto ; auto. apply max_heap_fresh. omega.
  Qed.

  (** [free x] is nicely dual to [new]. *)
  Lemma free_tc (p:ptr) :
    {{ p-->? }} free p {{ fun _ => emp }}.
  Proof.
    unf ; unfold ptsto_some, hexists, ptsto, free ; mysimp ; subst ; mysimp.
    rewrite lookup_insert. exists nil. exists x0. mysimp.
    rewrite remove_insert. auto.
  Qed.

  (** [write p v] requires a heap where [p] points to some value, and ensures
      [p] points to [v] afterwards. *)
  Lemma write_tc (t:stype) (p:tptr t) (v:interp t) :
    {{ p -->? }} write p v {{ fun _ => p --> v }}.
  Proof.
    unfold ptsto_some, typed_ptsto, hexists, ptsto, write, untyped_write ; unf.
    mysimp ; subst ; mysimp ; simpl in *.
    rewrite lookup_insert. exists ((p,existT interp t v)::nil). exists x0. mysimp.
    rewrite remove_insert ; auto.
  Qed.

  (** [read p] requires a heap where [p] points to some value [v], and ensures
      [p] points to [v] afterwards, and the result is equal to [v]. *)
  Lemma read_tc (t:stype) (p:tptr t) (v:interp t) :
    {{ p --> v }}
    read p
    {{ fun x => p --> x ** pure(x = v) }}.
  Proof.
    unf ; unfold typed_ptsto, ptsto, read, untyped_read, bind ;
      mysimp ; subst ; mysimp ; simpl in * ; mysimp.
    rewrite lookup_insert. destruct (stype_eq t t) ; try congruence.
    rewrite (proof_irrelevance e (eq_refl t)). unfold eq_rec_r ; simpl.
    simpl. exists ((p,existT interp t v)::nil). exists x0. mysimp.
    exists ((p,existT interp t v)::nil). exists nil. mysimp.
  Qed.

  (** This is one possible proof rule for [bind].  Basically, we require
      that the post-condition of the first command implies the pre-condition
      of the second command. *)
  Lemma bind_tc(T1 T2:Type) P1 Q1 P2 Q2 (c:Cmd T1)(f: T1 -> Cmd T2) :
    {{ P1 }} c {{ Q1 }} ->
    (forall x, {{ P2 x }} (f x) {{ Q2 }}) ->
    (forall x, Q1 x ==> P2 x) ->
    {{ P1 }} bind c f {{ Q2 }}.
  Proof.
    unfold bind ; unf ; mysimp ; subst.
    generalize (H (merge x x0) x0). clear H.
    apply existPull. exists x. exists x0. mysimp. destruct (c (merge x x0)) ;
    mysimp. subst. generalize (H0 t (merge x1 x2) x2). clear H0.
    apply existPull. exists x1. exists x2. mysimp. eapply H1 ; eauto. auto.
  Qed.
  Implicit Arguments bind_tc [T1 T2 P1 Q1 P2 Q2 c f].

  (** And we also have a rule of consequence which allows us to strengthen the
      pre-condition and weaken the post-condition.  Note however, that this will
      not allow us to "forget" any locations in our footprint. *)
  Lemma consequence_tc (T:Type) P1 Q1 P2 Q2 (c:Cmd T) :
    {{ P1 }} c {{ Q1 }} ->
    P2 ==> P1 ->
    (forall x, Q1 x ==> Q2 x) ->
    {{ P2 }} c {{ Q2 }}.
  Proof.
    unf ; mysimp ; subst ; mysimp. generalize (H (merge x x0) x0). clear H.
    apply existPull. exists x. exists x0. mysimp. destruct (c (merge x x0)) ; mysimp.
    subst. exists x1. exists x2. mysimp. eapply H1 ; mysimp.
  Qed.
  Implicit Arguments consequence_tc [T P2 Q2 c].

  (** This is a specialization of consequence that is a little more useful to use. *)
  Lemma strengthen_tc (T:Type) P1 P2 Q1 (c:Cmd T):
    {{P1}}c{{Q1}} ->
    P2 ==> P1 ->
    {{P2}}c{{Q1}}.
  Proof.
    intros. eapply consequence_tc ; eauto with sep_db.
  Qed.
  Implicit Arguments strengthen_tc [T P2 Q1 c].

  (** This is a specialization of consequence that is a little more useful to use. *)
  Lemma weaken_tc (T:Type) P1 Q1 Q2 (c:Cmd T):
    {{P1}}c{{Q1}} ->
    (forall x, Q1 x ==> Q2 x) ->
    {{P1}}c{{Q2}}.
  Proof.
    intros. eapply consequence_tc ; eauto with sep_db.
  Qed.

  (** Finally, this is the most important rule and the one we lacked with
      Hoare logic:  If [{{ P }} c {{ Q }}], then also
      [{{ P ** R }} c {{ Q ** R }}].  That is, properties such as [R] which
      are disjoint from the footprint are preserved when we run the command.
  *)
  Lemma frame_tc(T:Type)(c : Cmd T) P Q R :
    {{ P }} c {{ Q }} -> {{ P ** R }} c {{ fun x => (Q x) ** R }}.
  Proof.
    unf ; mysimp ; subst ; mysimp. rewrite <- merge_assoc ; auto ; disj.
    generalize (H (merge x1 (merge x2 x0)) (merge x2 x0)). clear H.
    apply existPull. exists x1. exists (merge x2 x0). mysimp ; disj.
    destruct (c (merge x1 (merge x2 x0))) ; mysimp ; subst.
    exists (merge x x2). exists x0. mysimp ; disj.
    exists x. exists x2. mysimp ; disj. rewrite merge_assoc ; disj ; auto.
  Qed.
  Implicit Arguments frame_tc [T c P Q].

  Ltac sep := repeat
    (simpl in * ; (try subst) ;
      match goal with
        | [ |- forall _, _ ] => intros
        | [ |- _ ** ?Q ==> _ ** ?Q ] => eapply himp_split
        | [ |- ?P ** _ ==> ?P ** _ ] => eapply himp_split
        | [ |- ?P ** _ ==> _ ** ?P ] => eapply hyp_comm
        | [ |- hexists _ ==> _ ] => eapply hyp_hexists
        | [ |- _ ** pure _ ==> _ ] => eapply hyp_comm ; eapply hyp_pure
        | [ |- (_ ** _) ** _ ==> _ ] => eapply hyp_assoc_r
        | [ |- _ ==> (_ ** _) ** _ ] => eapply assoc_concl
        | _ => eauto with sep_db
      end).

  (** * Examples *)
  Definition inc(p:tptr Nat_t) :=
    v <- read p ;
    write p (1 + v).

  (** So this claims that if we start in a state where [p] holds [n],
      then after running inc, we do not fail and get into a state
      where [p] holds [1+n].  Notice that it's rather delicate to
      hang on to the fact that the value read out is equal to [n].  If
      we used binary post-conditions (a relation on both the input heap
      and output heap), this wouldn't be necessary.  *)
  Definition inc_tc(p:tptr Nat_t)(n:interp Nat_t) :
    {{ p --> n }} inc p {{ fun _ => p --> 1+n }}.
  Proof.
    unfold inc ; sep.
    eapply bind_tc ; sep.
    eapply read_tc ; sep. simpl.
    eapply consequence_tc. eapply (frame_tc (pure (x = n))).
    eapply write_tc. sep. simpl. sep.
  Qed.

  (** The great part is that now if we have a property on some disjoint
     part of the state, say [p2 --> n2], then after calling [inc], we
     are guaranteed that property is preserved via the frame rule. *)
  Definition inc_two(p1 p2:tptr Nat_t)(n1 n2:interp Nat_t) :
    {{ p1 --> n1 ** p2 --> n2 }} inc p1 {{ fun _ => p1 --> 1+n1 ** p2 --> n2 }}.
  Proof.
    intros.
    apply (frame_tc (p2 --> n2)).
    apply inc_tc.
  Qed.

  (** swap the contents of two pointers *)
  Definition swap(t:stype)(p1 p2:tptr t) :=
    v1 <- read p1 ;
    v2 <- read p2 ;
    write p2 v1 ;;
    write p1 v2.

  (** Alas, reasoning isn't quite as simple as we might hope.  We have to
      not only put in the right uses of the frame and consequence rules,
      but we must also so a lot of commuting and re-associating to discharge
      the verification conditions.  For Ynot, Adam Chlipala wrote an Ltac
      tactic that mostly took care of this sort of simple reasoning for us.
      And Gonthier et al. have done some nice work showing how to use
      type-classes or canonical-structures to automate a lot of this sort
      of thing.  Below, we'll see you an alternative technique based on
      reflection. *)
  Lemma swap_tc(t:stype)(p1 p2:tptr t)(v1 v2:interp t) :
    {{ p1 --> v1 ** p2 --> v2 }} swap p1 p2 {{ fun _ => p1 --> v2 ** p2 --> v1 }}.
  Proof.
    unfold swap ; sep.
    eapply bind_tc ; sep.
    eapply (frame_tc (p2 --> v2)).
    eapply read_tc. sep.
    eapply (consequence_tc ((p2 --> v2 ** p1 --> x) ** pure (x = v1))).
    eapply (frame_tc (pure (x = v1))).
    eapply bind_tc ; sep.
    eapply (frame_tc (p1 --> x)).
    eapply read_tc ; sep. simpl.
    eapply (consequence_tc ((p2 -->? ** p1 --> x) ** pure (x0 = v2))).
    eapply (frame_tc (pure (x0 = v2))).
    eapply bind_tc ; sep.
    eapply (frame_tc (p1 --> x)).
    eapply write_tc ; sep. sep.
    eapply (consequence_tc (p1 -->? ** p2 --> x)).
    eapply (frame_tc (p2 --> x)).
    eapply write_tc ; sep. apply hyp_comm. sep. sep. eapply himp_id.
    sep. eapply himp_split ; sep. sep. eapply himp_id.
    eapply hyp_comm. sep. sep.
  Qed.

  (** ** Reflection and a Simple, Correct Semi-Decision Procedure *)

  (** Our goal is to build a Coq function that can simplify a separation
      implication [P ==> Q] and prove that function correct. One simple
      strategy is to flatten out all of the stars and cross off all of
      the simple predicates that appear in both [P] and [Q].

      But of course, we can't just crawl over an [hprop] because in
      general, these are functions!  So our trick is to write down some
      syntax that represents a particular predicate, and then give an
      interpretation that maps that syntax back to our real predicate.
      Then we can compute with the syntax.

      The Quote library should help us with this, but alas, it's not
      as clever as we might hope it would be... *)
  Definition hprop_name := nat.
  Definition hprop_map := list (hprop_name * hprop).
  Definition hprop_name_eq := eq_nat_dec.

  (** We begin by giving a basic syntax for predicates.  [Atom] will
      be used to represent things like abstract predicates (e.g., a
      variable [P]) or a points-to-predicate etc.  We'll use an
      environment to map [hprop_name]s to the real [hprop]. *)
  Inductive Hprop : Set :=
  | Emp : Hprop
  | Atom : hprop_name -> Hprop
  | Star : Hprop -> Hprop -> Hprop.

  Infix "#" := Star (right associativity, at level 80) : sep_scope.

  Fixpoint lookup_hprop (n:hprop_name) (hp:hprop_map) :=
    match hp with
      | nil => (pure False)
      | (m,P)::rest => if hprop_name_eq n m then P else lookup_hprop n rest
    end.

  Section HINTERP.
    (** assume we have an [hprop_map] lying around. *)
    Variable hmap : hprop_map.

    (** Now we given an interpreation to the syntax for predicates: *)
    Fixpoint hinterp (hp:Hprop) : hprop :=
      match hp with
        | Emp => emp
        | Atom n => lookup_hprop n hmap
        | Star h1 h2 => star (hinterp h1) (hinterp h2)
      end.

    (** Flatten a predicate into a list of [hprop_name]s. *)
    Fixpoint flatten (hp:Hprop) : list hprop_name :=
      match hp with
        | Emp => nil
        | Atom n => n::nil
        | Star h1 h2 => (flatten h1) ++ (flatten h2)
      end.

    (** Remove exactly one copy of the [hprop_name] [n] from the input list,
        returning [None] if we fail to find a copy of [n]. *)
    Fixpoint remove_one(n:hprop_name)(hps : list hprop_name) :option (list hprop_name) :=
      match hps with
        | nil => None
        | (m::rest) =>
          if hprop_name_eq n m then Some rest else
            match remove_one n rest with
              | None => None
              | Some hps' => Some (m::hps')
            end
      end.

    (** This is the heart of our simplification algorithm.  Here, we are
        running through the list of names [hp1], trying to cross off each
        one that occurs in [hp2].  If the current name doesn't occur, we
        add it to the end of [hp0] so that we can keep track of it.  That
        is, our invariant at each step should be that [hp0 ** hp1 ==> hp2]
        once we map the lists back to [hprop]s. *)
    Fixpoint simplify (hp0 hp1 hp2:list hprop_name) :=
      match hp1 with
        | nil => (hp0,hp2)
        | (n::hp1') =>
          match remove_one n hp2 with
            | Some hp2' => simplify hp0 hp1' hp2'
            | None => simplify (hp0 ++ n::nil) hp1' hp2
          end
      end.

    (** Convert a list of names back into an [Hprop]. *)
    Definition collapse := List.fold_right (fun n p => Star (Atom n) p) Emp.
    (** Convert a list of names into an [hprop]. *)
    Definition interp_list := List.fold_right (fun n p => (lookup_hprop n hmap) ** p) emp.

    (** So our cross-off algorithm takes two [Hprop]s, flattens them into
        lists of names, simplifies the two lists by crossing off common
        names, and then returns the two Hprop's we get by collapsing the
        resulting simplified lists. *)
    Definition cross_off (hp1 hp2 : Hprop) : Hprop * Hprop :=
      let (hp1', hp2') := simplify nil (flatten hp1) (flatten hp2) in
        (collapse hp1', collapse hp2').

    Lemma collapse_interp hp : hinterp (collapse hp) = interp_list hp.
    Proof.
      induction hp ; mysimp. rewrite IHhp. auto.
    Qed.

    (** The following are various lemmas needed to reason about the interpretation
        of the syntax. *)
    Lemma interp_list_app hp1 hp2 :
      interp_list (hp1 ++ hp2) ==> ((interp_list hp1) ** (interp_list hp2)).
    Proof.
      induction hp1. simpl. intros. apply comm_conc. apply conc_emp. auto with sep_db.
      simpl. intros. sep.
    Qed.

    Lemma app_interp_list hp1 hp2 :
      ((interp_list hp1) ** (interp_list hp2)) ==> interp_list (hp1 ++ hp2).
    Proof.
      induction hp1. simpl. intros. apply hyp_emp. sep. simpl ; intros. sep.
    Qed.

    Lemma hinterp_flatten hp : hinterp hp ==> interp_list (flatten hp).
    Proof.
      induction hp ; simpl. sep. apply conc_emp. sep.
      eapply himp_mp. eapply app_interp_list. eapply himp_split ; eauto.
    Qed.

    Lemma remove_one_splits n hp:
      match remove_one n hp with
        | Some hp' => exists hp1, exists hp2, hp = hp1 ++ n::hp2 /\ hp' = hp1 ++ hp2
        | None => True
      end.
    Proof.
      induction hp ; mysimp. destruct (hprop_name_eq n a). subst.
      exists nil. exists hp. mysimp. destruct (remove_one n hp).
      mysimp. subst. exists (a::x). exists x0. mysimp. mysimp.
    Qed.

    Lemma interp_list_comm x1 x2 : interp_list (x1 ++ x2) ==> interp_list (x2 ++ x1).
    Proof.
      induction x1 ; simpl. intros. rewrite <- app_nil_end. sep.
      intros. eapply himp_mp. eapply app_interp_list.
      eapply comm_conc. simpl. sep. apply interp_list_app.
    Qed.

    Lemma himp_remove_one n hp1 hp2 :
      match remove_one n hp1, remove_one n hp2 with
        | Some hp1', Some hp2' =>
          (interp_list hp1' ==> interp_list hp2') ->
          interp_list hp1 ==> interp_list hp2
        | _, _ => True
      end.
    Proof.
      intros.
      generalize (remove_one_splits n hp1). generalize (remove_one_splits n hp2).
      destruct (remove_one n hp1) ; auto. destruct (remove_one n hp2) ; auto.
      mysimp. subst.
      eapply himp_mp. eapply interp_list_comm. sep.
      eapply (@himp_mp (interp_list ((n::x0) ++ x))) ; try apply interp_list_comm.
      sep. eapply himp_mp. apply interp_list_comm.
      eapply (@himp_mp (interp_list (x ++ x0))). auto. apply interp_list_comm.
    Qed.

    Lemma himp_simp n hp1 hp2 :
      match remove_one n hp2 with
        | Some hp2' =>
          (interp_list hp1 ==> interp_list hp2') ->
          (interp_list (n::hp1) ==> interp_list hp2)
        | None => True
      end.
    Proof.
      intros. generalize (himp_remove_one n (n::hp1) hp2). simpl.
      destruct (hprop_name_eq n n) ; mysimp.
    Qed.

    (** This is the key invariant for our [simplify] routine. *)
    Lemma simplify_corr hp1 hp0 hp2 :
      interp_list (fst (simplify hp0 hp1 hp2)) ==>
      interp_list (snd (simplify hp0 hp1 hp2)) ->
      interp_list (hp0 ++ hp1) ==> interp_list hp2.
    Proof.
      induction hp1. simpl. intros. rewrite <- app_nil_end. auto. simpl. intros.
      generalize (himp_simp a (hp0 ++ hp1) hp2). intros. destruct (remove_one a hp2).
      eapply himp_mp. eapply H0.
      apply (IHhp1 hp0 l). eauto with sep_db.
      eapply (@himp_mp (interp_list ((a::hp1) ++ hp0))). sep. apply interp_list_comm.
      apply interp_list_comm.
      generalize (IHhp1 (hp0 ++ (a::nil)) hp2) ; rewrite app_ass ; simpl ; auto.
    Qed.

    Lemma flatten_hinterp hp : interp_list (flatten hp) ==> hinterp hp.
    Proof.
      induction hp ; mysimp. sep. apply hyp_comm. apply hyp_emp. sep.
      eapply (@himp_mp (interp_list (flatten hp1) ** interp_list (flatten hp2))).
      eapply himp_split ; auto. apply interp_list_app.
    Qed.

    (** This is the proof that the [cross_off] algorithm is correct.  That is,
        if we can prove that the resulting implication holds after crossing off,
        then the original implication holds. *)
    Lemma cross_off_corr :
      forall hp1 hp2,
        let (hp1',hp2') := cross_off hp1 hp2 in
        (hinterp hp1') ==> (hinterp hp2') ->
        (hinterp hp1) ==> (hinterp hp2).
    Proof.
      intros. remember (cross_off hp1 hp2) as e. unfold cross_off in Heqe.
      destruct e. intros.
      eapply (@himp_mp (interp_list (flatten hp1))) ; [ idtac | apply hinterp_flatten ].
      generalize (simplify_corr (flatten hp1) nil (flatten hp2)). intros.
      eapply himp_mp. eapply flatten_hinterp. simpl in H0. apply H0.
      destruct (simplify nil (flatten hp1) (flatten hp2)). simpl in *.
      repeat rewrite <- collapse_interp. injection Heqe ; intros ; subst. auto.
    Qed.
  End HINTERP.

  (** Here is an example using the reflection.  We have a large implication to
      prove that demands many re-associations, commutations, etc.  So we
      first build an [hmap] from numbers to [hprop]s, then we build
      syntax that parallels the predicates, being sure to use the right
      atoms according to the [hmap], and finally we invoke the [cross_off_corr]
      lemma to get a much simplified routine.  In this case, the simplification
      gets everything down to [emp ==> emp]. *)
  Lemma crazy P Q R S T : Q ** (P ** R) ** (S ** T) ==> T ** (S ** P) ** Q ** R.
    intros.
    generalize (
      let hmap := (0,P)::(1,Q)::(2,R)::(3,S)::(4,T)::nil in
      let H1 := Atom 1 # (Atom 0 # Atom 2) # (Atom 3 # Atom 4) in
      let H2 := Atom 4 # (Atom 3 # Atom 0) # Atom 1 # Atom 2 in
        cross_off_corr hmap H1 H2
    ).
    simpl.
    intro H. apply H.
    sep.
  Qed.

  Ltac lookup_name term map :=
    match map with
      | (?n,?P)::?rest =>
        match term with
          | P => constr:(Some (Atom n))
          | _ => lookup_name term rest
        end
      | _ => constr:(@None Hprop)
    end.

  Ltac reflect term map :=
    match term with
      | star ?P ?Q =>
        match reflect P map with
          | (?t1,?map1) =>
            match reflect Q map1 with
              | (?t2, ?map2) => constr:((Star t1 t2, map2))
            end
        end
      | emp => constr:((Emp, map))
      | _ =>
        match lookup_name term map with
          | Some ?t => constr:(t, map)
          | None => let n := constr:(S (List.length map)) in
                    constr:(Atom n, ((n,term)::map))
        end
    end.

  Ltac cross :=
    match goal with
      | [ |- ?A ==> ?B ] =>
        let map := constr:(@nil (hprop_name * hprop)) in
        match reflect A map with
          | (?t1, ?map1) =>
            match reflect B map1 with
              | (?t2, ?map2) =>
                apply (cross_off_corr map2 t1 t2) ; simpl
            end
        end
    end.

   Lemma crazy2 P Q R S T: Q ** (P ** R) ** (S ** T) ==> T ** (S ** P) ** Q ** R.
     intros.
     cross.
     sep.
    Defined.
Eval compute in crazy2.

    Lemma crazy3 (p q r s:tptr Nat_t) :
      (p --> 0 ** q --> 1) ** (r --> 2 ** emp) ** (s --> 3) ==>
      s --> 3 ** q --> 1 ** p --> 0 ** r --> 2.
    Proof.
      intros.
      cross.
      sep.
    Defined.

End FunctionalSepIMP.