Section VirtueInject.
Fixpoint build_function_for_a_block
(mu:meminj) {A} (b: positive) (ls: list (positive * (Z -> option A))):
Z -> option A:=
match ls with
| nil => (fun _ => None)
| (b0, fb)::ls' =>
match mu b0 with
| Some (b1, delt) =>
if PMap.elt_eq b b1 then
merge_func (fun p => (fb (p - delt)%Z)) (build_function_for_a_block mu b ls')
else  (build_function_for_a_block mu b ls')
| None => (build_function_for_a_block mu b ls')
end
end.
Definition tree_map_inject_over_tree {A B}
(t:PTree.t (Z -> option B))(mu:meminj) (map:PTree.t (Z -> option A)):
PTree.t (Z -> option A):=
PTree.map (fun b _ => build_function_for_a_block mu b (PTree.elements map)) t.
Definition tree_map_inject_over_mem {A} m mu map:
PTree.t (Z -> option A) :=
tree_map_inject_over_tree (snd (getMaxPerm m)) mu map.
(* apply an injections to the elements of a tree. *)
Fixpoint apply_injection_elements {A}
(mu:meminj) (ls: list (positive * (Z -> option A)))
: list (positive * (Z -> option A)) :=
match ls with
nil => nil
| cons (b, ofs_f) ls' =>
match (mu b) with
| None => apply_injection_elements mu ls'
| Some (b',d) =>
cons (b', fun ofs => ofs_f (ofs-d)%Z)
(apply_injection_elements mu ls')
end
end.
Fixpoint extract_function_for_block
{A} (b: positive) (ls: list (positive * (Z -> option A)))
: Z -> option A :=
match ls with
nil => fun _ => None
| cons (b', ofs_f') ls' =>
if (Pos.eq_dec b b') then
merge_func ofs_f' (extract_function_for_block b ls')
else (extract_function_for_block b ls')
end.
Fixpoint map_from_list
{A:Type}
(mu:meminj) (ls: list (positive * (Z -> option A))):
PTree.t (Z -> option A) :=
match ls with
nil => @PTree.empty (BinNums.Z -> option A)
| cons (b, ofs_f) ls =>
let t:= map_from_list mu ls in
match mu b with
None => t
| Some (b',d) =>
match PTree.get b' t with
None => PTree.set b' (fun ofs => ofs_f (ofs-d)%Z) t
| Some f_old =>
PTree.set b' (merge_func (fun ofs => ofs_f (ofs-d)%Z) f_old) t
end end end.
Definition tree_map_inject {A}(mu:meminj) (map:PTree.t (Z -> option A)):
PTree.t (Z -> option A):=
map_from_list mu (PTree.elements map).
Definition virtueThread_inject m (mu:meminj) (virtue:delta_map * delta_map):
delta_map * delta_map:=
pair1 (tree_map_inject_over_mem m mu) virtue.
Hint Unfold virtueThread_inject: pair.
(*NOTE: default is set to (fun _=> None) used to be, [fst map] but this makes no sense since it is not "mapped" it rellied in the fact that fst map s empty... which is the same... *)
Definition inject_access_map m (mu:meminj) (map:access_map): access_map:=
((* fst map*) (fun _=> None)  , tree_map_inject_over_mem m mu (snd map)).
(** *No overlap*)
Definition no_overlap {A} (f:meminj) (perms:PMap.t (Z -> option A)):=
forall b1 b1' delta1 b2 b2' delta2 ofs1 ofs2,
b1 <> b2 ->
f b1 = Some (b1', delta1) ->
f b2 = Some (b2', delta2) ->
at_least_Some (perms !! b1 ofs1)  ->
at_least_Some (perms !! b2 ofs2) ->
b1' <> b2' \/ ofs1 + delta1 <> ofs2 + delta2.
Definition dmap_no_overlap (f:meminj) (dm:delta_map):=
no_overlap f (fun _ : Z => None, dm).
Definition list_no_overlap {A} (mu:meminj) elements:Prop:=
forall b1 b1' delta b2 delta' ofs ofs' f f' (perm perm': A) ,
b1 <> b1' ->
mu b1 = Some(b2, delta) ->
mu b1' = Some(b2, delta') ->
In (b1,f) elements ->
In (b1',f') elements ->
f ofs = Some perm ->
f' ofs' = Some perm' ->
ofs + delta <> ofs' + delta'.
Definition list_no_overlap_one {A} (mu:meminj) b1 b2 ofs elements:Prop:=
forall delta,
mu b1 = Some (b2, delta) ->
forall b1' f' ofs' delta' (perm':A),
b1 <> b1' ->
mu b1' = Some(b2, delta') ->
In (b1',f') elements ->
f' ofs' = Some perm' ->
ofs' + delta' <> ofs + delta.
Definition virtueLP_inject m (mu:meminj):
(Pair access_map) -> Pair access_map :=
pair1 (inject_access_map m mu).
Definition inject_virtue (m: mem) (mu: meminj) (angel:virtue):=
Build_virtue
(virtueThread_inject m mu (virtueThread angel))
(virtueLP_inject m mu (virtueLP angel)).
Inductive injects (mu:meminj) (b:block): Prop:=
| InjectsBlock: forall b2 delta, mu b = Some (b2, delta) -> injects mu b.
Definition injects_map mu (m:access_map): Prop := forall b ofs p,
m !! b ofs = Some p -> injects mu b.
Definition injects_map_pair mu:= pair1_prop (injects_map mu).
Hint Unfold injects_map_pair: pair.
Definition injects_dmap mu (m:delta_map) := forall b ofs p,
dmap_get m b ofs = Some p -> injects mu b.
Definition injects_dmap_pair mu:= pair1_prop (injects_dmap mu).
Hint Unfold injects_dmap_pair: pair.
Record injects_angel mu angel:=
{ Hinj_map : injects_map_pair mu (virtueLP angel);
Hinj_dmap : injects_dmap_pair mu (virtueThread angel)}.

Lemma inject_virtue_perm_perfect:
forall f angel1 m1 m2,
Mem.inject f m1 m2 ->
injects_angel f angel1 ->
option_implication_dmap_access_pair (virtueThread angel1) (getMaxPerm m1) ->
perm_perfect_virtue f angel1 (inject_virtue m2 f angel1).