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

src/grew_graph.ml

@@ -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

src/grew_graph.mli

@@ -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].

src/grew_rule.ml

@@ -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