Commit 066dcb37 authored by bguillaum's avatar bguillaum

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
parent 5f7c38c3
......@@ -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
......
......@@ -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;
......
......@@ -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;
......
......@@ -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
......@@ -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))
......
......@@ -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)
......
......@@ -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
......
......@@ -209,12 +209,13 @@ end (* module G_deco *)
(* ================================================================================ *)
module G_graph = struct
type t = {
meta: string list; (* meta-informations *)
map: G_node.t Gid_map.t; (* node description *)
meta: string list; (* meta-informations *)
map: G_node.t Gid_map.t; (* node description *)
fusion: (Gid.t * (Gid.t * string)) list; (* the list of fusion word considered in UD conll *)
highest_index: int; (* the next free interger index *)
}
let empty = {meta=[]; map=Gid_map.empty; fusion=[]}
let empty = {meta=[]; map=Gid_map.empty; fusion=[]; highest_index=0; }
(* ---------------------------------------------------------------------- *)
let rename mapping graph =
......@@ -239,6 +240,7 @@ module G_graph = struct
) t.map (0, []) in
rename mapping t
let get_highest g = g.highest_index
let find node_id graph = Gid_map.find node_id graph.map
......@@ -254,13 +256,6 @@ module G_graph = struct
| (Gid.Old i,_) -> i
| _ -> Error.bug "[G_graph.max_binding]"
let list_num test =
let rec loop n = function
| [] -> raise Not_found
| x::_ when test x -> n
| _::t -> loop (n+1) t
in loop 0
(* is there an edge e out of node i ? *)
let edge_out domain graph node_id label_cst =
let node = Gid_map.find node_id graph.map in
......@@ -299,36 +294,29 @@ module G_graph = struct
let full_node_list = gr_ast.Ast.nodes
and full_edge_list = gr_ast.Ast.edges in
let next_free_position = ref 1. in
let named_nodes =
let rec loop already_bound = function
| [] -> []
| (ast_node, loc) :: tail ->
let node_id = ast_node.Ast.node_id in
if List.mem node_id already_bound
then Error.build "[GRS] [Graph.build] try to build a graph with twice the same node id '%s'" node_id
else
let (new_id,new_node) = G_node.build domain ~def_position:!next_free_position (ast_node, loc) in
next_free_position := 1. +. (max !next_free_position (G_node.get_position new_node));
let new_tail = loop (node_id :: already_bound) tail in
(new_id,new_node) :: new_tail in
loop [] full_node_list in
let rec loop already_bound index prec = function
| [] -> (Gid_map.empty,[])
let sorted_nodes = List.sort (fun (id1,_) (id2,_) -> Pervasives.compare id1 id2) named_nodes in
let (sorted_ids, node_list) = List.split sorted_nodes in
| (ast_node, loc)::tail ->
let node_id = ast_node.Ast.node_id in
if List.mem node_id already_bound
then Error.build ~loc "[GRS] [Graph.build] try to build a graph with twice the same node id '%s'" node_id
else
let (new_tail, table) = loop (node_id :: already_bound) (index+1) (Some (Gid.Old index)) tail in
let succ = if tail = [] then None else Some (Gid.Old (index+1)) in
let (_,new_node) = G_node.build domain ?prec ?succ index (ast_node, loc) in
(
Gid_map.add (Gid.Old index) new_node new_tail,
(node_id,index)::table
) in
(* table contains the sorted list of node ids *)
let table = Array.of_list sorted_ids in
(* the nodes, in the same order *)
let map_without_edges = List_.foldi_left (fun i acc elt -> Gid_map.add (Gid.Old i) elt acc) Gid_map.empty node_list in
let (map_without_edges, table) = loop [] 0 None full_node_list in
let map =
List.fold_left
(fun acc (ast_edge, loc) ->
let i1 = Id.build ~loc ast_edge.Ast.src table in
let i2 = Id.build ~loc ast_edge.Ast.tar table in
let i1 = List.assoc ast_edge.Ast.src table in
let i2 = List.assoc ast_edge.Ast.tar table in
let edge = G_edge.build domain ~locals (ast_edge, loc) in
(match map_add_edge acc (Gid.Old i1) edge (Gid.Old i2) with
| Some g -> g
......@@ -338,7 +326,7 @@ module G_graph = struct
)
) map_without_edges full_edge_list in
{meta=gr_ast.Ast.meta; map=map; fusion = []}
{meta=gr_ast.Ast.meta; map=map; fusion = []; highest_index = (List.length full_node_list) -1}
......@@ -389,7 +377,7 @@ module G_graph = struct
)
) conll.Conll.multiwords in
{meta = conll.Conll.meta; map=map_with_edges; fusion}
{meta = conll.Conll.meta; map=map_with_edges; fusion; highest_index= (List.length sorted_lines) -1 }
(* -------------------------------------------------------------------------------- *)
(** input : "Le/DET/le petit/ADJ/petit chat/NC/chat dort/V/dormir ./PONCT/." *)
......@@ -421,48 +409,9 @@ module G_graph = struct
try Some (List.assoc name atts)
with Not_found -> None
(* -------------------------------------------------------------------------------- *)
(** [of_xml d_xml] loads a graph in the xml format: [d_xml] must be a <D> xml element *)
let of_xml domain d_xml =
match d_xml with
| Xml.Element ("D", _, t_or_r_list) ->
let (t_list, r_list) = List.partition (function Xml.Element ("T",_,_) -> true | _ -> false) t_or_r_list in
let (nodes_without_edges, mapping) =
List_.foldi_left
(fun i (acc, acc_map) t_xml ->
match t_xml with
| Xml.Element ("T", t_atts, [Xml.PCData phon]) ->
let id = List.assoc "id" t_atts in
let other_feats = List.filter (fun (n,_) -> not (List.mem n ["id"; "start"; "end"; "label"])) t_atts in
let new_fs =
List.fold_left
(fun acc2 (fn,fv) -> G_fs.set_feat domain fn fv acc2)
G_fs.empty
(("phon", phon) :: ("cat", (List.assoc "label" t_atts)) :: other_feats) in
let new_node = G_node.set_fs new_fs (G_node.set_position (float i) G_node.empty) in
(Gid_map.add (Gid.Old i) new_node acc, String_map.add id (Gid.Old i) acc_map)
| _ -> Log.critical "[G_graph.of_xml] Not a wellformed <T> tag"
) (Gid_map.empty, String_map.empty) t_list in
let final_map =
List.fold_left
(fun acc r_xml ->
match r_xml with
| Xml.Element ("R", r_atts, _) ->
let src = List.assoc "from" r_atts
and tar = List.assoc "to" r_atts
and label = List.assoc "label" r_atts in
let gid_tar = String_map.find tar mapping in
let gid_src = String_map.find src mapping in
let old_node = Gid_map.find gid_src acc in
let new_map =
match G_node.add_edge (G_edge.make domain label) gid_tar old_node with
| Some new_node -> Gid_map.add gid_src new_node acc
| None -> Log.critical "[G_graph.of_xml] Fail to add edge" in
new_map
| _ -> Log.critical "[G_graph.of_xml] Not a wellformed <R> tag"
) nodes_without_edges r_list in
{meta=[]; map=final_map; fusion=[]}
| _ -> Log.critical "[G_graph.of_xml] Not a <D> tag"
(* -------------------------------------------------------------------------------- *)
(** [of_xml d_xml] loads a graph in the xml format: [d_xml] must be a <D> xml element *)
let of_xml domain d_xml = failwith "of_xml not available"
(* -------------------------------------------------------------------------------- *)
let del_edge domain ?edge_ident loc graph id_src label id_tar =
......@@ -507,6 +456,59 @@ module G_graph = struct
| Some g -> (index, {graph with map = g})
| None -> Log.bug "[Graph.add_neighbour] add_edge must not fail"; exit 1
(* -------------------------------------------------------------------------------- *)
let insert domain id1 id2 graph =
let node1 = Gid_map.find id1 graph.map in
let node2 = Gid_map.find id2 graph.map in
let pos1 = G_node.get_position node1 in
let pos2 = G_node.get_position node2 in
let new_pos= (pos1 +. pos2) /. 2. in
let new_index = graph.highest_index + 1 in
let new_gid = Gid.Old new_index in
let map = graph.map
|> (Gid_map.add new_gid (G_node.fresh domain ~prec:id1 ~succ:id2 new_pos))
|> (Gid_map.add id1 (G_node.set_succ new_gid node1))
|> (Gid_map.add id2 (G_node.set_prec new_gid node2)) in
(new_gid, { graph with map; highest_index = new_index })
(* -------------------------------------------------------------------------------- *)
let append domain id graph =
let node = Gid_map.find id graph.map in
let pos = G_node.get_position node in
let new_pos= pos +. 1. in
let new_index = graph.highest_index + 1 in
let new_gid = Gid.Old new_index in
let map = graph.map
|> (Gid_map.add new_gid (G_node.fresh domain ~prec:id new_pos))
|> (Gid_map.add id (G_node.set_succ new_gid node)) in
(new_gid, { graph with map; highest_index = new_index })
(* -------------------------------------------------------------------------------- *)
let prepend domain id graph =
let node = Gid_map.find id graph.map in
let pos = G_node.get_position node in
let new_pos= pos -. 1. in
let new_index = graph.highest_index + 1 in
let new_gid = Gid.Old new_index in
let map = graph.map
|> (Gid_map.add new_gid (G_node.fresh domain ~succ:id new_pos))
|> (Gid_map.add id (G_node.set_prec new_gid node)) in
(new_gid, { graph with map; highest_index = new_index })
(* -------------------------------------------------------------------------------- *)
let add_after loc domain node_id graph =
let node = Gid_map.find node_id graph.map in
match G_node.get_succ node with
| Some gid_succ -> insert domain node_id gid_succ graph
| None -> append domain node_id graph
(* -------------------------------------------------------------------------------- *)
let add_before loc domain node_id graph =
let node = Gid_map.find node_id graph.map in
match G_node.get_prec node with
| Some gid_prec -> insert domain gid_prec node_id graph
| None -> prepend domain node_id graph
(* -------------------------------------------------------------------------------- *)
(* 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 =
......@@ -722,26 +724,32 @@ module G_graph = struct
let style = match G_fs.get_string_atom "void" fs with
| Some "y" -> "; forecolor=red; subcolor=red; "
| _ -> "" in
bprintf buff "N_%s { %s%s }\n" (Gid.to_string id) dep_fs style
bprintf buff "N_%s { %s%s }\n"
(Gid.to_string id)
dep_fs
style
) snodes;
bprintf buff "} \n";
(* edges *)
bprintf buff "[EDGES] { \n";
List.iter
(fun (id, node) ->
begin
match G_node.get_prec node with
| None -> ()
| Some p -> bprintf buff "N_%s -> N_%s { label=\"__PREC__\"; bottom; style=dot}\n" (Gid.to_string id) (Gid.to_string p)
end;
begin
match G_node.get_succ node with
| None -> ()
| Some s -> bprintf buff "N_%s -> N_%s { label=\"__SUCC__\"; bottom; style=dot}\n" (Gid.to_string id) (Gid.to_string s)
end
) snodes;
if !Global.debug
then
List.iter
(fun (id, node) ->
begin
match G_node.get_prec node with
| None -> ()
| Some p -> bprintf buff "N_%s -> N_%s { label=\"__PREC__\"; bottom; style=dot; color=lightblue; forecolor=lightblue; }\n" (Gid.to_string id) (Gid.to_string p)
end;
begin
match G_node.get_succ node with
| None -> ()
| Some s -> bprintf buff "N_%s -> N_%s { label=\"__SUCC__\"; bottom; style=dot; color=lightblue; forecolor=lightblue; }\n" (Gid.to_string id) (Gid.to_string s)
end
) snodes;
Gid_map.iter
(fun gid elt ->
......@@ -790,6 +798,13 @@ module G_graph = struct
Buffer.contents buff
(* -------------------------------------------------------------------------------- *)
let list_num test =
let rec loop n = function
| [] -> raise Not_found
| x::_ when test x -> n
| _::t -> loop (n+1) t
in loop 0
let to_raw domain graph =
let nodes = Gid_map.fold (fun id elt acc -> (id,elt)::acc) graph.map [] in
let snodes = List.sort (fun (_,n1) (_,n2) -> G_node.position_comp n1 n2) nodes in
......
......@@ -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 *)
......
......@@ -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,_) =
......
......@@ -206,6 +206,10 @@ and standard target = parse
| "<<" { LPREC }
| ">>" { LSUCC }
| ":<" { BEFORE }
| ":>" { AFTER }
| "<" { LT }
| ">" { GT }
| "<=" | "≤" { LE }
......
......@@ -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 =
......
......@@ -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
......
......@@ -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