Library frag_list_entail
Load seplog_header.
Require Import Omega.
Require Import Bool.
Lemma singl_disjoint_neq: forall e1 e2 e3 e4 h1 h2 s,
(e1 |-> e2) s h1 ->
(e3 |-> e4) s h2 ->
h1 # h2 ->
eval e1 s <> eval e3 s.
Inductive Lst : expr -> expr -> store.s -> heap.h -> Prop :=
| Lst_end: forall e1 e2 s h,
eval e1 s = eval e2 s ->
sep.emp s h ->
Lst e1 e2 s h
| Lst_suiv: forall e1 e2 e3 e4 s h h1 h2,
h1 # h2 -> h = h1 +++ h2 ->
eval e1 s <> eval e3 s ->
eval e1 s <> 0%Z ->
eval (e1 +e nat_e 1) s <> 0%Z ->
(e1 |-> e2 ** (e1 +e nat_e 1 |-> e4)) s h1 ->
Lst e2 e3 s h2 ->
Lst e1 e3 s h.
Lemma Lst_equiv': forall s h e1 e2,
Lst e1 e2 s h ->
forall e3 e4 s',
eval e1 s = eval e3 s' ->
eval e2 s = eval e4 s' ->
Lst e3 e4 s' h.
Lemma Lst_equiv: forall s h e1 e2,
Lst e1 e2 s h ->
forall e3 e4,
eval e1 s = eval e3 s ->
eval e2 s = eval e4 s ->
Lst e3 e4 s h.
Lemma Lst_app : forall e1 e2 s h1,
Lst e1 e2 s h1 ->
forall e3 h2 h3 h,
Lst e2 e3 s h2 ->
(exists v, (e3 |-> int_e v) s h3) ->
h1 # h2 ->
h1 # h3 ->
h = h1 +++ h2 ->
Lst e1 e3 s h.
Lemma Lst_app' : forall e1 e2 s h1,
Lst e1 e2 s h1 ->
forall e3 h2 h,
Lst e2 e3 s h2 ->
h1 # h2 ->
h = h1 +++ h2 ->
eval e3 s = 0%Z ->
Lst e1 e3 s h.
Definition Pi := expr_b.
Definition eval_pi := eval_b.
Inductive Sigma : Set :=
| singl : expr -> expr -> Sigma
| cell : expr -> Sigma
| emp : Sigma
| star : Sigma -> Sigma -> Sigma
| lst : expr -> expr -> Sigma.
Fixpoint Sigma_interp (a : Sigma) : assert :=
match a with
singl e1 e2 => fun s h => (e1 |-> e2) s h /\ eval e1 s <> 0%Z
| emp => sep.emp
| star s1 s2 => Sigma_interp s1 ** Sigma_interp s2
| cell e => fun s h => (exists v, (e |-> int_e v) s h) /\ eval e s <> 0%Z
| lst e1 e2 => Lst e1 e2
end.
Definition assrt := prod Pi Sigma.
Definition assrt_interp (a : assrt) : assert :=
match a with
(pi, sigm) => fun s h => eval_pi pi s = true /\ Sigma_interp sigm s h
end.
Definition Assrt := list assrt.
Fixpoint Assrt_interp (l : Assrt) : assert :=
match l with
| nil => fun s h => False
| hd :: tl => fun s h => assrt_interp hd s h \/ Assrt_interp tl s h
end.
Notation "s ** t" := (star s t) (at level 80) : tmp_scope.
Open Local Scope tmp_scope.
Inductive entail : assrt -> assrt -> Prop :=
| entail_incons : forall pi1 pi2 sig1 sig2,
(forall s, eval_pi pi1 s = true -> False) ->
entail (pi1, sig1) (pi2, sig2)
| entail_tauto : forall pi1 pi2,
(forall s, eval_pi pi1 s = true -> eval_pi pi2 s = true) ->
entail (pi1, emp) (pi2, emp)
| entail_coml : forall pi1 sig1 sig2 L,
entail (pi1, sig2 ** sig1) L ->
entail (pi1, sig1 ** sig2) L
| entail_comr : forall pi1 sig1 sig2 L,
entail L (pi1, sig2 ** sig1) ->
entail L (pi1, sig1 ** sig2)
| entail_assocl : forall pi1 sig1 sig2 sig3 L,
entail (pi1, (sig1 ** sig2) ** sig3) L ->
entail (pi1, sig1 ** (sig2 ** sig3)) L
| entail_assocr : forall pi1 sig1 sig2 sig3 L,
entail L (pi1, (sig1 ** sig2) ** sig3) ->
entail L (pi1, sig1 ** (sig2 ** sig3))
| entail_epseliml : forall pi1 sig1 L,
entail (pi1, sig1) L ->
entail (pi1, sig1 ** emp) L
| entail_epselimr : forall pi1 sig1 L,
entail L (pi1, sig1) ->
entail L (pi1, sig1 ** emp)
| entail_empintrol : forall pi1 sig1 L,
entail (pi1, sig1 ** emp) L ->
entail (pi1, sig1) L
| entail_empintror : forall pi1 sig1 L,
entail L (pi1, sig1 ** emp) ->
entail L (pi1, sig1)
| entail_lstnilelimr : forall pi1 sig1 pi2 sig2 e1 e2,
(forall s, eval_pi pi1 s = true -> eval_pi (e1 == e2) s = true) ->
entail (pi1, sig1) (pi2, sig2) ->
entail (pi1, sig1) (pi2, sig2 ** (lst e1 e2))
| entail_lstnileliml : forall pi1 sig1 pi2 sig2 e1 e2,
(forall s, eval_pi pi1 s = true -> eval_pi (e1 == e2) s = true) ->
entail (pi1, sig1) (pi2, sig2) ->
entail (pi1, sig1 ** (lst e1 e2)) (pi2, sig2)
| entail_lstsamelst : forall pi1 sig1 pi2 sig2 e1 e2 e3 e4,
(forall s, eval_pi pi1 s = true -> eval_pi (e1 == e3) s = true) ->
(forall s, eval_pi pi1 s = true -> eval_pi (e2 == e4) s = true) ->
entail (pi1, sig1) (pi2, sig2) ->
entail (pi1, sig1 ** (lst e1 e2)) (pi2, sig2 ** (lst e3 e4))
| entail_lstelim : forall pi1 sig1 pi2 sig2 e1 e2 e3 e4,
(forall s, eval_pi pi1 s = true -> eval_pi (e1 == e3) s = true) ->
entail (pi1, sig1 ** (cell e4)) (pi2, sig2 ** (lst e2 e4)) ->
entail (pi1, (sig1 ** (cell e4)) ** (lst e1 e2)) (pi2, sig2 ** (lst e3 e4))
| entail_lstelim_v2 : forall pi1 sig1 pi2 sig2 e1 e2 e3 e4 sig1',
(forall s, eval_pi pi1 s = true -> eval_pi (e1 == e3) s = true) ->
entail (pi1, sig1) (pi1, (sig1' ** (cell e4))) ->
entail (pi1, sig1' ** (cell e4)) (pi2, sig2 ** (lst e2 e4)) ->
entail (pi1, sig1 ** (lst e1 e2)) (pi2, sig2 ** (lst e3 e4))
| entail_lstelim' : forall pi1 sig1 pi2 sig2 e1 e2 e3 e4 e5,
(forall s, eval_pi pi1 s = true -> eval_pi (e1 == e3) s = true) ->
(forall s, eval_pi pi1 s = true -> eval_pi (e4 =/= e5) s = true) ->
entail (pi1, sig1 ** (lst e4 e5)) (pi2, sig2 ** (lst e2 e4)) ->
entail (pi1, (sig1 ** (lst e4 e5)) ** (lst e1 e2)) (pi2, sig2 ** (lst e3 e4))
| entail_lstelim'_v2 : forall pi1 sig1 pi2 sig2 e1 e2 e3 e4 e5 sig1',
(forall s, eval_pi pi1 s = true -> eval_pi (e1 == e3) s = true) ->
entail (pi1, sig1) (pi1, sig1' ** (lst e4 e5)) ->
(forall s, eval_pi pi1 s = true -> eval_pi (e4 =/= e5) s = true) ->
entail (pi1, sig1' ** (lst e4 e5)) (pi2, sig2 ** (lst e2 e4)) ->
entail (pi1, sig1 ** (lst e1 e2)) (pi2, sig2 ** (lst e3 e4))
| entail_lstelim'' : forall pi1 sig1 pi2 sig2 e1 e2 e3 e4,
(forall s, eval_pi pi1 s = true -> eval_pi (e1 == e3) s = true) ->
(forall s, eval_pi pi1 s = true -> eval_pi (e4 == int_e 0%Z) s = true) ->
entail (pi1, sig1) (pi2, sig2 ** (lst e2 e4)) ->
entail (pi1, sig1 ** (lst e1 e2)) (pi2, sig2 ** (lst e3 e4))
| entail_lstelim''' : forall pi1 sig1 pi2 sig2 e1 e2 e3 e4,
(forall s, eval_pi pi1 s = true -> eval_pi (e1 == e3) s = true) ->
(forall s, eval_pi pi1 s = true -> eval_pi (e1 =/= e4) s = true) ->
(forall s, eval_pi pi1 s = true -> eval_pi (e1 =/= int_e 0%Z) s = true) ->
entail (pi1, sig1) (pi2, sig2 ** ((cell (e1 +e nat_e 1)) ** (lst e2 e4))) ->
entail (pi1, sig1 ** (singl e1 e2)) (pi2, sig2 ** (lst e3 e4))
| entail_star_elim : forall pi1 pi2 sig1 sig2 e1 e2 e3 e4,
(forall s, eval_pi pi1 s = true -> eval_pi (e1 == e3) s = true) ->
(forall s, eval_pi pi1 s = true -> eval_pi (e2 == e4) s = true) ->
entail (pi1, sig1) (pi2, sig2) ->
entail (pi1, sig1 ** (singl e1 e2)) (pi2, sig2 ** (singl e3 e4))
| entail_star_elim': forall pi1 pi2 sig1 sig2 e1 e2 e3,
(forall s, eval_pi pi1 s = true -> eval_pi (e1 == e3) s = true) ->
entail (pi1, sig1) (pi2, sig2) ->
entail (pi1, sig1 ** (singl e1 e2)) (pi2, sig2 ** (cell e3))
| entail_star_elim'': forall pi1 pi2 sig1 sig2 e1 e3,
(forall s, eval_pi pi1 s = true -> eval_pi (e1 == e3) s = true) ->
entail (pi1, sig1) (pi2, sig2) ->
entail (pi1, sig1 ** (cell e1)) (pi2, sig2 ** (cell e3))
| entail_sepcon_neq : forall pi1 sig1 pi2 sig2 e1 e2 e3 e4,
entail (pi1 &&& (e1 =/= e3), sig1 ** ((singl e1 e2) ** (singl e3 e4))) (pi2, sig2) ->
entail (pi1, sig1 ** ((singl e1 e2) ** (singl e3 e4))) (pi2, sig2)
| entail_sepcon_neq' : forall pi1 sig1 pi2 sig2 e1 e2 e3,
entail (pi1 &&& (e1 =/= e3), sig1 ** ((singl e1 e2) ** (cell e3))) (pi2, sig2) ->
entail (pi1, sig1 ** ((singl e1 e2) ** (cell e3))) (pi2, sig2)
| entail_sepcon_neq'' : forall pi1 sig1 pi2 sig2 e1 e3,
entail (pi1 &&& (e1 =/= e3), sig1 ** ((cell e1) ** (cell e3))) (pi2, sig2) ->
entail (pi1, sig1 ** ((cell e1) ** (cell e3))) (pi2, sig2)
| entail_sepcon_neq''' : forall pi1 sig1 pi2 sig2 e1 e2 e3,
(forall s, eval_pi pi1 s = true -> eval_pi (e1 =/= e2) s = true) ->
entail (pi1 &&& (e1 =/= e3), sig1 ** ((lst e1 e2) ** (cell e3))) (pi2, sig2) ->
entail (pi1, sig1 ** ((lst e1 e2) ** (cell e3))) (pi2, sig2)
| entail_sepcon_neq'''' : forall pi1 sig1 pi2 sig2 e1 e2 e3 e4,
(forall s, eval_pi pi1 s = true -> eval_pi (e1 =/= e2) s = true) ->
entail (pi1 &&& (e1 =/= e3), sig1 ** ((lst e1 e2) ** (singl e3 e4))) (pi2, sig2) ->
entail (pi1, sig1 ** ((lst e1 e2) ** (singl e3 e4))) (pi2, sig2)
| entail_sepcon_neq''''': forall pi1 sig1 pi2 sig2 e1 e2 e3 e4,
(forall s, eval_pi pi1 s = true -> eval_pi (e1 =/= e2) s = true) ->
(forall s, eval_pi pi1 s = true -> eval_pi (e3 =/= e4) s = true) ->
entail (pi1 &&& (e1 =/= e3), sig1 ** ((lst e1 e2) ** (lst e3 e4))) (pi2, sig2) ->
entail (pi1, sig1 ** ((lst e1 e2) ** (lst e3 e4))) (pi2, sig2)
| entail_singl_not_null : forall pi1 sig1 pi2 sig2 e1 e2,
entail (pi1 &&& (e1 =/= (nat_e 0)), sig1 ** (singl e1 e2)) (pi2, sig2) ->
entail (pi1, sig1 ** (singl e1 e2)) (pi2, sig2)
| entail_cell_not_null : forall pi1 sig1 pi2 sig2 e1,
entail (pi1 &&& (e1 =/= (nat_e 0)), sig1 ** (cell e1)) (pi2, sig2) ->
entail (pi1, sig1 ** (cell e1)) (pi2, sig2)
| entail_lst_not_null : forall pi1 sig1 pi2 sig2 e1 e2,
(forall s, eval_pi pi1 s = true -> eval_pi (e2 =/= (nat_e 0)) s = true) ->
entail (pi1 &&& (e1 =/= (nat_e 0)), sig1 ** (lst e1 e2)) (pi2, sig2) ->
entail (pi1, sig1 ** (lst e1 e2)) (pi2, sig2)
| entail_monotony : forall pi1 pi2 sig11 sig12 sig21 sig22,
entail (pi1,sig11) (pi2, sig21) ->
entail (pi1,sig12) (pi2, sig22) ->
entail (pi1, sig11 ** sig12) (pi2, sig21 ** sig22)
| entail_destructlist: forall pi1 pi2 sig1 sig2 e1 e2,
(entail (pi1 &&& (e1 == e2), sig1 ** (lst e1 e2)) (pi2, sig2)) ->
(entail (pi1 &&& (e1 =/= e2), sig1 ** (lst e1 e2)) (pi2, sig2)) ->
entail (pi1, star sig1 (lst e1 e2)) (pi2, sig2).
Notation "s '|--' t" := (entail s t) (at level 80) : tmp_scope.
Lemma entail_id : forall sig pi,
(pi, sig) |-- (pi, sig).
Lemma entail_star_elim_lst : forall pi1 sig1 pi2 sig2 e1 e2,
(pi1, sig1) |-- (pi2, sig2) ->
(pi1, sig1 ** (lst e1 e2)) |-- (pi2, sig2 ** (lst e1 e2)).
Lemma entail_star_elim_star : forall s pi1 sig1 pi2 sig2,
(pi1, sig1) |-- (pi2, sig2) ->
(pi1, sig1 ** s) |-- (pi2, sig2 ** s).
Close Local Scope tmp_scope.
Lemma entail_soundness : forall P Q,
entail P Q ->
assrt_interp P ==> assrt_interp Q.
Lemma entail_to_Sigma_impl : forall sig1 sig2,
entail (true_b, sig1) (true_b, sig2) ->
Sigma_interp sig1 ==> Sigma_interp sig2.
Ltac Entail_turnl :=
match goal with
| |- entail (?Pi, cell ?e) ?L => eapply entail_empintrol; eapply entail_coml; repeat eapply entail_assocl
| |- entail (?Pi, singl ?e1 ?e2) ?L => eapply entail_empintrol; eapply entail_coml; repeat eapply entail_assocl
| |- entail (?Pi, lst ?e1 ?e2) ?L => eapply entail_empintrol; eapply entail_coml; repeat eapply entail_assocl
| |- entail (?Pi, star ?e1 ?e2) ?L => eapply entail_coml; repeat eapply entail_assocl
| _ => eapply entail_empintrol; eapply entail_coml; repeat eapply entail_assocl
end.
Ltac Entail_turnr :=
match goal with
| |- entail ?L (?Pi, cell ?e) => eapply entail_empintror; eapply entail_comr; repeat eapply entail_assocr
| |- entail ?L (?Pi, singl ?e1 ?e2) => eapply entail_empintror; eapply entail_comr; repeat eapply entail_assocr
| |- entail ?L (?Pi, lst ?e1 ?e2) => eapply entail_empintror; eapply entail_comr; repeat eapply entail_assocr
| |- entail ?L (?Pi, star ?e1 ?e2) => eapply entail_comr; repeat eapply entail_assocr
| _ => eapply entail_empintror; eapply entail_comr; repeat eapply entail_assocr
end.
Ltac Elim_subheap := repeat eapply entail_assocl; repeat eapply entail_assocr;
match goal with
| |- entail (?pi1, star ?sig1 (singl ?e1 ?e2)) (?pi2, star ?sig2 (singl ?e3 ?e4)) =>
(eapply entail_star_elim; [unfold eval_pi; Omega_exprb | unfold eval_pi; Omega_exprb | idtac])
| |- entail (?pi1, star ?sig1 (singl ?e1 ?e2)) (?pi2, star ?sig2 (cell ?e3)) =>
(eapply entail_star_elim'; [unfold eval_pi; Omega_exprb | idtac])
| |- entail (?pi1, star ?sig1 (cell ?e1)) (?pi2, star ?sig2 (cell ?e3)) =>
(eapply entail_star_elim''; [unfold eval_pi; Omega_exprb | idtac])
| |- entail (?pi1, star ?sig1 (lst ?e1 ?e2)) (?pi2, star ?sig2 (lst ?e3 ?e4)) =>
((eapply entail_lstsamelst; [unfold eval_pi; Omega_exprb | unfold eval_pi; Omega_exprb | idtac]) || (eapply entail_lstelim'';[unfold eval_pi; Omega_exprb | unfold eval_pi; Omega_exprb | idtac]))
| |- entail (?pi1, star ?sig1 (singl ?e1 ?e2)) (?pi2, star ?sig2 (lst ?e3 ?e4)) =>
(eapply entail_lstelim'''; [unfold eval_pi; Omega_exprb | unfold eval_pi; Omega_exprb | unfold eval_pi; Omega_exprb | idtac])
| |- entail (?pi1, star ?sig1 ?s) (?pi2, star ?sig2 ?s) =>
eapply entail_star_elim_star
end.
Ltac Entail_arith_impl :=
match goal with
| |- entail (?pi, ?sig) (?pi, ?sig) =>
eapply entail_id
| |- entail (?pi1, emp) (?pi2, emp) => eapply entail_tauto; [unfold eval_pi; intros; Omega_exprb]
| |- entail (?pi1, emp) (?pi2, emp) => eapply entail_incons; [unfold eval_pi; intros; Omega_exprb]
end.
Ltac Entail_elim_emp :=
match goal with
| |- entail (?pi1, star ?sig1 emp) (?pi2, ?sig2) => eapply entail_epseliml; Entail_elim_emp
| |- entail (?pi1, ?sig1) (?pi2, star ?sig2 emp) => eapply entail_epselimr; Entail_elim_emp
| |- _ => idtac
end.
Ltac Entail_not_nul_constraint :=
match goal with
| |- entail (?pi1, star ?sig1 (cell ?e)) (?pi2, ?sig2) =>
eapply entail_cell_not_null; idtac
| |- entail (?pi1, star ?sig1 (singl ?e1 ? e2)) (?pi2, ?sig2) =>
eapply entail_singl_not_null; idtac
| |- entail (?pi1, star ?sig1 (lst ?e1 ? e2)) (?pi2, ?sig2) =>
eapply entail_lst_not_null; [unfold eval_pi; Omega_exprb | idtac]
| |- _ => idtac
end.
Ltac Entail_count_subheap sig :=
match sig with
| star ?sig1 ?sig2 =>
let x := Entail_count_subheap sig1 in (
let y := Entail_count_subheap sig2 in (
constr:(x + y)
)
)
| _ =>
constr:(1)
end.
Ltac Printt x := assert (x = x).
Ltac Entail_elim_right n m :=
let y := (constr:(nat_gt n m)) in (
match (eval compute in y) with
| true => idtac
| false =>
Entail_turnr; (Elim_subheap || (
let x := (constr:(S n)) in (
Entail_elim_right x m
)
)
)
end
).
Ltac Entail_elim_left := Entail_not_nul_constraint;
match goal with
| |- entail (?pi1, ?sig1) (?pi2, ?sig2) =>
Entail_elim_emp; Entail_arith_impl
| |- entail (?pi1, ?sig1) (?pi2, ?sig2) =>
let x := Entail_count_subheap sig2 in (
let vx := eval compute in x in (
Entail_elim_right 0 vx
)
); Entail_turnl
end.
Ltac Entail := repeat Entail_elim_left.
Require Import expr_b_dp.
Fixpoint remove_empty_heap (pi : Pi) (sig : Sigma) {struct sig} : Sigma :=
match sig with
| star sig1 sig2 =>
match remove_empty_heap pi sig1 with
| emp => remove_empty_heap pi sig2
| sig1' => match remove_empty_heap pi sig2 with
| emp => sig1'
| sig2' => star sig1' sig2'
end
end
| lst e1 e2 => if expr_b_dp (pi =b> (e1 == e2)) then emp else sig
| _ => sig
end.
Lemma remove_empty_heap_correct : forall sig pi s,
s |b= pi ->
forall h,
(Sigma_interp (remove_empty_heap pi sig) s h -> Sigma_interp sig s h).
Lemma remove_empty_heap_correct' : forall sig pi s,
s |b= pi ->
forall h,
(Sigma_interp sig s h -> Sigma_interp (remove_empty_heap pi sig) s h).
Fixpoint cell_in_sigma (pi : Pi) (sig : Sigma) (e : expr) {struct sig} : bool :=
match sig with
| singl e1 e2 => expr_b_dp (pi =b> (e1 == e))
| cell e1 => expr_b_dp (pi =b> (e1 == e))
| lst e1 e2 => andb
(expr_b_dp (pi =b> (e1 == e)))
(expr_b_dp (pi =b> (e1 =/= e2)))
| star s1 s2 => orb (cell_in_sigma pi s1 e ) (cell_in_sigma pi s2 e)
| _ => false
end.
Lemma cell_in_sigma_correct: forall sig e pi,
cell_in_sigma pi sig e = true ->
forall s h,
s |b= pi ->
Sigma_interp sig s h -> ((Sigma_interp (cell e)) ** TT) s h.
Opaque remove_empty_heap.
Definition sigma_eq (pi : Pi) (sig1 sig2 : Sigma) : bool :=
match (sig1, sig2) with
| (emp, emp) => true
| (singl e1 e2, singl e3 e4) => andb (expr_b_dp (pi =b> (e1 == e3))) (expr_b_dp (pi =b> (e2 == e4)))
| (singl e1 e2, cell e3) => expr_b_dp (pi =b> (e1 == e3))
| (cell e1, cell e3) => expr_b_dp (pi =b> (e1 == e3))
| (lst e1 e2, lst e3 e4) => andb (expr_b_dp (pi =b> (e1 == e3))) (expr_b_dp (pi =b> (e2 == e4)))
| (_, _) => false
end.
Lemma sigma_eq_correct: forall sig1 sig2 pi,
sigma_eq pi sig1 sig2 = true ->
(forall s h,
s |b= pi ->
(Sigma_interp sig1 s h -> Sigma_interp sig2 s h)
).
Fixpoint elim_common_cell (pi : Pi) (sig1 remainder sig2 : Sigma) {struct sig2} : option (Sigma * Sigma) :=
match sig2 with
| star sig21 sig22 =>
match elim_common_cell pi sig1 remainder sig21 with
| None =>
match elim_common_cell pi sig1 remainder sig22 with
| None => None
| Some (sig1', sig2') => Some (sig1', remove_empty_heap pi (star sig21 sig2'))
end
| Some (sig1', sig2') => Some (sig1', remove_empty_heap pi (star sig2' sig22))
end
| _ =>
if sigma_eq pi sig1 sig2 then Some (emp, emp) else
match (sig1, sig2) with
| (lst e11 e12, lst e21 e22) =>
if andb
(expr_b_dp (pi =b> (e11 == e21)))
(orb
(expr_b_dp (pi =b> (e22 == nat_e 0)))
(cell_in_sigma pi remainder e22) )
then Some (emp, lst e12 e22) else None
| (singl e1 e2, lst e3 e4) =>
if andb (expr_b_dp (pi =b> (e1 == e3)))
(andb (expr_b_dp (pi =b> (e1 =/= e4)))
(expr_b_dp (pi =b> (e1 =/= nat_e 0))))
then Some (emp, (star (cell (e1 +e nat_e 1)) (lst e2 e4)))
else None
| (emp, lst e3 e4) =>
if expr_b_dp (pi =b> (e3 == e4))
then Some (emp, emp)
else Some (emp, sig2)
| (emp, _) => Some (emp, sig2)
| _ => None
end
end.
Lemma elim_common_cell_mp : forall sig2 sig1 remainder pi sig1' sig2',
elim_common_cell pi sig1 remainder sig2 = Some (sig1', sig2') ->
(Sigma_interp sig1 ==> (Sigma_interp sig1' -* Sigma_interp sig1) ** Sigma_interp sig1').
Lemma elim_common_cell_correct : forall sig2 sig1 remainder pi sig1' sig2',
elim_common_cell pi sig1 remainder sig2 = Some (sig1', sig2') ->
forall s,
s |b= pi ->
forall h1 h2 h3 h,
Sigma_interp sig2' s h1 ->
(Sigma_interp sig1' -* Sigma_interp sig1) s h2 ->
Sigma_interp remainder s h3 ->
h = h1 +++ h2 ->
h1 # h2 ->
h2 # h3 ->
Sigma_interp sig2 s h.
Fixpoint elim_common_subheap (pi : Pi) (sig1 sig2 remainder : Sigma) {struct sig1} : option (Sigma * Sigma) :=
match sig1 with
| star sig11 sig12 =>
match elim_common_subheap pi sig11 sig2 (star sig12 remainder) with
| None => None
| Some (sig11', sig12') => Some (remove_empty_heap pi (star sig11' sig12), sig12')
end
| _ => elim_common_cell pi sig1 remainder sig2
end.
Lemma elim_common_subheap_correct: forall sig1 sig2 remainder pi sig1' sig2',
elim_common_subheap pi sig1 sig2 remainder = Some (sig1', sig2') ->
forall s,
s |b= pi ->
(forall h, Sigma_interp (star remainder sig1') s h -> Sigma_interp sig2' s h) ->
(forall h, Sigma_interp (star sig1 remainder) s h -> Sigma_interp sig2 s h).
Fixpoint star_assoc_left (sig1 sig2: Sigma) {struct sig1} : Sigma :=
match sig1 with
star sig11 sig12 => star_assoc_left sig12 (star sig2 sig11)
| _ => match sig2 with
emp => sig1
| _ => star sig2 sig1
end
end.
Lemma star_assoc_left_correct: forall sig1 sig2,
Sigma_interp (star_assoc_left sig1 sig2) ==> Sigma_interp (star sig1 sig2).
Lemma star_assoc_left_correct' : forall sig1 sig2,
Sigma_interp (star sig1 sig2) ==> Sigma_interp (star_assoc_left sig1 sig2).
Definition star_com (sig : Sigma) : Sigma :=
match sig with
star sig1 sig2 => star sig2 sig1
| _ => sig
end.
Lemma star_com_correct : forall sig,
Sigma_interp (star_com sig) ==> Sigma_interp sig.
Lemma star_com_correct' : forall sig,
Sigma_interp sig ==> Sigma_interp (star_com sig).
Definition rearrange_elim_common_subheap (pi : Pi) (sig1 sig2 : Sigma) : Sigma * Sigma :=
match elim_common_subheap pi sig1 sig2 emp with
| None => (remove_empty_heap pi (star_com (star_assoc_left sig1 emp)), sig2)
| Some s => s
end.
Lemma rearrange_elim_common_subheap_correct : forall sig1 sig2 pi sig1' sig2',
rearrange_elim_common_subheap pi sig1 sig2 = (sig1',sig2') ->
forall s,
s |b= pi ->
(forall h, Sigma_interp sig1' s h -> Sigma_interp sig2' s h) ->
(forall h, Sigma_interp sig1 s h -> Sigma_interp sig2 s h).
Fixpoint elim_common_subheap_iterate (pi:Pi) (sig1 sig2:Sigma) (step:nat) {struct step} : Sigma * Sigma :=
match step with
| 0 => (sig1, sig2)
| S n =>
match rearrange_elim_common_subheap pi sig1 sig2 with
| (sig1', sig2') => elim_common_subheap_iterate pi sig1' sig2' n
end
end.
Lemma elim_common_subheap_iterate_correct: forall n sig1 sig2 pi sig1' sig2',
elim_common_subheap_iterate pi sig1 sig2 n = (sig1',sig2') ->
forall s,
s |b= pi ->
(forall h, Sigma_interp sig1' s h -> Sigma_interp sig2' s h) ->
(forall h, Sigma_interp sig1 s h -> Sigma_interp sig2 s h).
Transparent remove_empty_heap.
Fixpoint sigma_size (sig : Sigma) : nat :=
match sig with
| singl e1 e2 => 1
| cell e1 => 1
| lst e1 e2 => 3
| star s1 s2 => sigma_size s1 + sigma_size s2
| emp => 1
end.
Inductive result (A : Set) : Set :=
| Good : result A
| Error : A -> result A.
Implicit Arguments Good [A].
Implicit Arguments Error [A].
Definition sigma_impl (pi:Pi) (sig1 sig2:Sigma) : result (Sigma * Sigma) :=
match elim_common_subheap_iterate pi sig1 sig2 ((sigma_size sig1 + sigma_size sig2) * 2) with
| (emp, emp) => Good
| e => Error e
end.
Lemma sigma_impl_correct: forall sig1 sig2 pi,
sigma_impl pi sig1 sig2 = Good ->
forall s,
s |b= pi ->
(forall h, Sigma_interp sig1 s h -> Sigma_interp sig2 s h).
Definition frag_entail_fct (a1 a2 : assrt) : result (assrt * assrt) :=
let (pi1, sig1) := a1 in
let (pi2, sig2) := a2 in
if expr_b_dp (!pi1) then Good
else
match sigma_impl pi1 sig1 sig2 with | Good => if expr_b_dp (pi1 =b> pi2) then Good
else
Error ((pi1, emp), (pi2, emp))
| Error (s1, s2) => Error ((pi1, s1), (pi2, s2))
end.
Lemma frag_entail_fct_correct: forall a1 a2,
frag_entail_fct a1 a2 = Good ->
(assrt_interp a1 ==> assrt_interp a2).
Definition compute_constraint_cell (pi : Pi) (sig1 sig2 : Sigma) : Pi :=
match (sig1,sig2) with
| (singl e1 e2, singl e3 e4) =>
if expr_b_dp (pi =b> (e1 =/= e3)) then pi else
pi &&& (e1 =/= e3)
| (singl e1 e2, cell e3) =>
if expr_b_dp (pi =b> (e1 =/= e3)) then pi else
pi &&& (e1 =/= e3)
| (cell e1, singl e3 e4) =>
if expr_b_dp (pi =b> (e1 =/= e3)) then pi else
pi &&& (e1 =/= e3)
| (cell e1, cell e3) =>
if expr_b_dp (pi =b> (e1 =/= e3)) then pi else
pi &&& (e1 =/= e3)
| (singl e1 e2, lst e3 e4) =>
if expr_b_dp (pi =b> (e3 =/= e4)) then
if expr_b_dp (pi =b> (e1 =/= e3)) then pi else
pi &&& (e1 =/= e3)
else pi
| (lst e1 e2, singl e3 e4) =>
if expr_b_dp (pi =b> (e1 =/= e2)) then
if expr_b_dp (pi =b> (e1 =/= e3)) then pi else
pi &&& (e1 =/= e3)
else pi
| (cell e1, lst e3 e4) =>
if expr_b_dp (pi =b> (e3 =/= e4)) then
if expr_b_dp (pi =b> (e1 =/= e3)) then pi else
pi &&& (e1 =/= e3)
else pi
| (lst e1 e2, cell e3) =>
if expr_b_dp (pi =b> (e1 =/= e2)) then
if expr_b_dp (pi =b> (e1 =/= e3)) then pi else
pi &&& (e1 =/= e3)
else pi
| (lst e1 e2, lst e3 e4) =>
if expr_b_dp (pi =b> (e1 =/= e2)) && expr_b_dp (pi =b> (e3 =/= e4)) then
if expr_b_dp (pi =b> (e1 =/= e3)) then pi else
pi &&& (e1 =/= e3)
else pi
| (_, _) => pi
end.
Lemma compute_constraint_cell_correct: forall sig1 sig2 pi,
assrt_interp (pi,star sig1 sig2) ==> assrt_interp ((compute_constraint_cell pi sig1 sig2), star sig1 sig2).
Fixpoint compute_constraint_cell_sigma (pi: Pi) (sig1 sig2:Sigma) {struct sig2} : Pi :=
match sig2 with
| star sig21 sig22 => compute_constraint_cell_sigma (compute_constraint_cell_sigma pi sig1 sig21) sig1 sig22
| _ => compute_constraint_cell pi sig1 sig2
end.
Lemma compute_constraint_cell_sigma_correct: forall sig2 sig1 pi,
assrt_interp (pi,star sig1 sig2) ==> assrt_interp ((compute_constraint_cell_sigma pi sig1 sig2 ),star sig1 sig2).
Fixpoint compute_constraints' (pi: Pi) (sig:Sigma) {struct sig} : Pi :=
match sig with
| star sig1 sig2 => compute_constraints' (compute_constraint_cell_sigma pi sig2 sig1) sig1
| _ => pi
end.
Lemma compute_constraints'_correct: forall sig pi,
assrt_interp (pi,sig) ==> assrt_interp ((compute_constraints' pi sig), sig).
Definition compute_constraints (pi : Pi) (sig : Sigma) : Pi :=
compute_constraints' pi (star_assoc_left sig emp).
Lemma compute_constraints_correct: forall pi sig,
(assrt_interp (pi,sig) ==> assrt_interp (compute_constraints pi sig, sig)).
Fixpoint cell_loc_not_null (pi : Pi) (sig : Sigma) {struct sig} : Pi :=
match sig with
| emp => pi
| lst e1 e2 => pi
| cell e1 =>
if expr_b_dp (pi =b> (e1 =/= nat_e 0)) then pi else
pi &&& (e1 =/= (nat_e 0))
| (singl e1 e2) =>
if expr_b_dp (pi =b> (e1 =/= nat_e 0)) then pi else
pi &&& (e1 =/= nat_e 0)
| star s1 s2 =>
cell_loc_not_null (cell_loc_not_null pi s1) s2
end.
Lemma cell_loc_not_null_correct: forall sig pi,
assrt_interp (pi,sig) ==> assrt_interp ((cell_loc_not_null pi sig), sig).
Definition assrt_entail_fct (a1 a2: assrt) : result (assrt * assrt) :=
let (pi1,sig1) := a1 in frag_entail_fct (compute_constraints (cell_loc_not_null pi1 sig1) sig1 , sig1) a2 .
Lemma assrt_entail_fct_correct: forall a1 a2,
assrt_entail_fct a1 a2 = Good ->
(assrt_interp a1 ==> assrt_interp a2).
Fixpoint orassrt_impl_Assrt1 (a:assrt) (A:Assrt) (l:list (assrt * assrt)) {struct A} : result (list (assrt * assrt)) :=
match A with
| nil => Error l
| hd::tl =>
match assrt_entail_fct a hd with
| Good => Good
| Error e => orassrt_impl_Assrt1 a tl (e :: l)
end
end.
Lemma orassrt_impl_Assrt1_correct: forall A a l,
orassrt_impl_Assrt1 a A l = Good ->
(assrt_interp a ==> Assrt_interp A).
Fixpoint orpi (l: list assrt) : expr_b :=
match l with
| nil => neg_b true_b
| (pi, sig) :: tl => pi ||| (orpi tl)
end.
Fixpoint orassrt_impl_Assrt2 (a:assrt) (A:Assrt) (l:list (assrt * assrt)) {struct A} : result (list (assrt * assrt)) :=
match A with
| nil => Error l
| (pi, sig) :: tl =>
match a with
| (pi', sig') =>
match sigma_impl (pi' &&& pi) sig' sig with
| Error (s1, s2) => Error (((pi', s1), (pi, s2)) :: l)
| Good =>
match tl with
| nil => Good
| _ => orassrt_impl_Assrt2 a tl l
end
end
end
end.
Lemma orassrt_impl_Assrt2_correct: forall A pi sig l,
orassrt_impl_Assrt2 (pi, sig) A l = Good -> forall s h,
s |b= pi =b> (orpi A) -> ((assrt_interp (pi,sig)) s h -> (Assrt_interp A) s h).
Definition entail_fct (a:assrt) (A:Assrt) (l:list (assrt * assrt)) : result (list (assrt * assrt)) :=
match a with
| (pi, sig) =>
if expr_b_dp (pi =b> (orpi A)) then match orassrt_impl_Assrt2 a A nil with | Good => Good
| Error e => orassrt_impl_Assrt1 a A nil end
else
orassrt_impl_Assrt1 a A nil end.
Lemma entail_fct_correct: forall A a l,
entail_fct a A l = Good ->
(assrt_interp a ==> Assrt_interp A).
Fixpoint Assrt_entail_Assrt_dp (A1 A2: Assrt) (l: list (assrt * assrt)) {struct A1} : result (list (assrt * assrt)) :=
match A1 with
| nil => Good
| hd::tl =>
match entail_fct hd A2 nil with
| Good => Assrt_entail_Assrt_dp tl A2 l
| Error e => Error (e ++ l)
end
end.
Lemma Assrt_entail_Assrt_dp_correct: forall A1 A2 l,
Assrt_entail_Assrt_dp A1 A2 l = Good ->
(Assrt_interp A1) ==> (Assrt_interp A2).