(* 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
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
(**************************************************************************)
(*                  Syntactic cancelation of heaps                        *)
(**************************************************************************)
(* Differences w.r.t. the paper:  In the paper we described the cancellation algorithm as producing a proposition. Instead, it will produce a sequence of "facts" which are later on evaluated into a proposition. We did this in order to further simplify the proposition. Each fact is of the form t1 = t2, where t1 and t2 are heaps, pointers, or values.  Another simplification we made in the paper is that the values contained in a heap are actually instances of a generic type 'dynamic'. This type is defined in the file heaps.v, and is just a structure containing a value and its type. So, instead of equating values, we are equating dynamics, therefore we need some extra step to prove the values are equal (see the examples at the bottom of the file). This can be avoided with extra canonical structures machinery. *)
(***************************)
(* interpretation contexts *)
(***************************)
Structure ctx := Context {heap_ctx : seq heap; ptr_ctx : seq ptr}.
Definition empc := Context [::] [::].
Definition subctx i j :=
prefix (heap_ctx i) (heap_ctx j) /\ prefix (ptr_ctx i) (ptr_ctx j).
(**************************************************************************)
(*                            Syntactic heaps                             *)
(* Pointers and heap variables are syntactified as indices in the context *)
(* Disjoint union is syntactified as concatenation of lists               *)
(**************************************************************************)
Inductive elem := Pts of nat & dynamic | Var of nat.
Definition synheap := seq elem.
(*****************************************************************************)
(* Validity of indices:                                                      *)
(*   valid i t  iif all the indices in t are in bounds of the contexts lists *)
(*****************************************************************************)
Fixpoint valid_ptrs i t :=
match t with
Pts sx _ :: s => (sx < size (ptr_ctx i)) && valid_ptrs i s
| Var _ :: s => valid_ptrs i s
| _ => true
end.
Fixpoint valid_heaps i t :=
match t with
Pts _ _ :: s => valid_heaps i s
| Var v :: s => (v < size (heap_ctx i)) && valid_heaps i s
| _ => true
end.
Definition valid i t := valid_ptrs i t && valid_heaps i t.
(*************************************)
(* interpretation of syntactic heaps *)
(*************************************)
(* lookup functions for heaps and pointers *)
Definition hlook := [fun i => onth (heap_ctx i)].
Definition plook := [fun i => onth (ptr_ctx i)].
(* notation for lookups with default *)
Notation plook' i x := (odflt null (plook i x)).
(* interpretation function for elements *)
Definition einterp i e :=
match e with
Pts x d =>
if plook i x is Some x'
then x' :-> Dyn.val d
else Undef
| Var h => if hlook i h is Some h' then h' else Undef
end.
(* main interpretation function *)
Fixpoint interp i t :=
if t is e :: t' then
if t' is [::] then einterp i e else einterp i e :+ interp i t'
else empty.
Inductive fact :=
eqH of synheap & synheap | eqD of dynamic & dynamic | eqX of nat & nat.
(* returns the proposition generated by a fact *)
Definition eval_fact i f :=
match f with
| eqH h1 h2 => interp i h1 = interp i h2
| eqD d1 d2 => d1 = d2
| eqX x1 x2 => plook i x1 = plook i x2
end.
(* returns the logic concatenation of all the facts in the list *)
Fixpoint eval i s :=
match s with
| [:: f] => eval_fact i f
| (f :: fs) => eval_fact i f /\ eval i fs
| [::] => True
end.
(* functions to collect pointers and heap variables indices out of a synheap *)
Fixpoint ptrs t : seq nat :=
if t is e :: t' then
if e is Pts x _ then x :: (ptrs t')
else ptrs t'
else [::].
Fixpoint vars t : seq nat :=
if t is e :: t' then
if e is Var h then h :: (vars t')
else vars t'
else [::].
Definition ptreq (x : nat) e := if e is Pts y _ then x == y else false.
Definition vareq (h : nat) e := if e is Var k then h == k else false.
Fixpoint pread x t :=
match t with
Pts y d :: s => if x == y then some d else pread x s
| e :: s => pread x s
| _ => None
end.
Notation pread' x t := (odflt (dyn tt) (pread x t)).
Definition pfree x t := filter (predC (ptreq x)) t.
Definition hfree h t := filter (predC (vareq h)) t.
(* Main function to perform the cancelation of heaps. One difference to point out from the description in the paper, appart from the fact that it is returning a list of facts, is that in the base case we consider the special case x1 :-> v1 = x2 :-> v2 -> x1 = x2 /\ v1 = v2  *)
Fixpoint cancel' (i : ctx) (t1 t2 r : synheap) (f : seq fact) : seq fact :=
match t1 with
| [::] => match r, t2 with
| [::], [::] => f
| [:: Pts x d], [:: Pts x' d'] =>
[:: eqX x x', eqD d d' & f]
| _ , _ => [:: eqH r t2 & f]
end
| Pts x d :: t1' =>
if x \in ptrs t2
then cancel' i t1' (pfree x t2) r [:: eqD d (pread' x t2) & f]
else cancel' i t1' t2 [:: Pts x d & r] f
| Var h :: t1' =>
if h \in vars t2 then cancel' i t1' (hfree h t2) r f
else cancel' i t1' t2 [:: Var h & r] f
end.
Definition cancel i t1 t2 := cancel' i t1 t2 [::] [::].
(* several auxiliary lemmas about the definitions given above *)

Lemma vars_hfree (h1 h2 : nat) t :
has (vareq h1) (hfree h2 t) = (h1 != h2) && (has (vareq h1) t).