Commit 151b8cb5 authored by Bruno Guillaume's avatar Bruno Guillaume

change shifts semantics: only edges outside the pattern are concerned by shifts

parent 6fe5403e
......@@ -583,30 +583,21 @@ module G_graph = struct
(* -------------------------------------------------------------------------------- *)
(* move out-edges (which respect cst [labels,neg]) from id_src are moved to out-edges out off node id_tar *)
let shift_out loc ?domain src_gid tar_gid label_cst graph =
let shift_out loc ?domain src_gid tar_gid is_gid_local label_cst graph =
let src_node = Gid_map.find src_gid graph.map in
let tar_node = Gid_map.find tar_gid graph.map in
let src_next = G_node.get_next src_node in
let tar_next = G_node.get_next tar_node in
(* Error if a loop is created by the shift_out *)
let src_tar_edges = Massoc_gid.assoc tar_gid src_next in
let _ =
try
let loop_edge = List.find (fun edge -> Label_cst.match_ ?domain label_cst edge) src_tar_edges in
Error.run ~loc "The shfit_out command tries to build a loop (with label %s)" (Label.to_string ?domain loop_edge)
with Not_found -> () in
let (new_src_next,new_tar_next) =
let (new_src_next, new_tar_next) =
Massoc_gid.fold
(fun (acc_src_next,acc_tar_next) next_gid edge ->
if Label_cst.match_ ?domain label_cst edge
if Label_cst.match_ ?domain label_cst edge && not (is_gid_local next_gid)
then
match Massoc_gid.add next_gid edge acc_tar_next with
| Some new_acc_tar_next -> (Massoc_gid.remove next_gid edge acc_src_next, new_acc_tar_next)
| None -> Error.run ~loc "The [shift_out] command tries to build a duplicate edge (with label \"%s\")" (Label.to_string ?domain edge)
else (acc_src_next,acc_tar_next)
)
(src_next, tar_next) src_next in
......@@ -618,21 +609,13 @@ module G_graph = struct
}
(* -------------------------------------------------------------------------------- *)
let shift_in loc ?domain src_gid tar_gid label_cst graph =
let tar_node = Gid_map.find tar_gid graph.map in
let tar_next = G_node.get_next tar_node in
(* Error if a loop is created by the shift_in *)
let tar_src_edges = Massoc_gid.assoc src_gid tar_next in
let _ =
try
let loop_edge = List.find (fun edge -> Label_cst.match_ ?domain label_cst edge) tar_src_edges in
Error.run ~loc "The [shift_in] command tries to build a loop (with label \"%s\")" (Label.to_string ?domain loop_edge)
with Not_found -> () in
let shift_in loc ?domain src_gid tar_gid is_gid_local label_cst graph =
{ graph with map =
Gid_map.mapi
(fun node_id node ->
Gid_map.mapi
(fun node_id node ->
if is_gid_local node_id
then node
else
let node_next = G_node.get_next node in
match Massoc_gid.assoc src_gid node_next with
| [] -> node (* no edges from node to src *)
......@@ -658,14 +641,14 @@ module G_graph = struct
}
(* -------------------------------------------------------------------------------- *)
let shift_edges loc ?domain src_gid tar_gid label_cst graph =
let shift_edges loc ?domain src_gid tar_gid is_gid_local label_cst graph =
graph
|> (shift_in loc ?domain src_gid tar_gid label_cst)
|> (shift_out loc ?domain src_gid tar_gid label_cst)
|> (shift_in loc ?domain src_gid tar_gid is_gid_local label_cst)
|> (shift_out loc ?domain src_gid tar_gid is_gid_local label_cst)
(* -------------------------------------------------------------------------------- *)
let merge_node loc ?domain graph src_gid tar_gid =
let se_graph = shift_edges loc ?domain src_gid tar_gid Label_cst.all graph in
let merge_node loc ?domain graph is_gid_local src_gid tar_gid =
let se_graph = shift_edges loc ?domain src_gid tar_gid is_gid_local Label_cst.all graph in
let src_node = Gid_map.find src_gid se_graph.map in
let tar_node = Gid_map.find tar_gid se_graph.map in
......
......@@ -144,16 +144,16 @@ module G_graph: sig
val add_before: Loc.t -> ?domain:Domain.t -> Gid.t -> t -> (Gid.t * t)
val add_after: Loc.t -> ?domain:Domain.t -> Gid.t -> t -> (Gid.t * t)
val merge_node: Loc.t -> ?domain:Domain.t -> t -> Gid.t -> Gid.t -> t option
val merge_node: Loc.t -> ?domain:Domain.t -> t -> (Gid.t -> bool) -> Gid.t -> Gid.t -> t option
(** move all in arcs to id_src are moved to in arcs on node id_tar from graph, with all its incoming edges *)
val shift_in: Loc.t -> ?domain:Domain.t -> Gid.t -> Gid.t -> Label_cst.t -> t -> t
val shift_in: Loc.t -> ?domain:Domain.t -> Gid.t -> Gid.t -> (Gid.t -> bool) -> Label_cst.t -> t -> t
(** move all out-edges from id_src are moved to out-edges out off node id_tar *)
val shift_out: Loc.t -> ?domain:Domain.t -> Gid.t -> Gid.t -> Label_cst.t -> t -> t
val shift_out: Loc.t -> ?domain:Domain.t -> Gid.t -> Gid.t -> (Gid.t -> bool) -> Label_cst.t -> t -> t
(** move all incident arcs from/to id_src are moved to incident arcs on node id_tar from graph, with all its incoming and outcoming edges *)
val shift_edges: Loc.t -> ?domain:Domain.t -> Gid.t -> Gid.t -> Label_cst.t -> t -> t
val shift_edges: Loc.t -> ?domain:Domain.t -> Gid.t -> Gid.t -> (Gid.t -> bool) -> Label_cst.t -> t -> t
(** [update_feat domain tar_id tar_feat_name concat_items] sets the feature of the node [tar_id]
with feature name [tar_feat_name] to be the contatenation of values described by the [concat_items].
......
......@@ -885,6 +885,10 @@ module Rule = struct
(* the exception below is added to handle unification failure in merge!! *)
exception Command_execution_fail
(* [in_img node_gid n_match] checks if [node_gid] belongs to the codomain of [n_match] *)
let test_locality matching created_nodes gid =
(Pid_map.exists (fun _ id -> id=gid) matching.n_match) || (List.exists (fun (_,id) -> id=gid) created_nodes)
(* ---------------------------------------------------------------------- *)
(** [apply_command instance matching created_nodes command] returns [(new_instance, new_created_nodes)] *)
let apply_command ?domain (command,loc) instance matching created_nodes =
......@@ -965,7 +969,7 @@ module Rule = struct
| Command.MERGE_NODE (src_cn, tar_cn) ->
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
(match G_graph.merge_node loc ?domain instance.Instance.graph src_gid tar_gid with
(match G_graph.merge_node loc ?domain instance.Instance.graph (test_locality matching created_nodes) src_gid tar_gid with
| Some new_graph ->
(
{instance with
......@@ -1051,7 +1055,7 @@ module Rule = struct
let tar_gid = node_find tar_cn in
(
{instance with
Instance.graph = G_graph.shift_in loc ?domain src_gid tar_gid label_cst instance.Instance.graph;
Instance.graph = G_graph.shift_in loc ?domain src_gid tar_gid (test_locality matching created_nodes) label_cst instance.Instance.graph;
history = List_.sort_insert (Command.H_SHIFT_IN (src_gid,tar_gid)) instance.Instance.history
},
created_nodes
......@@ -1062,7 +1066,7 @@ module Rule = struct
let tar_gid = node_find tar_cn in
(
{instance with
Instance.graph = G_graph.shift_out loc ?domain src_gid tar_gid label_cst instance.Instance.graph;
Instance.graph = G_graph.shift_out loc ?domain src_gid tar_gid (test_locality matching created_nodes) label_cst instance.Instance.graph;
history = List_.sort_insert (Command.H_SHIFT_OUT (src_gid,tar_gid)) instance.Instance.history
},
created_nodes
......@@ -1073,7 +1077,7 @@ module Rule = struct
let tar_gid = node_find tar_cn in
(
{instance with
Instance.graph = G_graph.shift_edges loc ?domain src_gid tar_gid label_cst instance.Instance.graph;
Instance.graph = G_graph.shift_edges loc ?domain src_gid tar_gid (test_locality matching created_nodes) label_cst instance.Instance.graph;
history = List_.sort_insert (Command.H_SHIFT_EDGE (src_gid,tar_gid)) instance.Instance.history
},
created_nodes
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment