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

dev/arch.dot

@@ -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

src/grew_ast.ml

@@ -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
 

src/grew_ast.mli

@@ -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;
     }
 

src/grew_command.ml

@@ -13,7 +13,7 @@ open Log
 
 open Grew_base
 open Grew_types
-
+open Grew_domain
 open Grew_ast
 open Grew_edge
 open Grew_fs

src/grew_command.mli

@@ -11,7 +11,7 @@
 open Grew_ast
 open Grew_base
 open Grew_types
-
+open Grew_domain
 open Grew_edge
 
 (* ================================================================================ *)

src/grew_domain.ml

+(**********************************************************************************)
+(*    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

src/grew_domain.mli

+(**********************************************************************************)
+(*    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
+

src/grew_edge.ml

@@ -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 *)

src/grew_edge.mli

@@ -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 *)

src/grew_fs.ml

@@ -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
 

src/grew_fs.mli

@@ -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 *)

src/grew_graph.mli

@@ -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

src/grew_grs.ml

@@ -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

src/grew_grs.mli

@@ -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

src/grew_html.ml

@@ -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>";
 

src/grew_html.mli

@@ -9,6 +9,7 @@
 (**********************************************************************************)
 
 open Grew_types
+open Grew_domain
 open Grew_rule
 open Grew_grs
 open Grew_graph

src/grew_node.mli

@@ -12,6 +12,7 @@ open Conll
 
 open Grew_base
 open Grew_types
+open Grew_domain
 open Grew_fs
 open Grew_edge
 open Grew_ast

src/grew_parser.mly

@@ -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 }

src/grew_rule.ml

@@ -15,8 +15,8 @@ open Dep2pict