Commit 48b71885 authored by bguillaum's avatar bguillaum
Browse files

Make domain optional

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@9065 7838e531-6607-4d57-9587-6c381814729c
parent 3cff195e
......@@ -72,7 +72,7 @@ module Command = struct
| H_MERGE_NODE of (Gid.t * Gid.t)
let build domain label_domain ?param (kai, kei) table locals ast_command =
let build ?domain ?param (kai, kei) table locals ast_command =
(* kai stands for "known act ident", kei for "known edge ident" *)
let pid_of_act_id loc node_name =
......@@ -95,7 +95,7 @@ module Command = struct
| (Ast.Del_edge_expl (act_i, act_j, lab), loc) ->
check_node_id loc act_i kai;
check_node_id loc act_j kai;
let edge = G_edge.make ~loc label_domain lab in
let edge = G_edge.make ~loc ?domain 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) ->
......@@ -105,23 +105,23 @@ module Command = struct
| (Ast.Add_edge (act_i, act_j, lab), loc) ->
check_node_id loc act_i kai;
check_node_id loc act_j kai;
let edge = G_edge.make ~loc label_domain lab in
let edge = G_edge.make ~loc ?domain 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, label_cst), loc) ->
check_node_id loc act_i kai;
check_node_id loc act_j kai;
((SHIFT_EDGE (pid_of_act_id loc act_i, pid_of_act_id loc act_j, Label_cst.build ~loc label_domain label_cst), loc), (kai, kei))
((SHIFT_EDGE (pid_of_act_id loc act_i, pid_of_act_id loc act_j, Label_cst.build ~loc ?domain label_cst), loc), (kai, kei))
| (Ast.Shift_in (act_i, act_j, label_cst), loc) ->
check_node_id loc act_i kai;
check_node_id loc act_j kai;
((SHIFT_IN (pid_of_act_id loc act_i, pid_of_act_id loc act_j, Label_cst.build label_domain ~loc label_cst), loc), (kai, kei))
((SHIFT_IN (pid_of_act_id loc act_i, pid_of_act_id loc act_j, Label_cst.build ?domain ~loc label_cst), loc), (kai, kei))
| (Ast.Shift_out (act_i, act_j, label_cst), loc) ->
check_node_id loc act_i kai;
check_node_id loc act_j kai;
((SHIFT_OUT (pid_of_act_id loc act_i, pid_of_act_id loc act_j, Label_cst.build label_domain ~loc label_cst), loc), (kai, kei))
((SHIFT_OUT (pid_of_act_id loc act_i, pid_of_act_id loc act_j, Label_cst.build ?domain ~loc label_cst), loc), (kai, kei))
| (Ast.Merge_node (act_i, act_j), loc) ->
check_node_id loc act_i kai;
......@@ -133,7 +133,7 @@ module Command = struct
if List.mem new_id kai
then Error.build ~loc "Node identifier \"%s\" is already used" new_id;
let edge = G_edge.make ~loc label_domain label in
let edge = G_edge.make ~loc ?domain label in
begin
try
(
......@@ -146,7 +146,7 @@ module Command = struct
)
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 label_domain edge)
(G_edge.to_string ?domain edge)
ancestor
(Loc.to_string loc)
end
......@@ -176,7 +176,7 @@ module Command = struct
if feat_name = "position"
then Error.build ~loc "Illegal del_feat command: the 'position' feature cannot be deleted";
check_node_id loc act_id kai;
Domain.check_feature_name ~loc domain feat_name;
Domain.check_feature_name ~loc ?domain feat_name;
((DEL_FEAT (pid_of_act_id loc act_id, feat_name), loc), (kai, kei))
| (Ast.Update_feat ((act_id, feat_name), ast_items), loc) ->
......@@ -185,7 +185,7 @@ module Command = struct
(function
| Ast.Qfn_item (node_id,feature_name) ->
check_node_id loc node_id kai;
Domain.check_feature_name ~loc domain feature_name;
Domain.check_feature_name ~loc ?domain feature_name;
Feat (pid_of_node_id loc node_id, feature_name)
| Ast.String_item s -> String s
| Ast.Param_item var ->
......@@ -199,9 +199,9 @@ module Command = struct
) ast_items in
(* check for consistency *)
(match items with
| _ when Domain.is_open_feature domain feat_name -> ()
| _ when Domain.is_open_feature ?domain feat_name -> ()
| [Param_out _] -> () (* TODO: check that lexical parameters are compatible with the feature domain *)
| [String s] -> Domain.check_feature ~loc domain feat_name s
| [String s] -> Domain.check_feature ~loc ?domain feat_name s
| [Feat (_,fn)] -> ()
| _ -> Error.build ~loc "[Update_feat] Only open features can be modified with the concat operator '+' but \"%s\" is not declared as an open feature" feat_name);
((UPDATE_FEAT (pid_of_act_id loc act_id, feat_name, items), loc), (kai, kei))
......
......@@ -64,8 +64,7 @@ module Command : sig
| H_MERGE_NODE of (Gid.t * Gid.t)
val build:
Domain.t ->
Domain.t ->
?domain: Domain.t ->
?param: (string list * string list) ->
(Id.name list * string list) ->
Id.table ->
......
......@@ -23,21 +23,21 @@ module Label_cst = struct
| Neg of Label.t list
| Regexp of (Str.regexp * string)
let to_string label_domain = function
| Pos l -> (List_.to_string (Label.to_string label_domain) "|" l)
| Neg l -> "^"^(List_.to_string (Label.to_string label_domain) "|" l)
let to_string ?domain = function
| Pos l -> (List_.to_string (Label.to_string ?domain) "|" l)
| Neg l -> "^"^(List_.to_string (Label.to_string ?domain) "|" l)
| Regexp (_,re) -> "re\""^re^"\""
let all = Neg []
let match_ label_domain cst g_label = match cst with
let match_ ?domain cst g_label = match cst with
| Pos labels -> Label.match_list labels g_label
| Neg labels -> not (Label.match_list labels g_label)
| Regexp (re,_) -> String_.re_match re (Label.to_string label_domain g_label)
| Regexp (re,_) -> String_.re_match re (Label.to_string ?domain g_label)
let build ?loc label_domain = function
| Ast.Neg_list p_labels -> Neg (List.sort compare (List.map (Label.from_string ?loc label_domain) p_labels))
| Ast.Pos_list p_labels -> Pos (List.sort compare (List.map (Label.from_string ?loc label_domain) p_labels))
let build ?loc ?domain = function
| Ast.Neg_list p_labels -> Neg (List.sort compare (List.map (Label.from_string ?loc ?domain) p_labels))
| Ast.Pos_list p_labels -> Pos (List.sort compare (List.map (Label.from_string ?loc ?domain) p_labels))
| Ast.Regexp re -> Regexp (Str.regexp re, re)
end (* module Label_cst *)
......@@ -45,20 +45,20 @@ end (* module Label_cst *)
module G_edge = struct
type t = Label.t
let to_string label_domain t = Label.to_string label_domain t
let to_string ?domain t = Label.to_string ?domain t
let make ?loc label_domain string = Label.from_string ?loc label_domain string
let make ?loc ?domain string = Label.from_string ?loc ?domain string
let build label_domain (ast_edge, loc) =
let build ?domain (ast_edge, loc) =
match ast_edge.Ast.edge_label_cst with
| Ast.Pos_list [one] -> Label.from_string ~loc label_domain one
| Ast.Pos_list [one] -> Label.from_string ~loc ?domain one
| Ast.Neg_list _ -> Error.build "Negative edge spec are forbidden in graphs%s" (Loc.to_string loc)
| Ast.Pos_list _ -> Error.build "Only atomic edge values are allowed in graphs%s" (Loc.to_string loc)
| Ast.Regexp _ -> Error.build "Regexp are not allowed in graphs%s" (Loc.to_string loc)
let is_void label_domain t = Label.is_void label_domain t
let to_dep label_domain ?(deco=false) t = Label.to_dep label_domain ~deco t
let to_dot label_domain ?(deco=false) t = Label.to_dot label_domain ~deco t
let is_void ?domain t = Label.is_void ?domain t
let to_dep ?domain ?(deco=false) t = Label.to_dep ?domain ~deco t
let to_dot ?domain ?(deco=false) t = Label.to_dot ?domain ~deco t
let color_of_option = function
| [] -> None
......@@ -76,34 +76,34 @@ module P_edge = struct
let get_id t = t.id
let build label_domain (ast_edge, loc) =
let build ?domain (ast_edge, loc) =
{ id = ast_edge.Ast.edge_id;
label_cst = Label_cst.build ~loc label_domain ast_edge.Ast.edge_label_cst
label_cst = Label_cst.build ~loc ?domain ast_edge.Ast.edge_label_cst
}
let to_string label_domain t =
let to_string ?domain t =
match t.id with
| None -> Label_cst.to_string label_domain t.label_cst
| Some i -> sprintf "%s:%s" i (Label_cst.to_string label_domain t.label_cst)
| None -> Label_cst.to_string ?domain t.label_cst
| Some i -> sprintf "%s:%s" i (Label_cst.to_string ?domain t.label_cst)
type edge_matcher =
| Fail
| Ok of Label.t
| Binds of string * Label.t list
let match_ label_domain p_edge g_edge =
let match_ ?domain p_edge g_edge =
match p_edge with
| {id = None; label_cst } when Label_cst.match_ label_domain label_cst g_edge -> Ok g_edge
| {id = Some i; label_cst } when Label_cst.match_ label_domain label_cst g_edge -> Binds (i, [g_edge])
| {id = None; label_cst } when Label_cst.match_ ?domain label_cst g_edge -> Ok g_edge
| {id = Some i; label_cst } when Label_cst.match_ ?domain label_cst g_edge -> Binds (i, [g_edge])
| _ -> Fail
let match_list label_domain p_edge g_edge_list =
let match_list ?domain p_edge g_edge_list =
match p_edge with
| {id = None; label_cst} when List.exists (fun g_edge -> Label_cst.match_ label_domain label_cst g_edge) g_edge_list ->
| {id = None; label_cst} when List.exists (fun g_edge -> Label_cst.match_ ?domain label_cst g_edge) g_edge_list ->
Ok (List.hd g_edge_list)
| {id = None} -> Fail
| {id = Some i; label_cst } ->
( match List.filter (fun g_edge -> Label_cst.match_ label_domain label_cst g_edge) g_edge_list with
( match List.filter (fun g_edge -> Label_cst.match_ ?domain label_cst g_edge) g_edge_list with
| [] -> Fail
| list -> Binds (i, list)
)
......
......@@ -21,10 +21,10 @@ module Label_cst : sig
| Neg of Label.t list
| Regexp of (Str.regexp * string)
val to_string: Domain.t -> t -> string
val to_string: ?domain:Domain.t -> t -> string
val all: t
val match_: Domain.t -> t -> Label.t -> bool
val build: ?loc:Loc.t -> Domain.t -> Ast.edge_label_cst -> t
val match_: ?domain:Domain.t -> t -> Label.t -> bool
val build: ?loc:Loc.t -> ?domain:Domain.t -> Ast.edge_label_cst -> t
end (* module Label_cst *)
......@@ -33,15 +33,15 @@ end (* module Label_cst *)
module G_edge: sig
type t = Label.t
val to_string: Domain.t -> t -> string
val to_string: ?domain:Domain.t -> t -> string
val make: ?loc:Loc.t -> Domain.t -> string -> t
val make: ?loc:Loc.t -> ?domain:Domain.t -> string -> t
val build: Domain.t -> Ast.edge -> t
val build: ?domain:Domain.t -> Ast.edge -> t
val is_void: Domain.t -> t -> bool
val to_dot: Domain.t -> ?deco:bool -> t -> string
val to_dep: Domain.t -> ?deco:bool -> t -> string
val is_void: ?domain:Domain.t -> t -> bool
val to_dot: ?domain:Domain.t -> ?deco:bool -> t -> string
val to_dep: ?domain:Domain.t -> ?deco:bool -> t -> string
end (* module G_edge *)
(* ================================================================================ *)
......@@ -54,16 +54,16 @@ module P_edge: sig
val get_id: t -> string option
val to_string: Domain.t -> t -> string
val to_string: ?domain:Domain.t -> t -> string
val build: Domain.t -> Ast.edge -> t
val build: ?domain:Domain.t -> Ast.edge -> t
type edge_matcher =
| Fail
| Ok of Label.t
| Binds of string * Label.t list
val match_: Domain.t -> t -> G_edge.t -> edge_matcher
val match_: ?domain:Domain.t -> t -> G_edge.t -> edge_matcher
val match_list: Domain.t -> t -> G_edge.t list -> edge_matcher
val match_list: ?domain:Domain.t -> t -> G_edge.t list -> edge_matcher
end (* module P_edge *)
......@@ -36,9 +36,9 @@ module G_feature = struct
| (None, Some j) -> 1
| (None, None) -> Pervasives.compare name1 name2
let build domain = function
let build ?domain = function
| ({Ast.kind=Ast.Equality [atom]; name=name},loc) ->
(name, Feature_value.build_value ~loc domain name atom)
(name, Feature_value.build_value ~loc ?domain name atom)
| _ -> Error.build "Illegal feature declaration in Graph (must be '=' and atomic)"
let to_string (feat_name, feat_val) = sprintf "%s=%s" feat_name (string_of_value feat_val)
......@@ -134,14 +134,14 @@ module P_feature = struct
| _ -> Error.bug "[P_feature.to_string] multiple parameters are not handled"
let build domain ?pat_vars = function
let build ?domain ?pat_vars = function
| ({Ast.kind=Ast.Absent; name=name}, loc) ->
Domain.check_feature_name ~loc domain name;
Domain.check_feature_name ~loc ?domain name;
(name, {cst=Absent;in_param=[];})
| ({Ast.kind=Ast.Equality unsorted_values; name=name}, loc) ->
let values = Feature_value.build_disj ~loc domain name unsorted_values in (name, {cst=Equal values;in_param=[];})
let values = Feature_value.build_disj ~loc ?domain name unsorted_values in (name, {cst=Equal values;in_param=[];})
| ({Ast.kind=Ast.Disequality unsorted_values; name=name}, loc) ->
let values = Feature_value.build_disj ~loc domain name unsorted_values in (name, {cst=Different values;in_param=[];})
let values = Feature_value.build_disj ~loc ?domain name unsorted_values in (name, {cst=Different values;in_param=[];})
| ({Ast.kind=Ast.Equal_param var; name=name}, loc) ->
begin
match pat_vars with
......@@ -165,8 +165,8 @@ module G_fs = struct
let empty = []
(* ---------------------------------------------------------------------- *)
let set_feat ?loc domain feature_name atom t =
let new_value = Feature_value.build_value ?loc domain feature_name atom in
let set_feat ?loc ?domain feature_name atom t =
let new_value = Feature_value.build_value ?loc ?domain feature_name atom in
let rec loop = function
| [] -> [(feature_name, new_value)]
| ((fn,_)::_) as t when feature_name < fn -> (feature_name, new_value)::t
......@@ -207,22 +207,22 @@ module G_fs = struct
let to_gr t = List_.to_string G_feature.to_gr ", " t
(* ---------------------------------------------------------------------- *)
let build domain ast_fs =
let unsorted = List.map (fun feat -> G_feature.build domain feat) ast_fs in
let build ?domain ast_fs =
let unsorted = List.map (fun feat -> G_feature.build ?domain feat) ast_fs in
List.sort G_feature.compare unsorted
(* ---------------------------------------------------------------------- *)
let of_conll ?loc domain line =
let of_conll ?loc ?domain line =
let raw_list0 =
("phon", Feature_value.build_value ?loc domain "phon" line.Conll.form)
:: ("cat", Feature_value.build_value ?loc domain "cat" line.Conll.upos)
:: (List.map (fun (f,v) -> (f, Feature_value.build_value ?loc domain f v)) line.Conll.feats) in
("phon", Feature_value.build_value ?loc ?domain "phon" line.Conll.form)
:: ("cat", Feature_value.build_value ?loc ?domain "cat" line.Conll.upos)
:: (List.map (fun (f,v) -> (f, Feature_value.build_value ?loc ?domain f v)) line.Conll.feats) in
let raw_list1 = match line.Conll.xpos with
| "" | "_" -> raw_list0
| s -> ("pos", Feature_value.build_value ?loc domain "pos" s) :: raw_list0 in
| s -> ("pos", Feature_value.build_value ?loc ?domain "pos" s) :: raw_list0 in
let raw_list2 = match line.Conll.lemma with
| "" | "_" -> raw_list1
| s -> ("lemma", Feature_value.build_value ?loc domain "lemma" s) :: raw_list1 in
| s -> ("lemma", Feature_value.build_value ?loc ?domain "lemma" s) :: raw_list1 in
List.sort G_feature.compare raw_list2
(* ---------------------------------------------------------------------- *)
......@@ -357,8 +357,8 @@ module P_fs = struct
| _ -> Error.bug "Position can't be parametrized"
with Not_found -> true
let build domain ?pat_vars ast_fs =
let unsorted = List.map (P_feature.build domain ?pat_vars) ast_fs in
let build ?domain ?pat_vars ast_fs =
let unsorted = List.map (P_feature.build ?domain ?pat_vars) ast_fs in
List.sort P_feature.compare unsorted
let feat_list t = List.map P_feature.get_name t
......
......@@ -23,7 +23,7 @@ module G_fs: sig
(** [set_feat domain feature_name atom t] adds the feature ([feature_name],[atom]) in [t].
If [t] already contains a feature named [feature_name], the old value is erased by the new one. *)
val set_feat: ?loc:Loc.t -> Domain.t -> feature_name -> string -> t -> t
val set_feat: ?loc:Loc.t -> ?domain:Domain.t -> feature_name -> string -> t -> t
(** [del_feat feature_name t] remove the feature with name [feature_name] in [t].
If [t] does not contain such a feature, [t] is returned unchanged. *)
......@@ -48,9 +48,9 @@ module G_fs: sig
val to_string: t -> string
val build: Domain.t -> Ast.feature list -> t
val build: ?domain:Domain.t -> Ast.feature list -> t
val of_conll: ?loc:Loc.t -> Domain.t -> Conll.line -> t
val of_conll: ?loc:Loc.t -> ?domain:Domain.t -> Conll.line -> t
(** [unif t1 t2] returns [Some t] if [t] is the unification of two graph feature structures
[None] is returned if the two feature structures cannot be unified. *)
......@@ -64,7 +64,7 @@ module P_fs: sig
val empty: t
val build: Domain.t -> ?pat_vars: string list -> Ast.feature list -> t
val build: ?domain:Domain.t -> ?pat_vars: string list -> Ast.feature list -> t
val to_string: t -> string
......
......@@ -48,21 +48,21 @@ module P_graph = struct
| Some new_node -> Some (Pid_map.add id_src new_node map)
(* -------------------------------------------------------------------------------- *)
let build_filter domain table (ast_node, loc) =
let build_filter ?domain table (ast_node, loc) =
let pid = Id.build ~loc ast_node.Ast.node_id table in
let fs = P_fs.build domain ast_node.Ast.fs in
let fs = P_fs.build ?domain ast_node.Ast.fs in
(pid, fs)
(* -------------------------------------------------------------------------------- *)
let build domain ?pat_vars ?(locals=[||]) (full_node_list : Ast.node list) full_edge_list =
let build ?domain ?pat_vars ?(locals=[||]) (full_node_list : Ast.node list) full_edge_list =
(* NB: insert searches for a previous node with the Same name and uses unification rather than constraint *)
(* NB: insertion of new node at the end of the list: not efficient but graph building is not the hard part. *)
let rec insert (ast_node, loc) = function
| [] -> [P_node.build domain ?pat_vars (ast_node, loc)]
| [] -> [P_node.build ?domain ?pat_vars (ast_node, loc)]
| (node_id,fs)::tail when ast_node.Ast.node_id = node_id ->
begin
try (node_id, P_node.unif_fs (P_fs.build domain ?pat_vars ast_node.Ast.fs) fs) :: tail
try (node_id, P_node.unif_fs (P_fs.build ?domain ?pat_vars ast_node.Ast.fs) fs) :: tail
with Error.Build (msg,_) -> raise (Error.Build (msg,Some loc))
end
| head :: tail -> head :: (insert (ast_node, loc) tail) in
......@@ -88,11 +88,11 @@ module P_graph = struct
(fun acc (ast_edge, loc) ->
let i1 = Id.build ~loc ast_edge.Ast.src pos_table in
let i2 = Id.build ~loc ast_edge.Ast.tar pos_table in
let edge = P_edge.build domain (ast_edge, loc) in
let edge = P_edge.build ?domain (ast_edge, loc) in
(match map_add_edge acc (Pid.Pos i1) edge (Pid.Pos i2) with
| Some g -> g
| None -> Error.build "[GRS] [Graph.build] try to build a graph with twice the same edge %s %s"
(P_edge.to_string domain edge)
(P_edge.to_string ?domain edge)
(Loc.to_string loc)
)
) map_without_edges full_edge_list in
......@@ -109,9 +109,9 @@ module P_graph = struct
(* -------------------------------------------------------------------------------- *)
(* It may raise [P_fs.Fail_unif] in case of contradiction on constraints *)
let build_extension domain ?pat_vars ?(locals=[||]) pos_table full_node_list full_edge_list =
let build_extension ?domain ?pat_vars ?(locals=[||]) pos_table full_node_list full_edge_list =
let built_nodes = List.map (P_node.build domain ?pat_vars) full_node_list in
let built_nodes = List.map (P_node.build ?domain ?pat_vars) full_node_list in
let (old_nodes, new_nodes) =
List.partition
......@@ -155,7 +155,7 @@ module P_graph = struct
match Id.build_opt tar pos_table with
| Some i -> Pid.Pos i
| None -> Pid.Neg (Id.build ~loc tar new_table) in
let edge = P_edge.build domain (ast_edge, loc) in
let edge = P_edge.build ?domain (ast_edge, loc) in
match map_add_edge acc i1 edge i2 with
| Some map -> map
| None -> Log.fbug "[GRS] [Graph.build_extension] add_edge cannot fail in pattern extension"; exit 2
......@@ -240,9 +240,9 @@ module G_graph = struct
Gid_map.fold (fun gid _ acc -> fct gid acc) t.map init
(* is there an edge e out of node i ? *)
let edge_out domain graph node_id label_cst =
let edge_out ?domain graph node_id label_cst =
let node = Gid_map.find node_id graph.map in
Massoc_gid.exists (fun _ e -> Label_cst.match_ domain label_cst e) (G_node.get_next node)
Massoc_gid.exists (fun _ e -> Label_cst.match_ ?domain label_cst e) (G_node.get_next node)
let get_annot_info graph =
let annot_info =
......@@ -273,7 +273,7 @@ module G_graph = struct
| None -> None
(* -------------------------------------------------------------------------------- *)
let build domain ?(grewpy=false) ?(locals=[||]) gr_ast =
let build ?domain ?(grewpy=false) ?(locals=[||]) gr_ast =
let full_node_list =
if grewpy
then List.sort (Ast.grewpy_compare) gr_ast.Ast.nodes
......@@ -291,7 +291,7 @@ module G_graph = struct
else
let (new_tail, table) = loop (node_id :: already_bound) (index+1) (Some index) tail in
let succ = if tail = [] then None else Some (index+1) in
let (_,new_node) = G_node.build domain ?prec ?succ index (ast_node, loc) in
let (_,new_node) = G_node.build ?domain ?prec ?succ index (ast_node, loc) in
(
Gid_map.add index new_node new_tail,
(node_id,index)::table
......@@ -304,11 +304,11 @@ module G_graph = struct
(fun acc (ast_edge, loc) ->
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 (ast_edge, loc) in
let edge = G_edge.build ?domain (ast_edge, loc) in
(match map_add_edge acc i1 edge i2 with
| Some g -> g
| None -> Error.build "[GRS] [Graph.build] try to build a graph with twice the same edge %s %s"
(G_edge.to_string domain edge)
(G_edge.to_string ?domain edge)
(Loc.to_string loc)
)
) map_without_edges full_edge_list in
......@@ -316,7 +316,7 @@ module G_graph = struct
{meta=gr_ast.Ast.meta; map=map; fusion = []; highest_index = (List.length full_node_list) -1}
(* -------------------------------------------------------------------------------- *)
let of_conll domain conll =
let of_conll ?domain conll =
let sorted_lines = Conll.root :: (List.sort Conll.compare conll.Conll.lines) in
......@@ -326,10 +326,10 @@ module G_graph = struct
| [] -> Gid_map.empty
| [last] ->
let loc = Loc.file_opt_line conll.Conll.file last.Conll.line_num in
Gid_map.add index (G_node.of_conll domain ~loc ?prec last) Gid_map.empty
Gid_map.add index (G_node.of_conll ?domain ~loc ?prec last) Gid_map.empty
| line::tail ->
let loc = Loc.file_opt_line conll.Conll.file line.Conll.line_num in
Gid_map.add index (G_node.of_conll domain ~loc ?prec ~succ:(index+1) line)
Gid_map.add index (G_node.of_conll ?domain ~loc ?prec ~succ:(index+1) line)
(loop (index+1) (Some index) tail) in
let map_without_edges = loop 0 None sorted_lines in
......@@ -342,11 +342,11 @@ module G_graph = struct
List.fold_left
(fun acc2 (gov, dep_lab) ->
let gov_id = Id.gbuild ~loc gov gtable in
let edge = G_edge.make domain ~loc dep_lab in
let edge = G_edge.make ?domain ~loc dep_lab in
(match map_add_edge acc2 gov_id edge dep_id with
| Some g -> g
| None -> Error.build "[GRS] [Graph.of_conll] try to build a graph with twice the same edge %s %s"
(G_edge.to_string domain edge)
(G_edge.to_string ?domain edge)
(Loc.to_string loc)
)
) acc line.Conll.deps
......@@ -369,7 +369,7 @@ module G_graph = struct
(* -------------------------------------------------------------------------------- *)
(** input : "Le/DET/le petit/ADJ/petit chat/NC/chat dort/V/dormir ./PONCT/." *)
let of_brown domain ?sentid brown =
let of_brown ?domain ?sentid brown =
let units = Str.split (Str.regexp " ") brown in
let conll_lines = List.mapi
(fun i item -> match Str.full_split (Str.regexp "/[A-Z'+'']+/") item with
......@@ -381,7 +381,7 @@ module G_graph = struct
Conll.build_line ~id:(i+1) ~form ~lemma ~xpos:pos ~feats ~deps:([(i, "SUC")]) ()
| _ -> Error.build "[Graph.of_brown] Cannot parse Brown item >>>%s<<< (expected \"phon/POS/lemma\") in >>>%s<<<" item brown
) units in
of_conll domain { Conll.file=None; meta=[]; lines=conll_lines; multiwords=[] }
of_conll ?domain { Conll.file=None; meta=[]; lines=conll_lines; multiwords=[] }
(* -------------------------------------------------------------------------------- *)
let opt_att atts name =
......@@ -390,10 +390,10 @@ module G_graph = struct
(* -------------------------------------------------------------------------------- *)
(** [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 of_xml ?domain d_xml = failwith "of_xml not available"
(* -------------------------------------------------------------------------------- *)
let del_edge domain ?edge_ident loc graph id_src label id_tar =
let del_edge ?domain ?edge_ident loc graph id_src label id_tar =
let node_src =
try Gid_map.find id_src graph.map
with Not_found ->
......@@ -401,7 +401,7 @@ module G_graph = struct
| None -> Log.fcritical "[RUN] Some edge refers to a dead node, please report"
| Some id -> Error.run ~loc "[Graph.del_edge] cannot find source node of edge \"%s\"" id in
try {graph with map = Gid_map.add id_src (G_node.remove id_tar label node_src) graph.map}
with Not_found -> Error.run ~loc "[Graph.del_edge] cannot find edge '%s'" (G_edge.to_string domain label)
with Not_found -> Error.run ~loc "[Graph.del_edge] cannot find edge '%s'" (G_edge.to_string ?domain label)
(* -------------------------------------------------------------------------------- *)
let del_node graph node_id =
......@@ -439,10 +439,10 @@ module G_graph = struct
{ graph with map = new_map }
(* -------------------------------------------------------------------------------- *)
let add_neighbour loc domain graph node_id label = failwith "no more add_neighbour"
let add_neighbour loc ?domain graph node_id label = failwith "no more add_neighbour"
(* -------------------------------------------------------------------------------- *)
let insert domain id1 id2 graph =
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
......@@ -450,50 +450,50 @@ module G_graph = struct
let new_pos= (pos1 +. pos2) /. 2. in
let new_gid = graph.highest_index + 1 in
let map = graph.map
|> (Gid_map.add new_gid (G_node.fresh domain ~prec:id1 ~succ:id2 new_pos))
|> (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_gid })
(* -------------------------------------------------------------------------------- *)
let append domain id graph =
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_gid = graph.highest_index + 1 in
let map = graph.map
|> (Gid_map.add new_gid (G_node.fresh domain ~prec: