TMP_activate command

src/grew_command.ml

@@ -20,9 +20,10 @@ open Grew_fs
 module Command  = struct
   type command_node =        (* a command node is either: *)
     | Pat of Pid.t           (* a node identified in the pattern *)
-    | New of string          (* a node introduced by a new_neighbour *)
-    | Act of Pid.t * string  (* a node introduced by a activate *)
+    | New of string          (* a node introduced by a new_neighbour *) (* TODO: remove *)
+    | Act of Pid.t * string  (* a node introduced by an activate *)
 
+  (* [item] is a element of the RHS of an update_feat command *)
   type item =
     | Feat of (command_node * string)
     | String of string
@@ -37,29 +38,33 @@ module Command  = struct
     | ADD_EDGE of (command_node * command_node * G_edge.t)
     | DEL_FEAT of (command_node * string)
     | UPDATE_FEAT of (command_node * string * item list)
-    | NEW_NEIGHBOUR of (string * G_edge.t * Pid.t)
+    | NEW_NEIGHBOUR of (string * G_edge.t * Pid.t) (* TODO: remove *)
     | SHIFT_EDGE of (command_node * command_node)
     | SHIFT_IN of (command_node * command_node)
     | SHIFT_OUT of (command_node * command_node)
     | MERGE_NODE of (command_node * command_node)
+    | ACT_NODE of command_node
+
 
   type t = p * Loc.t  (* remember command location to be able to localize a command failure *)
 
   (* a item in the command history: command applied to a graph *)
   type h =
     | H_DEL_NODE of Gid.t
-    | H_DEL_EDGE_EXPL of (Gid.t * Gid.t *G_edge.t)
+    | H_DEL_EDGE_EXPL of (Gid.t * Gid.t * G_edge.t)
     | H_DEL_EDGE_NAME of string
     | H_ADD_EDGE of (Gid.t * Gid.t * G_edge.t)
     | H_DEL_FEAT of (Gid.t * string)
     | H_UPDATE_FEAT of (Gid.t * string * string)
-    | H_NEW_NEIGHBOUR of (string * G_edge.t * Gid.t)
+    | H_NEW_NEIGHBOUR of (string * G_edge.t * Gid.t) (* TODO: remove *)
     | H_SHIFT_EDGE of (Gid.t * Gid.t)
     | H_SHIFT_IN of (Gid.t * Gid.t)
     | H_SHIFT_OUT of (Gid.t * Gid.t)
     | H_MERGE_NODE of (Gid.t * Gid.t)
+    | H_ACT_NODE of (Gid.t * string)
 
   let build ?param (kai, kei) table locals ast_command =
+    (* kai stands for "known act ident", kei for "known edge ident" *)
 
     let pid_of_act_id loc = function
         | (node_name, Some n) -> Act (Pid.Pos (Id.build ~loc node_name table), n)
@@ -68,58 +73,61 @@ module Command  = struct
             Pat (Pid.Pos (Id.build ~loc node_name table))
           with _ -> New node_name in
 
+    (* check that an act_id is well-defined earlier *)
     let check_act_id loc act_id kai =
       if not (List.mem act_id kai)
       then Error.build ~loc "Unbound node identifier \"%s\"" (Ast.act_id_to_string act_id) in
 
+    (* check that the edge_id is defined in the pattern *)
     let check_edge loc edge_id kei =
       if not (List.mem edge_id kei)
       then Error.build ~loc "Unbound edge identifier \"%s\"" edge_id in
 
     match ast_command with
       | (Ast.Del_edge_expl (act_i, act_j, lab), loc) ->
-        check_act_id loc act_i kai;
-        check_act_id loc act_j kai;
-	let edge = G_edge.make ~loc ~locals lab in
-	((DEL_EDGE_EXPL (pid_of_act_id loc act_i, pid_of_act_id loc act_j, edge), loc), (kai, kei))
+          check_act_id loc act_i kai;
+          check_act_id loc act_j kai;
+	        let edge = G_edge.make ~loc ~locals lab in
+	        ((DEL_EDGE_EXPL (pid_of_act_id loc act_i, pid_of_act_id loc act_j, edge), loc), (kai, kei))
 
       | (Ast.Del_edge_name id, loc) ->
-        check_edge loc id kei;
-        (DEL_EDGE_NAME id, loc), (kai, List_.rm id kei)
+          check_edge loc id kei;
+          (DEL_EDGE_NAME id, loc), (kai, List_.rm id kei)
 
       | (Ast.Add_edge (act_i, act_j, lab), loc) ->
-        check_act_id loc act_i kai;
-        check_act_id loc act_j kai;
-	let edge = G_edge.make ~loc ~locals lab in
-	((ADD_EDGE (pid_of_act_id loc act_i, pid_of_act_id loc act_j, edge), loc), (kai, kei))
+          check_act_id loc act_i kai;
+          check_act_id loc act_j kai;
+	        let edge = G_edge.make ~loc ~locals lab in
+        	((ADD_EDGE (pid_of_act_id loc act_i, pid_of_act_id loc act_j, edge), loc), (kai, kei))
 
       | (Ast.Shift_edge (act_i, act_j), loc) ->
-        check_act_id loc act_i kai;
-        check_act_id loc act_j kai;
-	((SHIFT_EDGE (pid_of_act_id loc act_i, pid_of_act_id loc act_j), loc), (kai, kei))
+          check_act_id loc act_i kai;
+          check_act_id loc act_j kai;
+	        ((SHIFT_EDGE (pid_of_act_id loc act_i, pid_of_act_id loc act_j), loc), (kai, kei))
 
       | (Ast.Shift_in (act_i, act_j), loc) ->
-        check_act_id loc act_i kai;
-        check_act_id loc act_j kai;
-	((SHIFT_IN (pid_of_act_id loc act_i, pid_of_act_id loc act_j), loc), (kai, kei))
+          check_act_id loc act_i kai;
+          check_act_id loc act_j kai;
+	        ((SHIFT_IN (pid_of_act_id loc act_i, pid_of_act_id loc act_j), loc), (kai, kei))
 
       | (Ast.Shift_out (act_i, act_j), loc) ->
-        check_act_id loc act_i kai;
-        check_act_id loc act_j kai;
-	((SHIFT_OUT (pid_of_act_id loc act_i, pid_of_act_id loc act_j), loc), (kai, kei))
+          check_act_id loc act_i kai;
+          check_act_id loc act_j kai;
+	        ((SHIFT_OUT (pid_of_act_id loc act_i, pid_of_act_id loc act_j), loc), (kai, kei))
 
       | (Ast.Merge_node (act_i, act_j), loc) ->
-        check_act_id loc act_i kai;
-        check_act_id loc act_j kai;
-	((MERGE_NODE (pid_of_act_id loc act_i, pid_of_act_id loc act_j), loc), (List_.rm act_i kai, kei))
+          check_act_id loc act_i kai;
+          check_act_id loc act_j kai;
+	        ((MERGE_NODE (pid_of_act_id loc act_i, pid_of_act_id loc act_j), loc), (List_.rm act_i kai, kei))
 
       | (Ast.New_neighbour (new_id, ancestor, label), loc) ->
-        check_act_id loc ancestor kai;
-        if List.mem (new_id, None) kai
-        then Error.build ~loc "Node identifier \"%s\" is already used" new_id;
-	let edge = G_edge.make ~loc ~locals label in
-	begin
-	  try
+          check_act_id loc ancestor kai;
+          if List.mem (new_id, None) kai
+          then Error.build ~loc "Node identifier \"%s\" is already used" new_id;
+
+          let edge = G_edge.make ~loc ~locals label in
+	        begin
+	          try
             (
               (NEW_NEIGHBOUR
                  (new_id,
@@ -128,43 +136,48 @@ module Command  = struct
                  ), loc),
               ((new_id, None)::kai, kei)
             )
-	  with Not_found ->
-	    Log.fcritical "[GRS] tries to build a command New_neighbour (%s) on node %s which is not in the pattern %s"
-	      (G_edge.to_string edge)
-	      (fst ancestor)
-	      (Loc.to_string loc)
-	end
+	          with not_found ->
+	            Log.fcritical "[GRS] tries to build a command New_neighbour (%s) on node %s which is not in the pattern %s"
+	             (G_edge.to_string edge)
+	             (fst ancestor)
+	             (Loc.to_string loc)
+	        end
+
+      | (Ast.Activate (_,None), loc) ->
+          Error.build ~loc "Cannot activate a pattern node"
 
-      | (Ast.Activate n, loc) -> failwith "Not implemented"
+      | (Ast.Activate act_n, loc) ->
+          (* TODO: add a check on source node *)
+          ((ACT_NODE (pid_of_act_id loc act_n), loc), (act_n :: kai, kei))
 
       | (Ast.Del_node act_n, loc) ->
-        check_act_id loc act_n kai;
-        ((DEL_NODE (pid_of_act_id loc act_n), loc), (List_.rm act_n kai, kei))
+          check_act_id loc act_n kai;
+          ((DEL_NODE (pid_of_act_id loc act_n), loc), (List_.rm act_n kai, kei))
 
       | (Ast.Del_feat (act_id, feat_name), loc) ->
-        if feat_name = "position"
-        then Error.build ~loc "Illegal del_feat command: the 'position' feature cannot be deleted";
-        check_act_id loc act_id kai;
-        ((DEL_FEAT (pid_of_act_id loc act_id, feat_name), loc), (kai, kei))
+          if feat_name = "position"
+          then Error.build ~loc "Illegal del_feat command: the 'position' feature cannot be deleted";
+          check_act_id loc act_id kai;
+          ((DEL_FEAT (pid_of_act_id loc act_id, feat_name), loc), (kai, kei))
 
       | (Ast.Update_feat ((act_id, feat_name), ast_items), loc) ->
-        check_act_id loc act_id kai;
-        let items = List.map
-          (function
-            (* special case of a basic identifier understood as a string *)
-            | Ast.Qfn_item ci when Ast.is_simple ci -> String (Ast.complex_id_to_string ci)
-            | Ast.Qfn_item ci ->
-              let (act_id,feature_name) = Ast.act_qfn_of_ci ci in
-              check_act_id loc act_id kai; Feat (pid_of_act_id loc act_id, feature_name)
-            | Ast.String_item s -> String s
-            | Ast.Param_item var ->
-              match param with
-                | None -> Error.build "Unknown command variable '%s'" var
-                | Some (par,cmd) ->
-                  match (List_.pos var par, List_.pos var cmd) with
-                    | (_,Some index) -> Param_out index
-                    | (Some index,_) -> Param_in index
-                    | _ -> Error.build "Unknown command variable '%s'" var
-          ) ast_items in
-        ((UPDATE_FEAT (pid_of_act_id loc act_id, feat_name, items), loc), (kai, kei))
+          check_act_id loc act_id kai;
+          let items = List.map
+            (function
+              (* special case of a basic identifier understood as a string *)
+              | Ast.Qfn_item ci when Ast.is_simple ci -> String (Ast.complex_id_to_string ci)
+              | Ast.Qfn_item ci ->
+                let (act_id,feature_name) = Ast.act_qfn_of_ci ci in
+                check_act_id loc act_id kai; Feat (pid_of_act_id loc act_id, feature_name)
+              | Ast.String_item s -> String s
+              | Ast.Param_item var ->
+                match param with
+                  | None -> Error.build "Unknown command variable '%s'" var
+                  | Some (par,cmd) ->
+                    match (List_.pos var par, List_.pos var cmd) with
+                      | (_,Some index) -> Param_out index
+                      | (Some index,_) -> Param_in index
+                      | _ -> Error.build "Unknown command variable '%s'" var
+            ) ast_items in
+          ((UPDATE_FEAT (pid_of_act_id loc act_id, feat_name, items), loc), (kai, kei))
 end (* module Command *)

src/grew_command.mli

@@ -15,8 +15,8 @@ open Grew_edge
 (* ==================================================================================================== *)
 module Command : sig
   type command_node =       (* a command node is either: *)
-    | Pat of Pid.t     (* a node identified in the pattern *)
-    | New of string  (* a node introduced by a new_neighbour *)
+    | Pat of Pid.t          (* a node identified in the pattern *)
+    | New of string         (* a node introduced by a new_neighbour *)
     | Act of Pid.t * string (* a node introduced by a activate *)
 
   type item =
@@ -37,8 +37,9 @@ module Command : sig
     | SHIFT_IN of (command_node * command_node)
     | SHIFT_OUT of (command_node * command_node)
     | MERGE_NODE of (command_node * command_node)
+    | ACT_NODE of command_node
+
 
-	
   type t = (p * Loc.t)
   type h =
     | H_DEL_NODE of Gid.t
@@ -52,6 +53,7 @@ module Command : sig
     | H_SHIFT_IN of (Gid.t * Gid.t)
     | H_SHIFT_OUT of (Gid.t * Gid.t)
     | H_MERGE_NODE of (Gid.t * Gid.t)
+    | H_ACT_NODE of (Gid.t * string)
 
   val build:
       ?param: (string list * string list) ->

src/grew_graph.ml

@@ -449,6 +449,19 @@ module G_graph = struct
           ) graph.map Gid_map.empty
     }
 
+  (* -------------------------------------------------------------------------------- *)
+  let activate loc node_id new_name graph =
+    let index = match node_id with
+      | Gid.Old id -> Gid.Act (id, new_name)
+      | _ -> Error.run ~loc "[Graph.activate] is possible only from a \"ground\" node" in
+
+    if Gid_map.mem index graph.map
+    then Error.run ~loc "[Graph.activate] try to activate twice the \"same\" node (with new_name '%s')" new_name;
+
+    let node = Gid_map.find node_id graph.map in
+    let new_map = Gid_map.add index (G_node.build_new node) graph.map in
+    (index, {graph with map = new_map})
+
   (* -------------------------------------------------------------------------------- *)
   let add_neighbour loc graph node_id label =
     let index = match node_id with

src/grew_graph.mli

@@ -50,7 +50,7 @@ module P_graph: sig
 
   type extension = {
       ext_map: P_node.t Pid_map.t; (* node description for new nodes and for edge "Old -> New"  *)
-      old_map: P_node.t Pid_map.t; (* a partial map for new constraints on old nodes "Old [...]" *) 	
+      old_map: P_node.t Pid_map.t; (* a partial map for new constraints on old nodes "Old [...]" *)
     }
 
   (* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
@@ -137,6 +137,7 @@ module G_graph: sig
   val del_node: t -> Gid.t -> t
 
   val add_neighbour: Loc.t -> t -> Gid.t -> G_edge.t -> (Gid.t * t)
+  val activate: Loc.t -> Gid.t -> string -> t -> (Gid.t * t)
 
   val merge_node: Loc.t -> t -> Gid.t -> Gid.t -> t option
 

src/grew_node.ml

@@ -82,6 +82,8 @@ module G_node = struct
 
   let build_neighbour t = { empty with position = (get_position t) +. 0.01 }
 
+  let build_new t = { empty with position = (get_position t) +. 0.01 }
+
   let position_comp n1 n2 = Pervasives.compare n1.position n2.position
 
   let rename mapping n = {n with next = Massoc_gid.rename mapping n.next}

src/grew_node.mli

@@ -53,6 +53,7 @@ module G_node: sig
   val get_annot_info: t -> string option
 
   val build_neighbour: t -> t
+  val build_new: t -> t
 
   val rename: (Gid.t * Gid.t) list -> t -> t
 end

src/grew_rule.ml

@@ -352,7 +352,7 @@ module Rule = struct
       G_deco.edges = List.fold_left (fun acc (_,edge) -> edge::acc) matching.a_match matching.e_match;
     }
 
-  let find cnode ?loc (matching, created_nodes) =
+  let find cnode ?loc (matching, (created_nodes,activated_nodes)) =
     match cnode with
     | Command.Pat pid ->
         (try Pid_map.find pid matching.n_match
@@ -360,7 +360,10 @@ module Rule = struct
     | Command.New name ->
         (try List.assoc name created_nodes
         with Not_found -> Error.run ?loc "Identifier '%s' not found" name)
-    | Command.Act _ -> Log.critical "TODO: not yet implemented"
+    | Command.Act (pid, new_name) ->
+        (try List.assoc (pid, new_name) activated_nodes
+        with Not_found -> Error.run ?loc "Activated identifier with suffix '%s' not found" new_name)
+
 
 
   let down_deco (matching,created_nodes) commands =
@@ -566,8 +569,8 @@ module Rule = struct
   exception Command_execution_fail
 
 (** [apply_command instance matching created_nodes command] returns [(new_instance, new_created_nodes)] *)
-  let apply_command (command,loc) instance matching created_nodes =
-    let node_find cnode = find ~loc cnode (matching, created_nodes) in
+  let apply_command (command,loc) instance matching (created_nodes, (activated_nodes:((Pid.t * string) * Gid.t) list)) =
+    let node_find cnode = find ~loc cnode (matching, (created_nodes, activated_nodes)) in
 
     match command with
     | Command.ADD_EDGE (src_cn,tar_cn,edge) ->
@@ -581,7 +584,7 @@ module Rule = struct
                 Instance.graph = new_graph;
                 history = List_.sort_insert (Command.H_ADD_EDGE (src_gid,tar_gid,edge)) instance.Instance.history
               },
-               created_nodes
+               (created_nodes, activated_nodes)
               )
           | None ->
               Error.run "ADD_EDGE: the edge '%s' already exists %s" (G_edge.to_string edge) (Loc.to_string loc)
@@ -595,7 +598,7 @@ module Rule = struct
           Instance.graph = G_graph.del_edge loc instance.Instance.graph src_gid edge tar_gid;
            history = List_.sort_insert (Command.H_DEL_EDGE_EXPL (src_gid,tar_gid,edge)) instance.Instance.history
         },
-         created_nodes
+         (created_nodes, activated_nodes)
         )
 
     | Command.DEL_EDGE_NAME edge_ident ->
@@ -607,7 +610,7 @@ module Rule = struct
           Instance.graph = G_graph.del_edge ~edge_ident loc instance.Instance.graph src_gid edge tar_gid;
           history = List_.sort_insert (Command.H_DEL_EDGE_EXPL (src_gid,tar_gid,edge)) instance.Instance.history
         },
-         created_nodes
+         (created_nodes, activated_nodes)
         )
 
     | Command.DEL_NODE node_cn ->
@@ -617,7 +620,7 @@ module Rule = struct
           Instance.graph = G_graph.del_node instance.Instance.graph node_gid;
           history = List_.sort_insert (Command.H_DEL_NODE node_gid) instance.Instance.history
         },
-         created_nodes
+         (created_nodes, activated_nodes)
         )
 
     | Command.MERGE_NODE (src_cn, tar_cn) ->
@@ -630,7 +633,7 @@ module Rule = struct
               Instance.graph = new_graph;
               history = List_.sort_insert (Command.H_MERGE_NODE (src_gid,tar_gid)) instance.Instance.history
             },
-             created_nodes
+             (created_nodes, activated_nodes)
             )
         | None -> raise Command_execution_fail
         )
@@ -658,7 +661,7 @@ module Rule = struct
           Instance.graph = new_graph;
           history = List_.sort_insert (Command.H_UPDATE_FEAT (tar_gid,tar_feat_name,new_feature_value)) instance.Instance.history
         },
-         created_nodes
+         (created_nodes, activated_nodes)
         )
 
     | Command.DEL_FEAT (tar_cn,feat_name) ->
@@ -668,7 +671,7 @@ module Rule = struct
           Instance.graph = G_graph.del_feat instance.Instance.graph tar_gid feat_name;
           history = List_.sort_insert (Command.H_DEL_FEAT (tar_gid,feat_name)) instance.Instance.history
         },
-         created_nodes
+         (created_nodes, activated_nodes)
         )
 
     | Command.NEW_NEIGHBOUR (created_name,edge,base_pid) ->
@@ -680,7 +683,18 @@ module Rule = struct
           history = List_.sort_insert (Command.H_NEW_NEIGHBOUR (created_name,edge,new_gid)) instance.Instance.history;
           activated_node = new_gid :: instance.Instance.activated_node;
         },
-         (created_name,new_gid) :: created_nodes
+         ((created_name,new_gid) :: created_nodes, activated_nodes)
+        )
+
+    | Command.ACT_NODE (Command.Act (pid, new_name)) ->
+        let node_gid = node_find (Command.Pat(pid)) in
+        let (new_gid, new_graph) = G_graph.activate loc node_gid new_name instance.Instance.graph in
+        (
+         {instance with
+          Instance.graph = new_graph;
+          history = List_.sort_insert (Command.H_ACT_NODE (node_gid,new_name)) instance.Instance.history
+        },
+         (created_nodes, ((pid, new_name), new_gid) :: activated_nodes)
         )
 
     | Command.SHIFT_IN (src_cn,tar_cn) ->
@@ -691,7 +705,7 @@ module Rule = struct
           Instance.graph = G_graph.shift_in loc instance.Instance.graph src_gid tar_gid;
           history = List_.sort_insert (Command.H_SHIFT_IN (src_gid,tar_gid)) instance.Instance.history
         },
-         created_nodes
+         (created_nodes, activated_nodes)
         )
 
     | Command.SHIFT_OUT (src_cn,tar_cn) ->
@@ -702,7 +716,7 @@ module Rule = struct
           Instance.graph = G_graph.shift_out loc instance.Instance.graph src_gid tar_gid;
           history = List_.sort_insert (Command.H_SHIFT_OUT (src_gid,tar_gid)) instance.Instance.history
         },
-         created_nodes
+         (created_nodes, activated_nodes)
         )
 
     | Command.SHIFT_EDGE (src_cn,tar_cn) ->
@@ -713,7 +727,7 @@ module Rule = struct
             Instance.graph = G_graph.shift_edges loc instance.Instance.graph src_gid tar_gid;
             history = List_.sort_insert (Command.H_SHIFT_EDGE (src_gid,tar_gid)) instance.Instance.history
           },
-          created_nodes
+          (created_nodes, activated_nodes)
         )
 
 (** [apply_rule instance matching rule] returns a new instance after the application of the rule
@@ -735,7 +749,7 @@ module Rule = struct
         (fun (instance, created_nodes) command ->
           apply_command command instance matching created_nodes
         )
-        (instance, [])
+        (instance, ([],[]))
         rule.commands in
 
     let rule_app = {

src/libgrew_utils.ml

@@ -169,17 +169,27 @@ module Gid = struct
   type t =
     | Old of int
     | New of (int * int) (* identifier for "created nodes" *)
+    | Act of (int * string)  (* identifier for "activated nodes" *)
 
   (* a compare function which ensures that new nodes are at the "end" of the graph *)
   let compare t1 t2 = match (t1,t2) with
+    | Old o1, Old o2 -> Pervasives.compare o1 o2
+
     | Old _ , New _ -> -1
     | New _, Old _ -> 1
-    | Old o1, Old o2 -> Pervasives.compare o1 o2
     | New n1, New n2 -> Pervasives.compare n1 n2
 
+    | Old _ , Act _ -> -1
+    | Act _, Old _ -> 1
+    | Act n1, Act n2 -> Pervasives.compare n1 n2
+
+    | Act _ , New _ -> -1
+    | New _, Act _ -> 1
+
   let to_string = function
     | Old i -> sprintf "%d" i
     | New (i,j) -> sprintf"%d__%d" i j
+    | Act (i,n) -> sprintf"%d#%s" i n
 end (* module Gid *)
 
 (* ================================================================================ *)

src/libgrew_utils.mli

@@ -83,6 +83,7 @@ module Gid : sig
   type t =
     | Old of int
     | New of (int * int) (* identifier for "created nodes" *)
+    | Act of (int * string)  (* identifier for "activated nodes" *)
 
   val compare: t -> t -> int
 

src/parser/lexer.mll

@@ -22,6 +22,7 @@
   (* a general notion of "ident" is needed to cover all usages:
      with or without '#', with several '.' (separator for feature names and usual symbol for labels...) *)
   let parse_complex_ident string =
+    printf "--parse_complex_ident-->%s<--\n%!" string;
     match Str.split (Str.regexp "#") string with
       | [x] -> Ast.No_sharp x
       | [x;y] -> Ast.Sharp (x,y)
@@ -118,6 +119,7 @@ and global = parse
 | "del_node"    { DEL_NODE }
 | "add_node"    { ADD_NODE }
 | "del_feat"    { DEL_FEAT }
+| "activate"    { ACTIVATE }
 
 | "module"      { MODULE }
 | "confluent"   { CONFLUENT }