New declaration of add_node

PREC and SUCC rels printed only in debug mode

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@8965 7838e531-6607-4d57-9587-6c381814729c

src/grew_ast.ml

@@ -188,6 +188,11 @@ module Ast = struct
     | String_item of string
     | Param_item of string
 
+  let string_of_concat_item = function
+    | Qfn_item id -> sprintf "%s" (dump_feature_ident id)
+    | String_item s -> sprintf "\"%s\"" s
+    | Param_item var -> sprintf "%s" var
+
   type u_command =
     | Del_edge_expl of (Id.name * Id.name * edge_label)
     | Del_edge_name of string
@@ -200,12 +205,61 @@ module Ast = struct
 
     | Merge_node of (Id.name * Id.name)
     | New_neighbour of (Id.name * Id.name * edge_label)
+    | New_node of Id.name
+    | New_before of (Id.name * Id.name)
+    | New_after of (Id.name * Id.name)
+
     | Del_node of Id.name
 
     | Del_feat of feature_ident
     | Update_feat of feature_ident * concat_item list
   type command = u_command * Loc.t
 
+  let string_of_u_command u_command = match u_command with
+    | Del_edge_expl (n1,n2,label) ->
+      sprintf "del_edge %s -[%s]-> %s" n1 label n2
+    | Del_edge_name name -> sprintf "del_edge %s" name
+    | Add_edge (n1,n2,label) ->
+      sprintf "add_edge %s -[%s]-> %s" n1 label n2
+
+    | Shift_in (n1,n2,([],true)) ->
+      sprintf "shift_in %s ==> %s" n1 n2
+    | Shift_in (n1,n2,(labels,false)) ->
+      sprintf "shift_in %s =[%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
+    | Shift_in (n1,n2,(labels,true)) ->
+      sprintf "shift_in %s =[^%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
+
+    | Shift_out (n1,n2,([],true)) ->
+      sprintf "shift_out %s ==> %s" n1 n2
+    | Shift_out (n1,n2,(labels,false)) ->
+      sprintf "shift_out %s =[%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
+    | Shift_out (n1,n2,(labels,true)) ->
+      sprintf "shift_out %s =[^%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
+
+    | Shift_edge (n1,n2,([],true)) ->
+      sprintf "shift %s ==> %s" n1 n2
+    | Shift_edge (n1,n2,(labels,false)) ->
+      sprintf "shift %s =[%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
+    | Shift_edge (n1,n2,(labels,true)) ->
+      sprintf "shift %s =[^%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
+
+    | Merge_node (n1,n2) -> sprintf "merge %s ==> %s" n1 n2
+    | New_neighbour (n1,n2,label) -> sprintf "add_node %s: <-[%s]- %s" n1 label n2
+    | New_node (n) -> sprintf "add_node %s" n
+    | New_before (n1,n2) -> sprintf "add_node %s :< %s" n1 n2
+    | New_after (n1,n2) -> sprintf "add_node %s :> %s" n1 n2
+    | Del_node act_id -> sprintf "del_node %s" act_id
+    | Update_feat ((act_id, feat_name),item_list) ->
+      sprintf "%s.%s = %s" act_id feat_name (List_.to_string string_of_concat_item " + " item_list)
+    | Del_feat (act_id, feat_name) ->
+      sprintf "del_feat %s.%s" act_id feat_name
+
+  let rec replace_new_neighbour = function
+  | [] -> []
+  | (New_neighbour (new_name, old_name, edge),loc) :: tail ->
+    (New_after (new_name, old_name),loc) :: (Add_edge (old_name, new_name, edge),loc) :: (replace_new_neighbour tail)
+  | head :: tail -> head :: (replace_new_neighbour tail)
+
   (* the [rule] type is used for 3 kinds of module items:
      - rule     { param=None; ... }
      - lex_rule

src/grew_ast.mli

@@ -123,12 +123,22 @@ module Ast : sig
 
     | Merge_node of (Id.name * Id.name)
     | New_neighbour of (Id.name * Id.name * edge_label)
+
+    | New_node of Id.name
+    | New_before of (Id.name * Id.name)
+    | New_after of (Id.name * Id.name)
+
     | Del_node of Id.name
 
     | Del_feat of feature_ident
     | Update_feat of feature_ident * concat_item list
+  val string_of_u_command:  u_command -> string
   type command = u_command * Loc.t
 
+
+
+  val replace_new_neighbour: command list -> command list
+
   type rule = {
       rule_id:Id.name;
       pattern: pattern;

src/grew_base.ml

@@ -601,6 +601,7 @@ module Global = struct
   let current_file = ref "Not a file"
   let current_line = ref 1
   let label_flag = ref false
+  let debug = ref false
 
   let init file =
     current_file := file;

src/grew_base.mli

@@ -277,4 +277,6 @@ module Global: sig
   val current_line: int ref
   val init: string -> unit
   val label_flag: bool ref
+
+  val debug: bool ref
 end

src/grew_command.ml

@@ -40,6 +40,11 @@ module Command  = struct
     | DEL_FEAT of (command_node * string)
     | UPDATE_FEAT of (command_node * string * item list)
     | NEW_NEIGHBOUR of (string * G_edge.t * Pid.t) (* TODO: remove *)
+
+    | NEW_NODE of string
+    | NEW_BEFORE of (string * command_node)
+    | NEW_AFTER of (string * command_node)
+
     | SHIFT_EDGE of (command_node * command_node * Label_cst.t)
     | SHIFT_IN of (command_node * command_node * Label_cst.t)
     | SHIFT_OUT of (command_node * command_node * Label_cst.t)
@@ -56,11 +61,17 @@ module Command  = struct
     | 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) (* TODO: remove *)
+
+    | H_NEW_NODE of string
+    | H_NEW_BEFORE of (string * Gid.t)
+    | H_NEW_AFTER of (string * Gid.t)
+
     | 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)
 
+
   let build domain label_domain ?param (kai, kei) table locals ast_command =
     (* kai stands for "known act ident", kei for "known edge ident" *)
 
@@ -140,6 +151,23 @@ module Command  = struct
 	             (Loc.to_string loc)
 	        end
 
+      | (Ast.New_node new_id, loc) ->
+          if List.mem new_id kai
+          then Error.build ~loc "Node identifier \"%s\" is already used" new_id;
+          (((NEW_NODE new_id), loc),(new_id::kai, kei))
+
+      | (Ast.New_before (new_id, old_id), loc) ->
+          check_node_id loc old_id kai;
+          if List.mem new_id kai
+          then Error.build ~loc "Node identifier \"%s\" is already used" new_id;
+          ((NEW_BEFORE (new_id,pid_of_act_id loc old_id), loc),(new_id::kai, kei))
+
+      | (Ast.New_after (new_id, old_id), loc) ->
+          check_node_id loc old_id kai;
+          if List.mem new_id kai
+          then Error.build ~loc "Node identifier \"%s\" is already used" new_id;
+          ((NEW_AFTER (new_id,pid_of_act_id loc old_id), loc),(new_id::kai, kei))
+
       | (Ast.Del_node act_n, loc) ->
           check_node_id loc act_n kai;
           ((DEL_NODE (pid_of_act_id loc act_n), loc), (List_.rm act_n kai, kei))

src/grew_command.mli

@@ -34,6 +34,11 @@ module Command : sig
     | DEL_FEAT of (command_node * string)
     | UPDATE_FEAT of (command_node * string * item list)
     | NEW_NEIGHBOUR of (string * G_edge.t * Pid.t)
+
+    | NEW_NODE of string
+    | NEW_BEFORE of (string * command_node)
+    | NEW_AFTER of (string * command_node)
+
     | SHIFT_EDGE of (command_node * command_node * Label_cst.t)
     | SHIFT_IN of (command_node * command_node * Label_cst.t)
     | SHIFT_OUT of (command_node * command_node * Label_cst.t)
@@ -48,6 +53,11 @@ module Command : sig
     | 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_NODE of string
+    | H_NEW_BEFORE of (string * Gid.t)
+    | H_NEW_AFTER of (string * Gid.t)
+
     | H_SHIFT_EDGE of (Gid.t * Gid.t)
     | H_SHIFT_IN of (Gid.t * Gid.t)
     | H_SHIFT_OUT of (Gid.t * Gid.t)

src/grew_fs.ml

@@ -306,8 +306,8 @@ module G_fs = struct
       | [] -> "_"
       | l ->  String.concat "#" l in
 
-    let last = match (filter, position) with
-      | (Some l, Some f) when List.mem "position" l && f > 0. -> [G_feature.to_string ("position", Float f)]
+    let last = match (!Global.debug, position) with
+      | (true, Some f) -> [(G_feature.to_string ("position", Float f))^":B:lightblue"]
       | _ -> [] in
 
     let lines = List.fold_left

src/grew_graph.mli

@@ -90,7 +90,9 @@ module G_graph: sig
 
   val normalize: t -> t
 
-  (** raise ??? *)
+  val get_highest: t -> int
+
+    (** TODO REMOVE  ??? *)
   val max_binding: t -> int
 
   (** [edge_out label_domain t id label_cst] returns true iff there is an out-edge from the node [id] with a label compatible with [label_cst] *)
@@ -137,6 +139,9 @@ module G_graph: sig
 
   val add_neighbour: Loc.t -> Domain.t -> t -> Gid.t -> G_edge.t -> (Gid.t * t)
 
+  val add_before: Loc.t -> Domain.t -> Gid.t -> t -> (Gid.t * t)
+  val add_after: Loc.t -> Domain.t -> Gid.t -> t -> (Gid.t * t)
+
   val merge_node: Loc.t -> Domain.t -> t -> 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 *)

src/grew_html.ml

@@ -49,42 +49,7 @@ module Html_doc = struct
   let buff_html_command ?(li_html=false) buff (u_command,_) =
     bprintf buff "      ";
     if li_html then bprintf buff "<li>";
-    (match u_command with
-    | Ast.Del_edge_expl (n1,n2,label) ->
-      bprintf buff "del_edge %s -[%s]-> %s" n1 label n2
-    | Ast.Del_edge_name name -> bprintf buff "del_edge %s" name
-    | Ast.Add_edge (n1,n2,label) ->
-      bprintf buff "add_edge %s -[%s]-> %s" n1 label n2
-
-    | Ast.Shift_in (n1,n2,([],true)) ->
-      bprintf buff "shift_in %s ==> %s" n1 n2
-    | Ast.Shift_in (n1,n2,(labels,false)) ->
-      bprintf buff "shift_in %s =[%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
-    | Ast.Shift_in (n1,n2,(labels,true)) ->
-      bprintf buff "shift_in %s =[^%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
-
-    | Ast.Shift_out (n1,n2,([],true)) ->
-      bprintf buff "shift_out %s ==> %s" n1 n2
-    | Ast.Shift_out (n1,n2,(labels,false)) ->
-      bprintf buff "shift_out %s =[%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
-    | Ast.Shift_out (n1,n2,(labels,true)) ->
-      bprintf buff "shift_out %s =[^%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
-
-    | Ast.Shift_edge (n1,n2,([],true)) ->
-      bprintf buff "shift %s ==> %s" n1 n2
-    | Ast.Shift_edge (n1,n2,(labels,false)) ->
-      bprintf buff "shift %s =[%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
-    | Ast.Shift_edge (n1,n2,(labels,true)) ->
-      bprintf buff "shift %s =[^%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
-
-    | Ast.Merge_node (n1,n2) -> bprintf buff "merge %s ==> %s" n1 n2
-    | Ast.New_neighbour (n1,n2,label) -> bprintf buff "add_node %s: <-[%s]- %s" n1 label n2
-    | Ast.Del_node act_id -> bprintf buff "del_node %s" act_id
-    | Ast.Update_feat ((act_id, feat_name),item_list) ->
-      bprintf buff "%s.%s = %s" act_id feat_name (List_.to_string string_of_concat_item " + " item_list)
-    | Ast.Del_feat (act_id, feat_name) ->
-      bprintf buff "del_feat %s.%s" act_id feat_name
-    );
+    bprintf buff "%s" (Ast.string_of_u_command u_command);
     if li_html then bprintf buff "</li>\n" else bprintf buff ";\n"
 
   let html_feature (u_feature,_) =

src/grew_lexer.mll

@@ -206,6 +206,10 @@ and standard target = parse
 
 | "<<"       { LPREC }
 | ">>"       { LSUCC }
+
+| ":<"         { BEFORE }
+| ":>"         { AFTER }
+
 | "<"        { LT }
 | ">"        { GT }
 | "<=" | "≤" { LE }

src/grew_node.ml

@@ -41,6 +41,9 @@ module G_node = struct
   let get_prec t = t.prec
   let get_succ t = t.succ
 
+  let set_succ id t = { t with succ = Some id }
+  let set_prec id t = { t with prec = Some id }
+
   let empty = { fs = G_fs.empty; next = Massoc_gid.empty; succ = None; prec = None; position = -1.; conll_root=false }
 
   let is_conll_root t = t.conll_root
@@ -61,19 +64,17 @@ module G_node = struct
 
   let get_annot_info t = G_fs.get_annot_info t.fs
 
-  let build domain ?def_position (ast_node, loc) =
+  let build domain ?prec ?succ position (ast_node, loc) =
     let fs = G_fs.build domain ast_node.Ast.fs in
-    let position = match (ast_node.Ast.position, def_position) with
-      | (Some position, _) -> position
-      | (None, Some position) -> position
-      | (None, None) -> Error.bug "Cannot build a node without position" in
-    (ast_node.Ast.node_id, { empty with fs; position })
+    (ast_node.Ast.node_id, { empty with fs; position = float_of_int position; prec; succ })
 
   let of_conll ?loc ?prec ?succ domain line =
     if line = Conll.root
     then { empty with conll_root=true }
     else { empty with fs = G_fs.of_conll ?loc domain line; position = float line.Conll.id; prec; succ }
 
+  let fresh domain ?prec ?succ position = { empty with position; prec; succ }
+
   let remove (id_tar : Gid.t) label t = {t with next = Massoc_gid.remove id_tar label t.next}
 
   let remove_key node_id t =

src/grew_node.mli

@@ -31,6 +31,9 @@ module G_node: sig
   val get_succ: t -> Gid.t option
   val get_prec: t -> Gid.t option
 
+  val set_prec: Gid.t -> t -> t
+  val set_succ: Gid.t -> t -> t
+
   val set_fs: G_fs.t -> t -> t
   val set_position: float -> t -> t
   val set_next: G_edge.t Massoc_gid.t -> t -> t
@@ -47,8 +50,9 @@ module G_node: sig
   val rm_out_edges: t -> t
 
   val add_edge: G_edge.t -> Gid.t -> t -> t option
-  val build: Domain.t -> ?def_position: float -> Ast.node -> (Id.name * t)
+  val build: Domain.t -> ?prec:Gid.t -> ?succ:Gid.t -> int -> Ast.node -> (Id.name * t)
   val of_conll: ?loc:Loc.t -> ?prec:Gid.t -> ?succ:Gid.t -> Domain.t -> Conll.line -> t
+  val fresh: Domain.t -> ?prec:Gid.t -> ?succ:Gid.t -> float -> t
 
   val get_position: t -> float
 

src/grew_parser.mly

@@ -55,6 +55,9 @@ let localize t = (t,get_loc ())
 %token LPREC                       /* << */
 %token LSUCC                       /* >> */
 
+%token BEFORE                      /* :< */
+%token AFTER                       /* :> */
+
 %token PIPE                        /* | */
 
 %token EDGE                        /* -> */
@@ -311,7 +314,7 @@ rule:
             {
               { Ast.rule_id = fst id_loc;
                 pattern = Ast.complete_pattern { Ast.pat_pos = p; Ast.pat_negs = n };
-                commands = cmds;
+                commands = Ast.replace_new_neighbour cmds;
                 param = None;
                 lex_par = None;
                 rule_doc = begin match doc with Some d -> d | None -> [] end;
@@ -384,7 +387,6 @@ pat_node:
 
 node_features:
         (*  "cat = n|v|adj"     *)
-        (*  "cat = *"           *)
         | name_loc=simple_id_with_loc EQUAL values=separated_nonempty_list(PIPE,feature_value)
             { let (name,loc) = name_loc in
               match values with
@@ -395,6 +397,10 @@ node_features:
         | name_loc=simple_id_with_loc EQUAL STAR
             { let (name,loc) = name_loc in ({Ast.kind = Ast.Disequality []; name},loc) }
 
+        (*  "cat"           *)
+        | name_loc=simple_id_with_loc
+            { let (name,loc) = name_loc in ({Ast.kind = Ast.Disequality []; name},loc) }
+
         (*   "cat<>n|v|adj"     *)
         | name_loc=simple_id_with_loc DISEQUAL values=separated_nonempty_list(PIPE,feature_value)
             { let (name,loc) = name_loc in ( {Ast.kind = Ast.Disequality values; name}, loc) }
@@ -604,6 +610,18 @@ command:
         | ADD_NODE new_ci_loc=simple_id_with_loc DDOT label=delimited(RTL_EDGE_LEFT,label_ident,RTL_EDGE_RIGHT) anc_ci=simple_id
             { let (new_ci,loc) = new_ci_loc in (Ast.New_neighbour (new_ci, anc_ci,label), loc) }
 
+        (* add_node n *)
+        | ADD_NODE new_ci_loc=simple_id_with_loc
+            { let (new_ci,loc) = new_ci_loc in (Ast.New_node new_ci, loc) }
+
+        (* add_node n :< m *)
+        | ADD_NODE new_ci_loc=simple_id_with_loc BEFORE old_ci=simple_id
+            { let (new_ci,loc) = new_ci_loc in (Ast.New_before (new_ci,old_ci), loc) }
+
+        (* add_node n :> m *)
+        | ADD_NODE new_ci_loc=simple_id_with_loc AFTER old_ci=simple_id
+            { let (new_ci,loc) = new_ci_loc in (Ast.New_after (new_ci,old_ci), loc) }
+
         (* del_feat m.cat *)
         | DEL_FEAT com_fead_id_loc= feature_ident_with_loc
             { let (com_fead_id,loc) = com_fead_id_loc in (Ast.Del_feat com_fead_id, loc) }

src/grew_rule.ml

@@ -32,15 +32,15 @@ module Instance = struct
     history: Command.h list;
     rules: string list;
     big_step: Libgrew_types.big_step option;
-    free_index: int;
+    highest_index: int;
   }
 
-  let empty = {graph = G_graph.empty; rules=[]; history=[]; big_step=None; free_index=0; }
+  let empty = {graph = G_graph.empty; rules=[]; history=[]; big_step=None; highest_index=0; }
 
   let from_graph graph =
     {empty with
       graph = graph;
-      free_index = (G_graph.max_binding graph) + 1;
+      highest_index = (G_graph.max_binding graph) + 1;
     }
 
   let rev_steps t =
@@ -59,8 +59,8 @@ module Instance = struct
           (node_id, Gid.Old next_free) :: acc_map,
           next_free + 1
         )
-      ) ([], t.free_index) t.actiiivated_node in
-    { empty with graph = G_graph.rename mapping t.graph; free_index = new_free }
+      ) ([], t.highest_index) t.actiiivated_node in
+    { empty with graph = G_graph.rename mapping t.graph; highest_index = new_free }
 *)
 
   (* comparison is done on the list of commands *)
@@ -813,6 +813,39 @@ module Rule = struct
          (created_name,new_gid) :: created_nodes
         )
 
+    | Command.NEW_AFTER (created_name,base_cn) ->
+        let base_gid = node_find base_cn in
+        let (new_gid,new_graph) = G_graph.add_after loc domain base_gid instance.Instance.graph in
+        (
+         {instance with
+          Instance.graph = new_graph;
+          history = List_.sort_insert (Command.H_NEW_AFTER (created_name,new_gid)) instance.Instance.history;
+        },
+         (created_name,new_gid) :: created_nodes
+        )
+
+    | Command.NEW_NODE (created_name) ->
+        let base_gid =  Gid.Old (G_graph.get_highest instance.Instance.graph) in
+        let (new_gid,new_graph) = G_graph.add_after loc domain base_gid instance.Instance.graph in
+        (
+         {instance with
+          Instance.graph = new_graph;
+          history = List_.sort_insert (Command.H_NEW_AFTER (created_name,new_gid)) instance.Instance.history;
+        },
+         (created_name,new_gid) :: created_nodes
+        )
+
+    | Command.NEW_BEFORE (created_name,base_cn) ->
+        let base_gid = node_find base_cn in
+        let (new_gid,new_graph) = G_graph.add_before loc domain base_gid instance.Instance.graph in
+        (
+         {instance with
+          Instance.graph = new_graph;
+          history = List_.sort_insert (Command.H_NEW_BEFORE (created_name,new_gid)) instance.Instance.history;
+        },
+         (created_name,new_gid) :: created_nodes
+        )
+
     | Command.SHIFT_IN (src_cn,tar_cn,label_cst) ->
         let src_gid = node_find src_cn in
         let tar_gid = node_find tar_cn in

src/grew_rule.mli

@@ -24,7 +24,7 @@ module Instance : sig
     history: Command.h list;
     rules: string list;
     big_step: Libgrew_types.big_step option;
-    free_index: int;
+    highest_index: int;
   }
 
   (** [from_graph graph] return a fresh instance based on the input [graph]. *)

src/libgrew.ml

@@ -12,6 +12,8 @@ open Printf
 open Log
 open Conll
 
+let libgrew_debug_mode () = Grew_base.Global.debug := true
+
 (* ==================================================================================================== *)
 (** {2 Location} *)
 (* ==================================================================================================== *)

src/libgrew.mli

@@ -10,6 +10,8 @@
 
 open Conll
 
+val libgrew_debug_mode: unit -> unit
+
 (* ==================================================================================================== *)
 (** {2 Location} *)
 (* ==================================================================================================== *)