Add LoadPath "..".
Require Import List.
Require Import base.
Require Import uf.UF_interface.
Require Import uf.UF_implementation.
Require Import rbt.MMapRBT.
Require Import rbt.MMapInterface.
Require Import partition_base.
Require Import partition_interface.

Module Internal_Structures (Import Input : INPUT)
                           (Import ot : OrderedType with Definition t := Input.e
                                                    with Definition eq := @Logic.eq Input.e).

  Module UF := Union_Find Input ot.
  Module UFL := UnionFind_Lemmas Input UF. Import UFL.
  Module RBT := Make ot.

  Definition var := ot.t.

  (*Implementation section*)
  Definition emptyUF := UF.empty.
  Definition add_singleton2uf (uf : UF.t) (v : var) :
   (UF.t * var) :=
   match (UF.find uf v) with
   | (Some v', uf') => (uf', v')
   | (None, uf')    => (UF.singleton uf' v,v)
   end.
  Definition add_singleton2uf_t p v := fst (add_singleton2uf p v).
  Definition add_singleton2uf_v p v := snd (add_singleton2uf p v).
  Definition union_singleton2uf (v : var) (p : (UF.t * option var)):
   (UF.t * option var):=
   let (uf,ov)  := p in
   let (uf',v') := add_singleton2uf uf v in
   match ov with
   | None     => (uf', Some v')
   | Some v'' => let uf'' := UF.union uf' v' v'' in (uf'',UF.find_e uf'' v')
   end.
  Definition union_singleton2uf_t v p := fst (union_singleton2uf v p).
  Definition union_singleton2uf_v v p := snd (union_singleton2uf v p).
  Definition add_list2uf (uf : UF.t) (l : list var)  : (UF.t * option var):=
   fold_right union_singleton2uf (uf,None) l.
  Definition add_list2uf_t uf l := fst (add_list2uf uf l).
  Definition add_list2uf_v uf l := snd (add_list2uf uf l).
  Definition eqn2uf {A : Type} `{VAB : varsable A var} (uf : UF.t) (eqn : A) :=
   add_list2uf uf (vars eqn) .
  Implicit Arguments eqn2uf [A VAB].
  Definition eqn2uf_t {A : Type} `{VAB : varsable A var} (uf : UF.t) (eqn : A) := fst (eqn2uf uf eqn).
  Implicit Arguments eqn2uf_t [A VAB].
  Definition eqn2uf_v {A : Type} `{VAB : varsable A var} uf eqn:= snd (eqn2uf uf eqn).
  Implicit Arguments eqn2uf_v [A VAB].
  Definition eqnlist2uf {A : Type} `{VAB : varsable A var} (l : list A) : UF.t :=
   fold_right (fun eqn uf => eqn2uf_t uf eqn) emptyUF l.
  Definition get_t {A : Type} (p : (UF.t * A)) := fst p.
  Definition get_v {A : Type} (p : (UF.t * A)) := snd p.

  Definition emptyRBT (A : Type):= @RBT.empty A.
  Definition find_var {A : Type } `{VAB : varsable A var} (uf : UF.t)  (eqn : A) :
  (option var * UF.t) :=
   match (vars eqn) with
   | nil  => (None,uf)
   | v::l => UF.find uf v
   end.
  Definition find_var_v {A : Type } `{VAB : varsable A var} (uf : UF.t) (eqn : A) :
   option var := fst (find_var uf eqn).
  Definition find_var_uf {A : Type } `{VAB : varsable A var} (uf : UF.t)  (eqn : A) :
   UF.t := snd (find_var uf eqn).
  Definition find_add {B: Type}
  (a : var) (b : B) (rbt : RBT.map_of (list B)) : RBT.map_of (list B):=
   match RBT.find a rbt with
   | Some l => RBT.add a (b::l) rbt
   | None   => RBT.add a (b::nil) rbt
   end.
  Definition find_list_rbt {B : Type} (a : var) (rbt : RBT.map_of (list B)) : list B :=
   match RBT.find a rbt with
   | None => nil
   | Some l => l
   end.
  (*Precondition: all vars were already in uf*)
  Definition add_equation2RBT {A : Type} `{VAB : varsable A var}
  (eqn : A) (uf : UF.t) (rbt : RBT.map_of (list A)) (l : list A) :
  (list A * (RBT.map_of (list A)))%type:=
   match find_var_v uf eqn with
   | None   => match (vars eqn) with
               | nil    => (eqn::l,rbt)
               | v'::l' => (l,rbt) (*should never happen*)
               end
   | Some v => (l,find_add v eqn rbt)
   end.
  Definition add_equation2RBT_l {A : Type} `{VAB : varsable A var} (eqn:A) uf rbt l :=
   fst (add_equation2RBT eqn uf rbt l).
  Implicit Arguments add_equation2RBT_l [A VAB].
  Definition add_equation2RBT_rbt {A : Type} `{VAB : varsable A var} (eqn:A) uf rbt l :=
   snd (add_equation2RBT eqn uf rbt l).
  Implicit Arguments add_equation2RBT_rbt [A VAB].
  Definition get_list {A B : Type} (p : (list A * RBT.map_of B)%type) := fst p.
  Definition get_rbt {A B : Type} (p : (list A * RBT.map_of B)%type) := snd p.
  (*Precondition: all vars were already in uf*)
  Definition eqnlist2RBT {A : Type} `{VAB : varsable A var}
  (l : list A) (uf : UF.t) : (list A * RBT.map_of (list A))%type :=
   fold_right (fun eqn p => add_equation2RBT eqn uf (snd p) (fst p))
              (nil,emptyRBT (list A)) l.
  Definition eqnlist2RBT_l {A : Type} `{VAB : varsable A var} (l : list A) uf :=
   fst (eqnlist2RBT l uf).
  Implicit Arguments eqnlist2RBT_l [A VAB].
  Definition eqnlist2RBT_rbt {A : Type} `{VAB : varsable A var} (l : list A) uf :=
   snd (eqnlist2RBT l uf).
  Implicit Arguments eqnlist2RBT_rbt [A VAB].
  (*Conditions for UF section*)
  Definition UF_in_cond {A : Type} `{VAB : varsable A var} (uf : UF.t) (l : A)  : Prop :=
   forall v', In v' (vars l) -> UF.In uf v'.
  Definition UF_component_cond {A : Type} `{VAB : varsable A var} (uf : UF.t)  (eqn : A): Prop :=
   (vars eqn) <> nil ->
   (exists v, forall v', In v' (vars eqn) -> UF.find_e uf v' = Some v).
  Definition UF_lcomponents_cond {A : Type} `{VAB : varsable A var} uf (l : list A) : Prop :=
   forall eqn, In eqn l -> UF_component_cond uf eqn.
  Definition UF_set_of_cond {A : Type} `{VAB:varsable A var}(uf : UF.t) (eqn : A) : Prop :=
   forall v1 v2, In v1 (vars eqn) -> In v2 (vars eqn) -> UF.In uf v1 /\ UF.set_of uf v1 v2.

  Lemma UF_set_of_cond_equiv: forall {A : Type} `{VAB:varsable A var} uf (eqn : A),
   UF_set_of_cond uf eqn <-> UF_component_cond uf eqn.
  Proof.
   intros. split;repeat intro.
   unfold UF_set_of_cond in H.
   remember (vars eqn).
   icase l. tauto.
   assert (In v (v::l)). left;trivial.
   destruct (H v v H1 H1).
   apply In_Some in H2.
   destruct H2. exists x. intros.
   destruct (H v v' H1 H4). congruence.
   unfold UF_component_cond in H.
   detach H. destruct H.
   generalize (H _ H0);intro.
   generalize (H _ H1);intro.
   split. apply In_Some. exists x;trivial.
   congruence.
   intro. unfold var in H. unfold t in *.
   rewrite H in H0. inv H0.
  Qed.

  Lemma UF_in_cond_prop1 : forall {A : Type} `{VAB : varsable A var} (a : A) l uf,
   UF_in_cond uf  (a::l) <-> UF_in_cond uf a /\ UF_in_cond uf l.
  Proof.
   repeat intro.
   unfold UF_in_cond.
   simpl. split;intros.
   split;intros;
   spec H v'; rewrite in_app_iff in H; tauto.
   rewrite in_app_iff in H0.
   destruct H.
   spec H v'. spec H1 v'. tauto.
  Qed.

  Lemma UF_in_cond_prop2: forall (A : Type) (VAB : varsable A var) (l : list A) (a : A)  uf,
   UF_in_cond uf l -> In a l-> UF_in_cond uf a.
  Proof.
   induction l;intros. inversion H0.
   apply UF_in_cond_prop1 in H.
   destruct H0. subst. tauto.
   apply IHl;trivial. tauto.
  Qed.

  Lemma UF_component_cond_prop1: forall {A : Type} `{VAB : varsable A var} (a : A) l uf,
   UF_component_cond uf (a::l)  -> UF_component_cond uf a /\ UF_component_cond uf l.
  Proof.
   intros.
   unfold UF_component_cond in *.
   split;intros.
   detach H. destruct H.
   exists x;intros. apply H.
   simpl. rewrite in_app_iff. left;trivial.
   simpl. intro. apply H0. apply app_eq_nil in H. tauto.
   detach H. destruct H.
   exists x;intros. apply H.
   simpl. rewrite in_app_iff. right;trivial.
   simpl. intro. apply H0. apply app_eq_nil in H. tauto.
  Qed.

  Lemma UF_component_cond_prop2: forall {A : Type} `{VAB : varsable A var} (a : A) uf,
   UF_component_cond uf a -> UF_in_cond uf a.
  Proof.
   intros.
   unfold UF_in_cond,UF_component_cond in *.
   intros.
   detach H. destruct H. spec H v' H0.
   unfold UF.In. rewrite H. simpl. trivial.
   intro. unfold var in *. unfold t in *.
   rewrite H in H0. inv H0.
  Qed.

  Lemma UF_lcomponents_cond_prop1: forall {A : Type} `{VAB : varsable A var} (a : A) l uf,
   UF_lcomponents_cond uf (a::l) <-> UF_component_cond uf a /\ UF_lcomponents_cond uf l.
  Proof.
   intros.
   unfold UF_lcomponents_cond,UF_component_cond in *.
   split;intros.
   split;intros.
   apply H;trivial. left;trivial.
   apply H;trivial. right;trivial.
   destruct H.
   destruct H0. subst a. apply H. trivial.
   apply H2;trivial.
  Qed.

  Lemma UF_lcomponents_cond_prop2: forall {A : Type} `{VAB: varsable A var} (l : list A) uf,
   UF_component_cond uf l -> UF_lcomponents_cond uf l.
  Proof.
   intros.
   unfold UF_lcomponents_cond, UF_component_cond in *.
   intros.
   detach H. destruct H.
   exists x. intros. apply H. eapply sublist_vars.
   apply H0. apply H2.
   intro. apply H1. apply sublist_vars in H0. rewrite H in H0.
   apply sublist_nil;trivial.
  Qed.

  Lemma UF_lcomponents_cond_prop3: forall {A : Type} `{VAB: varsable A var} (l : list A) uf,
   UF_lcomponents_cond uf l -> UF_in_cond uf l.
  Proof.
   intros.
   unfold UF_lcomponents_cond,UF_component_cond,UF_in_cond in *.
   intros.
   apply var_list_exist in H0.
   destruct H0 as [? [? ?]].
   spec H x H0. detach H. destruct H.
   spec H v' H1.
   unfold UF.In. rewrite H. simpl;trivial.
   intro. rewrite H in H1. inversion H1.
  Qed.

  Lemma UF_lcomponents_cond_prop4: forall {A : Type} `{VAB: varsable A var} (l l' : list A) uf,
   UF_lcomponents_cond uf l -> sublist l' l -> UF_lcomponents_cond uf l'.
  Proof.
   intros.
   unfold UF_lcomponents_cond in *.
   intros. apply H. apply H0. apply H1.
  Qed.

  (*UF Lemmas section*)
  Lemma find_rewrite: forall uf uf' e e',
   (e',uf') = UF.find uf e -> uf' = UF.find_t uf e /\ e' = UF.find_e uf e.
  Proof.
   intros.
   unfold UF.find_t,UF.find_e.
   rewrite<-H;simpl. tauto.
  Qed.

  Lemma add_singleton2uf_rewrite: forall uf uf' v v',
   (uf',v') = add_singleton2uf uf v ->
   uf' = add_singleton2uf_t uf v /\ v' = add_singleton2uf_v uf v.
  Proof.
   intros.
   unfold add_singleton2uf_t,add_singleton2uf_v.
   rewrite<- H. simpl;tauto.
  Qed.

  Lemma add_singleton2uf_not_In: forall uf v ,
   ~UF.In uf v ->
   UF.set_in (add_singleton2uf_t uf v) (set_singleton v).
  Proof.
   intros.
   unfold add_singleton2uf_t,add_singleton2uf .
   remember (UF.find uf v). icase p.
   apply find_rewrite in Heqp. destruct Heqp;subst.
   remember (UF.find_e uf v). icase o;simpl.
   elimtype False. apply H.
   apply In_Some. exists e0. rewrite Heqo;trivial.
   apply UF.singleton_set_in_refl. intro. apply H.
   rewrite In_find_reduce in H0. trivial.
  Qed.

  Lemma add_singleton2uf_In: forall uf v1 v2,
   UF.In uf v1 -> UF.set_of uf v1 v2 ->
   forall v, UF.In (add_singleton2uf_t uf v) v1 /\
             UF.set_of (add_singleton2uf_t uf v) v1 v2 .
  Proof.
   intros.
   unfold add_singleton2uf_t,add_singleton2uf.
   remember (UF.find uf v). icase p.
   apply find_rewrite in Heqp.
   destruct Heqp;subst.
   remember (UF.find_e uf v). icase o;simpl.
   split. apply In_find_reduce. trivial.
   rewrite set_of_find_reduce. trivial.
   assert (~UF.In (UF.find_t uf v) v).
    rewrite In_find_reduce. intro.
    apply In_Some in H1. destruct H1. rewrite H1 in Heqo. inv Heqo.
   apply singleton_set_of;trivial.
   apply In_find_reduce. trivial.
   rewrite set_of_find_reduce. trivial.
  Qed.

  Lemma add_singleton2uf_set_of: forall uf v,
   UF.In (add_singleton2uf_t uf v) (add_singleton2uf_v uf v) /\
   UF.set_of (add_singleton2uf_t uf v) (add_singleton2uf_v uf v) v.
  Proof.
   intros.
   unfold add_singleton2uf_t,add_singleton2uf_v,add_singleton2uf.
   remember (UF.find uf v). icase p.
   apply find_rewrite in Heqp.
   destruct Heqp;subst.
   remember (UF.find_e uf v). icase o;simpl.
   split. apply In_find_reduce. apply find_In with v.
   rewrite Heqo;trivial.
   rewrite set_of_find_reduce.
   apply set_of_comm.
   apply Some_set_of.
   rewrite Heqo;trivial.
   split. apply In_Some.
   exists v. symmetry in Heqo.
   apply set_singleton_find.
   apply UF.singleton_set_in_refl.
   rewrite In_find_reduce.
   apply In_None. trivial.
   apply set_of_refl.
  Qed.

  Lemma union_singleton2uf_rewrite: forall uf uf' v v',
   (uf',v') = union_singleton2uf uf v ->
   uf' = union_singleton2uf_t uf v /\ v' = union_singleton2uf_v uf v.
  Proof.
   intros.
   unfold union_singleton2uf_t,union_singleton2uf_v.
   rewrite<- H. simpl;tauto.
  Qed.

  Lemma union_singleton2uf_In: forall uf v v' v1 v2,
   UF.In uf v ->
   UF.In uf v1 ->
   UF.set_of uf v1 v2 ->
   UF.In (union_singleton2uf_t v' (uf,Some v)) v1 /\
   UF.set_of (union_singleton2uf_t v' (uf,Some v) ) v1 v2.
  Proof.
   intros.
   unfold union_singleton2uf_t,union_singleton2uf.
   remember (add_singleton2uf uf v'). icase p;simpl.
   apply add_singleton2uf_rewrite in Heqp.
   destruct Heqp;subst.
   generalize (add_singleton2uf_set_of uf v);intro.
   destruct H2.
   generalize (add_singleton2uf_In _ _ _ H0 H1 v);intro.
   simpl.
   destruct H4.
   apply union_set_of.
   apply add_singleton2uf_set_of.
   eapply add_singleton2uf_In.
   apply H. apply set_of_refl.
   eapply add_singleton2uf_In.
   apply H0. apply set_of_refl.
   apply add_singleton2uf_In;trivial.
  Qed.

  Lemma union_singleton2uf_None: forall uf v,
   union_singleton2uf v (uf,None) =
  (add_singleton2uf_t uf v, Some (add_singleton2uf_v uf v)).
  Proof.
   intros.
   unfold union_singleton2uf.
   unfold add_singleton2uf_v,add_singleton2uf_t.
   remember (add_singleton2uf uf v).
   destruct p. simpl. trivial.
  Qed.

  Lemma union_singleton2uf_Some: forall uf a a' v,
   UF.In uf a ->
   union_singleton2uf_v a' (uf,Some a) = Some v ->
   UF.In (union_singleton2uf_t a' (uf,Some a)) v /\
   UF.set_of (union_singleton2uf_t a' (uf,Some a)) a' v.
  Proof.
   intros.
   unfold union_singleton2uf_t.
   unfold union_singleton2uf_v in H0.
   unfold union_singleton2uf in *.
   remember (add_singleton2uf uf a'). icase p.
   apply add_singleton2uf_rewrite in Heqp.
   destruct Heqp;subst. simpl in *.
   split. eapply find_In. apply H0.
   apply set_of_trans with (e':=add_singleton2uf_v uf a').
   eapply union_set_of.
   apply add_singleton2uf_set_of.
   eapply add_singleton2uf_In;trivial.
   apply set_of_refl.
   destruct (add_singleton2uf_set_of uf a').
   apply In_Some in H1. destruct H1.
   apply In_Some. exists x. congruence.
   apply set_of_comm. apply add_singleton2uf_set_of.
   apply Some_set_of in H0. apply H0.
  Qed.

  Lemma union_singleton2uf_combine: forall uf a v,
   UF.In uf a ->
   UF.In (union_singleton2uf_t v (uf, Some a)) a /\
   UF.set_of (union_singleton2uf_t v (uf, Some a)) v a.
  Proof.
   intros.
   unfold union_singleton2uf_t,union_singleton2uf.
   remember (add_singleton2uf uf v). icase p. simpl.
   apply add_singleton2uf_rewrite in Heqp. destruct Heqp. subst.
   split. eapply union_set_of.
   apply add_singleton2uf_set_of.
   eapply add_singleton2uf_In;trivial.
   apply set_of_refl.
   eapply add_singleton2uf_In;trivial.
   apply set_of_refl.
   apply set_of_refl.
   apply set_of_trans with (add_singleton2uf_v uf v).
   eapply union_set_of.
   apply add_singleton2uf_set_of.
   eapply add_singleton2uf_In;trivial.
   apply set_of_refl.
   destruct (add_singleton2uf_set_of uf v).
   apply In_Some in H0. destruct H0.
   apply In_Some. exists x.
   rewrite<- H0.
   generalize (set_of_rewrite);intro.
   rewrite H2 in H1. congruence.
   apply set_of_comm. apply add_singleton2uf_set_of.
   apply union_combine.
   apply add_singleton2uf_set_of.
   eapply add_singleton2uf_In;trivial.
   apply set_of_refl.
  Qed.

  Lemma union_singleton2uf_exist_Some: forall {A : Type} `{VAB:varsable A var} uf a v,
   UF.In uf a ->
   exists v', union_singleton2uf_v v (uf,Some a) = Some v'.
  Proof.
   intros.
   unfold union_singleton2uf_v,union_singleton2uf.
   remember (add_singleton2uf uf v).
   icase p. apply add_singleton2uf_rewrite in Heqp.
   destruct Heqp;subst. simpl.
   apply In_Some.
   eapply union_set_of.
   apply add_singleton2uf_set_of.
   eapply add_singleton2uf_In;trivial.
   apply set_of_refl.
   apply add_singleton2uf_set_of.
   apply set_of_refl.
  Qed.

  Lemma add_list2uf_rewrite: forall uf uf' a' l,
   (uf',a') = add_list2uf uf l ->
   uf' = add_list2uf_t uf l /\ a' = add_list2uf_v uf l.
  Proof.
   intros.
   unfold add_list2uf_t,add_list2uf_v;rewrite<-H.
   simpl;auto.
  Qed.

  Lemma add_list2uf_step_rewrite: forall uf a l,
   add_list2uf uf (a::l) = union_singleton2uf a (add_list2uf uf l).
  Proof.
   intros. simpl. tauto.
  Qed.

  Lemma add_list2uf_single: forall uf a,
   add_list2uf uf (a::nil) = union_singleton2uf a (uf,None).
  Proof.
   intros. simpl. tauto.
  Qed.

  Lemma add_list2uf_Some: forall {A : Type} `{VAB:varsable A var} l uf a,
    add_list2uf_v uf l = Some a -> UF.In (add_list2uf_t uf l) a .
  Proof.
   induction l;intros.
   unfold add_list2uf_v in H. inv H.
   unfold add_list2uf_t.
   unfold add_list2uf_v in H.
   rewrite add_list2uf_step_rewrite in *.
   remember (add_list2uf uf l).
   remember (union_singleton2uf a p).
   icase p0.
   apply union_singleton2uf_rewrite in Heqp0.
   destruct Heqp0;subst t0 o. simpl in *.
   icase p. apply add_list2uf_rewrite in Heqp.
   destruct Heqp;subst.
   remember (add_list2uf_v uf l). icase o.
   symmetry in Heqo. apply IHl in Heqo.
   destruct (union_singleton2uf_combine _ _ a Heqo).
   apply union_singleton2uf_Some;trivial.
   unfold union_singleton2uf_v,union_singleton2uf_t in *.
   rewrite union_singleton2uf_None in *. simpl in *.
   inv H. apply add_singleton2uf_set_of.
  Qed.

  Lemma add_list2uf_None: forall {A : Type} `{VAB:varsable A var} l uf,
   add_list2uf_v uf l = None <-> l = nil.
  Proof.
   induction l;intros;
   unfold add_list2uf_v.
   simpl;tauto.
   rewrite add_list2uf_step_rewrite.
   split;intros.
   remember (add_list2uf uf l). icase p.
   apply add_list2uf_rewrite in Heqp.
   destruct Heqp;subst.
   remember (add_list2uf_v uf l).
   icase o;symmetry in Heqo.
   apply add_list2uf_Some in Heqo.
   apply union_singleton2uf_exist_Some with (v:=a) in Heqo.
   destruct Heqo.
   unfold union_singleton2uf_v in H0.
   unfold var in *. unfold t in *. rewrite H0 in H. inv H.
   apply IHl in Heqo. subst.
   unfold add_list2uf_t in H. simpl in H.
   destruct (add_singleton2uf uf a);inv H.
   inv H.
  Qed.

  Lemma add_list2uf_In: forall {A : Type} `{VAB:varsable A var} l uf a a',
   UF.In uf a ->
   UF.set_of uf a a' ->
   UF.In (add_list2uf_t uf l) a /\ UF.set_of (add_list2uf_t uf l) a a'.
  Proof.
   induction l;intros.
   unfold add_list2uf_t;simpl. tauto.
   unfold add_list2uf_t.
   rewrite add_list2uf_step_rewrite.
   remember (add_list2uf uf l).
   remember (union_singleton2uf a p).
   icase p0.
   apply union_singleton2uf_rewrite in Heqp0.
   destruct Heqp0;subst. simpl.
   remember (add_list2uf uf l).
   icase p.
   apply add_list2uf_rewrite in Heqp. destruct Heqp.
   icase o;subst.
   apply union_singleton2uf_In.
   apply add_list2uf_Some. rewrite H2;trivial.
   eapply IHl;trivial. apply H0.
   apply IHl;trivial.
   unfold union_singleton2uf_t.
   rewrite union_singleton2uf_None. simpl.
   apply add_singleton2uf_In.
   eapply IHl;trivial. apply H0.
   apply IHl;trivial.
  Qed.

  Lemma add_list2uf_set_of: forall {A : Type} `{VAB:varsable A var} l uf a v,
   In v l ->
   add_list2uf_v uf l = Some a ->
   UF.set_of (add_list2uf_t uf l) a v.
  Proof.
   induction l;intros. inv H.
   generalize (add_list2uf_Some _ _ _ H0);intro.
   unfold add_list2uf_t. unfold add_list2uf_v,add_list2uf_t in H0,H1.
   rewrite add_list2uf_step_rewrite in *.
   remember (union_singleton2uf a (add_list2uf uf l)).
   destruct p. apply union_singleton2uf_rewrite in Heqp.
   destruct Heqp. subst. simpl in *.
   apply set_of_comm.
   remember (add_list2uf uf l).
   icase p. apply add_list2uf_rewrite in Heqp.
   destruct Heqp. subst.
   remember (add_list2uf_v uf l).
   symmetry in Heqo. icase o.
   destruct H;subst.
   apply union_singleton2uf_Some;trivial.
   apply add_list2uf_Some;trivial.
   generalize (IHl _ _ _ H Heqo);intro.
   apply add_list2uf_Some in Heqo.
   remember (add_list2uf_t uf l) as uf'.
   apply set_of_comm.
   apply set_of_trans with (e':=v0).
   apply set_of_trans with (e':=a).
   apply set_of_comm.
   apply union_singleton2uf_Some;trivial.
   apply union_singleton2uf_combine;trivial.
   apply union_singleton2uf_In;trivial.

   unfold union_singleton2uf_t,union_singleton2uf_v in *.
   rewrite union_singleton2uf_None in *. simpl in *. inv H0.
   destruct H;subst.
   apply set_of_comm. apply add_singleton2uf_set_of.
   apply add_list2uf_None in Heqo. subst. inv H.
  Qed.

  Lemma eqn2uf_component_cond: forall {A : Type} `{VAB:varsable A var}
  (a : A) (uf : UF.t),
   UF_component_cond (eqn2uf_t uf a) a.
  Proof.
   intros. apply UF_set_of_cond_equiv.
   repeat intro.
   unfold eqn2uf_t,eqn2uf.
   remember (add_list2uf uf (vars a)).
   icase p. apply add_list2uf_rewrite in Heqp.
   destruct Heqp;subst. simpl.
   remember (add_list2uf_v uf (vars a)).
   symmetry in Heqo. icase o.
   apply add_list2uf_set_of with (uf:=uf) (a:=v) in H;trivial.
   apply add_list2uf_set_of with (uf:=uf) (a:=v) in H0;trivial.
   apply add_list2uf_Some in Heqo.
   apply In_Some in Heqo. destruct Heqo.
   split. apply In_Some. exists x.
   unfold var in *;unfold t in *;congruence.
   unfold var in *;unfold t in *;congruence.
   apply add_list2uf_None in Heqo.
   unfold var in *;unfold t in *;rewrite Heqo in H. inv H.
  Qed.

  Lemma eqnlist2uf_lcomponents_cond: forall {A : Type} `{VAB:varsable A var} (l : list A),
   UF_lcomponents_cond (eqnlist2uf l) l.
  Proof.
   induction l;intros.
   unfold UF_lcomponents_cond. intros. inversion H.
   rewrite UF_lcomponents_cond_prop1. split.
   apply eqn2uf_component_cond. simpl.
   do 2 intro.
   apply UF_set_of_cond_equiv.
   spec IHl eqn H.
   apply UF_set_of_cond_equiv in IHl.
   repeat intro.
   destruct (IHl v1 v2 H0 H1).
   unfold eqn2uf_t,eqn2uf.
   apply add_list2uf_In;trivial.
  Qed.

  (*RBT Lemmas section*)

  Lemma find_list_rbt_spec: forall {B : Type} rbt a (b : list B),
   RBT.MapsTo a b rbt -> find_list_rbt a rbt = b.
  Proof.
   intros.
   unfold find_list_rbt.
   rewrite<- RBT.find_spec in H.
   rewrite H. trivial.
  Qed.
  Lemma find_add_spec1: forall {A : Type} `{VAB : varsable A var}
   (eqn : A) v rbt,
   RBT.MapsTo v (eqn::(find_list_rbt v rbt)) (find_add v eqn rbt).
  Proof.
   intros.
   unfold find_list_rbt,find_add.
   remember (RBT.find v rbt).
   icase o;
   apply RBT.add_spec1.
  Qed.
  Lemma find_add_spec2: forall {A : Type} `{VAB : varsable A var}
   (eqn : A) v v' l rbt,
   v' <> v ->
   (RBT.MapsTo v' l (find_add v eqn rbt) <-> RBT.MapsTo v' l rbt).
  Proof.
   intros.
   unfold find_add.
   remember (RBT.find v rbt).
   icase o;apply RBT.add_spec2;trivial.
  Qed.

  Lemma find_var_v_spec1: forall {A : Type} `{VAB : varsable A var} (eqn : A) uf,
   UF_in_cond uf eqn ->
   vars eqn <> nil ->
   exists v, find_var_v uf eqn = Some v.
  Proof.
   intros.
   unfold find_var_v,find_var.
   unfold UF_in_cond in H.
   remember (vars eqn). icase l. tauto.
   spec H v. detach H. unfold UF.In,UF.find_e in H.
   icase (UF.find uf v). icase o. exists e0. trivial.
   left;trivial.
  Qed.

  Lemma add_equation2RBT_rewrite : forall {A : Type} `{VAB :varsable A var} (eqn : A) rbt rbt' uf l l',
   (l',rbt') = add_equation2RBT eqn rbt uf l ->
   l' = add_equation2RBT_l eqn rbt uf l /\
   rbt' = add_equation2RBT_rbt eqn rbt uf l.
  Proof.
   intros.
   unfold add_equation2RBT_l,add_equation2RBT_rbt.
   rewrite <-H;simpl. tauto.
  Qed.

  Lemma add_equation2RBT_spec1 : forall {A : Type} `{VAB :varsable A var} v (eqn : A) rbt uf l,
   find_var_v uf eqn = Some v ->
   RBT.MapsTo v (eqn::(find_list_rbt v rbt))
                (add_equation2RBT_rbt eqn uf rbt l).
  Proof with auto.
   intros.
   unfold add_equation2RBT_rbt,add_equation2RBT in *.
   icase (find_var_v uf eqn). inv H.
   apply find_add_spec1.
  Qed.

  Lemma add_equation2RBT_spec2 : forall {A : Type} `{VAB :varsable A var} v v' eqn rbt uf l l',
   find_var_v uf eqn = Some v ->
   v' <> v ->
   (RBT.MapsTo v' l' (add_equation2RBT_rbt eqn uf rbt l) <->
    RBT.MapsTo v' l' rbt).
  Proof.
   intros.
   unfold add_equation2RBT_rbt,add_equation2RBT.
   remember (find_var_v uf eqn). icase o. inv H.
   apply find_add_spec2;trivial.
  Qed.

  Lemma add_equation2RBT_spec3: forall {A : Type} `{VAB :varsable A var} v eqn rbt uf l,
   find_var_v uf eqn = Some v ->
   add_equation2RBT_l eqn uf rbt l = l.
  Proof.
   intros.
   unfold add_equation2RBT_l,add_equation2RBT.
   icase (find_var_v uf eqn).
  Qed.

  Lemma add_equation2RBT_spec4 : forall {A : Type} `{VAB :varsable A var} (eqn : A) rbt uf l,
   vars eqn = nil ->
   add_equation2RBT eqn uf rbt l = (eqn::l,rbt).
  Proof.
   intros.
   unfold add_equation2RBT.
   unfold find_var_v,find_var.
   remember (vars eqn). icase l0.
  Qed.

  Lemma add_equation2RBT_spec5 : forall {A : Type} `{VAB : varsable A var} (eqn : A) rbt uf l,
   add_equation2RBT_l eqn uf rbt l = eqn::l ->
   vars eqn = nil.
  Proof.
   intros.
   unfold add_equation2RBT_l,add_equation2RBT in H.
   unfold find_var_v,find_var in H.
   remember (vars eqn). icase l0.
   assert (forall {A : Type} (l' : list A) a, l' = a::l' -> False).
    induction l'; repeat intro. inv H0.
    spec IHl' a. apply IHl'. inversion H0. subst a;trivial.
   elimtype False.
   icase (UF.find uf v).
   icase o;inversion H;
   apply H0 with A l eqn;trivial.
  Qed.

  Lemma add_equation2RBT_spec6 : forall {A : Type} `{VAB : varsable A var} (eqn : A) rbt uf l l' v,
   find_var_v uf eqn = Some v -> l' <> nil ->
   RBT.MapsTo v (eqn::l') (add_equation2RBT_rbt eqn uf rbt l) ->
   RBT.MapsTo v l' rbt.
  Proof.
   intros.
   unfold add_equation2RBT_rbt,add_equation2RBT in H1.
   remember (find_var_v uf eqn). icase o. inv H.
   unfold find_add in H1.
   remember (RBT.find v rbt). icase o. simpl in H1.
   assert (eqn::l' = eqn::l0).
    eapply RBT.MapsTo_spec2. apply H1. apply RBT.add_spec1.
   inv H.
   symmetry in Heqo0. apply RBT.find_spec. trivial.
   assert (eqn::l' = eqn::nil).
    eapply RBT.MapsTo_spec2. apply H1. apply RBT.add_spec1.
   inv H. tauto.
  Qed.

  Lemma eqnlist2RBT_rewrite: forall {A} `{VAB : varsable A var} (l l' : list A) uf rbt,
   (l',rbt) = eqnlist2RBT l uf ->
   l' = eqnlist2RBT_l l uf/\
   rbt = eqnlist2RBT_rbt l uf.
  Proof.
   intros.
   unfold eqnlist2RBT_l,eqnlist2RBT_rbt.
   rewrite <- H. simpl. tauto.
  Qed.

  Lemma eqnlist2RBT_step_rewrite: forall {A} `{VAB : varsable A var} (eqn : A) l uf,
   eqnlist2RBT (eqn::l) uf = add_equation2RBT eqn uf (eqnlist2RBT_rbt l uf) (eqnlist2RBT_l l uf).
  Proof.
   intros. simpl. trivial.
  Qed.

  Lemma eqnlist2RBT_spec1: forall {A} `{VAB : varsable A var} l (eqn : A) uf v,
   UF_in_cond uf l->
   In eqn l -> find_var_v uf eqn = Some v ->
   exists l', RBT.MapsTo v l' (eqnlist2RBT_rbt l uf) /\ In eqn l'.
  Proof.
   induction l;intros. inv H0.
   destruct H0. subst a.
   simpl.
   exists (eqn::(find_list_rbt v (eqnlist2RBT_rbt l uf))).
   split.
   apply add_equation2RBT_spec1;trivial.
   left;trivial.
   rewrite UF_in_cond_prop1 in H.
   destruct H.
   spec IHl eqn uf v H2 H0.
   spec IHl H1.
   destruct IHl as [? [? ?]].
   simpl.
   unfold eqnlist2RBT_rbt. rewrite eqnlist2RBT_step_rewrite.
   generalize (list_eq_dec e_eq_dec (vars a) nil);intros.
   (*a is in list*)
   destruct H5.
   rewrite add_equation2RBT_spec4;trivial. simpl.
   exists x. tauto.
   (*a is in rbt*)
   generalize (find_var_v_spec1 _ _ H n);intro.
   destruct H5.
   generalize (e_eq_dec v x0);intro.
   (*Same principle element*)
   destruct H6. subst x0.
   assert (find_list_rbt v (get_rbt (eqnlist2RBT l uf)) = x).
    apply find_list_rbt_spec;trivial.
   exists (a::x).
   rewrite<-H6.
   split. apply add_equation2RBT_spec1;trivial.
   right. congruence.
   (*Different principle elements*)
   exists x. eapply add_equation2RBT_spec2 in n0; trivial.
   unfold add_equation2RBT_rbt in n0. rewrite n0.
   split;trivial. apply H5.
  Qed.

  Lemma list2RBT_spec2 : forall {A} `{VAB : varsable A var} (l l' : list A) uf v,
   UF_in_cond uf l ->
   RBT.MapsTo v l' (eqnlist2RBT_rbt l uf) ->
   sublist l' l.
  Proof.
   induction l;repeat intro.
   simpl in H.
   assert (RBT.Empty (emptyRBT (list A))).
    apply RBT.empty_spec.
   spec H2 v l'. contradiction.
   simpl in H0.
   generalize (list_eq_dec e_eq_dec (vars a) nil);intro.
   rewrite UF_in_cond_prop1 in H. destruct H.
   unfold eqnlist2RBT_rbt in H0.
   rewrite eqnlist2RBT_step_rewrite in H0.
   (*a is in list*)
   destruct H2.
   rewrite add_equation2RBT_spec4 in H0;trivial.
   spec IHl l' uf v H3 H0.
   right. apply IHl. trivial.
   (*a is in rbt*)
   generalize (find_var_v_spec1 _ _ H n);intro.
   destruct H2.
   generalize (e_eq_dec v x);intro.
   destruct H4.
   (*Same principle element*)
   subst x.
   assert (l' = a :: find_list_rbt v (get_rbt (eqnlist2RBT l uf))).
    eapply RBT.MapsTo_spec2. apply H0. apply add_equation2RBT_spec1;trivial.
   rewrite H4 in *.
   destruct H1. subst a. left;trivial.
   apply add_equation2RBT_spec6 in H0;trivial.
   spec IHl (find_list_rbt v (get_rbt (eqnlist2RBT l uf))) uf v H3 H0.
   right. apply IHl. trivial.
   intro. rewrite H5 in H1. inv H1.
   (*Different priciple elements*)
   generalize (add_equation2RBT_spec2 _ _ _ (eqnlist2RBT_rbt l uf) _ (eqnlist2RBT_l l uf) l' H2 n0);intro.
   rewrite H4 in H0.
   spec IHl l' uf v H3 H0.
   right. apply IHl;trivial.
  Qed.

  Lemma list2RBT_spec3: forall {A} `{VAB : varsable A var} (l : list A) eqn uf,
   UF_in_cond uf l ->
   ((In eqn l /\ vars eqn = nil) <-> In eqn (eqnlist2RBT_l l uf)).
  Proof with try tauto.
   induction l;intros.
   simpl. tauto.
   rewrite UF_in_cond_prop1 in H. destruct H.
   spec IHl eqn uf H0. destruct IHl.
   simpl.
   unfold eqnlist2RBT_l. rewrite eqnlist2RBT_step_rewrite.
   generalize (list_eq_dec e_eq_dec (vars a) nil);intro.
   destruct H3.
   (*a is in list*)
   rewrite add_equation2RBT_spec4;trivial.
   simpl. split;intros... destruct H3... subst...
   (*a is in rbt*)
   apply find_var_v_spec1 in H;trivial.
   destruct H.
   remember (add_equation2RBT a uf (eqnlist2RBT_rbt l uf) (eqnlist2RBT_l l uf)).
   icase p. apply add_equation2RBT_rewrite in Heqp.
   destruct Heqp;subst.
   rewrite add_equation2RBT_spec3 with (v:=x);trivial.
   split;intros... destruct H3. destruct H3... subst...
  Qed.

  Lemma list2RBT_spec4: forall {A} `{VAB : varsable A var} (l l' :list A) uf eqn v,
   UF_in_cond uf l ->
   RBT.MapsTo v l' (eqnlist2RBT_rbt l uf) ->
   In eqn l' ->
   find_var_v uf eqn = Some v.
  Proof.
   induction l;intros.
   simpl in H0.
   assert (RBT.Empty (emptyRBT (list A))).
    apply RBT.empty_spec.
   spec H2 v l'. contradiction.
   simpl in H0. rewrite UF_in_cond_prop1 in H.
   destruct H.
   generalize (list_eq_dec e_eq_dec (vars a) nil);intro.
   unfold eqnlist2RBT_rbt in H0.
   rewrite eqnlist2RBT_step_rewrite in H0.
   destruct H3.
   rewrite add_equation2RBT_spec4 in H0;trivial.
   apply IHl with l';trivial.
   apply find_var_v_spec1 in H;trivial.
   destruct H.
   generalize (e_eq_dec v x);intro.
   destruct H3. subst x.
   assert ( l' = a::(find_list_rbt v (get_rbt (eqnlist2RBT l uf)))).
    eapply RBT.MapsTo_spec2. apply H0. apply add_equation2RBT_spec1;trivial.
   rewrite H3 in *.
   destruct H1. subst a. trivial.
   eapply IHl;trivial.
   eapply add_equation2RBT_spec6. apply H.
   assert (find_list_rbt v (get_rbt (eqnlist2RBT l uf)) <> nil).
    intro. rewrite H4 in H1. inversion H1.
   apply H4. apply H0. apply H1.
   remember (add_equation2RBT a uf (eqnlist2RBT_rbt l uf) (eqnlist2RBT_l l uf)).
   icase p. apply add_equation2RBT_rewrite in Heqp.
   destruct Heqp;subst. simpl in H0.
   rewrite add_equation2RBT_spec2 in H0;trivial.
   eapply IHl;trivial. apply H0. apply H1. apply H. apply n0.
  Qed.

  Lemma list2RBT_spec5: forall {A} `{VAB : varsable A var} (l l' : list A) v uf,
   UF_in_cond uf l ->
   RBT.MapsTo v l' (eqnlist2RBT_rbt l uf) ->
   vars l' <> nil.
  Proof.
   induction l;intros.
   simpl in H0.
   unfold eqnlist2RBT_rbt in H0. simpl in H0.
   assert (RBT.Empty (emptyRBT (list A))).
    apply RBT.empty_spec.
   spec H1 v l'. contradiction.
   rewrite UF_in_cond_prop1 in H.
   destruct H.
   simpl in H0.
   unfold eqnlist2RBT_rbt in H0.
   rewrite eqnlist2RBT_step_rewrite in H0.
   generalize (list_eq_dec e_eq_dec (vars a) nil);intro.
   destruct H2.
   rewrite add_equation2RBT_spec4 in H0;trivial.
   eapply IHl. apply H1. apply H0.
   eapply find_var_v_spec1 in n;try apply H.
   destruct n.
   generalize (e_eq_dec v x);intro.
   destruct H3. subst x.
   assert (l' = a::(find_list_rbt v (get_rbt (eqnlist2RBT l uf)))).
    eapply RBT.MapsTo_spec2. apply H0. apply add_equation2RBT_spec1;trivial.
   intro. rewrite H3 in H4. simpl in H4.
   apply app_eq_nil in H4. destruct H4.
   unfold find_var_v,find_var in H2.
   unfold var in *. unfold t in *;rewrite H4 in H2. inversion H2.
   remember (add_equation2RBT a uf (eqnlist2RBT_rbt l uf) (eqnlist2RBT_l l uf)).
   icase p. apply add_equation2RBT_rewrite in Heqp.
   destruct Heqp;subst. simpl in H0.
   rewrite add_equation2RBT_spec2 in H0.
   eapply IHl. apply H1. apply H0.
   apply H2. apply n.
  Qed.

  Lemma list2RBT_spec6: forall {A} `{VAB : varsable A var} (l : list A) l1 l2 v1 v2 uf,
   UF_lcomponents_cond uf l ->
   RBT.MapsTo v1 l1 (eqnlist2RBT_rbt l uf) ->
   RBT.MapsTo v2 l2 (eqnlist2RBT_rbt l uf) ->
   (v1 <> v2 <-> disjoint (vars l1) (vars l2)).
  Proof.
   intros. split;repeat intro.
   destruct H3.
   copy H. apply UF_lcomponents_cond_prop3 in H5.
   copy H0. copy H1.
   apply list2RBT_spec2 in H0;trivial.
   apply list2RBT_spec2 in H1;trivial.
   apply var_list_exist in H3.
   apply var_list_exist in H4.
   destruct H3 as [? [? ?]]. destruct H4 as [? [? ?]].
   apply list2RBT_spec4 with (eqn:= x0) in H6;trivial.
   apply list2RBT_spec4 with (eqn:= x1) in H7;trivial.
   generalize (H x0 (H0 _ H3));intro.
   generalize (H x1 (H1 _ H4));intro.
   unfold UF_component_cond in *.
   detach H11. detach H10.
   destruct H11;destruct H10.
   unfold find_var_v,find_var in *.
   remember (vars x0). icase l0.
   remember (vars x1). icase l3.
   generalize (H10 x H8);intro.
   generalize (H11 x H9);intro.
   generalize (H11 v0);intro. detach H14.
   generalize (H10 v);intro. detach H15.
   unfold UF.find_e in *. unfold var in *. unfold t in *;congruence.
   left;trivial. left;trivial.
   intro. rewrite H10 in H8. inversion H8.
   intro. rewrite H11 in H9. inversion H9.
   (*The other direction*)
   subst v2.
   assert (l1 = l2).
    eapply RBT.MapsTo_spec2. apply H0. apply H1.
   subst l2.
   apply list2RBT_spec5 in H1.
   icase (vars l1). spec H2 v. apply H2.
   split;left;trivial.
   apply UF_lcomponents_cond_prop3;trivial.
  Qed.

  Lemma list2RBT_spec7: forall {A} `{VAB : varsable A var} (l : list A) uf,
   UF_in_cond uf l ->
   vars (eqnlist2RBT_l l uf) = nil.
  Proof.
   intros.
   assert (forall eqn, In eqn (eqnlist2RBT_l l uf) -> vars eqn = nil).
    intros.
    generalize (list2RBT_spec3 l  eqn uf);intro.
    apply H1;trivial.
   remember (eqnlist2RBT_l l uf). clear Heql0 H.
   induction l0. trivial.
   simpl. simpl in IHl0;rewrite IHl0.
   rewrite H0. trivial.
   left;trivial.
   intros. apply H0. right;trivial.
  Qed.

  (*Other Lemmas section*)

  Lemma InA_Kvpeq_In: forall {A : Type} l k (val : A),
   InA RBT.Kvpeq (k,val) l <-> In (k,val) l.
  Proof.
   induction l;intros. simpl.
   apply InA_nil.
   simpl.
   rewrite InA_cons.
   split;intro.
   destruct H. left.
   destruct a. compute in H.
   destruct H;subst;trivial.
   right. apply IHl;trivial.
   destruct H. subst.
   left. compute. tauto.
   right. apply IHl;trivial.
  Qed.

  Lemma NoDupA_Kvpeq_NoDup: forall {A: Type} (l :list (var*A)),
   NoDupA RBT.Kvpeq l <-> NoDup l.
  Proof.
   induction l;intros.
   split;intros. apply NoDup_nil.
   apply NoDupA_nil.
   split;intros.
   inv H.
   apply NoDup_cons.
   intro. apply H2. destruct a. apply InA_Kvpeq_In;trivial.
   apply IHl;trivial.
   inv H.
   apply NoDupA_cons.
   intro. apply H2. destruct a. apply InA_Kvpeq_In;trivial.
   apply IHl;trivial.
  Qed.

  Lemma RBT_elements_diff: forall {A : Type} (rbt : RBT.map_of A) i j v v' a a',
   nth_op i (RBT.elements rbt) = Some (v,a) ->
   nth_op j (RBT.elements rbt) = Some (v',a') ->
   (i <> j <-> v <> v').
  Proof.
   intros.
   assert (InA RBT.Kvpeq (v,a) (RBT.elements rbt)).
    apply InA_Kvpeq_In. apply nth_op_In. exists i;trivial.
   assert (InA RBT.Kvpeq (v',a') (RBT.elements rbt)).
    apply InA_Kvpeq_In. apply nth_op_In. exists j;trivial.
   copy H1;copy H2.
   apply RBT.elements_spec1 in H1.
   apply RBT.elements_spec1 in H2.
   generalize (RBT.elements_spec3 rbt);intro.
   apply NoDupA_Kvpeq_NoDup in H5.
   apply InA_Kvpeq_In in H3.
   apply InA_Kvpeq_In in H4.
   generalize (NoDup_nth_op_diff _ _ _ _ _ H5 H H0);intro.
   split;repeat intro;subst.
   apply H6 in H7. apply H7. f_equal.
   eapply RBT.MapsTo_spec2.
   apply H1. apply H2.
   rewrite H0 in H. inv H. tauto.
  Qed.

  Lemma remove_1st_spec2: forall {A: Type} (rbt : RBT.map_of (list A)) l,
   (In l (remove_1st (RBT.elements rbt)) <->
   exists v, RBT.MapsTo v l rbt).
  Proof.
   intros.
   rewrite remove_1st_spec1.
   split;intros. destruct H.
   exists x. apply RBT.elements_spec1.
   apply InA_Kvpeq_In;trivial.
   destruct H. exists x.
   apply InA_Kvpeq_In.
   apply RBT.elements_spec1;trivial.
  Qed.

End Internal_Structures.


Require Export Task.model_data.
Import FloatIO.
Import DebugIO.
Import DScopeNotations.
Import ListNotations.
Import RecordSetNotations'.
Open Scope D_scope.

From compcert Require Import Decidableplus.

Instance Decidable_eq_sv : forall (x y: stateVar), Decidable (eq x y) := Decidable_eq state_var_eq.

(*+ Map from the positive id for a stateVar to the stateVar. *)
Definition posToStateVarTreeType := PTree.t stateVar.
Definition emptyPosToStateVarTree := PTree.empty stateVar.

Fixpoint updatePosToStateVarTree (svIdStrList: list (stateVar * string))
         (tree: posToStateVarTreeType) : posToStateVarTreeType :=
  match svIdStrList with
  | nil => tree
  | cons (sv, str) xtail =>
    let tree1 := PTree.set (svIndex sv) sv tree in
    updatePosToStateVarTree xtail tree1
  end.

Definition posToStateVarTree :=
  updatePosToStateVarTree svStrList emptyPosToStateVarTree.

(* Map a positive to the corresonding stateVar *)
Definition posToStateVar (p: positive) := PTree.get p posToStateVarTree.

(*+ Maps with stateVar as domain *)
Module SvIndex <: Maps.INDEXED_TYPE.
  Definition t := stateVar.
  Definition index := svIndex.
  Definition eq := state_var_eq.
  Lemma index_inj:
    forall r1 r2, index r1 = index r2 -> r1 = r2.
  Proof.
    intros.
    destruct r1 eqn: r1eq; destruct r2 eqn: r2eq; simpl in *;try reflexivity;
      unfold index in H; simpl in H; inversion H.
  Qed.
End SvIndex.

Module SvTree := Maps.ITree(SvIndex).

(*+ Map from stateVar to stateVar name as string *)
Definition stringSvTreeTy := SvTree.t string.
Definition emptyStringPTree := SvTree.empty string.

Fixpoint updateStringSvTree (valList: list (stateVar * string)) (intree: stringSvTreeTy) :=
  match valList with
  | nil => intree
  | cons (sv, val) vltail =>
    let tree1 := SvTree.set sv val intree in
    updateStringSvTree vltail tree1
  end.

Definition svToStringTree :=
  updateStringSvTree svStrList emptyStringPTree.

Definition svToStrOpt (sv: stateVar) : option string :=
  SvTree.get sv svToStringTree.

Lemma svToStrComplete:
  forall sv : stateVar, exists s : string,
      svToStrOpt sv = Some s.
Proof.
  intros.
  destruct sv; unfold svToStrOpt;compute; eexists; f_equal.
Qed.

(* Since we have proven that svToStrOpt will always give a
   result, define a function that extracts that value,
   and in the impossible case returns the empty string.
*)
Definition svToStr (sv: stateVar) : string :=
  match svToStrOpt sv with
  | Some x => x
  | None => ""
  end.

(*+ Map from stateVar to float, for simulation variables *)
Definition floatSvTreeTy := SvTree.t float.
Definition emptyFloatPTree := SvTree.empty float.

Fixpoint updateFloatSvTree (valList: list (stateVar * float)) (intree: floatSvTreeTy) :=
  match valList with
  | nil => intree
  | cons (sv, fval) vltail =>
    let tree1 := SvTree.set sv fval intree in
    updateFloatSvTree vltail tree1
  end.

Fixpoint printFloatKeyVals (kvl: list (stateVar * float)) :=
  match kvl with
  | nil => nil
  | cons (sv, fval) tl =>
    (sv, print_float fval) :: printFloatKeyVals tl
  end.

(*+ Defaults *)
Definition driver_defaults (_ : unit) :=
  [
            (SvT,        "0.0"#D);
            (SvT_STOP,   "0.0"#D);
            (SvDT,       "0.005"#D);
            (SvDT_MAX,   "0.005"#D);
            (SvDT_MIN,   "0.005"#D);
            (SvDT_PRINT, "0.01"#D)
  ].

(* Variable state after applying driver defaults and then model defaults
   that are not specific to auto subsystem (if not modularized). *)
Definition state0 (_ : unit) := (* Eval compute in *)
      let driverState := updateFloatSvTree (driver_defaults tt) emptyFloatPTree in
      updateFloatSvTree (model_default_values tt) driverState.

(* This takes a long time to prove, so during development comment it out.

Lemma state0Complete:
  forall sv: stateVar, exists f: float,
      SvTree.get sv (state0 tt) = Some f.
Proof.
  intros.
  destruct sv;compute; eexists; f_equal.
Qed.

 *)

(* Since we have proven that state is complete, we can define a
   function that always returns a float, using a default
   in the impossible case.
 *)
Definition svGetFloat (sv: stateVar) (tree : floatSvTreeTy) :=
  match SvTree.get sv tree with
  | Some x => x
  | None => Details.my_nan
  end.

(* Compute PTree.elements (state0 ()). *)

(* Give stateVar given its positive id, or if not a valid id,
   an arbitrary stateVar
*)
Definition posToStateVar' (pos: positive) :=
  match posToStateVar pos with
  | Some x => x
  | None => SvT (* Assume we always have time as a state variable. *)
  end.

Fixpoint printFloatStateElements (elist: list (positive * float)) : list (string * string) :=
  match elist with
  | nil => nil
  | cons (pos, fval) tl =>
    (svToStr (posToStateVar' pos), print_float fval) :: printFloatStateElements tl
  end.

Definition printFloatState (state: floatSvTreeTy) :=
  printFloatStateElements (PTree.elements state).

(* Compute printFloatState (state0 ()). *)

(*+ Simulation data structures *)
Record flagsTy :=
  mkFlags
    {
      stop_simulation : bool; (* Stop the simulation, t > tStop, *)
      end_of_run : bool;      (* Terminate early, user event logic. *)
      evaluate_xd : bool     (* Flag to determine of xd needs to reevaluated. *)
    }.

(* These Settable instances allow us to do partial update of records easily *)
Instance etaFlags  : Settable _ :=
  settable! mkFlags <stop_simulation; end_of_run; evaluate_xd >.

Record eventTy :=
  mkEvent
    {
      key : string;
      time : float;
    }.

Instance etaEvent : Settable eventTy :=
  settable! mkEvent <key;time >.

Record logEntryTy :=
  mkLogEntry
    {
      le_caption: string;
      le_vars: list (string * string);
      le_events: list (string * string);
    }.

Instance etaLogEntry : Settable _ :=
  settable! mkLogEntry <le_caption;le_vars;le_events>.

Record simTy :=
  mkSim
    {
      vars : floatSvTreeTy;              (* Simulation variables and constants. *)
      solkeys : list stateVar;           (* Keys of fields in Solution. *)
      solution : list (list string);     (* Simulation detail results. *)
      sim_events : list eventTy;         (* User events. *)
      log_entries : list logEntryTy;             (* Text logging for debugging or information. *)
      flags : flagsTy                    (* control flags *)
    }.

Instance etaSim  : Settable _ :=
  settable! mkSim <vars;solkeys;solution;sim_events;log_entries;flags>.

(*+ Utilitys for simulation structures *)
Definition printFloatSvTreeTy (vars: floatSvTreeTy) :=
  printFloatStateElements (PTree.elements vars).

(* Convert list of events to readable form *)
Fixpoint printEvents (evs: list eventTy) : list (string * string) :=
  match evs with
  | nil => nil
  | cons ev evtl =>
    let caption := ev.(key) in
    let time_str := print_float ev.(time) in
    (caption, time_str) :: printEvents evtl
  end.

(* Use this version if you want a log
Definition log_sim (caption: string) (sim: simTy) : simTy :=
  let le := {|
        le_caption := caption;
        le_vars := printFloatSvTreeTy sim.(vars);
        le_events := printEvents sim.(sim_events)
      |} in
  let result_sim := sim[[log_entries ::= (fun oldlog => le :: oldlog)]] in
  result_sim.

 *)

(* This is the dummy version *)
Definition log_sim (caption: string) (sim: simTy) : simTy := sim.

Definition default_flags :=
  {|
    stop_simulation := false;
    end_of_run := false;
    evaluate_xd := false;
  |}.

Definition set_vars (sim: simTy) (new_vars : floatSvTreeTy) :=
  let sim' := log_sim "set_vars:sim" sim in
  let new_vars' := printFloatSvTreeTy new_vars in
  let result_sim := sim[[vars := new_vars]] in
  let result_sim' := log_sim "set_vars: result" result_sim in
  result_sim'.

Definition set_var (key: stateVar) (val: float) (sim: simTy) :=
  let sim_log := log_sim "set_var:sim" sim in
  let result_sim := sim_log[[vars := SvTree.set key val sim.(vars)]] in
  let result_log := log_sim "set_var:result" result_sim in
  result_log.

Fixpoint union_vars (sim: simTy) (updates: list (stateVar * float)) :=
  match updates with
  | nil => sim
  | cons (sv, fval) remaining =>
    let sim1 := set_var sv fval sim in
    union_vars sim1 remaining
  end.

(*+ Common event functions and utilities *)
(*
  An Event function takes the event and the simulation state as inputs and
  returns a pair consisting of the updated simulation state and an
  optional float which, if present, is the time at which the event should
  be rescheduled. If the optional float is not present, then then
  event is not rescheduled, which, with the current event processing
  algorithm, means that its time is unchanged, and it will continue
  to fire, since the condition for firing is that
  eventtime < currenttime + dtmin. In other words, the default for
  an event is for it to persist and it is only inhibited by scheduling
  it to some future time.
*)
Definition event_function_signature := eventTy -> simTy -> (simTy * option float).

Definition t_ge_tstop_event_func : event_function_signature :=
  fun (this: eventTy) (sim: simTy) =>
  let sim1 := log_sim "t_ge_tstop_event_func: sim1" sim in
  let vars := sim1.(vars) in
  let t := svGetFloat SvT vars in
  let t_stop := svGetFloat SvT_STOP vars in
  let stop_sim := t >=? t_stop in
  let new_flags := sim1.(flags)[[stop_simulation := stop_sim]] in
  let result_sim := sim1[[flags := new_flags]] in
  let result_log := log_sim "t_ge_tstop_event_func: result_sim" result_sim in
  (result_log, None).

Fixpoint make_solution_row_helper (vars: floatSvTreeTy) (keys: list stateVar) : list string :=
  match keys with
  | nil => nil
  | cons key others =>
    let fval := svGetFloat key vars in
    let sval := print_float fval in
    sval :: make_solution_row_helper vars others
  end.

Definition make_solution_row (sim: simTy) :=
  let row := make_solution_row_helper sim.(vars) sim.(solkeys) in
  let result_sim := sim[[solution ::= (fun old => row :: old)]] in
  let result_log := log_sim "make_solution_row: result" result_sim in
  result_log.

Definition append_solution_event_func  : event_function_signature :=
  fun (this: eventTy) (sim: simTy) =>
  let sim1 := make_solution_row sim in
  let sim1log := log_sim "append_solution_event_func:sim1" sim1 in
  let vars := sim1log.(vars) in
  let dt_print := svGetFloat SvDT_PRINT vars in
  let t := svGetFloat SvT vars in
  let new_t := t + dt_print in
  (sim1log, Some new_t).

Definition driver_default_events :=
  [
    {| key := "t_ge_tstop_event"; time := 0%D |};
    {| key := "append_log_event"; time := 0%D |}
  ].

Definition driver_default_handlers : list (string * event_function_signature) :=
  [
    ("t_ge_tstop_event", t_ge_tstop_event_func);
    ("append_log_event", append_solution_event_func)
  ].

Definition default_sim :=
  {|
    vars := (state0 tt);
    solkeys := modelOutputs;
    solution := nil;
    sim_events := driver_default_events;
    log_entries := nil;
    flags := default_flags;
  |}.

Fixpoint handle_event (handlers: list (string * event_function_signature))
         (this: eventTy) (sim: simTy) :=
  match handlers with
  | nil => (sim, None)
  | cons (eventKey, evFun) otherHandlers =>
    if (eventKey =? this.(key))%string then
      evFun this sim
    else
      handle_event otherHandlers this sim
  end.

(* Update a list of events by changing the scheduled time for the
   one with the specified function id.
*)
Fixpoint schedule_event (evs: list eventTy) (evkey: string) (new_time: float) :=
  match evs with
  | nil => nil
  | cons ev evtl =>
    let ev' :=
        if (ev.(key) =? evkey)%string then
          ev[[time := new_time]]
        else
          ev
    in
    ev' :: schedule_event evtl evkey new_time
  end.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal50.

From lfind Require Import LFind.
Require Import Arith.
Require Import Extraction.
Extract Inductive nat => nat [ "(O)" "S" ].
Extract Inductive list => list [ "Nil" "Cons" ].
Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal50_count_insort_114_count_cons/goal50_lfind_orig.ml"  adtind.goal50.insort adtind.goal50.eqb adtind.goal50.count.
Success.


Require Import HahnBase.
Require Import Heaps.
Require Import List.
Require Import Models.
Require Import Permissions.
Require Import Permutation.
Require Import Prelude.
Require Import Processes.
Require Import Programs.
Require Import QArith.
Require Import Qcanon.
Require Import Utf8.

Import ListNotations.

Set Implicit Arguments.

(** * Program Logic *)

Module Type Assertions
  (doms: Domains)
  (procs: Processes doms)
  (heaps: Heaps doms)
  (progs: Programs doms procs heaps)
  (models: Models doms procs heaps progs).

Export doms procs heaps progs models.

(** ** Assertion Language *)

Inductive Assn :=
  | Aplain(B: Cond)
  | Aex(f: Val -> Assn)
  | Adisj(A1 A2: Assn)
  | Astar(A1 A2: Assn)
  | Awand(A1 A2: Assn)
  | Apointsto(q: Qc)(E1 E2: Expr)
  | Aproc(AP: AbstrProc)
  | Abisim (AP AQ: AbstrProc).

Add Search Blacklist "Assn_rect".
Add Search Blacklist "Assn_ind".
Add Search Blacklist "Assn_rec".

Definition Atrue: Assn := Aplain (Bconst true).
Definition Afalse: Assn := Aplain (Bconst false).

Lemma assn_aex_ext : forall f g, f = g -> Aex f = Aex g.
Proof. intuition vauto. Qed.

Fixpoint Aiter (xs: list Assn): Assn :=
  match xs with
    | nil => Atrue
    | A :: xs' => Astar A (Aiter xs')
  end.

Fixpoint assn_fv (A: Assn)(x: Var): Prop :=
  match A with
    | Aplain B => In x (cond_fv B)
    | Aex f => exists v: Val, assn_fv (f v) x
    | Adisj A1 A2
    | Astar A1 A2
    | Awand A1 A2 => assn_fv A1 x \/ assn_fv A2 x
    | Apointsto _ E1 E2 => In x (expr_fv E1) \/ In x (expr_fv E2)
    | Aproc AP => aproc_fv AP x
    | Abisim AP AQ => aproc_fv AP x \/ aproc_fv AQ x
  end.

Lemma assn_fv_iter :
  forall (xs: list Assn)(x: Var),
  assn_fv (Aiter xs) x <-> exists A, In A xs /\ assn_fv A x.
Proof.
  induction xs as [|A xs IH]; intro x.
  - split; intro H; desf.
  - split; intro H.
    + simpl in H. destruct H as [H | H].
      * exists A. split; vauto.
      * rewrite IH in H. destruct H as (A' & H1 & H2).
        exists A'. split; auto. by apply in_cons.
    + destruct H as (A' & H1 & H2).
      simpls. destruct H1 as [H1 | H1]; vauto.
      right. rewrite IH. exists A'. split; vauto.
Qed.

Fixpoint assn_subst (x: Var)(E: Expr)(A: Assn): Assn :=
  match A with
    | Aplain B => Aplain (cond_subst x E B)
    | Aex f => Aex (fun v => assn_subst x E (f v))
    | Adisj A1 A2 => Adisj (assn_subst x E A1) (assn_subst x E A2)
    | Astar A1 A2 => Astar (assn_subst x E A1) (assn_subst x E A2)
    | Awand A1 A2 => Awand (assn_subst x E A1) (assn_subst x E A2)
    | Apointsto q E1 E2 => Apointsto q (expr_subst x E E1) (expr_subst x E E2)
    | Aproc AP =>  Aproc (aproc_subst x E AP)
    | Abisim AP AQ => Abisim (aproc_subst x E AP) (aproc_subst x E AQ)
  end.

Definition Aexists (x: Var)(A: Assn): Assn :=
  Aex (fun v => assn_subst x (Econst v) A).

Lemma assn_subst_pres :
  forall A x E, ~ assn_fv A x -> assn_subst x E A = A.
Proof.
  induction A; intros x E H1; simpls.
  - rewrite cond_subst_pres; auto.
  - apply assn_aex_ext. extensionality y. rewrite H; auto.
    intro H2. apply H1. by exists y.
  - rewrite IHA1, IHA2; auto.
  - rewrite IHA1, IHA2; auto.
  - rewrite IHA1, IHA2; auto.
  - repeat rewrite expr_subst_pres; auto.
  - rewrite aproc_subst_pres; auto.
  - repeat rewrite aproc_subst_pres; auto.
Qed.

(** ** Sematics of Assertions *)

Fixpoint sat (ph: PermHeap)(P: Proc)(s: Store)(A: Assn): Prop :=
  match A with
    (* non-spatial assertions *)
    | Aplain B => cond_eval B s = true
    (* existential quantifiers *)
    | Aex f => exists v, sat ph P s (f v)
    (* disjunction *)
    | Adisj A1 A2 => sat ph P s A1 \/ sat ph P s A2
     (* separating conjunction *)
    | Astar A1 A2 =>
        exists ph1 ph2,
          permheap_disj ph1 ph2 /\
          permheap_add ph1 ph2 = ph /\
        exists P1 P2,
          bisim (Ppar P1 P2) P /\
          sat ph1 P1 s A1 /\
          sat ph2 P2 s A2
    (* magic wand *)
    | Awand A1 A2 =>
        forall ph' P',
        permheap_disj ph ph' ->
        sat ph' P' s A1 ->
        sat (permheap_add ph ph') (Ppar P P') s A2
    (* heap ownership *)
    | Apointsto q E1 E2 =>
        let l := expr_eval E1 s in
        let v := expr_eval E2 s in
        phc_leq (PHCcell q v) (ph l)
    (* process ownership *)
    | Aproc AP =>
        let P1 := aproc_conv AP s in
        exists P2, bisim P (Ppar P1 P2)
    (* process bisimulation *)
    | Abisim AP AQ => bisim (aproc_conv AP s) (aproc_conv AQ s)
  end.

Lemma sat_pproc_eq :
  forall A ph P1 P2 s, bisim P1 P2 -> sat ph P1 s A -> sat ph P2 s A.
Proof.
  induction A; intros ph P1 P2 s H1 H2; vauto.
  (* existential quantifiers *)
  - simpl in H2. destruct H2 as (v & H2).
    exists v. by apply H with P1.
  (* disjunction *)
  - simpls. destruct H2 as [H2 | H2].
    left. by apply IHA1 with P1.
    right. by apply IHA2 with P1.
  (* separating conjunction *)
  - simpls.
    destruct H2 as (ph1 & ph2 & D1 & H2 & P3 & P4 & H3 & SAT1 & SAT2).
    exists ph1, ph2. intuition.
    exists P3, P4. intuition. by rewrite <- H1.
  (* magic wand *)
  - simpls. intros ph' P' H3 H4.
    apply IHA2 with (Ppar P1 P').
    + rewrite H1. reflexivity.
    + apply H2; auto.
  (* process ownership *)
  - unfold sat in *.
    destruct H2 as (P & H2).
    exists P. rewrite <- H2. intuition.
Qed.

Add Parametric Morphism : sat
  with signature eq ==> bisim ==> eq ==> eq ==> iff
    as assn_sat_procmap_mor.
Proof.
  intros ph P1 P2 H1 s A. split; intro H2.
  - apply sat_pproc_eq with P1; auto.
  - apply sat_pproc_eq with P2; auto.
Qed.

Lemma sat_subst :
  forall A ph P s x E,
  sat ph P s (assn_subst x E A) <->
  sat ph P (updatestore s x (expr_eval E s)) A.
Proof.
  induction A; intros ph P s y E'; auto.
  (* non-spatial assertions *)
  - split; intro H; simpls.
    + by rewrite <- cond_eval_subst.
    + by rewrite cond_eval_subst.
  (* existential quantifiers *)
  - split; intro H1; simpls.
    + destruct H1 as (v & H1).
      exists v. by apply H.
    + destruct H1 as (v & H1).
      exists v. by apply <- H.
  (* disjunction *)
  - split; intro H; simpls.
    + destruct H as [H | H].
      * left. by rewrite <- IHA1.
      * right. by rewrite <- IHA2.
    + destruct H as [H | H].
      * left. by rewrite IHA1.
      * right. by rewrite IHA2.
  (* separating conjunction *)
  - split; intro H; simpls.
    + destruct H as (ph1 & ph2 & D1 & H1 & P1 & P2 & H2 & SAT1 & SAT2).
      exists ph1, ph2. intuition.
      exists P1, P2. intuition.
      * by apply IHA1.
      * by apply IHA2.
    + destruct H as (ph1 & ph2 & D1 & H1 & P1 & P2 & H2 & SAT1 & SAT2).
      exists ph1, ph2. intuition.
      exists P1, P2. intuition.
      * by apply <- IHA1.
      * by apply <- IHA2.
  (* magic wands *)
  - split; intro H; simpls.
    + intros ph' P' D1 SAT.
      apply IHA2, H; auto.
      by apply IHA1.
    + intros ph' P' D1 SAT.
      apply IHA2, H; auto.
      by apply IHA1.
  (* heap ownership *)
  - split; intro H.
    + simpl. repeat rewrite <- expr_eval_subst in *. vauto.
    + simpl. repeat rewrite expr_eval_subst in *. vauto.
  (* process ownership *)
  - split; intro H.
    + destruct H as (P' & H1). exists P'.
      rewrite H1. apply bisim_par; auto.
      by apply aproc_conv_subst.
    + destruct H as (P' & H1). exists P'.
      rewrite H1. apply bisim_par; auto.
      symmetry. by apply aproc_conv_subst.
  (* process bisimulation *)
  - split; intro H.
    + simpls. by repeat rewrite <- aproc_conv_subst.
    + simpls. by repeat rewrite aproc_conv_subst.
Qed.

Lemma sat_agree :
  forall A ph P s1 s2,
    (forall x, assn_fv A x -> s1 x = s2 x) ->
  sat ph P s1 A -> sat ph P s2 A.
Proof.
  induction A; intros ph P s1 s2 H1.
  (* plain assertions *)
  - intro H2. simpls.
    rewrite <- cond_agree with (s1 := s1); vauto.
  (* existential quantifiers *)
  - intro H2. simpls. destruct H2 as (v & H2).
    exists v. apply H with s1; auto.
    intros x H3. apply H1. by exists v.
  (* disjunction *)
  - intro H2. simpls.
    destruct H2 as [H2 | H2].
    + left. apply IHA1 with s1; auto.
    + right. apply IHA2 with s1; auto.
  (* separating conjunction *)
  - intro H2; simpls.
    destruct H2 as (ph1 & ph2 & D1 & H2 & P1 & P2 & H3 & SAT1 & SAT2).
    exists ph1, ph2. intuition.
    exists P1, P2. intuition.
    * apply IHA1 with s1; auto.
    * apply IHA2 with s1; auto.
  (* magic wand *)
  - intro H2. simpls.
    intros ph' P' H3 H4.
    apply IHA2 with s1; auto.
    apply H2; auto. apply IHA1 with s2; auto.
    intros x H6. symmetry. apply H1. by left.
  (* heap ownership *)
  - intro H2. unfold sat in *.
    rewrite <- expr_agree with E1 s1 s2, <- expr_agree with E2 s1 s2; auto.
    + red. intros x H3. apply H1. simpl. by right.
    + red. intros x H3. apply H1. simpl. by left.
  (* process ownership *)
  - intro H2. unfold sat in *.
    destruct H2 as (P' & H2). exists P'.
    rewrite aproc_conv_agree with AP s2 s1; auto.
    intros x H4. symmetry. apply H1. simpl. done.
  (* process bisimulation *)
  - intro H2. simpls.
    rewrite aproc_conv_agree with AP s2 s1, aproc_conv_agree with AQ s2 s1; auto.
    + intros x H3. symmetry. apply H1. by right.
    + intros x H3. symmetry. apply H1. by left.
Qed.

Lemma sat_weaken :
  forall A ph1 ph2 P1 P2 s,
  permheap_disj ph1 ph2 ->
  sat ph1 P1 s A ->
  sat (permheap_add ph1 ph2) (Ppar P1 P2) s A.
Proof.
  induction A; intros ph1 ph2 P1 P2 s H1 H2; auto.
  (* existential quantifiers *)
  - simpls. destruct H2 as (v & H2).
    exists v. by apply H.
  (* disjunction *)
  - simpls. destruct H2 as [H2 | H2].
    + left. by apply IHA1.
    + right. by apply IHA2.
  (* separating conjunction *)
  - simpls.
    destruct H2 as (ph3 & ph4 & D1 & H2 & P3 & P4 & H3 & SAT1 & SAT2).
    clarify. exists ph3, (permheap_add ph4 ph2). intuition.
    { by apply permheap_disj_assoc_l. }
    { by rewrite permheap_add_assoc. }
    exists P3, (Ppar P4 P2). intuition.
    { rewrite par_assoc; auto. by rewrite H3. }
    apply IHA2; auto. by apply permheap_disj_add_l with ph3.
  (* magic wand *)
  - simpls. intros ph' P' H4 H5.
    rewrite permheap_add_assoc, <- par_assoc.
    apply H2.
    { by apply permheap_disj_assoc_l. }
    rewrite permheap_add_comm, par_comm.
    apply IHA1; auto.
    apply permheap_disj_add_r with ph1; auto.
    symmetry. by rewrite permheap_add_comm.
  (* heap ownership *)
  - unfold sat in *. rewrite <- permheap_add_cell.
    apply phc_leq_weaken; vauto.
  (* process ownership *)
  - unfold sat in *. destruct H2 as (P & H2).
    exists (Ppar P P2). by rewrite par_assoc, <- H2.
Qed.

Lemma sat_iter_permut :
  forall xs ys,
  Permutation xs ys ->
  forall ph P s,
  sat ph P s (Aiter xs) ->
  sat ph P s (Aiter ys).
Proof.
  intros xs ys PERM.
  induction PERM; intros ph P s SAT; simpls.
  - destruct SAT as (ph1 & ph2 & D1 & H1 & P1 & P2 & H2 & SAT1 & SAT2).
    exists ph1, ph2. intuition.
    exists P1, P2. intuition.
  - destruct SAT as (ph1 & ph2 & D1 & H1 & P1 & P2 & H2 & SAT1 & SAT).
    destruct SAT as (ph3 & ph4 & D2 & H3 & P3 & P4 & H4 & SAT3 & SAT4).
    clarify.
    exists ph3, (permheap_add ph1 ph4). intuition.
    { apply permheap_disj_assoc_l.
      + symmetry. by apply permheap_disj_add_r with ph4.
      + rewrite permheap_add_comm.
        by apply permheap_disj_assoc_r. }
    { rewrite <- permheap_add_assoc.
      rewrite permheap_add_comm with ph3 ph1.
      by rewrite permheap_add_assoc. }
    exists P3, (Ppar P1 P4). intuition.
    { rewrite par_assoc.
      rewrite par_comm with (P := P3)(Q := P1).
      rewrite <- par_assoc.
      by rewrite <- H2, <- H4. }
    exists ph1, ph4. intuition.
    { apply permheap_disj_add_r with ph3; auto.
      by rewrite permheap_add_comm. }
    exists P1, P4. intuition.
  - by apply IHPERM2, IHPERM1.
Qed.

(** ** Logical consequence *)

Definition entails (A1 A2: Assn): Prop :=
  forall ph P s,
    permheap_valid ph -> sat ph P s A1 -> sat ph P s A2.
Definition entails_rev (A1 A2: Assn): Prop := entails A2 A1.
Definition equiv (A1 A2: Assn): Prop := entails A1 A2 /\ entails A2 A1.

Instance entails_refl : Reflexive entails.
Proof. intro. red. intuition. Qed.
Instance entails_trans : Transitive entails.
Proof. unfold entails. intuition. Qed.
Instance entails_rev_refl : Reflexive entails_rev.
Proof. intro. red. intuition. Qed.
Instance entails_rev_trans : Transitive entails_rev.
Proof. unfold entails_rev. intros ?????. by transitivity y. Qed.
Instance equiv_refl : Reflexive equiv.
Proof. red. ins. split; vauto. Qed.
Instance equiv_symm : Symmetric equiv.
Proof. red. intros A1 A2 (H1&H2). split; auto. Qed.
Instance equiv_trans : Transitive equiv.
Proof. red. intros A1 A2 A3 (H1&H2) (H3&H4). split; by transitivity A2. Qed.
Instance equiv_eq : Equivalence equiv.
Proof. split; intuition. Qed.

Hint Resolve entails_refl entails_rev_refl equiv_refl.

Lemma entails_flip : forall A1 A2, entails A1 A2 <-> entails_rev A2 A1.
Proof. ins. Qed.

(** *** Congruence *)

Add Parametric Morphism : Adisj
  with signature entails ==> entails ==> entails as adisj_entails_mor.
Proof.
  intros A1 A1' ENT1 A2 A2' ENT2.
  red. intros ph P s H1 [SAT | SAT]; simpls.
  - left. apply ENT1; auto.
  - right. apply ENT2; auto.
Qed.

Add Parametric Morphism : Adisj
  with signature equiv ==> equiv ==> entails as adisj_equiv_ent_mor.
Proof. intros A1 A2 (H1&_) A3 A4 (H2&_). by rewrite H1, H2. Qed.

Add Parametric Morphism : Adisj
  with signature equiv ==> equiv ==> equiv as adisj_equiv_mor.
Proof.
  intros A1 A2 (H1&H2) A3 A4 (H3&H4). split.
  - by rewrite H1, H3.
  - by rewrite H2, H4.
Qed.

Add Parametric Morphism : Astar
  with signature entails ==> entails ==> entails
    as astar_entails_mor.
Proof.
  intros A1 A1' ENT1 A2 A2' ENT2.
  red. intros ph P s H1 SAT. simpls.
  destruct SAT as (ph1 & ph2 & D1 & H2 & P1 & P2 & H3 & SAT1 & SAT2).
  exists ph1, ph2. intuition.
  exists P1, P2. intuition.
  - apply ENT1; auto. by apply permheap_disj_valid_l in D1.
  - apply ENT2; auto. by apply permheap_disj_valid_r in D1.
Qed.

Add Parametric Morphism : Astar
  with signature equiv ==> equiv ==> entails as astar_equiv_ent_mor.
Proof. intros A1 A2 (H1&_) A3 A4 (H2&_). by rewrite H1, H2. Qed.

Add Parametric Morphism : Astar
  with signature equiv ==> equiv ==> equiv as astar_equiv_mor.
Proof.
  intros A1 A2 (H1&H2) A3 A4 (H3&H4). split.
  - by rewrite H1, H3.
  - by rewrite H2, H4.
Qed.

Add Parametric Morphism : Awand
  with signature entails_rev ==> entails ==> entails as awand_entails_mor.
Proof.
  intros A1 A1' ENT1 A2 A2' ENT2.
  red. intros ph P s H1 WAND. simpls.
  intros ph' P' D1 SAT1.
  apply ENT2; auto. apply WAND; auto.
  apply ENT1; auto. by apply permheap_disj_valid_r in D1.
Qed.

Add Parametric Morphism : Awand
  with signature equiv ==> equiv ==> equiv as awand_equiv_mor.
Proof.
  intros A1 A2 (H1&H2) A3 A4 (H3&H4). split.
  - rewrite entails_flip in H2. by rewrite H2, H3.
  - rewrite entails_flip in H1. by rewrite H1, H4.
Qed.

(** *** Weakening rule *)

(** The weakening rule shows that our separation logic is _intuitionistic_. *)

Lemma sat_star_combine :
  forall ph1 ph2 P1 P2 s A1 A2,
  permheap_disj ph1 ph2 ->
  sat ph1 P1 s A1 ->
  sat ph2 P2 s A2 ->
  sat (permheap_add ph1 ph2) (Ppar P1 P2) s (Astar A1 A2).
Proof.
  intros ph1 ph2 P1 P2 s A1 A2 D1 H1 H2.
  exists ph1, ph2. repeat split; auto.
  exists P1, P2. intuition.
Qed.

Lemma sat_star_weaken :
  forall ph P s A1 A2,
  sat ph P s (Astar A1 A2) -> sat ph P s A1.
Proof.
  intros ph P s A1 A2 SAT.
  destruct SAT as (ph1 & ph2 & D1 & H1 & P1 & P2 & H2 & SAT1 & SAT2).
  rewrite <- H1, <- H2. by apply sat_weaken.
Qed.

Theorem assn_weaken :
  forall A1 A2, entails (Astar A1 A2) A1.
Proof.
  intros A1 A2 ph P s H1 H2.
  by apply sat_star_weaken with A2.
Qed.

(** *** Separating conjunction *)

(** Soundness of the axioms of _associativity_ and _commutativity_. *)

Lemma sat_star_assoc_l :
  forall ph P s A1 A2 A3,
  sat ph P s (Astar A1 (Astar A2 A3)) ->
  sat ph P s (Astar (Astar A1 A2) A3).
Proof.
  intros ph P s A1 A2 A3 SAT.
  destruct SAT as (ph1 & ph1' & D1 & H1 & P1 & P1' & H2 & SAT1 & SAT2).
  destruct SAT2 as (ph2 & ph3 & D3 & H3 & P2 & P3 & H4 & SAT2 & SAT3).
  exists (permheap_add ph1 ph2), ph3. repeat split; vauto.
  { by apply permheap_disj_assoc_r. }
  { by rewrite permheap_add_assoc. }
  exists (Ppar P1 P2), P3. intuition.
  { rewrite <- par_assoc. by rewrite H4. }
  exists ph1, ph2. repeat split; vauto.
  apply permheap_disj_add_r with ph3; auto.
Qed.

Theorem star_assoc_l :
  forall A1 A2 A3,
  entails (Astar A1 (Astar A2 A3)) (Astar (Astar A1 A2) A3).
Proof.
  intros A1 A2 A3 ph P s H1 H2.
  by apply sat_star_assoc_l.
Qed.

Lemma sat_star_assoc_r :
  forall ph P s A1 A2 A3,
  sat ph P s (Astar (Astar A1 A2) A3) ->
  sat ph P s (Astar A1 (Astar A2 A3)).
Proof.
  intros ph P s A1 A2 A3 SAT.
  destruct SAT as (ph1' & ph3 & D1 & H1 & P1' & P3 & H2 & SAT1 & SAT2).
  destruct SAT1 as (ph1 & ph2 & D3 & H3 & P1 & P2 & H4 & SAT1 & SAT3).
  exists ph1, (permheap_add ph2 ph3). repeat split; vauto.
  { by apply permheap_disj_assoc_l. }
  { by rewrite permheap_add_assoc. }
  exists P1, (Ppar P2 P3). intuition.
  { rewrite par_assoc; auto. by rewrite H4. }
  exists ph2, ph3. repeat split; vauto.
  apply permheap_disj_add_l with ph1; auto.
Qed.

Theorem star_assoc_r :
  forall A1 A2 A3,
  entails (Astar (Astar A1 A2) A3) (Astar A1 (Astar A2 A3)).
Proof.
  intros A1 A2 A3 ph P s H1 H2.
  by apply sat_star_assoc_r.
Qed.

Theorem star_assoc :
  forall A1 A2 A3,
  equiv (Astar (Astar A1 A2) A3) (Astar A1 (Astar A2 A3)).
Proof.
  ins. split; [apply star_assoc_r|apply star_assoc_l].
Qed.

Lemma sat_star_comm :
  forall ph P s A1 A2,
  sat ph P s (Astar A1 A2) -> sat ph P s (Astar A2 A1).
Proof.
  intros ph P s A1 A2 SAT.
  destruct SAT as (ph1 & ph2 & D1 & H1 & P1 & P2 & H2 & SAT1 & SAT2).
  exists ph2, ph1. repeat split; auto.
  - by rewrite permheap_add_comm.
  - exists P2, P1. intuition. by rewrite par_comm.
Qed.

Theorem star_comm :
  forall A1 A2, entails (Astar A1 A2) (Astar A2 A1).
Proof.
  intros A1 A2 ph P s H1 H2.
  by apply sat_star_comm.
Qed.

Theorem star_comm_equiv :
  forall A1 A2, equiv (Astar A1 A2) (Astar A2 A1).
Proof.
  ins. split; by apply star_comm.
Qed.

Corollary star_weaken_r :
  forall A1 A2, entails (Astar A1 A2) A2.
Proof.
  intros A1 A2. transitivity (Astar A2 A1).
  apply star_comm. apply assn_weaken.
Qed.

Corollary star_weaken_l :
  forall A1 A2, entails (Astar A1 A2) A1.
Proof.
  intros A1 A2. rewrite star_comm.
  by apply star_weaken_r.
Qed.

Lemma sat_star_true :
  forall ph P s A,
  permheap_valid ph -> sat ph P s A -> sat ph P s (Astar A Atrue).
Proof.
  intros ph P s A H1 SAT.
  exists ph, permheap_iden. repeat split; auto.
  { by rewrite permheap_add_iden_l. }
  exists P, Pepsilon. intuition vauto.
  by rewrite par_epsilon_r.
Qed.

Theorem star_true :
  forall A, entails A (Astar A Atrue).
Proof.
  intros A ph P s H1 SAT.
  by apply sat_star_true.
Qed.

Lemma sat_star_swap_l :
  forall ph P s A1 A2 A3,
  sat ph P s (Astar A1 (Astar A2 A3)) ->
  sat ph P s (Astar A2 (Astar A1 A3)).
Proof.
  intros ph P s A1 A2 A3 SAT.
  apply sat_star_assoc_r.
  apply sat_star_assoc_l in SAT.
  destruct SAT as (ph1 & ph2 & D1 & H1 & P1 & P2 & H2 & SAT1 & SAT2).
  exists ph1, ph2. repeat split; vauto.
  exists P1, P2. intuition. by apply sat_star_comm.
Qed.

Lemma star_swap_l :
  forall A1 A2 A3,
  entails (Astar A1 (Astar A2 A3)) (Astar A2 (Astar A1 A3)).
Proof.
  intros A1 A2 A3. rewrite star_assoc_l.
  rewrite star_comm with (A1 := A1)(A2 := A2).
  by rewrite star_assoc_r.
Qed.

Lemma sat_star_swap_r :
  forall ph P s A1 A2 A3,
  sat ph P s (Astar (Astar A1 A2) A3) ->
  sat ph P s (Astar (Astar A1 A3) A2).
Proof.
  intros ph P s A1 A2 A3 SAT.
  apply sat_star_assoc_l.
  apply sat_star_assoc_r in SAT.
  destruct SAT as (ph1 & ph2 & D1 & H1 & P1 & P2 & H2 & SAT1 & SAT2).
  exists ph1, ph2. repeat split; vauto.
  exists P1, P2. intuition. by apply sat_star_comm.
Qed.

Lemma star_swap_r :
  forall A1 A2 A3,
  entails (Astar (Astar A1 A2) A3) (Astar (Astar A1 A3) A2).
Proof.
  intros A1 A2 A3. rewrite star_assoc_r.
  rewrite star_comm with (A1 := A2)(A2 := A3).
  by rewrite star_assoc_l.
Qed.

Theorem star_add_l :
  forall A1 A2 A3, entails A2 A3 -> entails (Astar A1 A2) (Astar A1 A3).
Proof.
  intros ??? ENT. by rewrite ENT.
Qed.

Theorem star_add_r :
  forall A1 A2 A3, entails A2 A3 -> entails (Astar A2 A1) (Astar A3 A1).
Proof.
  intros ??? ENT. by rewrite ENT.
Qed.

Lemma star_disj_l :
  forall A1 A2 A3,
  entails (Astar A1 (Adisj A2 A3)) (Adisj (Astar A1 A2) (Astar A1 A3)).
Proof.
  intros A1 A2 A3 ph P s H1 SAT.
  destruct SAT as (ph1 & ph2 & H2 & H3 & P1 & P2 & H4 & SAT1 & SAT2).
  destruct SAT2 as [SAT2 | SAT2].
  - left. exists ph1, ph2. intuition. exists P1, P2. intuition.
  - right. exists ph1, ph2. intuition. exists P1, P2. intuition.
Qed.

Lemma star_disj_r :
  forall A1 A2 A3,
  entails (Adisj (Astar A1 A2) (Astar A1 A3)) (Astar A1 (Adisj A2 A3)).
Proof.
  intros A1 A2 A3 ph P s H1 [SAT | SAT];
  destruct SAT as (ph1 & ph2 & H2 & H3 & P1 & P2 & H4 & SAT1 & SAT2).
  - exists ph1, ph2. intuition. exists P1, P2. intuition. by left.
  - exists ph1, ph2. intuition. exists P1, P2. intuition. by right.
Qed.

Lemma star_disj :
  forall A1 A2 A3,
  equiv (Astar A1 (Adisj A2 A3)) (Adisj (Astar A1 A2) (Astar A1 A3)).
Proof.
  ins. split; [by apply star_disj_l|by apply star_disj_r].
Qed.

(** *** Iterated separating conjunction *)

Theorem aiter_permut :
  forall xs ys, Permutation xs ys -> entails (Aiter xs) (Aiter ys).
Proof.
  intros xs ys H. red. intros ph p s H1 SAT.
  by apply sat_iter_permut with xs.
Qed.

Add Parametric Morphism : Aiter
  with signature @Permutation Assn ==> entails as iter_permut_mor.
Proof.
  ins. by apply aiter_permut.
Qed.

Lemma sat_aiter_cons_l :
  forall ph p s A xs,
  sat ph p s (Astar A (Aiter xs)) -> sat ph p s (Aiter (A :: xs)).
Proof.
  intuition vauto.
Qed.

Theorem aiter_cons_l :
  forall A xs, entails (Astar A (Aiter xs)) (Aiter (A :: xs)).
Proof.
  intuition vauto.
Qed.

Lemma sat_aiter_cons_r :
  forall ph p s A xs,
  sat ph p s (Aiter (A :: xs)) -> sat ph p s (Astar A (Aiter xs)).
Proof.
  intuition vauto.
Qed.

Theorem aiter_cons_r :
  forall A xs, entails (Aiter (A :: xs)) (Astar A (Aiter xs)).
Proof.
  intuition vauto.
Qed.

Lemma sat_aiter_add_l :
  forall (xs ys : list Assn) ph P s,
  sat ph P s (Astar (Aiter xs) (Aiter ys)) -> sat ph P s (Aiter (xs ++ ys)).
Proof.
  induction xs as [|A xs IH]; intros ys ph P s SAT.
  - simpl (Aiter []) in SAT. rewrite app_nil_l.
    by apply sat_star_comm, sat_star_weaken in SAT.
  - simpl (Aiter (A :: xs)) in SAT.
    replace ((A :: xs) ++ ys) with (A :: (xs ++ ys)); auto.
    apply sat_aiter_cons_l. apply sat_star_assoc_r in SAT.
    destruct SAT as (ph1 & ph2 & H1 & H2 & P1 & P2 & H3 & SAT1 & SAT2).
    exists ph1, ph2. repeat split; vauto.
    exists P1, P2. intuition.
Qed.

Theorem aiter_add_l :
  forall xs ys, entails (Astar (Aiter xs) (Aiter ys)) (Aiter (xs ++ ys)).
Proof.
  intros xs ys ph P s H SAT.
  by apply sat_aiter_add_l.
Qed.

Lemma sat_aiter_add_r :
  forall (xs ys : list Assn) ph P s,
  permheap_valid ph ->
  sat ph P s (Aiter (xs ++ ys)) ->
  sat ph P s (Astar (Aiter xs) (Aiter ys)).
Proof.
  induction xs as [|A xs IH]; intros ys ph P s H1 SAT.
  - simpl (Aiter []). rewrite app_nil_l in SAT.
    apply sat_star_comm. by apply sat_star_true.
  - simpl (Aiter (A :: xs)).
    replace ((A :: xs) ++ ys) with (A :: (xs ++ ys)) in SAT; auto.
    apply sat_aiter_cons_r in SAT. apply sat_star_assoc_l.
    destruct SAT as (ph1 & ph2 & H2 & H3 & P1 & P2 & H4 & SAT1 & SAT2).
    exists ph1, ph2. repeat split; vauto.
    exists P1, P2. intuition. apply IH; vauto.
    by apply permheap_disj_valid_r in H2.
Qed.

Theorem aiter_add_r :
  forall xs ys, entails (Aiter (xs ++ ys)) (Astar (Aiter xs) (Aiter ys)).
Proof.
  induction xs; intro ys; simpls.
  - rewrite <- star_comm. by rewrite <- star_true.
  - rewrite <- star_assoc_l. by rewrite <- IHxs.
Qed.

Lemma sat_aiter_star_l :
  forall ph p s A1 A2 (xs : list Assn),
  sat ph p s (Aiter (Astar A1 A2 :: xs)) ->
  sat ph p s (Aiter (A1 :: A2 :: xs)).
Proof.
  intros ph p s A1 A2 xs SAT.
  simpl (Aiter (A1 :: A2 :: xs)).
  by apply sat_star_assoc_r.
Qed.

Theorem aiter_star_l :
  forall A1 A2 xs,
  entails (Aiter (Astar A1 A2 :: xs)) (Aiter (A1 :: A2 :: xs)).
Proof.
  intros A1 A2 xs. simpls.
  by rewrite star_assoc_r.
Qed.

Lemma sat_aiter_star_r :
  forall ph P s A1 A2 (xs : list Assn),
  sat ph P s (Aiter (A1 :: A2 :: xs)) ->
  sat ph P s (Aiter (Astar A1 A2 :: xs)).
Proof.
  intros ph P s A1 A2 xs SAT.
  simpl (Aiter (A1 :: A2 :: xs)) in SAT.
  by apply sat_star_assoc_l.
Qed.

Theorem aiter_star_r :
  forall A1 A2 xs,
  entails (Aiter (A1 :: A2 :: xs)) (Aiter (Astar A1 A2 :: xs)).
Proof.
  intros A1 A2 xs. simpls.
  by rewrite star_assoc_l.
Qed.

Lemma sat_aiter_weaken :
  forall ph P s A (xs : list Assn),
  sat ph P s (Aiter (A :: xs)) -> sat ph P s (Aiter xs).
Proof.
  intros ph P s A xs SAT.
  simpl (Aiter (A :: xs)) in SAT.
  apply sat_star_weaken with A.
  by apply sat_star_comm.
Qed.

Corollary aiter_weaken :
  forall A xs, entails (Aiter (A :: xs)) (Aiter xs).
Proof.
  intros A xs.
  rewrite aiter_cons_r.
  rewrite star_comm.
  by rewrite assn_weaken.
Qed.

(** *** Plain assertions *)

Theorem atrue_intro :
  forall A, entails A Atrue.
Proof.
  red. simpls.
Qed.

Theorem afalse_elim :
  forall A1 A2, entails A1 Afalse -> entails A1 A2.
Proof.
  unfold entails.
  intros A1 A2 H1 ph P s H2 H4.
  apply H1 in H4; vauto.
Qed.

Lemma aplain_tauto :
  forall E,
  entails (Aplain (Beq E E)) Atrue /\
  entails Atrue (Aplain (Beq E E)).
Proof.
  intros E. split.
  - red. ins.
  - red. ins. desf.
Qed.

(** Plain assertions can freely be duplicated. *)

Lemma aplain_dupl :
  forall B, entails (Aplain B) (Astar (Aplain B) (Aplain B)).
Proof.
  intros B. red. intros ph P s H3 H4. simpls.
  exists permheap_iden, ph. intuition.
  { apply permheap_add_iden_r. }
  exists Pepsilon, P. intuition.
  apply par_epsilon_l.
Qed.

(** *** Existential quantifiers *)

Theorem aexists_intro :
  forall A1 A2 x v,
  entails A1 (assn_subst x (Econst v) A2) ->
  entails A1 (Aexists x A2).
Proof.
  intros A1 A2 x v H ph P s H1 H2.
  exists v. by apply H.
Qed.

(** *** Disjunction *)

Lemma sat_adisj_elim_l :
  forall ph P s A1 A2, sat ph P s A1 -> sat ph P s (Adisj A1 A2).
Proof.
  intros ph p s A1 A2 SAT. simpl. by left.
Qed.

Lemma sat_adisj_elim_r :
  forall ph P s A1 A2, sat ph P s A2 -> sat ph P s (Adisj A1 A2).
Proof.
  intros ph P s A1 A2 SAT. simpl. by right.
Qed.

Theorem adisj_elim_l :
  forall A A1 A2, entails A A1 -> entails A (Adisj A1 A2).
Proof.
  intros A A1 A2 H ph P s H1 SAT.
  by apply sat_adisj_elim_l, H.
Qed.

Theorem adisj_elim_r :
  forall A A1 A2, entails A A2 -> entails A (Adisj A1 A2).
Proof.
  intros A A1 A2 H ph P s H1 SAT.
  by apply sat_adisj_elim_r, H.
Qed.

Lemma adisj_idemp :
  forall A, entails A (Adisj A A) /\ entails (Adisj A A) A.
Proof.
  intro A. split; ins; vauto. red. ins. desf.
Qed.

(** *** Magic wand *)

Theorem awand_intro :
  forall A1 A2 A3, entails (Astar A1 A2) A3 -> entails A1 (Awand A2 A3).
Proof.
  intros A1 A2 A3 H1 ph P s H2 H3 ph' P' H4 H5.
  apply H1; auto.
  exists ph, ph'. intuition.
  exists P, P'. intuition.
Qed.

Theorem awand_elim :
  forall A1 A2 A A',
  entails A1 (Awand A A') -> entails A2 A -> entails (Astar A1 A2) A'.
Proof.
  intros A1 A2 A A' H1 H2 ph P s H3 H4.
  simpls. desf. rewrite <- H5.
  apply H1; auto.
  { by apply permheap_disj_valid_l in H4. }
  apply H2; auto.
  by apply permheap_disj_valid_r in H4.
Qed.

(** *** Heap ownership *)

(** *** Process ownership *)

Theorem aproc_bisim :
  forall AP1 AP2, abisim AP1 AP2 -> entails (Aproc AP1) (Aproc AP2).
Proof.
  intros AP1 AP2 H ph P s H2 H3.
  unfold sat in *. destruct H3 as (P' & H3).
  exists P'. rewrite H3. by rewrite H.
Qed.

Theorem aproc_split :
  forall AP1 AP2,
  entails (Aproc (APpar AP1 AP2)) (Astar (Aproc AP1) (Aproc AP2)).
Proof.
  intros AP1 AP2 ph P s H1 (P' & H2). rewrite H2.
  exists permheap_iden, ph. intuition.
  { by apply permheap_add_iden_r. }
  exists (aproc_conv AP1 s), (Ppar (aproc_conv AP2 s) P').
  intuition vauto.
  - rewrite par_assoc. simpl. done.
  - exists Pepsilon. by rewrite par_epsilon_r.
Qed.

Theorem aproc_merge :
  forall AP1 AP2,
  entails (Astar (Aproc AP1) (Aproc AP2)) (Aproc (APpar AP1 AP2)).
Proof.
  intros AP1 AP2 ph P s H1 H2. unfold sat in H2.
  destruct H2 as (ph1 & ph2 & D1 & H2 & P1 & P2 & H3 & SAT1 & SAT2).
  destruct SAT1 as (P1' & H4). destruct SAT2 as (P2' & H5).
  exists (Ppar P1' P2'). intuition clarify.
  simpl (aproc_conv (APpar AP1 AP2) s). rewrite <- H3, H4, H5.
  repeat rewrite <- par_assoc.
  apply bisim_par; auto.
  repeat rewrite par_assoc.
  apply bisim_par; auto.
  by rewrite par_comm with (P := P1').
Qed.

Theorem aproc_weaken :
  forall AP1 AP2, entails (Aproc (APpar AP1 AP2)) (Aproc AP1).
Proof.
  intros AP1 AP2.
  transitivity (Astar (Aproc AP1) (Aproc AP2)).
  - by apply aproc_split.
  - apply assn_weaken.
Qed.

(** *** Process bisimulation *)

Theorem abisim_proc :
  forall AP AQ, entails (Astar (Aproc AP) (Abisim AP AQ)) (Aproc AQ).
Proof.
  intros AP AQ. red. intros ph P s H1 H2.
  destruct H2 as (ph1 & ph2 & D1 & H2 & P1 & P2 & H3 & SAT1 & SAT2).
  clarify. simpls. destruct SAT1 as (P1' & H4).
  exists (Ppar P1' P2). rewrite <- SAT2, <- H3.
  rewrite par_assoc. by rewrite <- H4.
Qed.

Theorem abisim_closed :
  forall AP AQ, abisim AP AQ -> entails (Atrue) (Abisim AP AQ).
Proof.
  intros AP AQ H1. red. intros ph P s H2 H3. simpls.
Qed.

Theorem abisim_cond_true :
  forall B AP, entails (Aplain B) (Abisim (APcond B AP) AP).
Proof.
  intros B AP. red. intros ph P s H1 H2. simpls.
  transitivity (Pcond (PBconst true) (aproc_conv AP s)).
  - apply bisim_cond_eval; vauto. simpls.
    by rewrite <- cond_conv_eval.
  - by apply pcond_true.
Qed.

Theorem abisim_cond_false :
  forall B AP, entails (Aplain (Bnot B)) (Abisim (APcond B AP) APdelta).
Proof.
  intros B AP. red. intros ph P s H1 H2. simpls.
  unfold negb in H2. desf. clear H2.
  transitivity (Pcond (PBconst false) (aproc_conv AP s)).
  - apply bisim_cond_eval; vauto. simpls.
    by rewrite <- cond_conv_eval.
  - by apply pcond_false.
Qed.

Theorem abisim_sigma_cond :
  forall x B AP,
  ~ In x (cond_fv B) ->
  entails (Atrue) (Abisim (APsigma x (APcond B AP)) (APcond B (APsigma x AP))).
Proof.
  intros x B AP H1. red. intros ph P s H2 _. simpls.
  set (f := fun v => aproc_conv (aproc_subst x (Econst v) AP) s).
  set (g := fun v => Pcond (cond_conv B s) (f v)).
  transitivity (Psum g).
  - subst g f. apply bisim_sum. red. intro v.
    rewrite cond_subst_pres; vauto.
  - subst g f. apply bisim_sum_cond.
Qed.

(** Likewise to [bisim], also [Abisim] resembles an equivalence relation and
    is a congruence for all connectives defined for [AbstrProc]. *)

Theorem abisim_refl :
  forall AP, entails Atrue (Abisim AP AP).
Proof.
  intros AP. red. intros ph P s H1 H2. simpls.
Qed.

Theorem abisim_symm :
  forall AP AQ, entails (Abisim AP AQ) (Abisim AQ AP).
Proof.
  intros AP AQ. red. intros ph P s H1 H2. simpls. auto.
Qed.

Theorem abisim_trans :
  forall AP AQ AR, entails (Astar (Abisim AP AQ) (Abisim AQ AR)) (Abisim AP AR).
Proof.
  intros AP AQ AR. red. intros ph P s H1 H2. simpls.
  destruct H2 as (ph1 & ph2 & H3 & H2 & P1 & P2 & H4 & SAT1 & SAT2).
  transitivity (aproc_conv AQ s); auto.
Qed.

Theorem abisim_seq :
  forall AP AP' AQ AQ',
  entails (Astar (Abisim AP AP') (Abisim AQ AQ')) (Abisim (APseq AP AQ) (APseq AP' AQ')).
Proof.
  intros AP AP' AQ AQ'. red. intros ph P s H1 H2. simpls.
  destruct H2 as (ph1 & ph2 & H3 & H2 & P1 & P2 & H4 & SAT1 & SAT2).
  apply bisim_seq; auto.
Qed.

Theorem abisim_alt :
  forall AP AP' AQ AQ',
  entails (Astar (Abisim AP AP') (Abisim AQ AQ')) (Abisim (APalt AP AQ) (APalt AP' AQ')).
Proof.
  intros AP AP' AQ AQ'. red. intros ph P s H1 H2. simpls.
  destruct H2 as (ph1 & ph2 & H3 & H2 & P1 & P2 & H4 & SAT1 & SAT2).
  apply bisim_alt; auto.
Qed.

Theorem abisim_par :
  forall AP AP' AQ AQ',
  entails (Astar (Abisim AP AP') (Abisim AQ AQ')) (Abisim (APpar AP AQ) (APpar AP' AQ')).
Proof.
  intros AP AP' AQ AQ'. red. intros ph P s H1 H2. simpls.
  destruct H2 as (ph1 & ph2 & H3 & H2 & P1 & P2 & H4 & SAT1 & SAT2).
  apply bisim_par; auto.
Qed.

Theorem abisim_sum :
  forall AP AQ x,
  ~ aproc_fv AP x ->
  ~ aproc_fv AQ x ->
  entails (Abisim AP AQ) (Abisim (APsigma x AP) (APsigma x AQ)).
Proof.
  intros AP AQ x H1 H2. red. intros ph P s H3 H4. simpls.
  apply bisim_sum. red. intro v.
  repeat rewrite aproc_subst_pres; auto.
Qed.

Theorem abisim_cond :
  forall AP AQ b,
  entails (Abisim AP AQ) (Abisim (APcond b AP) (APcond b AQ)).
Proof.
  intros AP AQ b. red. intros ph P s H3 H4. simpls.
  apply bisim_cond; auto.
Qed.

Theorem abisim_iter :
  forall AP AQ,
  entails (Abisim AP AQ) (Abisim (APiter AP) (APiter AQ)).
Proof.
  intros AP AQ. red. intros ph P s H3 H4. simpls.
  apply bisim_iter; auto.
Qed.

End Assertions.


From VST Require Import floyd.proofauto.

From appliedfm Require Import Int63.model.int63.
From appliedfm Require Import Int63.vst.clightgen.int63.

Definition encode_int63_spec: ident * funspec :=
  DECLARE _encode_int63
  WITH x: Z, gv: globals
  PRE [ tlong ]
      PROP ( )
      PARAMS (Vlong (Int64.repr x))
      GLOBALS(gv)
      SEP ( )
  POST [ tlong ]
      PROP ( )
      RETURN (Vlong (Int64.repr (encode_Z x)))
      SEP ( ).

Definition decode_int63_spec: ident * funspec :=
  DECLARE _decode_int63
  WITH x: Z, gv: globals
  PRE [ tlong ]
      PROP (Int64.min_signed <= encode_Z x <= Int64.max_signed)
      PARAMS (Vlong (Int64.repr (encode_Z x)))
      GLOBALS(gv)
      SEP ( )
  POST [ tlong ]
      PROP ( )
      RETURN (Vlong (Int64.repr x))
      SEP ( ).

Definition int63_zero_spec: ident * funspec :=
  DECLARE _int63_zero
  WITH gv: globals
  PRE [ ]
      PROP ()
      PARAMS ()
      GLOBALS(gv)
      SEP ( )
  POST [ tlong ]
      PROP ( )
      RETURN (Vlong (Int64.repr (encode_Z 0)))
      SEP ( ).

Definition int63_one_spec: ident * funspec :=
  DECLARE _int63_one
  WITH gv: globals
  PRE [ ]
      PROP ()
      PARAMS ()
      GLOBALS(gv)
      SEP ( )
  POST [ tlong ]
      PROP ( )
      RETURN (Vlong (Int64.repr (encode_Z 1)))
      SEP ( ).

Definition int63_neg_spec: ident * funspec :=
  DECLARE _int63_neg
  WITH x: Z, gv: globals
  PRE [ tlong ]
      PROP (
          Int64.min_signed <= encode_Z x <= Int64.max_signed;
          Int64.min_signed <= encode_Z (- x) <= Int64.max_signed
      )
      PARAMS (Vlong (Int64.repr (encode_Z x)))
      GLOBALS(gv)
      SEP ( )
  POST [ tlong ]
      PROP ( )
      RETURN (Vlong (Int64.repr (encode_Z (- x))))
      SEP ( ).

Definition int63_abs_spec: ident * funspec :=
  DECLARE _int63_abs
  WITH x: Z, gv: globals
  PRE [ tlong ]
      PROP (
          Int64.min_signed <= encode_Z x <= Int64.max_signed;
          Int64.min_signed <= encode_Z (- x) <= Int64.max_signed
      )
      PARAMS (Vlong (Int64.repr (encode_Z x)))
      GLOBALS(gv)
      SEP ( )
  POST [ tlong ]
      PROP ( )
      RETURN (Vlong (Int64.repr (encode_Z (Z.abs x))))
      SEP ( ).

Definition int63_add_spec: ident * funspec :=
  DECLARE _int63_add
  WITH x: Z, y: Z, gv: globals
  PRE [ tlong, tlong ]
      PROP (
          Int64.min_signed <= encode_Z x <= Int64.max_signed;
          Int64.min_signed <= encode_Z y <= Int64.max_signed;
          Int64.min_signed <= encode_Z (x + y) < Int64.max_signed
      )
      PARAMS (
          Vlong (Int64.repr (encode_Z x));
          Vlong (Int64.repr (encode_Z y))
      )
      GLOBALS(gv)
      SEP ( )
  POST [ tlong ]
      PROP ( )
      RETURN (Vlong (Int64.repr (encode_Z (x + y))))
      SEP ( ).

Definition int63_sub_spec: ident * funspec :=
  DECLARE _int63_sub
  WITH x: Z, y: Z, gv: globals
  PRE [ tlong, tlong ]
      PROP (
          Int64.min_signed <= encode_Z x <= Int64.max_signed;
          Int64.min_signed <= encode_Z y <= Int64.max_signed;
          Int64.min_signed <= encode_Z (x - y) <= Int64.max_signed
      )
      PARAMS (
          Vlong (Int64.repr (encode_Z x));
          Vlong (Int64.repr (encode_Z y))
      )
      GLOBALS(gv)
      SEP ( )
  POST [ tlong ]
      PROP ( )
      RETURN (Vlong (Int64.repr (encode_Z (x - y))))
      SEP ( ).

Definition int63_mul_spec: ident * funspec :=
  DECLARE _int63_mul
  WITH x: Z, y: Z, gv: globals
  PRE [ tlong, tlong ]
      PROP (
          Int64.min_signed <= encode_Z x <= Int64.max_signed;
          Int64.min_signed <= encode_Z y <= Int64.max_signed;
          Int64.min_signed <= encode_Z (x * y) <= Int64.max_signed
      )
      PARAMS (
          Vlong (Int64.repr (encode_Z x));
          Vlong (Int64.repr (encode_Z y))
      )
      GLOBALS(gv)
      SEP ( )
  POST [ tlong ]
      PROP ( )
      RETURN (Vlong (Int64.repr (encode_Z (x * y))))
      SEP ( ).

Definition int63_div_spec: ident * funspec :=
  DECLARE _int63_div
  WITH x: Z, y: Z, gv: globals
  PRE [ tlong, tlong ]
      PROP (
          Int64.min_signed <= encode_Z x <= Int64.max_signed;
          Int64.min_signed <= encode_Z y <= Int64.max_signed;
          y <> 0
      )
      PARAMS (
          Vlong (Int64.repr (encode_Z x));
          Vlong (Int64.repr (encode_Z y))
      )
      GLOBALS(gv)
      SEP ( )
  POST [ tlong ]
      PROP ( )
      RETURN (Vlong (Int64.repr (encode_Z (Z.quot x y))))
      SEP ( ).

Definition int63_rem_spec: ident * funspec :=
  DECLARE _int63_rem
  WITH x: Z, y: Z, gv: globals
  PRE [ tlong, tlong ]
      PROP (
          Int64.min_signed <= encode_Z x <= Int64.max_signed;
          Int64.min_signed <= encode_Z y <= Int64.max_signed;
          y <> 0
      )
      PARAMS (
          Vlong (Int64.repr (encode_Z x));
          Vlong (Int64.repr (encode_Z y))
      )
      GLOBALS(gv)
      SEP ( )
  POST [ tlong ]
      PROP ( )
      RETURN (Vlong (Int64.repr (encode_Z (Z.rem x y))))
      SEP ( ).

Definition int63_shiftl_spec: ident * funspec :=
  DECLARE _int63_shiftl
  WITH x: Z, y: Z, gv: globals
  PRE [ tlong, tlong ]
      PROP (
          Int64.min_signed <= encode_Z x <= Int64.max_signed;
          Int64.min_signed <= encode_Z y <= Int64.max_signed;
          0 <= x;
          0 <= y < Int64.zwordsize
      )
      PARAMS (
          Vlong (Int64.repr (encode_Z x));
          Vlong (Int64.repr (encode_Z y))
      )
      GLOBALS(gv)
      SEP ( )
  POST [ tlong ]
      PROP ( )
      RETURN (Vlong (Int64.repr (encode_Z (Z.shiftl x y))))
      SEP ( ).

Definition int63_shiftr_spec: ident * funspec :=
  DECLARE _int63_shiftr
  WITH x: Z, y: Z, gv: globals
  PRE [ tlong, tlong ]
      PROP (
          Int64.min_signed <= encode_Z x <= Int64.max_signed;
          Int64.min_signed <= encode_Z y <= Int64.max_signed;
          0 <= y < Int64.zwordsize
      )
      PARAMS (
          Vlong (Int64.repr (encode_Z x));
          Vlong (Int64.repr (encode_Z y))
      )
      GLOBALS(gv)
      SEP ( )
  POST [ tlong ]
      PROP ( )
      RETURN (Vlong (Int64.repr (encode_Z (Z.shiftr x y))))
      SEP ( ).

Definition int63_or_spec: ident * funspec :=
  DECLARE _int63_or
  WITH x: Z, y: Z, gv: globals
  PRE [ tlong, tlong ]
      PROP (
          Int64.min_signed <= encode_Z x <= Int64.max_signed;
          Int64.min_signed <= encode_Z y <= Int64.max_signed
      )
      PARAMS (
          Vlong (Int64.repr (encode_Z x));
          Vlong (Int64.repr (encode_Z y))
      )
      GLOBALS(gv)
      SEP ( )
  POST [ tlong ]
      PROP ( )
      RETURN (Vlong (Int64.repr (encode_Z (Z.lor x y))))
      SEP ( ).

Definition int63_and_spec: ident * funspec :=
  DECLARE _int63_and
  WITH x: Z, y: Z, gv: globals
  PRE [ tlong, tlong ]
      PROP (
          Int64.min_signed <= encode_Z x <= Int64.max_signed;
          Int64.min_signed <= encode_Z y <= Int64.max_signed
      )
      PARAMS (
          Vlong (Int64.repr (encode_Z x));
          Vlong (Int64.repr (encode_Z y))
      )
      GLOBALS(gv)
      SEP ( )
  POST [ tlong ]
      PROP ( )
      RETURN (Vlong (Int64.repr (encode_Z (Z.land x y))))
      SEP ( ).

Definition int63_xor_spec: ident * funspec :=
  DECLARE _int63_xor
  WITH x: Z, y: Z, gv: globals
  PRE [ tlong, tlong ]
      PROP (
          Int64.min_signed <= encode_Z x <= Int64.max_signed;
          Int64.min_signed <= encode_Z y <= Int64.max_signed
      )
      PARAMS (
          Vlong (Int64.repr (encode_Z x));
          Vlong (Int64.repr (encode_Z y))
      )
      GLOBALS(gv)
      SEP ( )
  POST [ tlong ]
      PROP ( )
      RETURN (Vlong (Int64.repr (encode_Z (Z.lxor x y))))
      SEP ( ).

Definition int63_not_spec: ident * funspec :=
  DECLARE _int63_not
  WITH x: Z, gv: globals
  PRE [ tlong ]
      PROP (Int64.min_signed <= encode_Z x <= Int64.max_signed)
      PARAMS (Vlong (Int64.repr (encode_Z x)))
      GLOBALS(gv)
      SEP ( )
  POST [ tlong ]
      PROP ( )
      RETURN (Vlong (Int64.repr (encode_Z (Z.lnot x))))
      SEP ( ).

Module int63__specs.
  Definition exports: funspecs :=
    [ decode_int63_spec
    ; encode_int63_spec
    ; int63_zero_spec
    ; int63_one_spec
    ; int63_neg_spec
    ; int63_abs_spec
    ; int63_add_spec
    ; int63_sub_spec
    ; int63_mul_spec
    ; int63_div_spec
    ; int63_rem_spec
    ; int63_shiftl_spec
    ; int63_shiftr_spec
    ; int63_or_spec
    ; int63_and_spec
    ; int63_xor_spec
    ; int63_not_spec
  ].
  Definition externs: funspecs := [].
  Definition imports: funspecs := [].
  Definition private: funspecs := [].
  Definition internals: funspecs := private ++ exports.
  Definition gprog: funspecs := imports ++ internals.
  Definition vprog: varspecs := ltac:(mk_varspecs prog).
End int63__specs.