(* Copyright (C) 2012  G. Gonthier, B. Ziliani, A. Nanevski, D. Dreyer  This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version.  This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more details.  You should have received a copy of the GNU General Public License along with this program.  If not, see <http://www.gnu.org/licenses/>. *)
From mathcomp
From LemmaOverloading
From mathcomp
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
(*************)
(* Locations *)
(*************)
Inductive ptr := ptr_nat of nat.
Definition null := ptr_nat 0.
Definition nat_ptr (x : ptr) := let: ptr_nat y := x in y.
Definition eq_ptr (x y : ptr) :=
match x, y with ptr_nat m, ptr_nat n => m == n end.
Definition ltn_ptr (x y : ptr) :=
match x, y with ptr_nat m, ptr_nat n => m < n end.
End NullLemmas.
(****************)
(* main methods *)
(****************)
Definition def h := if h is Def _ _ then true else false.
Definition empty := @Def (finmap.nil _ _) is_true_true.
Definition upd h x d := nosimpl
(if h is Def hs ns then
if decP (@idP (x != null)) is left pf then
Def (@upd_nullP _ _ d pf ns)
else Undef
else Undef).
Definition dom h : pred ptr := nosimpl
(if h is Def f _ then mem (supp f) else pred0).
Definition free x h : heap :=
(if h is Def hs ns then Def (free_nullP x ns) else Undef).
Definition look (x : ptr) h :=
(if h is Def hs _ then
if fnd x hs is Some d then d else dyn tt
else dyn tt).
Definition union2 h1 h2 := nosimpl
(if (h1, h2) is (Def hs1 ns1, Def hs2 ns2) then
if disj hs1 hs2 then
Def (@un_nullP _ _ ns1 ns2)
else Undef
else Undef).
Definition empb h :=
if h is Def hs _ then supp hs == [::] else false.
Definition fresh h :=
(if h is Def hs _ then last null (supp hs) else null) .+ 1.
Definition subdom h1 h2 :=
if (h1, h2) is (Def hs1 _, Def hs2 _) then
all (fun x => x \in supp hs2) (supp hs1)
else false.
Definition subheap h1 h2 :=
subdom h1 h2 /\ forall x, x \in dom h1 -> look x h1 = look x h2.
(* Definition subheap h1 h2 p :=  *)
(*   if (h1, h2) is (Def hs1 _, Def hs2 _) then  *)
(*     all (fun x => p (look x h1) (look x h2)) (supp hs1) *)
(*   else false. *)
Definition subtract h1 h2 :=
if h1 is (Def hs1 _) then
foldl (fun h x => free x h) h2 (supp hs1)
else Undef.
Definition pick h :=
if h is Def hs _ then head null (supp hs) else null.
Definition pts A (x : ptr) (v : A) := upd empty x (dyn v).
Notation "h1 :+ h2" := (union2 h1 h2) (at level 43, left associativity).
Notation "h2 :- h1" := (subtract h1 h2) (at level 43, left associativity).
Notation "x :-> v" := (pts x v) (at level 30).
(***********************)
(* monoidal properties *)
(***********************)
(*******)
(* def *)
(*******)
(********)
(* free *)
(********)
(* some transformation lemmas *)
(*********)
(* fresh *)
(*********)
(**********)
(* subdom *)
(**********)
Hint Resolve subdom_emp subdomPE : core.
(***********)
(* subheap *)
(***********)
(***********************)
(* Some derived lemmas *)
(***********************)
(* the three projections from defPtUn are often useful *)
End BlockUpdate.
(*********************************************************************)
(* Freshness for even and odd locations -- used in information flow, *)
(* where heaps are split into low (even) and high (odd) parts.       *)
(*********************************************************************)
Definition low : pred ptr := fun x => 0 == nat_ptr x %[mod 2].
Definition high : pred ptr := fun x => 1 == nat_ptr x %[mod 2].
Definition get_lows h :=
if h is Def hs _ then filter low (supp hs) else [::].
Definition get_highs h :=
if h is Def hs _ then filter high (supp hs) else [::].
Definition ldom h : pred ptr := fun x => x \in get_lows h.
Definition hdom h : pred ptr := fun x => x \in get_highs h.
Definition lfresh h := (last null (get_lows h)) .+ 2.
Definition hfresh h := (last (null .+ 1) (get_highs h)) .+ 2.

Lemma highPtUn A h1 h2 (x : ptr) (v : A) :
def (x :-> v :+ h1) -> high x ->
(x :-> v :+ h1 =~ h2) = (h1 =~ h2).