Module Freezer : FREEZER.
Definition FRZ (p: mpred) := p.
Definition FRZL (ps:list mpred): mpred := fold_right sepcon emp ps.
Inductive FRZRw' (L1 G1: list mpred): Type :=
| FRZRw'_constr: forall F: mpred,
(fold_right sepcon emp G1) |-- fold_right sepcon emp L1 * F -> FRZRw' L1 G1.
Definition FRZRw := FRZRw'.
Definition FRZRw_constr:= FRZRw'_constr.
Definition FRZR (L1 G1: list mpred) {w: FRZRw L1 G1}: mpred :=
match w with
| FRZRw'_constr F _ => F
end.
Tactic Notation "freeze1_SEP" constr(n) :=
eapply (freeze1_SEP' (Z.to_nat n)); simpl.
Tactic Notation "freeze1_SEP" constr(n) constr(m) :=
(gather_SEP' (n::m::nil)); eapply (freeze1_SEP' (Z.to_nat 0)); simpl.
Tactic Notation "freeze1_SEP" constr(n) constr(m) constr(k)  :=
(gather_SEP' (n::m::k::nil)); eapply (freeze1_SEP' (Z.to_nat 0)); simpl.
Tactic Notation "freeze1_SEP" constr(n) constr(m) constr(k)  constr(p) :=
(gather_SEP' (n::m::k::p::nil)); eapply (freeze1_SEP' (Z.to_nat 0)); simpl.
Tactic Notation "freeze1_SEP" constr(n) constr(m) constr(k) constr(p) constr(q) :=
(gather_SEP' (n::m::k::p::q::nil)); eapply (freeze1_SEP' (Z.to_nat 0)); simpl.
(*******************freezing a list of mpreds ******************************)
Fixpoint delete_list {A: Type} (ns: list nat) (xs: list A) : list A :=
(* ns must already be sorted *)
match ns with
| nil => xs
| n::ns' => delete_nth n (delete_list ns' xs)
end.
Definition freezelist_nth (ns: list nat) (al: list mpred) : list mpred * list mpred :=
(map (fun i => my_nth i al emp) ns,
delete_list (SortNat.sort ns) al).
Function is_increasing (ns: list nat) (last: nat) {measure length ns}: bool  :=
match ns with
| nil => true
| a::nil => Nat.ltb a last
| a::b::ns' => andb (Nat.ltb a b) (is_increasing (b::ns') last)
end.
*)
Fixpoint my_nth {A} (n : nat) (l : list A) (default : A) {struct l} : A :=
match n with
| 0%nat => match l with
| [] => default
| x :: _ => x
end
| S m => match l with
| [] => default
| _ :: t => my_nth m t default
end
end.
(*Variant if l is monotonically decreasing Fixpoint new_freezelist_nth (l: list nat) (al: list mpred): (list mpred) * (list mpred) := match l with | nil => (nil,al) | (n::l') => let (xs, ys) := new_freezelist_nth l' (my_delete_nth n al) in (my_nth n al emp::xs, ys) end.*)
(* Ltac flatten_emp_in_mpreds RR := match RR with | (SEPx (?R)) => match R with context [emp :: ?R'] => let n := constr:(length R - Datatypes.S (length R'))%nat in let n' := eval lazy beta zeta iota delta in n in erewrite(@flatten_emp_in_mpreds' n' R _ (eq_refl _)); [ | let RR := fresh "RR" in set (RR := R); unfold firstn, app, skipn; subst RR; cbv beta iota; apply eq_refl ] end end.  Ltac flatten_emp := match goal with | |- semax _ ?PQR _ _ => flatten_emp_in_SEP PQR | |-  ?PQR |-- _ => first [flatten_emp_in_SEP PQR | flatten_emp_in_mpreds PQR ] end.*)
Ltac flatten_emp_in_SEP PQR :=
match PQR with
| PROPx ?P (LOCALx ?Q (SEPx (?R))) =>
match R with context [emp :: ?R'] =>
let n := constr:((length R - Datatypes.S (length R'))%nat) in
let n' := eval lazy beta zeta iota delta in n in
erewrite(@flatten_emp_in_SEP' n' P Q R _ (eq_refl _));
[ |
let RR := fresh "RR" in set (RR := R);
unfold firstn, app, skipn; subst RR; cbv beta iota;
apply eq_refl
]
end
end.
Ltac flatten_emp :=
match goal with
| |- semax _ ?PQR _ _ => flatten_emp_in_SEP PQR
| |-  ?PQR |-- _ => flatten_emp_in_SEP PQR
end.
(*Thawing a freezer results in the sepcon product of the frozen items.*)
(*Tactic requires the resulting goal to be normalized manually.*)
Ltac thaw' name :=
rewrite (FRZL_ax name); unfold name, abbreviate; clear name.
(*add simplification of the list operations inside the freezer, flatten the sepcon, and eliminate the emp term*)
Ltac thaw name :=
thaw' name;
let x := fresh "x" in let y := fresh "y" in let a := fresh "a" in
lazymatch goal with
|  |- context [fold_right_sepcon (map ?F ?A)] =>
set (x:= fold_right_sepcon (map F A));
set (y := F) in *;
simpl in x
|  |- context [fold_right_sepcon ?A] =>
set (x:= fold_right_sepcon A);
unfold fold_right_sepcon in x
end;
pattern x;
match goal with |- ?A x => set (a:=A) end;
revert x;
rewrite <- ?sepcon_assoc, sepcon_emp;
intro x; subst a x; try subst y;
unfold my_delete_list, my_delete_nth, my_nth, fold_right_sepcon;
repeat flatten_sepcon_in_SEP; repeat flatten_emp.
(************************ Ramification ************************)
Inductive split_FRZ_in_SEP: list mpred -> list mpred -> list mpred -> Prop :=
| split_FRZ_in_SEP_nil: split_FRZ_in_SEP nil nil nil
| split_FRZ_in_SEP_FRZ: forall R R' RF F, split_FRZ_in_SEP R R' RF -> split_FRZ_in_SEP (FRZ F :: R) R' (FRZ F :: RF)
| split_FRZ_in_SEP_FRZL: forall R R' RF F, split_FRZ_in_SEP R R' RF -> split_FRZ_in_SEP (FRZL F :: R) R' (FRZL F :: RF)
| split_FRZ_in_SEP_FRZR: forall R R' RF L G w, split_FRZ_in_SEP R R' RF -> split_FRZ_in_SEP (@FRZR L G w :: R) R' (@FRZR L G w :: RF)
| split_FRZ_in_SEP_other: forall R R' RF R0, split_FRZ_in_SEP R R' RF -> split_FRZ_in_SEP (R0 :: R) (R0 :: R') RF.
Ltac prove_split_FRZ_in_SEP :=
solve [
repeat first
[ simple apply split_FRZ_in_SEP_nil
| simple apply split_FRZ_in_SEP_FRZ
| simple apply split_FRZ_in_SEP_FRZL
| simple apply split_FRZ_in_SEP_FRZR
| simple apply split_FRZ_in_SEP_other]].
Ltac unfold_app :=
change (@app mpred)
with (fix app (l m : list mpred) {struct l} : list mpred :=
match l with
| nil => m
| cons a l1 => cons a (app l1 m)
end);
change (@app Prop)
with (fix app (l m : list Prop) {struct l} : list Prop :=
match l with
| nil => m
| cons a l1 => cons a (app l1 m)
end);
cbv beta iota.
Ltac localize R_L :=
eapply (localize R_L); [prove_split_FRZ_in_SEP |];
let FR_L := fresh "RamL" in
let FR_G := fresh "RamG" in
intros FR_L FR_G;
eexists;
unfold_app.
Inductive ramif_frame_gen: mpred -> mpred -> Prop :=
| ramif_frame_gen_refl: forall P, ramif_frame_gen P P
| ramif_frame_gen_prop: forall (Pure: Prop) P Q, Pure -> ramif_frame_gen P (imp (prop Pure) Q) -> ramif_frame_gen P Q
| ramif_frame_gen_allp: forall {A: Type} (x: A) P Q, (forall x: A, ramif_frame_gen (P x) (Q x)) -> ramif_frame_gen (allp P) (Q x).
Ltac prove_ramif_frame_gen_rec wit :=
match wit with
| pair ?wit0 ?x =>
prove_ramif_frame_gen_rec wit0;
match goal with
| |- ramif_frame_gen _ ?P => super_pattern P x
end;
apply (ramif_frame_gen_allp x);
clear dependent x;
intros x
| _ =>
match goal with
| |- ramif_frame_gen _ ?P => super_pattern P wit
end;
apply (ramif_frame_gen_allp wit);
clear dependent wit;
intros wit
end.
Ltac prove_ramif_frame_gen wit :=
prove_ramif_frame_gen_rec wit;
apply ramif_frame_gen_refl.
Ltac conj_gen assu :=
match assu with
| pair ?assu0 ?a => let r := conj_gen assu0 in constr:(conj r a)
| _ => constr:(assu)
end.
Ltac prove_ramif_frame_gen_prop assu :=
let H := conj_gen assu in
let Pure := type of H in
apply (ramif_frame_gen_prop Pure _ _ H).

Lemma ramif_frame_gen_spec: forall P Q, ramif_frame_gen P Q -> P |-- Q.