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)).

Lemma tree_map_inject_over_mem_correct:
forall {A} m2 mu (perm:PTree.t (Z -> option A)) b1 b2 ofs delt,
mu b1 = Some (b2, delt) ->
Mem.perm m2 b2 (ofs + delt) Max Nonempty ->
(tree_map_inject_over_mem m2 mu perm) ! b2 =
Some (build_function_for_a_block
mu b2 (PTree.elements perm)).