Commit 6576f632 authored by bguillaum's avatar bguillaum

reorganisation of code (new file grew_domain)

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@9146 7838e531-6607-4d57-9587-6c381814729c
parent eeae0985
......@@ -2,11 +2,12 @@ digraph grew {
node [shape=Mrecord];
rankdir = LR;
grew_base [label="grew_base|String_map\nString_set\nInt_map\nInt_set\nString_\nDot\nLoc\nFile\nArray_\nList_\nMassoc_make()\nError\nId\nTimeout\nGlobal"]
grew_types [label="grew_types|Pid(_map\|_set)\nGid(_map)\nMassoc[_gid\|_pid]\nLabel_domain\nFeature_domain\nDomain\nLabel\nFeature_value\nLex_par\nConcat_item"]
grew_types [label="grew_types|Pid(_map\|_set)\nGid(_map)\nMassoc[_gid\|_pid]\nLex_par\nConcat_item"]
grew_ast [label="grew_ast|Ast"]
grew_domain [label="grew_domain|Label_domain\nFeature_domain\nDomain"]
grew_loader [label="grew_loader|Loader\nParser"]
grew_fs [label="grew_fs|G_feature\nP_feature\nG_fs\nP_fs"]
grew_edge [label="grew_edge|Label_cst\nG_edge\nP_edge"]
grew_fs [label="grew_fs|Feature_value\nG_feature\nP_feature\nG_fs\nP_fs"]
grew_edge [label="grew_edge|Label\nLabel_cst\nG_edge\nP_edge"]
grew_node [label="grew_node|G_node\nP_node"]
grew_command [label="grew_command|Command"]
grew_graph [label="grew_graph|P_deco\nP_graph\nG_deco\nG_graph"]
......@@ -14,9 +15,9 @@ digraph grew {
grew_grs [label="grew_grs|Rewrite_history\nModul\nGrs"]
grew_html [label="grew_html|Html_doc\nHtml_rh\nHtml_sentences\nHtml_annot\nGr_stat\nCorpus_stat"]
grew_ast -> grew_types -> grew_base
grew_edge -> grew_ast
grew_fs -> grew_ast
grew_domain -> grew_ast -> grew_types -> grew_base
grew_edge -> grew_domain
grew_fs -> grew_domain
grew_command -> grew_edge
grew_command -> grew_fs
grew_node -> grew_edge
......
......@@ -364,10 +364,27 @@ module Ast = struct
| Modul of modul
| Includ of (string * Loc.t)
type feature_spec =
| Closed of feature_name * feature_atom list (* cat:V,N *)
| Open of feature_name (* phon, lemma, ... *)
| Num of feature_name (* position *)
let build_closed feature_name feature_values =
let sorted_list = List.sort Pervasives.compare feature_values in
let without_duplicate =
let rec loop = function
| [] -> []
| x::y::tail when x=y ->
Log.fwarning "In the declaration of the feature name \"%s\", the value \"%s\" appears more than once" feature_name x;
loop (y::tail)
| x::tail -> x:: (loop tail)
in loop sorted_list in
Closed (feature_name, without_duplicate)
type domain = {
feature_domain: Feature_domain.feature_spec list;
label_domain: (string * string list) list;
}
feature_domain: feature_spec list;
label_domain: (string * string list) list;
}
type domain_wi = Dom of domain | Dom_file of string
......
......@@ -180,8 +180,15 @@ module Ast : sig
| Modul of modul
| Includ of (string * Loc.t)
type feature_spec =
| Closed of feature_name * feature_atom list (* cat:V,N *)
| Open of feature_name (* phon, lemma, ... *)
| Num of feature_name (* position *)
val build_closed: feature_name -> feature_atom list -> feature_spec
type domain = {
feature_domain: Feature_domain.feature_spec list;
feature_domain: feature_spec list;
label_domain: (string * string list) list;
}
......
......@@ -13,7 +13,7 @@ open Log
open Grew_base
open Grew_types
open Grew_domain
open Grew_ast
open Grew_edge
open Grew_fs
......
......@@ -11,7 +11,7 @@
open Grew_ast
open Grew_base
open Grew_types
open Grew_domain
open Grew_edge
(* ================================================================================ *)
......
(**********************************************************************************)
(* Libcaml-grew - a Graph Rewriting library dedicated to NLP applications *)
(* *)
(* Copyright 2011-2013 Inria, Université de Lorraine *)
(* *)
(* Webpage: http://grew.loria.fr *)
(* License: CeCILL (see LICENSE folder or "http://www.cecill.info") *)
(* Authors: see AUTHORS file *)
(**********************************************************************************)
open Printf
open Log
open Grew_base
open Grew_types
open Grew_ast
(* ================================================================================ *)
module Label_domain = struct
(** describe the display style of a label *)
type line = Solid | Dot | Dash
type style = {
text: string;
bottom: bool;
color: string option;
bgcolor: string option;
line: line;
}
let is_void style = (style.text = "void")
type t = string array * style array
(** The [default] style value *)
let default = { text="UNSET"; bottom=false; color=None; bgcolor=None; line=Solid }
(** [decl] is the type for a label declaration: the name and a list of display styles *)
type decl = string * string list
(** Computes the style of a label from its options and maybe its shape (like I:...). *)
let parse_option string_label options =
let init_style = match Str.bounded_split (Str.regexp ":") string_label 2 with
| ["S"; l] -> {default with text=l; color=Some "red"}
| ["D"; l] -> {default with text=l; color=Some "blue"; bottom=true}
| ["I"; l] -> {default with text=l; color=Some "grey"}
| _ -> {default with text=string_label} in
List.fold_left
(fun acc_style -> function
| "@bottom" -> {acc_style with bottom=true}
| "@dash" -> {acc_style with line=Dash}
| "@dot" -> {acc_style with line=Dot}
| s when String.length s > 4 && String.sub s 0 4 = "@bg_" ->
let color = String.sub s 4 ((String.length s) - 4) in
{acc_style with bgcolor=Some color}
| s -> {acc_style with color=Some (String_.rm_first_char s)}
) init_style options
(* [build decl_list] returns a label_domain *)
let build decl_list =
let slist = List.sort (fun (x,_) (y,_) -> compare x y) decl_list in
let (labels, opts) = List.split slist in
let labels_array = Array.of_list labels in
(labels_array,
Array.mapi (fun i opt -> parse_option labels_array.(i) opt) (Array.of_list opts)
)
let to_dep ?(deco=false) style =
let dep_items =
(if style.bottom then ["bottom"] else [])
@ (match style.color with Some c -> ["color="^c; "forecolor="^c] | None -> [])
@ (match style.bgcolor with Some c -> ["bgcolor="^c] | None -> [])
@ (match style.line with
| Dot -> ["style=dot"]
| Dash -> ["style=dash"]
| Solid when deco -> ["bgcolor=yellow"]
| Solid -> []) in
sprintf "{ label = \"%s\"; %s}" style.text (String.concat "; " dep_items)
let dot_color string =
match (string.[0], String.length string) with
| ('#', 4) -> sprintf "\"#%c%c%c%c%c%c\"" string.[1] string.[1] string.[2] string.[2] string.[3] string.[3]
| ('#', 7) -> sprintf "\"%s\"" string
| _ -> string
let to_dot ?(deco=false) style =
let dot_items =
(match style.color with Some c -> let d = dot_color c in ["color="^d; "fontcolor="^d] | None -> [])
@ (match style.line with
| Dot -> ["style=dotted"]
| Dash -> ["style=dashed"]
| Solid when deco -> ["style=dotted"]
| Solid -> []) in
sprintf "[label=\"%s\", %s]" style.text (String.concat ", " dot_items)
end
(* ================================================================================ *)
module Feature_domain = struct
type t = Ast.feature_spec list
let is_defined feature_name feature_domain =
List.exists (function
| Ast.Closed (fn,_) when fn = feature_name -> true
| Ast.Open fn when fn = feature_name -> true
| Ast.Num fn when fn = feature_name -> true
| _ -> false
) feature_domain
let rec build = function
| [] -> [Ast.Num "position"]
| (Ast.Num "position") :: tail -> Log.warning "[Feature_domain] declaration of the feature name \"position\" in useless"; build tail
| (Ast.Open "position") :: _
| (Ast.Closed ("position",_)) :: _ ->
Error.build "[Feature_domain] The feature named \"position\" is reserved and must be types 'integer', you cannot not redefine it"
| (Ast.Num fn) :: tail | (Ast.Open fn) :: tail | Ast.Closed (fn,_) :: tail when is_defined fn tail ->
Error.build "[Feature_domain] The feature named \"%s\" is defined several times" fn
| x :: tail -> x :: (build tail)
let feature_names feature_domain =
List.map (function Ast.Closed (fn, _) | Ast.Open fn | Ast.Num fn -> fn) feature_domain
let get feature_name feature_domain =
List.find (function
| Ast.Closed (fn,_) when fn = feature_name -> true
| Ast.Open fn when fn = feature_name -> true
| Ast.Num fn when fn = feature_name -> true
| _ -> false
) feature_domain
let sub feature_domain name1 name2 =
match (get name1 feature_domain, get name2 feature_domain) with
| (_, Ast.Open _) -> true
| (Ast.Closed (_,l1), Ast.Closed (_,l2)) -> List_.sort_include l1 l2
| (Ast.Num _, Ast.Num _) -> true
| _ -> false
let is_open feature_domain name =
List.exists (function Ast.Open n when n=name -> true | _ -> false) feature_domain
(* This function is defined here because it is used by check_feature *)
let build_disj ?loc ?feature_domain name unsorted_values =
let values = List.sort Pervasives.compare unsorted_values in
match (feature_domain, name.[0]) with
| (None, _)
| (Some _, '_') -> List.map (fun s -> String s) values (* no check on feat_name starting with '_' *)
| (Some dom, _) ->
let rec loop = function
| [] -> Error.build ?loc "[GRS] Unknown feature name '%s'" name
| ((Ast.Open n)::_) when n = name ->
List.map (fun s -> String s) values
| ((Ast.Num n)::_) when n = name ->
(try List.map (fun s -> Float (String_.to_float s)) values
with Failure _ -> Error.build ?loc "[GRS] The feature '%s' is of type int" name)
| ((Ast.Closed (n,vs))::_) when n = name ->
(match List_.sort_diff values vs with
| [] -> List.map (fun s -> String s) values
| l when List.for_all (fun x -> x.[0] = '_') l -> List.map (fun s -> String s) values
| l -> Error.build ?loc "Unknown feature values '%s' for feature name '%s'"
(List_.to_string (fun x->x) ", " l)
name
)
| _::t -> loop t in
loop dom
let check_feature ?loc ?feature_domain name value =
ignore (build_disj ?loc ?feature_domain name [value])
end (* Feature_domain *)
(* ================================================================================ *)
module Domain = struct
type t = Label_domain.t * Feature_domain.t
let build ld fd = (ld, fd)
let build_disj ?loc ?domain name unsorted_values =
match domain with
| Some (_, feature_domain) -> Feature_domain.build_disj ?loc ~feature_domain name unsorted_values
| None -> Feature_domain.build_disj ?loc name unsorted_values
let feature_names (_, feature_domain) = Feature_domain.feature_names feature_domain
let get_label_name ?domain index = match domain with
| Some ((names,_),_) -> Some names.(index)
| None -> None
let get_label_style ?domain index = match domain with
| Some ((_,styles),_) -> Some styles.(index)
| None -> None
let edge_id_from_string ?loc ?domain str = match domain with
| Some ((names,_),_) ->
begin
try Some (Id.build ?loc str names)
with Not_found -> Error.build "[Domain.edge_id_from_string] unknown edge label '%s'" str
end
| None -> None
let is_open_feature ?domain name = match domain with
| Some (_, feature_domain) -> Feature_domain.is_open feature_domain name
| None -> true
let check_feature ?loc ?domain name value = match domain with
| Some (_, feature_domain) -> Feature_domain.check_feature ?loc ~feature_domain name value
| None -> ()
let check_feature_name ?loc ?domain name = match domain with
| None -> ()
| Some (_, feature_domain) ->
if not (Feature_domain.is_defined name feature_domain)
then Error.build ?loc "The feature name \"%s\" in not defined in the domain" name
end
(**********************************************************************************)
(* Libcaml-grew - a Graph Rewriting library dedicated to NLP applications *)
(* *)
(* Copyright 2011-2013 Inria, Université de Lorraine *)
(* *)
(* Webpage: http://grew.loria.fr *)
(* License: CeCILL (see LICENSE folder or "http://www.cecill.info") *)
(* Authors: see AUTHORS file *)
(**********************************************************************************)
open Grew_base
open Grew_types
open Grew_ast
(* ================================================================================ *)
module Label_domain : sig
type style
val parse_option: string -> string list -> style
val is_void: style -> bool
val to_dep: ?deco:bool -> style -> string
val to_dot: ?deco:bool -> style -> string
type t
(* [decl] is the type for a label declaration: the name and a list of display options *)
type decl = string * string list
val build: decl list -> t
end
(* ================================================================================ *)
module Feature_domain: sig
type t
val build: Ast.feature_spec list -> t
(** [sub domain fn1 fn2] returns [true] iff the domain of [fn1] is a subset if the domain of [fn2]. *)
val sub: t -> feature_name -> feature_name -> bool
end (* module Feature_domain *)
(* ================================================================================ *)
module Domain : sig
type t
val build: Label_domain.t -> Feature_domain.t -> t
val build_disj : ?loc:Loc.t -> ?domain:t ->
feature_name ->
feature_atom list -> value list
val feature_names: t -> string list
val get_label_name: ?domain:t -> int -> string option
val get_label_style: ?domain:t -> int -> Label_domain.style option
val edge_id_from_string: ?loc:Loc.t -> ?domain:t -> string -> int option
(** [is_open_feature domain feature_name] returns [true] iff no domain is set or if [feature_name] is defined to be open in the current domain. *)
val is_open_feature: ?domain: t -> feature_name -> bool
(** [check_feature ~loc domain feature_name feature_value] fails iff a domain is set and [feature_name,feature_value] is not defined in the current domain. *)
val check_feature: ?loc:Loc.t -> ?domain: t -> feature_name -> feature_atom -> unit
(** [check_feature_name ~loc domain feature_name] fails iff a domain is set and [feature_name] is not defined in the current domain. *)
val check_feature_name: ?loc:Loc.t -> ?domain:t -> feature_name -> unit
end
......@@ -14,6 +14,55 @@ open Printf
open Grew_base
open Grew_types
open Grew_ast
open Grew_domain
(* ================================================================================ *)
module Label = struct
(** Internal representation of labels *)
type t = int
(* a array for no label not defined in a domain (no more than 100 labels!) *)
let no_domain = Array.make 100 ""
let no_domain_size = ref 0
let match_list p_label_list g_label = List.exists (fun p_label -> p_label = g_label) p_label_list
let to_string ?domain i =
match Domain.get_label_name ?domain i with
| Some s -> s
| None when i < !no_domain_size -> no_domain.(i)
| _ -> Log.bug "Inconsistency in [Label.to_string]"; exit 1
let get_style ?domain i =
match Domain.get_label_style ?domain i with
| Some s -> s
| None -> Label_domain.parse_option no_domain.(i) []
let is_void ?domain t = Label_domain.is_void (get_style ?domain t)
let to_dep ?domain ?(deco=false) t =
let style = get_style ?domain t in
Label_domain.to_dep ~deco style
let to_dot ?domain ?(deco=false) t =
let style = get_style ?domain t in
Label_domain.to_dot ~deco style
let from_string ?loc ?domain ?(locals=[||]) str =
match Domain.edge_id_from_string ?loc ?domain str with
| Some id -> id
| None ->
let rec loop = function
| 100 -> Log.bug "[Label.from_string] you cannot use more than 100 diff label without domain"; exit 1
| i when i >= !no_domain_size ->
no_domain.(i) <- str;
incr no_domain_size;
i
| i when no_domain.(i) = str -> i
| i -> loop (i+1) in
loop 0
end (* module Label *)
(* ================================================================================ *)
(** The module [Label_cst] defines contraints on label edges *)
......
......@@ -10,8 +10,28 @@
open Grew_base
open Grew_types
open Grew_ast
open Grew_domain
(* ================================================================================ *)
(** The module [Label] defines the type of atomic label edges *)
module Label : sig
type t
(** [match_list p_label_list g_label] returns [true] iff [g_label] match at least one of the p_label of [p_label_list] *)
val match_list: t list -> t -> bool
val to_string: ?domain:Domain.t -> t -> string
val is_void: ?domain: Domain.t -> t -> bool
val to_dep: ?domain: Domain.t -> ?deco:bool -> t -> string
val to_dot: ?domain: Domain.t -> ?deco:bool -> t -> string
val from_string: ?loc:Loc.t -> ?domain: Domain.t -> ?locals:Label_domain.decl array -> string -> t
end (* module Label *)
(* ================================================================================ *)
(** The module [Label_cst] defines contraints on label edges *)
......
......@@ -15,9 +15,21 @@ open Conll
open Grew_base
open Grew_types
open Grew_ast
open Grew_domain
let decode_feat_name s = Str.global_replace (Str.regexp "__\\([0-9a-z]+\\)$") "[\\1]" s
(* ================================================================================ *)
module Feature_value = struct
let build_disj ?loc ?domain name unsorted_values =
Domain.build_disj ?loc ?domain name unsorted_values
let build_value ?loc ?domain name value =
match build_disj ?loc ?domain name [value] with
| [x] -> x
| _ -> Error.bug ?loc "[Feature_value.build_value]"
end (* module Feature_value *)
(* ================================================================================ *)
module G_feature = struct
......
......@@ -13,6 +13,15 @@ open Conll
open Grew_base
open Grew_types
open Grew_ast
open Grew_domain
(* ================================================================================ *)
module Feature_value: sig
val build_disj: ?loc:Loc.t -> ?domain: Domain.t -> feature_name -> feature_atom list -> value list
val build_value: ?loc:Loc.t -> ?domain: Domain.t -> feature_name -> feature_atom -> value
end (* module Feature_domain *)
(* ================================================================================ *)
(* module [G_fs] defines the feature structures that are used in graphs *)
......
......@@ -12,8 +12,8 @@ open Conll
open Grew_base
open Grew_types
open Grew_ast
open Grew_domain
open Grew_fs
open Grew_edge
open Grew_node
......
......@@ -15,6 +15,7 @@ open Grew_fs
open Grew_base
open Grew_types
open Grew_ast
open Grew_domain
open Grew_edge
open Grew_command
open Grew_graph
......
......@@ -10,9 +10,10 @@
open Grew_base
open Grew_types
open Grew_ast
open Grew_domain
open Grew_graph
open Grew_rule
open Grew_ast
(* ================================================================================ *)
module Rewrite_history: sig
......
......@@ -14,6 +14,7 @@ open Log
open Grew_base
open Grew_types
open Grew_ast
open Grew_domain
open Grew_graph
open Grew_rule
open Grew_grs
......@@ -385,9 +386,9 @@ module Html_doc = struct
wnl " <code class=\"code\">";
List.iter
(function
| Feature_domain.Closed (feat_name,values) -> wnl "<b>%s</b> : %s<br/>" feat_name (String.concat " | " values)
| Feature_domain.Open feat_name -> wnl " <b>%s</b> : *<br/>" feat_name
| Feature_domain.Num feat_name -> wnl " <b>%s</b> : #<br/>" feat_name
| Ast.Closed (feat_name,values) -> wnl "<b>%s</b> : %s<br/>" feat_name (String.concat " | " values)
| Ast.Open feat_name -> wnl " <b>%s</b> : *<br/>" feat_name
| Ast.Num feat_name -> wnl " <b>%s</b> : #<br/>" feat_name
) ast.Ast.feature_domain;
wnl " </code>";
......
......@@ -9,6 +9,7 @@
(**********************************************************************************)
open Grew_types
open Grew_domain
open Grew_rule
open Grew_grs
open Grew_graph
......
......@@ -12,6 +12,7 @@ open Conll
open Grew_base
open Grew_types
open Grew_domain
open Grew_fs
open Grew_edge
open Grew_ast
......
......@@ -270,13 +270,13 @@ feature:
| feature_name=feature_name DDOT feature_values=features_values
{
match feature_values with
| ["#"] -> Feature_domain.Num feature_name
| _ -> Feature_domain.build_closed feature_name feature_values
| ["#"] -> Ast.Num feature_name
| _ -> Ast.build_closed feature_name feature_values
}
/* phon:* */
| feature_name=feature_name DDOT STAR
{ Feature_domain.Open feature_name }
{ Ast.Open feature_name }
feature_name:
| ci=ID { ci }
......
......@@ -15,8 +15,8 @@ open Dep2pict
open Grew_base
open Grew_types
open Grew_ast
open Grew_domain
open Grew_edge
open Grew_fs
open Grew_node
......
......@@ -10,7 +10,7 @@
open Grew_base
open Grew_types
open Grew_domain
open Grew_graph
open Grew_command
open Grew_edge
......
This diff is collapsed.
......@@ -63,79 +63,6 @@ module Massoc_gid : S with type key = Gid.t
(* ================================================================================ *)
module Massoc_pid : S with type key = Pid.t
(* ================================================================================ *)
module Label_domain : sig
type t
(* [decl] is the type for a label declaration: the name and a list of display options *)
type decl = string * string list
val build: decl list -> t
end
(* ================================================================================ *)
module Feature_domain: sig
type feature_spec =
| Closed of feature_name * feature_atom list (* cat:V,N *)
| Open of feature_name (* phon, lemma, ... *)
| Num of feature_name (* position *)
type t
val build: feature_spec list -> t
(** [sub domain fn1 fn2] returns [true] iff the domain of [fn1] is a subset if the domain of [fn2]. *)
val sub: t -> feature_name -> feature_name -> bool
val build_closed: feature_name -> feature_atom list -> feature_spec
end (* module Feature_domain *)
(* ================================================================================ *)
module Domain : sig
type t
val build: Label_domain.t -> Feature_domain.t -> t
val feature_names: t -> string list
(** [is_open_feature domain feature_name] returns [true] iff no domain is set or if [feature_name] is defined to be open in the current domain. *)
val is_open_feature: ?domain: t -> feature_name -> bool
(** [check_feature ~loc domain feature_name feature_value] fails iff a domain is set and [feature_name,feature_value] is not defined in the current domain. *)
val check_feature: ?loc:Loc.t -> ?domain: t -> feature_name -> feature_atom -> unit
(** [check_feature_name ~loc domain feature_name] fails iff a domain is set and [feature_name] is not defined in the current domain. *)
val check_feature_name: ?loc:Loc.t -> ?domain:t -> feature_name -> unit
end
(* ================================================================================ *)
(** The module [Label] defines the type of atomic label edges *)
module Label : sig
type t
(** [match_list p_label_list g_label] returns [true] iff [g_label] match at least one of the p_label of [p_label_list] *)
val match_list: t list -> t -> bool
val to_string: ?domain:Domain.t -> t -> string
val is_void: ?domain: Domain.t -> t -> bool
val to_dep: ?domain: Domain.t -> ?deco:bool -> t -> string
val to_dot: ?domain: Domain.t -> ?deco:bool -> t -> string
val from_string: ?loc:Loc.t -> ?domain: Domain.t -> ?locals:Label_domain.decl array -> string -> t
end (* module Label *)
(* ================================================================================ *)
module Feature_value: sig
val build_disj: ?loc:Loc.t -> ?domain: Domain.t -> feature_name -> feature_atom list -> value list
val build_value: ?loc:Loc.t -> ?domain: Domain.t -> feature_name -> feature_atom -> value
end (* module Feature_domain *)
(* ================================================================================ *)
(** module for rules that are lexically parametrized *)
module Lex_par: sig
......
......@@ -57,13 +57,13 @@ let handle ?(name="") ?(file="No file defined") fct () =
(** {2 Domain} *)
(* ==================================================================================================== *)
module Domain = struct
type t = Grew_types.Domain.t
type t = Grew_domain.Domain.t
let load filename =
let ast = Grew_loader.Loader.domain filename in
Grew_grs.Grs.domain_build ast
let feature_names domain = handle ~name:"feature_names" (fun () -> Grew_types.Domain.feature_names domain) ()
let feature_names domain = handle ~name:"feature_names" (fun () -> Grew_domain.Domain.feature_names domain) ()
end
(* ==================================================================================================== *)
......@@ -271,9 +271,6 @@ module Rewrite = struct
let simple_rewrite ~gr ~grs ~strat =
handle ~name:"Rewrite.simple_rewrite" (fun () -> Grew_grs.Grs.simple_rewrite grs strat gr) ()
let get_graphs rh =