Commit 48b71885 authored by bguillaum's avatar bguillaum

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
......
This diff is collapsed.
......@@ -56,7 +56,7 @@ module P_graph: sig
(** It raises [P_fs.Fail_unif] exception in case of inconsistent feature structures. *)
val build:
Domain.t ->
?domain:Domain.t ->
?pat_vars: string list ->
?locals: Label_domain.decl array ->
Ast.node list ->
......@@ -65,7 +65,7 @@ module P_graph: sig
(** It raises [P_fs.Fail_unif] exception in case of inconsistent feature structures. *)
val build_extension:
Domain.t ->
?domain:Domain.t ->
?pat_vars: string list ->
?locals: Label_domain.decl array ->
Id.table ->
......@@ -93,7 +93,7 @@ module G_graph: sig
val get_highest: 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] *)
val edge_out: Domain.t -> t -> Gid.t -> Label_cst.t -> bool
val edge_out: ?domain:Domain.t -> t -> Gid.t -> Label_cst.t -> bool
(** [get_annot_info graph] searches for exactly one node with an annot-feature (with name starting with "__").
It returns the annot-feature name without the prefix "__" together with the position.
......@@ -104,15 +104,15 @@ module G_graph: sig
(* Build functions *)
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
val build: Domain.t -> ?grewpy: bool -> ?locals: Label_domain.decl array -> Ast.gr -> t
val build: ?domain:Domain.t -> ?grewpy: bool -> ?locals: Label_domain.decl array -> Ast.gr -> t
val of_conll: Domain.t -> Conll.t -> t
val of_conll: ?domain:Domain.t -> Conll.t -> t
(** input : "Le/DET/le petit/ADJ/petit chat/NC/chat dort/V/dormir ./PONCT/."
It supposes that "SUC" is defined in current relations *)
val of_brown: Domain.t -> ?sentid: string -> string -> t
val of_brown: ?domain:Domain.t -> ?sentid: string -> string -> t
val of_xml: Domain.t -> Xml.xml -> t
val of_xml: ?domain:Domain.t -> Xml.xml -> t
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
(* Update functions *)
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
......@@ -128,34 +128,34 @@ module G_graph: sig
(** [del_edge ?edge_ident loc graph id_src label id_tar] removes the edge (id_src -[label]-> id_tar) from graph.
Log.critical if the edge is not in graph *)
val del_edge: Domain.t -> ?edge_ident: string -> Loc.t -> t -> Gid.t -> G_edge.t -> Gid.t -> t
val del_edge: ?domain:Domain.t -> ?edge_ident: string -> Loc.t -> t -> Gid.t -> G_edge.t -> Gid.t -> t
(** [del_node graph id] remove node [id] from [graph], with all its incoming and outcoming edges.
[graph] is unchanged if the node is not in it. *)
val del_node: t -> Gid.t -> t
val add_neighbour: Loc.t -> Domain.t -> t -> Gid.t -> G_edge.t -> (Gid.t * t)
val add_neighbour: Loc.t -> ?domain: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 add_before: Loc.t -> ?domain:Domain.t -> Gid.t -> t -> (Gid.t * t)
val add_after: Loc.t -> ?domain:Domain.t -> Gid.t -> t -> (Gid.t * t)
val merge_node: Loc.t -> Domain.t -> t -> Gid.t -> Gid.t -> t option
val merge_node: Loc.t -> ?domain: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 *)
val shift_in: Loc.t -> Domain.t -> Gid.t -> Gid.t -> Label_cst.t -> t -> t
val shift_in: Loc.t -> ?domain:Domain.t -> Gid.t -> Gid.t -> Label_cst.t -> t -> t
(** move all out-edges from id_src are moved to out-edges out off node id_tar *)
val shift_out: Loc.t -> Domain.t -> Gid.t -> Gid.t -> Label_cst.t -> t -> t
val shift_out: Loc.t -> ?domain:Domain.t -> Gid.t -> Gid.t -> Label_cst.t -> t -> t
(** move all incident arcs from/to id_src are moved to incident arcs on node id_tar from graph, with all its incoming and outcoming edges *)
val shift_edges: Loc.t -> Domain.t -> Gid.t -> Gid.t -> Label_cst.t -> t -> t
val shift_edges: Loc.t -> ?domain:Domain.t -> Gid.t -> Gid.t -> Label_cst.t -> t -> t
(** [update_feat domain tar_id tar_feat_name concat_items] sets the feature of the node [tar_id]
with feature name [tar_feat_name] to be the contatenation of values described by the [concat_items].
It returns both the new graph and the new feature value produced as the second element *)
val update_feat: ?loc:Loc.t -> Domain.t -> t -> Gid.t -> string -> Concat_item.t list -> (t * string)
val update_feat: ?loc:Loc.t -> ?domain:Domain.t -> t -> Gid.t -> string -> Concat_item.t list -> (t * string)
val set_feat: ?loc:Loc.t -> Domain.t -> t -> Gid.t -> string -> string -> t
val set_feat: ?loc:Loc.t -> ?domain:Domain.t -> t -> Gid.t -> string -> string -> t
(** [del_feat graph node_id feat_name] returns [graph] where the feat [feat_name] of [node_id] is deleted
If the feature is not present, [graph] is returned. *)
......@@ -164,13 +164,13 @@ module G_graph: sig
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
(* Output functions *)
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
val to_gr: Domain.t -> t -> string
val to_dot: Domain.t -> ?main_feat:string -> ?deco:G_deco.t -> t -> string
val to_gr: ?domain:Domain.t -> t -> string
val to_dot: ?domain:Domain.t -> ?main_feat:string -> ?deco:G_deco.t -> t -> string
val to_sentence: ?main_feat:string -> t -> string
val to_dep: Domain.t -> ?filter : string list -> ?main_feat:string -> ?deco:G_deco.t -> t -> string
val to_conll_string: Domain.t -> t -> string
val to_dep: ?domain:Domain.t -> ?filter : string list -> ?main_feat:string -> ?deco:G_deco.t -> t -> string
val to_conll_string: ?domain:Domain.t -> t -> string
val to_raw: Domain.t -> t ->
val to_raw: ?domain:Domain.t -> t ->
string list *
(string * string) list list *
(int * string * int) list
......
......@@ -43,11 +43,11 @@ module Rewrite_history = struct
| { good_nf = [] } -> 0 (* dead branch *)
| { good_nf = l} -> List.fold_left (fun acc t -> acc + (num_sol t)) 0 l
let save_nfs label_domain ?filter ?main_feat ~dot base_name t =
let save_nfs ?domain ?filter ?main_feat ~dot base_name t =
let rec loop file_name rules t =
match (t.good_nf, t.bad_nf) with
| [],[] when dot -> Instance.save_dot_png label_domain ?filter ?main_feat file_name t.instance; [rules, file_name]
| [],[] -> ignore (Instance.save_dep_png label_domain ?filter ?main_feat file_name t.instance); [rules, file_name]
| [],[] when dot -> Instance.save_dot_png ?domain ?filter ?main_feat file_name t.instance; [rules, file_name]
| [],[] -> ignore (Instance.save_dep_png ?domain ?filter ?main_feat file_name t.instance); [rules, file_name]
| [],_ -> []
| l, _ ->
List_.foldi_left
......@@ -62,78 +62,78 @@ module Rewrite_history = struct
[] l
in loop base_name [] t
let save_gr label_domain base t =
let save_gr ?domain base t =
let rec loop file_name t =
match (t.good_nf, t.bad_nf) with
| [],[] -> File.write (Instance.to_gr label_domain t.instance) (file_name^".gr")
| [],[] -> File.write (Instance.to_gr ?domain t.instance) (file_name^".gr")
| l, _ -> List.iteri (fun i son -> loop (sprintf "%s_%d" file_name i) son) l
in loop base t
let save_conll label_domain base t =
let save_conll ?domain base t =
let rec loop file_name t =
match (t.good_nf, t.bad_nf) with
| [],[] -> File.write (Instance.to_conll_string label_domain t.instance) (file_name^".conll")
| [],[] -> File.write (Instance.to_conll_string ?domain t.instance) (file_name^".conll")
| l, _ -> List.iteri (fun i son -> loop (sprintf "%s_%d" file_name i) son) l
in loop base t
let save_full_conll label_domain base t =
let save_full_conll ?domain base t =
let cpt = ref 0 in
let rec loop t =
match (t.good_nf, t.bad_nf) with
| [],[] ->
File.write (Instance.to_conll_string label_domain t.instance) (sprintf "%s__%d.conll" base !cpt);
File.write (Instance.to_conll_string ?domain t.instance) (sprintf "%s__%d.conll" base !cpt);
incr cpt
| l, _ -> List.iter loop l
in loop t; !cpt
(* suppose that all modules are confluent and produced exacly one normal form *)
let save_det_gr label_domain base t =
let save_det_gr ?domain base t =
let rec loop t =
match (t.good_nf, t.bad_nf) with
| [],[] -> File.write (Instance.to_gr label_domain t.instance) (base^".gr")
| [],[] -> File.write (Instance.to_gr ?domain t.instance) (base^".gr")
| [one], [] -> loop one
| _ -> Error.run "[save_det_gr] Not a single rewriting"
in loop t
let save_annot label_domain out_dir base_name t =
let save_annot ?domain out_dir base_name t =
List.mapi
(fun i alts ->
match alts.good_nf with
| [alt_1; alt_2] ->
let a = sprintf "%s_%d_A" base_name i in
let b = sprintf "%s_%d_B" base_name i in
let hpa = Instance.save_dep_svg label_domain (Filename.concat out_dir a) alt_1.instance in
let hpb = Instance.save_dep_svg label_domain (Filename.concat out_dir b) alt_2.instance in
let hpa = Instance.save_dep_svg ?domain (Filename.concat out_dir a) alt_1.instance in
let hpb = Instance.save_dep_svg ?domain (Filename.concat out_dir b) alt_2.instance in
let (afn,apos) = G_graph.get_annot_info alt_1.instance.Instance.graph
and (bfn,bpos) = G_graph.get_annot_info alt_2.instance.Instance.graph in
(base_name,i,(afn,apos),(bfn,bpos),(hpa,hpb))
| _ -> Error.run "Not two alternatives in an annotation rewriting in %s" base_name
) t.good_nf
let save_det_conll label_domain ?header base t =
let save_det_conll ?domain ?header base t =
let rec loop t =
match (t.good_nf, t.bad_nf) with
| ([],[]) ->
let output =
match header with
| Some h -> sprintf "%% %s\n%s" h (Instance.to_conll_string label_domain t.instance)
| None -> Instance.to_conll_string label_domain t.instance in
| Some h -> sprintf "%% %s\n%s" h (Instance.to_conll_string ?domain t.instance)
| None -> Instance.to_conll_string ?domain t.instance in
File.write output (base^".conll")
| ([one], []) -> loop one
| _ -> Error.run "[save_det_conll] Not a single rewriting"
in loop t
let det_dep_string label_domain t =
let det_dep_string ?domain t =
let rec loop t =
match (t.good_nf, t.bad_nf) with
| [],[] ->
let graph = t.instance.Instance.graph in
Some (G_graph.to_dep label_domain graph)
Some (G_graph.to_dep ?domain graph)
| [one], [] -> loop one
| _ -> None
in loop t
let conll_dep_string label_domain ?(keep_empty_rh=false) t =
let conll_dep_string ?domain ?(keep_empty_rh=false) t =
if (not keep_empty_rh) && is_empty t
then None
else
......@@ -141,7 +141,7 @@ module Rewrite_history = struct
match (t.good_nf, t.bad_nf) with
| [],[] ->
let graph = t.instance.Instance.graph in
Some (G_graph.to_conll_string label_domain graph)
Some (G_graph.to_conll_string ?domain graph)
| [one], [] -> loop one
| _ -> None
in loop t
......@@ -167,10 +167,10 @@ module Modul = struct
| r::tail -> loop ((Rule.get_name r) :: already_defined) tail in
loop [] t.rules
let build domain ast_module =
let build ?domain 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 domain ~locals ast_module.Ast.mod_dir) ast_module.Ast.rules in
let rules_or_filters = List.map (Rule.build ?domain ~locals ast_module.Ast.mod_dir) ast_module.Ast.rules in
let (filters, rules) = List.partition Rule.is_filter rules_or_filters in
let modul =
{
......@@ -220,7 +220,7 @@ end (* module Sequence *)
module Grs = struct
type t = {
domain: Domain.t;
domain: Domain.t option;
modules: Modul.t list; (* the ordered list of modules used from rewriting *)
sequences: Sequence.t list;
filename: string;
......@@ -233,7 +233,7 @@ module Grs = struct
let get_domain t = t.domain
let sequence_names t = List.map (fun s -> s.Sequence.name) t.sequences
let empty = {domain=Domain.empty; modules=[]; sequences=[]; ast=Ast.empty_grs; filename=""; }
let empty = {domain=None; modules=[]; sequences=[]; ast=Ast.empty_grs; filename=""; }
let check t =
(* check for duplicate modules *)
......@@ -252,15 +252,18 @@ module Grs = struct
| s::tail -> loop (s.Sequence.name :: already_defined) tail in
loop [] t.sequences
let domain_build ast_domain =
Domain.build
let domain_build= function
| {Ast.label_domain=[]; feature_domain=[]} -> None
| ast_domain -> Some (
Domain.build
(Label_domain.build ast_domain.Ast.label_domain)
(Feature_domain.build ast_domain.Ast.feature_domain)
)
let build filename =
let ast = Loader.grs filename in
let domain = domain_build ast.Ast.domain in
let modules = List.map (Modul.build domain) ast.Ast.modules in
let modules = List.map (Modul.build ?domain) ast.Ast.modules in
let grs = {domain; sequences = List.map (Sequence.build modules) ast.Ast.sequences; modules; ast; filename} in
check grs;
grs
......@@ -293,7 +296,7 @@ module Grs = struct
| next::tail ->
let (good_set, bad_set) =
Rule.normalize
grs.domain
?domain: grs.domain
next.Modul.name
~confluent: next.Modul.confluent
next.Modul.rules
......@@ -319,7 +322,7 @@ module Grs = struct
| next :: tail ->
let (good_set, bad_set) =
Rule.normalize
grs.domain
?domain: grs.domain
next.Modul.name
~confluent: next.Modul.confluent
next.Modul.rules
......
......@@ -34,7 +34,7 @@ module Rewrite_history: sig
- returns a list of couples (rules, file)
*)
val save_nfs:
Domain.t ->
?domain:Domain.t ->