activate mechanism to create new nodes

emacs/grew.el

@@ -3,10 +3,10 @@
 ;; Mode used to write Grew with emacs (highlight)
 ;; see: https://wikilligramme.loria.fr/doku.php?id=grew:grew
 
-(require 'generic-x) ;;pour Emacs OK, mais semble ne pas marcher avec XEmacs 
+(require 'generic-x) ;;pour Emacs OK, mais semble ne pas marcher avec XEmacs
 (define-generic-mode 'grew-mode
   '("%");;comments
-  '("features" "module" "rule" "lex_rule" "match" "without" "labels" "sequences" "commands" "graph" "confluent" "include" "filter");;keywords
+  '("features" "module" "rule" "lex_rule" "match" "without" "labels" "sequences" "commands" "graph" "confluent" "include" "filter" "suffixes");;keywords
   '(
 ;;    ("class\\s (\*\*)* +\\(\\sw[a-zA-Z0-9_.-]*\\)" 1 'font-lock-type-face);noms de classes
 ;;    ("\?[a-zA-Z0-9]+" . font-lock-variable-name-face)

src/grew_ast.ml

@@ -10,7 +10,6 @@
 
 open Printf
 open Log
-
 open Libgrew_utils
 
 module Ast = struct
@@ -22,6 +21,7 @@ module Ast = struct
   type feature_name = string (* cat, num, ... *)
   type feature_atom = string (* V, N, inf, ... *)
   type feature_value = string (* V, 4, "free text", ... *)
+  type suffix = string
 
   (* -------------------------------------------------------------------------------- *)
   (* complex_id: V, V#alpha, V.cat, V#alpha.cat, p_obj.loc *)
@@ -217,7 +217,7 @@ module Ast = struct
   type modul = {
     module_id:Id.name;
     local_labels: (string * string list) list;
-    new_node_names: string list;
+    suffixes: string list;
     rules: rule list;
     confluent: bool;
     module_doc:string list;

src/grew_ast.mli

@@ -9,11 +9,12 @@
 (**********************************************************************************)
 
 open Libgrew_utils
- 
+
 module Ast : sig
   type feature_name = string (* cat, num, ... *)
   type feature_atom = string (* V, N, inf, ... *)
   type feature_value = string (* V, 4, "free text", ... *)
+  type suffix = string
 
   (* -------------------------------------------------------------------------------- *)
   (* complex_id: V, V#alpha, V.cat, V#alpha.cat, p_obj.loc *)
@@ -46,7 +47,7 @@ module Ast : sig
   val act_qfn_of_ci: complex_id -> act_qfn
 
 
-  type feature_spec = 
+  type feature_spec =
     | Closed of feature_name * feature_atom list (* cat:V,N *)
     | Open of feature_name (* phon, lemma, ... *)
     | Int of feature_name (* position *)
@@ -54,7 +55,7 @@ module Ast : sig
   type domain = feature_spec list
   val normalize_domain: domain -> domain
 
-  type feature_kind = 
+  type feature_kind =
     | Equality of feature_value list
     | Disequality of feature_value list
     | Param of string (* $ident *)
@@ -88,7 +89,7 @@ module Ast : sig
   type ineq = Lt | Gt | Le | Ge
   val string_of_ineq: ineq -> string
 
-  type u_const = 
+  type u_const =
     | Start of Id.name * edge_label list (* (source, labels) *)
     | Cst_out of Id.name
     | End of Id.name * edge_label list (* (target, labels) *)
@@ -109,7 +110,7 @@ module Ast : sig
     | String_item of string
     | Param_item of string
 
-  type u_command = 
+  type u_command =
     | Del_edge_expl of (act_id * act_id * edge_label)
     | Del_edge_name of string
     | Add_edge of (act_id * act_id * edge_label)
@@ -135,36 +136,36 @@ module Ast : sig
       rule_doc:string list;
       rule_loc: Loc.t;
     }
-        
+
   type modul = {
       module_id:Id.name;
       local_labels: (string * string list) list;
-      new_node_names: string list;
+      suffixes: string list;
       rules: rule list;
       confluent: bool;
       module_doc:string list;
       mod_loc:Loc.t;
       mod_dir: string; (* the directory where the module is defined (for lp file localisation) *)
     }
-        
+
   type sequence = {
       seq_name:string;
       seq_mod:string list;
       seq_doc:string list;
       seq_loc:Loc.t;
     }
-        
-(** 
-    a GRS: graph rewriting system 
+
+(**
+    a GRS: graph rewriting system
  *)
-  type module_or_include = 
+  type module_or_include =
     | Modul of modul
     | Includ of (string * Loc.t)
 
   type grs_with_include = {
       domain_wi: domain;
       labels_wi: (string * string list) list;    (* the list of global edge labels *)
-      modules_wi: module_or_include list; 
+      modules_wi: module_or_include list;
       sequences_wi: sequence list;
     }
 

src/grew_command.ml

@@ -63,7 +63,7 @@ module Command  = struct
     | H_MERGE_NODE of (Gid.t * Gid.t)
     | H_ACT_NODE of (Gid.t * string)
 
-  let build ?param (kai, kei) table locals ast_command =
+  let build ?param (kai, kei) table locals suffixes ast_command =
     (* kai stands for "known act ident", kei for "known edge ident" *)
 
     let pid_of_act_id loc = function
@@ -143,12 +143,15 @@ module Command  = struct
 	             (Loc.to_string loc)
 	        end
 
-      | (Ast.Activate (_,None), loc) ->
-          Error.build ~loc "Cannot activate a pattern node"
-
       | (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))
+        begin
+          match act_n with
+          | (_,None) -> Error.build ~loc "Cannot activate a pattern node"
+          | (src, Some suffix) ->
+            check_act_id loc (src,None) kai;
+            if not (List.mem suffix suffixes) then Error.build ~loc "Undefined suffix \"%s\"" suffix;
+            ((ACT_NODE (pid_of_act_id loc act_n), loc), (act_n :: kai, kei))
+        end
 
       | (Ast.Del_node act_n, loc) ->
           check_act_id loc act_n kai;

src/grew_command.mli

@@ -60,6 +60,7 @@ module Command : sig
       (Ast.act_id list * string list) ->
       Id.table ->
       Label.decl array ->
+      Ast.suffix list ->
       Ast.command ->
         t * (Ast.act_id list * string list)
 end (* module Command *)

src/grew_graph.ml

@@ -229,6 +229,30 @@ module G_graph = struct
     map: G_node.t Gid_map.t; (* node description *)
   }
 
+  (* -------------------------------------------------------------------------------- *)
+  let rename mapping graph =
+    {graph with map =
+        Gid_map.fold
+          (fun id node acc ->
+            let new_id = try List.assoc id mapping with Not_found -> id in
+            let new_node = G_node.rename mapping node in
+            Gid_map.add new_id new_node acc
+          ) graph.map Gid_map.empty
+    }
+
+  (* -------------------------------------------------------------------------------- *)
+  (* [normalize g] changes all graphs keys to Old _ (used when entering a new module) *)
+  let normalize t =
+    let (_, mapping) =
+      Gid_map.fold
+        (fun key value (max_binding, mapping) ->
+          match key with
+          | Gid.Old n -> (n, mapping)
+          | Gid.New _ -> (max_binding, mapping)
+          | Gid.Act (n,suffix) -> (max_binding+1, (key, (Gid.Old (max_binding+1)))::mapping)
+        ) t.map (0, []) in
+        rename mapping t
+
   let empty = {meta=[]; map=Gid_map.empty}
 
   let find node_id graph = Gid_map.find node_id graph.map
@@ -416,17 +440,6 @@ module G_graph = struct
   (* Update functions *)
   (* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
 
-  (* -------------------------------------------------------------------------------- *)
-  let rename mapping graph =
-    {graph with map =
-        Gid_map.fold
-          (fun id node acc ->
-            let new_id = try List.assoc id mapping with Not_found -> id in
-            let new_node = G_node.rename mapping node in
-            Gid_map.add new_id new_node acc
-          ) graph.map Gid_map.empty
-    }
-
   (* -------------------------------------------------------------------------------- *)
   let del_edge ?edge_ident loc graph id_src label id_tar =
     let node_src =
@@ -450,13 +463,13 @@ module G_graph = struct
     }
 
   (* -------------------------------------------------------------------------------- *)
-  let activate loc node_id new_name graph =
+  let activate loc node_id suffix graph =
     let index = match node_id with
-      | Gid.Old id -> Gid.Act (id, new_name)
+      | Gid.Old id -> Gid.Act (id, suffix)
       | _ -> 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;
+    then Error.run ~loc "[Graph.activate] try to activate twice the \"same\" node (with suffix '%s')" suffix;
 
     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
@@ -470,7 +483,7 @@ module G_graph = struct
           | Some label_int -> Gid.New (id, label_int)
           | None -> Error.run ~loc "[Graph.add_neighbour] try to add neighbour with a local label"
         )
-      | Gid.New _ -> Error.run ~loc "[Graph.add_neighbour] try to add neighbour node to a neighbour node" in
+      | Gid.New _ | Gid.Act _ -> Error.run ~loc "[Graph.add_neighbour] try to add neighbour node to a neighbour node" in
 
     if Gid_map.mem index graph.map
     then Error.run ~loc "[Graph.add_neighbour] try to build twice the \"same\" neighbour node (with label '%s')" (Label.to_string label);

src/grew_graph.mli

@@ -95,6 +95,8 @@ module G_graph: sig
 
   val fold_gid: (Gid.t -> 'a -> 'a) -> t -> 'a -> 'a
 
+  val normalize: t -> t
+
   (** raise ??? *)
   val max_binding: t -> int
 

src/grew_grs.ml

@@ -136,6 +136,7 @@ module Modul = struct
   type t = {
     name: string;
     local_labels: (string * string list) array;
+    suffixes: string list;
     rules: Rule.t list;
     filters: Rule.t list;
     confluent: bool;
@@ -154,14 +155,16 @@ module Modul = struct
   let build ast_module =
     let locals = Array.of_list ast_module.Ast.local_labels in
     Array.sort compare locals;
-    let rules_or_filters = List.map (Rule.build ~locals ast_module.Ast.mod_dir) ast_module.Ast.rules in
+    let suffixes = ast_module.Ast.suffixes in
+    let rules_or_filters = List.map (Rule.build ~locals suffixes ast_module.Ast.mod_dir) ast_module.Ast.rules in
     let (filters, rules) = List.partition Rule.is_filter rules_or_filters in
     let modul =
       {
         name = ast_module.Ast.module_id;
         local_labels = locals;
-        rules = rules;
-        filters = filters;
+        suffixes;
+        rules;
+        filters;
         confluent = ast_module.Ast.confluent;
         loc = ast_module.Ast.mod_loc;
       } in
@@ -260,7 +263,9 @@ module Grs = struct
     Timeout.start ();
     let modules_to_apply = modules_of_sequence grs sequence in
 
-    let rec loop instance = function
+    let rec loop instance module_list =
+      let instance = {instance with Instance.graph = G_graph.normalize instance.Instance.graph} in
+      match module_list with
       | [] -> (* no more modules to apply *)
         {Rewrite_history.instance = instance; module_name = ""; good_nf = []; bad_nf = []; }
       | next::tail ->
@@ -284,7 +289,9 @@ module Grs = struct
   let build_rew_display grs sequence instance =
     let modules_to_apply = modules_of_sequence grs sequence in
 
-    let rec loop instance = function
+    let rec loop instance module_list =
+      let instance = {instance with Instance.graph = G_graph.normalize instance.Instance.graph} in
+      match module_list with
       | [] -> Grew_types.Leaf instance.Instance.graph
       | next :: tail ->
         let (good_set, bad_set) =

src/grew_grs.mli

@@ -13,10 +13,11 @@ open Grew_graph
 open Grew_rule
 open Grew_ast
 
+(* ==================================================================================================== *)
 module Rewrite_history: sig
   type t = {
       instance: Instance.t;
-      module_name: string; 
+      module_name: string;
       good_nf: t list;
       bad_nf: Instance.t list;
     }
@@ -24,17 +25,17 @@ module Rewrite_history: sig
   val is_empty: t -> bool
 
   val num_sol: t -> int
-    
+
   (** [save_nfs ?main_feat base_name t] does two things:
       - write PNG files of normal forms
       - returns a list of couples (rules, file)
   *)
   val save_nfs:
-    ?filter: string list -> 
-    ?main_feat: string -> 
+    ?filter: string list ->
+    ?main_feat: string ->
     dot: bool ->
-    string -> 
-    t -> 
+    string ->
+    t ->
     ((string * string list) list * string) list
 
   (** [save_annot out_dir base_name t] writes a set of svg_file for an annotation folder. *)
@@ -55,10 +56,12 @@ module Rewrite_history: sig
   val conll_dep_string: ?keep_empty_rh:bool -> t -> string option
 end
 
+(* ==================================================================================================== *)
 module Modul: sig
   type t = {
     name: string;
     local_labels: (string * string list) array;
+    suffixes: string list;
     rules: Rule.t list;
     filters: Rule.t list;
     confluent: bool;
@@ -66,13 +69,12 @@ module Modul: sig
   }
 end
 
-
-
+(* ==================================================================================================== *)
 module Grs: sig
   type t
 
   val empty:t
-  
+
   val get_modules: t -> Modul.t list
 
   val get_ast: t -> Ast.grs

src/grew_rule.ml

@@ -259,7 +259,7 @@ module Rule = struct
     Buffer.contents buff
 
   (* ====================================================================== *)
-  let build_commands ?param ?(locals=[||]) pos pos_table ast_commands =
+  let build_commands ?param ?(locals=[||]) suffixes pos pos_table ast_commands =
     let known_act_ids = List.map (fun x -> (x,None)) (Array.to_list pos_table) in
     let known_edge_ids = get_edge_ids pos in
 
@@ -272,6 +272,7 @@ module Rule = struct
               (kai,kei)
               pos_table
               locals
+              suffixes
               ast_command in
           command :: (loop (new_kai,new_kei) tail) in
     loop (known_act_ids, known_edge_ids) ast_commands
@@ -290,7 +291,7 @@ module Rule = struct
     parse_pat_vars vars
 
   (* ====================================================================== *)
-  let build ?(locals=[||]) dir rule_ast =
+  let build ?(locals=[||]) suffixes dir rule_ast =
 
     let (param, pat_vars, cmd_vars) =
       match rule_ast.Ast.param with
@@ -317,7 +318,7 @@ module Rule = struct
       name = rule_ast.Ast.rule_id;
       pos = pos;
       neg = List.map (fun pattern_ast -> build_neg_pattern ~locals pos_table pattern_ast) rule_ast.Ast.neg_patterns;
-      commands = build_commands ~param:(pat_vars,cmd_vars) ~locals pos pos_table rule_ast.Ast.commands;
+      commands = build_commands ~param:(pat_vars,cmd_vars) ~locals suffixes pos pos_table rule_ast.Ast.commands;
       loc = rule_ast.Ast.rule_loc;
       param = param;
       param_names = (pat_vars,cmd_vars)
@@ -696,6 +697,7 @@ module Rule = struct
         },
          (created_nodes, ((pid, new_name), new_gid) :: activated_nodes)
         )
+    | Command.ACT_NODE _ -> Error.bug "Try to activate a node without suffix" (Loc.to_string loc)
 
     | Command.SHIFT_IN (src_cn,tar_cn) ->
         let src_gid = node_find src_cn in

src/grew_rule.mli

@@ -74,7 +74,7 @@ module Rule : sig
 
   (** [build ?local dir ast_rule] returns the Rule.t value corresponding to [ast_rule].
       [dir] is used for localisation of lp files *)
-  val build: ?locals:Label.decl array -> string -> Ast.rule -> t
+  val build: ?locals:Label.decl array -> string list -> string -> Ast.rule -> t
 
   (** [normalize module_name ?confluent rule_list filter_list instance] returns two sets of good normal forms and bad normal forms *)
   (* raise Stop if some command fails to apply *)

src/libgrew_utils.ml

@@ -522,7 +522,7 @@ module Massoc_make (Ord: OrderedType) = struct
       | [one] when one=value -> M.remove key t
       | old -> M.add key (List_.usort_remove value old) t
 
-  let rec remove_key key t = M.remove key t
+  let remove_key key t = M.remove key t
 
   let rec mem key value t =
     try List_.sort_mem value (M.find key t)

src/parser/gr_grs_parser.mly

@@ -62,7 +62,7 @@ let localize t = (t,get_loc ())
 %token FEATURE                     /* feature */
 %token FILE                        /* file */
 %token LABELS                      /* labels */
-%token NEW_NODES                   /* new_nodes */
+%token SUFFIXES                    /* suffixes */
 %token ACTIVATE                    /* activate */
 %token MATCH                       /* match */
 %token WITHOUT                     /* without */
@@ -249,11 +249,11 @@ modules:
         | x=list(grew_module) { x }
 
 grew_module:
-        | doc=option(COMMENT) MODULE conf=boption(CONFLUENT) id_loc=simple_id_with_loc LACC l=option(labels) nn=option(new_nodes) r=rules RACC
+        | doc=option(COMMENT) MODULE conf=boption(CONFLUENT) id_loc=simple_id_with_loc LACC l=option(labels) suff=option(suffixes) r=rules RACC
            {
             { Ast.module_id = fst id_loc;
               local_labels = (match l with None -> [] | Some x -> x);
-              new_node_names = (match nn with None -> [] | Some x -> x);
+              suffixes = (match suff with None -> [] | Some x -> x);
               rules = r;
               confluent = conf;
               module_doc = (match doc with Some d -> d | None -> []);
@@ -262,9 +262,9 @@ grew_module:
             }
           }
 
-new_nodes:
-        (* "new_nodes {a, b, c}" *)
-        | NEW_NODES x=delimited(LACC,separated_nonempty_list_final_opt(COMA,COMPLEX_ID),RACC)
+suffixes:
+        (* "suffixes {a, b, c}" *)
+        | SUFFIXES x=delimited(LACC,separated_nonempty_list_final_opt(COMA,COMPLEX_ID),RACC)
             { List.map Ast.simple_id_of_ci x }
 
 

src/parser/lexer.mll

@@ -105,7 +105,7 @@ and global = parse
 | "feature"     { FEATURE }
 | "file"        { FILE }
 | "labels"      { LABELS }
-| "new_nodes"   { NEW_NODES }
+| "suffixes"    { SUFFIXES }
 | "match"       { MATCH }
 | "without"     { WITHOUT }
 | "commands"    { COMMANDS }