Commit d4b24e62 authored by bguillaum's avatar bguillaum

Split grew_base -> new file grew_types

Move module Label from grew_edge to grew_types

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@8445 7838e531-6607-4d57-9587-6c381814729c
parent 6fbcbc60
PRE_FILES_DEP = grew_base grew_ast
PRE_FILES_DEP = grew_base grew_types grew_ast
PRE_FILES_CMO = $(PRE_FILES_DEP:%=%.cmo)
PRE_FILES_CMX = $(PRE_FILES_DEP:%=%.cmx)
......@@ -93,22 +93,6 @@ endif
DEPENDS_DIR= -I parser
###### grew_core.ml ##############################################################
GREW_CORE_DEP = libgrew_types
GREW_CORE_CMI = $(GREW_CORE_DEP:%=%.cmi)
GREW_CORE_CMO = $(GREW_CORE_DEP:%=%.cmo)
GREW_CORE_CMX = $(GREW_CORE_DEP:%=%.cmx)
grew_core.cmi: $(GREW_CORE_CMI) grew_core.mli
$(OCAMLC) -c grew_core.mli
grew_core.cmo: $(GREW_CORE_CMO) parser_byte grew_core.cmi grew_core.ml
$(OCAMLC) $(BYTE_FLAGS) -c $(DEPENDS_DIR) $(GREW_CORE_CMO) grew_core.ml
grew_core.cmx: $(GREW_CORE_CMX) parser_opt grew_core.cmi grew_core.ml
$(OCAMLOPT) $(OPT_FLAGS) -c $(DEPENDS_DIR) $(GREW_CORE_CMX) grew_core.ml
################################################################################
###### grew_base.ml ##############################################################
GREW_UTILS_DEP =
GREW_UTILS_CMI = $(GREW_UTILS_DEP:%=%.cmi)
......@@ -125,9 +109,24 @@ grew_base.cmx: $(GREW_UTILS_CMX) grew_base.cmi grew_base.ml
$(OCAMLOPT) $(OPT_FLAGS) -c $(DEPENDS_DIR) grew_base.ml
################################################################################
###### grew_types.ml ##############################################################
GREW_UTILS_DEP = grew_base
GREW_UTILS_CMI = $(GREW_UTILS_DEP:%=%.cmi)
GREW_UTILS_CMO = $(GREW_UTILS_DEP:%=%.cmo)
GREW_UTILS_CMX = $(GREW_UTILS_DEP:%=%.cmx)
grew_types.cmi: $(GREW_UTILS_CMI) grew_types.mli
$(OCAMLC) -c grew_types.mli
grew_types.cmo: $(GREW_UTILS_CMO) grew_types.cmi grew_types.ml
$(OCAMLC) $(BYTE_FLAGS) -c $(DEPENDS_DIR) grew_types.ml
grew_types.cmx: $(GREW_UTILS_CMX) grew_types.cmi grew_types.ml
$(OCAMLOPT) $(OPT_FLAGS) -c $(DEPENDS_DIR) grew_types.ml
################################################################################
###### grew_ast.ml ##############################################################
GREW_AST_DEP = grew_base
GREW_AST_DEP = grew_base grew_types
GREW_AST_CMI = $(GREW_AST_DEP:%=%.cmi)
GREW_AST_CMO = $(GREW_AST_DEP:%=%.cmo)
GREW_AST_CMX = $(GREW_AST_DEP:%=%.cmx)
......@@ -160,7 +159,7 @@ grew_html.cmx: $(GREW_HTML_CMX) grew_html.cmi grew_html.ml
################################################################################
###### grew_fs.ml ##############################################################
GREW_FS_DEP = grew_base grew_ast
GREW_FS_DEP = grew_base grew_types grew_ast
GREW_FS_CMI = $(GREW_FS_DEP:%=%.cmi)
GREW_FS_CMO = $(GREW_FS_DEP:%=%.cmo)
GREW_FS_CMX = $(GREW_FS_DEP:%=%.cmx)
......@@ -177,7 +176,7 @@ grew_fs.cmx: $(GREW_FS_CMX) grew_fs.cmi grew_fs.ml
###### grew_edge.ml ##############################################################
GREW_EDGE_DEP = grew_base grew_ast
GREW_EDGE_DEP = grew_base grew_types grew_ast
GREW_EDGE_CMI = $(GREW_EDGE_DEP:%=%.cmi)
GREW_EDGE_CMO = $(GREW_EDGE_DEP:%=%.cmo)
GREW_EDGE_CMX = $(GREW_EDGE_DEP:%=%.cmx)
......@@ -194,7 +193,7 @@ grew_edge.cmx: $(GREW_EDGE_CMX) grew_edge.cmi grew_edge.ml
###### grew_node.ml ##############################################################
GREW_NODE_DEP = grew_base grew_ast grew_fs grew_edge
GREW_NODE_DEP = grew_base grew_types grew_ast grew_fs grew_edge
GREW_NODE_CMI = $(GREW_NODE_DEP:%=%.cmi)
GREW_NODE_CMO = $(GREW_NODE_DEP:%=%.cmo)
GREW_NODE_CMX = $(GREW_NODE_DEP:%=%.cmx)
......@@ -211,7 +210,7 @@ grew_node.cmx: $(GREW_NODE_CMX) grew_node.cmi grew_node.ml
###### grew_graph.ml ##############################################################
GREW_GRAPH_DEP = grew_base grew_ast grew_command grew_edge grew_fs grew_node
GREW_GRAPH_DEP = grew_base grew_types grew_ast grew_command grew_edge grew_fs grew_node
GREW_GRAPH_CMI = $(GREW_GRAPH_DEP:%=%.cmi)
GREW_GRAPH_CMO = $(GREW_GRAPH_DEP:%=%.cmo)
GREW_GRAPH_CMX = $(GREW_GRAPH_DEP:%=%.cmx)
......@@ -245,7 +244,7 @@ libgrew_types.cmx: $(LIBGREW_TYPES_CMX) libgrew_types.cmi libgrew_types.ml
###### grew_command.ml ##############################################################
GREW_COMMAND_DEP = grew_base grew_ast grew_edge grew_fs
GREW_COMMAND_DEP = grew_base grew_types grew_ast grew_edge grew_fs
GREW_COMMAND_CMI = $(GREW_COMMAND_DEP:%=%.cmi)
GREW_COMMAND_CMO = $(GREW_COMMAND_DEP:%=%.cmo)
GREW_COMMAND_CMX = $(GREW_COMMAND_DEP:%=%.cmx)
......@@ -262,7 +261,7 @@ grew_command.cmx: $(GREW_COMMAND_CMX) grew_command.cmi grew_command.ml
###### grew_rule.ml ##############################################################
GREW_RULE_DEP = grew_base grew_ast grew_command grew_edge grew_fs grew_node libgrew_types grew_graph
GREW_RULE_DEP = grew_base grew_types grew_ast grew_command grew_edge grew_fs grew_node libgrew_types grew_graph
GREW_RULE_CMI = $(GREW_RULE_DEP:%=%.cmi)
GREW_RULE_CMO = $(GREW_RULE_DEP:%=%.cmo)
GREW_RULE_CMX = $(GREW_RULE_DEP:%=%.cmx)
......@@ -287,7 +286,7 @@ endif
###### grew_grs.ml ##############################################################
GREW_GRS_DEP = grew_base grew_edge libgrew_types grew_graph grew_rule
GREW_GRS_DEP = grew_base grew_types grew_edge libgrew_types grew_graph grew_rule
GREW_GRS_CMI = $(GREW_GRS_DEP:%=%.cmi)
GREW_GRS_CMO = $(GREW_GRS_DEP:%=%.cmo)
GREW_GRS_CMX = $(GREW_GRS_DEP:%=%.cmx)
......
......@@ -12,6 +12,7 @@ open Printf
open Log
open Grew_base
(* ================================================================================ *)
module Ast = struct
let dot_split s = Str.split (Str.regexp "\\.") s
let get_single s = match dot_split s with
......
......@@ -9,12 +9,9 @@
(**********************************************************************************)
open Grew_base
open Grew_types
module Ast : sig
type feature_name = string (* cat, num, ... *)
type feature_atom = string (* V, N, inf, ... *)
type feature_value = string (* V, 4, "free text", ... *)
type suffix = string
(* -------------------------------------------------------------------------------- *)
(* complex_id: V, V#alpha, V.cat, V#alpha.cat, p_obj.loc *)
......@@ -46,7 +43,6 @@ module Ast : sig
type act_qfn = act_id * feature_name
val act_qfn_of_ci: complex_id -> act_qfn
type feature_spec =
| Closed of feature_name * feature_atom list (* cat:V,N *)
| Open of feature_name (* phon, lemma, ... *)
......@@ -155,9 +151,6 @@ module Ast : sig
seq_loc:Loc.t;
}
(**
a GRS: graph rewriting system
*)
type module_or_include =
| Modul of modul
| Includ of (string * Loc.t)
......@@ -169,6 +162,7 @@ module Ast : sig
sequences_wi: sequence list;
}
(* a GRS: graph rewriting system *)
type grs = {
domain: domain;
labels: (string * string list) list;
......
......@@ -60,6 +60,7 @@ module String_ = struct
let of_float float = Str.global_replace (Str.regexp ",") "." (sprintf "%g" float)
let rm_first_char = function "" -> "" | s -> String.sub s 1 ((String.length s) - 1)
end (* module String_ *)
(* ================================================================================ *)
......@@ -117,84 +118,6 @@ module File = struct
List.rev !rev_lines
end (* module File *)
(* ================================================================================ *)
module Pid = struct
(* type t = int *)
type t = Pos of int | Neg of int
let compare = Pervasives.compare
let to_id = function
| Pos i -> sprintf "p_%d" i
| Neg i -> sprintf "n_%d" i
let to_string = function
| Pos i -> sprintf "Pos %d" i
| Neg i -> sprintf "Neg %d" i
end (* module Pid *)
(* ================================================================================ *)
module Pid_map =
struct
include Map.Make (Pid)
exception True
let exists fct map =
try
iter
(fun key value ->
if fct key value
then raise True
) map;
false
with True -> true
(* let range key_set m = *)
(* IntSet.fold (fun k s -> (IntSet.add (find k m) s)) key_set IntSet.empty *)
(* let keys m = *)
(* fold (fun k v s -> (IntSet.add k s)) m IntSet.empty *)
(* union of two maps*)
let union_map m m' = fold (fun k v m'' -> (add k v m'')) m m'
end (* module Pid_map *)
(* ================================================================================ *)
module Pid_set = Set.Make (Pid)
(* ================================================================================ *)
module Gid = struct
type t =
| Old of int
| New of (int * int) (* identifier for "created nodes" *)
| Act of (int * string) (* identifier for "activated nodes" *)
(* a compare function which ensures that new nodes are at the "end" of the graph *)
let compare t1 t2 = match (t1,t2) with
| Old o1, Old o2 -> Pervasives.compare o1 o2
| Old _ , New _ -> -1
| New _, Old _ -> 1
| New n1, New n2 -> Pervasives.compare n1 n2
| Old _ , Act _ -> -1
| Act _, Old _ -> 1
| Act n1, Act n2 -> Pervasives.compare n1 n2
| Act _ , New _ -> -1
| New _, Act _ -> 1
let to_string = function
| Old i -> sprintf "%d" i
| New (i,j) -> sprintf"%d__%d" i j
| Act (i,n) -> sprintf"%d____%s" i n
end (* module Gid *)
(* ================================================================================ *)
module Gid_map = Map.Make (Gid)
(* ================================================================================ *)
module Array_ = struct
let dicho_mem elt array =
......@@ -583,13 +506,6 @@ module Massoc_make (Ord: OrderedType) = struct
end (* module Massoc_make *)
(* ================================================================================ *)
module Massoc_gid = Massoc_make (Gid)
(* ================================================================================ *)
module Massoc_pid = Massoc_make (Pid)
(* ================================================================================ *)
module Id = struct
type name = string
......@@ -630,165 +546,6 @@ module Html = struct
fprintf out_ch "</html>\n";
end (* module Html *)
(* ================================================================================ *)
module Conll = struct
type line = {
line_num: int;
num: string;
phon: string;
lemma: string;
pos1: string;
pos2: string;
morph: (string * string) list;
deps: (string * string ) list;
}
let root = { line_num = -1; num="0"; phon="ROOT"; lemma="__"; pos1="_X"; pos2=""; morph=[]; deps=[] }
let line_to_string l =
let (gov_list, lab_list) = List.split l.deps in
sprintf "%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s"
l.num l.phon l.lemma l.pos1 l.pos2
(match l.morph with [] -> "_" | list -> String.concat "|" (List.map (fun (f,v) -> sprintf "%s=%s" f v) list))
(String.concat "|" (gov_list))
(String.concat "|" (lab_list))
let parse_morph file_name line_num = function
| "_" -> []
| morph ->
List.map
(fun feat ->
match Str.split (Str.regexp "=") feat with
| [feat_name] -> (feat_name, "true")
| [feat_name; feat_value] -> (feat_name, feat_value)
| _ -> Error.build ~loc:(file_name,line_num) "[Conll.load] illegal morphology \n>>>>>%s<<<<<<" morph
) (Str.split (Str.regexp "|") morph)
let underscore s = if s = "" then "_" else s
let parse_line file_name (line_num, line) =
match Str.split (Str.regexp "\t") line with
| [ num; phon; lemma; pos1; pos2; morph; govs; dep_labs; _; _ ] ->
begin
try
let gov_list = if govs = "_" then [] else Str.split (Str.regexp "|") govs
and lab_list = if dep_labs = "_" then [] else Str.split (Str.regexp "|") dep_labs in
let deps = List.combine gov_list lab_list in
{line_num = line_num;
num = num;
phon = underscore phon;
lemma = underscore lemma;
pos1 = underscore pos1;
pos2 = underscore pos2;
morph = parse_morph file_name line_num morph;
deps = deps;
}
with exc -> Error.build ~loc:(file_name,line_num) "[Conll.load] illegal line, exc=%s\n>>>>>%s<<<<<<" (Printexc.to_string exc) line
end
| l -> Error.build ~loc:(file_name,line_num) "[Conll.load] illegal line, %d fields (10 are expected)\n>>>>>%s<<<<<<" (List.length l) line
let load file_name =
let lines = File.read_ln file_name in
List.map (parse_line file_name) lines
let parse file_name lines = List.map (parse_line file_name) lines
(* We would prefer to compare the float equivalent of l1.num l2.num but this would break the dicho_find function *)
let compare l1 l2 = Pervasives.compare ((* float_of_string *) l1.num) ((* float_of_string *) l2.num)
end (* module Conll *)
(* ================================================================================ *)
(* This module defines a type for lexical parameter (i.e. one line in a lexical file) *)
module Lex_par = struct
type item = string list * string list (* first list: pattern parameters $id , second list command parameters @id *)
type t = item list
let empty=[]
let append = List.append
let dump t =
printf "[Lex_par.dump] --> size = %d\n" (List.length t);
List.iter (fun (pp,cp) ->
printf "%s##%s\n"
(String.concat "#" pp)
(String.concat "#" cp)
) t
let rm_peripheral_white s =
Str.global_replace (Str.regexp "\\( \\|\t\\)*$") ""
(Str.global_replace (Str.regexp "^\\( \\|\t\\)*") "" s)
let parse_line ?loc nb_p nb_c line =
let line = rm_peripheral_white line in
if line = "" || line.[0] = '%'
then None
else
match Str.split (Str.regexp "##") line with
| [args] when nb_c = 0 ->
(match Str.split (Str.regexp "#") args with
| l when List.length l = nb_p -> Some (l,[])
| _ -> Error.bug ?loc
"Illegal lexical parameter line: \"%s\" doesn't contain %d args"
line nb_p)
| [args; values] ->
(match (Str.split (Str.regexp "#") args, Str.split (Str.regexp "#") values) with
| (lp,lc) when List.length lp = nb_p && List.length lc = nb_c -> Some (lp,lc)
| _ -> Error.bug ?loc
"Illegal lexical parameter line: \"%s\" doesn't contain %d args and %d values"
line nb_p nb_c)
| _ -> Error.bug ?loc "Illegal param line: '%s'" line
let from_lines ?loc nb_p nb_c lines = List_.opt_map (parse_line ?loc nb_p nb_c) lines
let load ?loc dir nb_p nb_c file =
try
let full_file =
if Filename.is_relative file
then Filename.concat dir file
else file in
let lines = File.read full_file in
List_.opt_mapi (fun i line -> parse_line ~loc:(full_file,i) nb_p nb_c line) lines
with Sys_error _ -> Error.build ?loc "External lexical file '%s' not found" file
let sub x y = List.mem x (Str.split (Str.regexp "|") y)
let filter index atom t =
match
List_.opt_map
(fun (p_par, c_par) ->
let par = List.nth p_par index in
if atom=par
then Some (p_par, c_par)
else
if sub atom par (* atom is one of the values of the disjunction par *)
then Some (List_.set index atom p_par, c_par)
else None
) t
with
| [] -> None
| t -> Some t
let get_param_value index = function
| [] -> Error.bug "[Lex_par.get_command_value] empty parameter"
| (params,_)::_ -> List.nth params index
let get_command_value index = function
| [(_,one)] -> List.nth one index
| [] -> Error.bug "[Lex_par.get_command_value] empty parameter"
| (_,[sing])::tail when index=0 ->
Printf.sprintf "%s/%s"
sing
(List_.to_string
(function
| (_,[s]) -> s
| _ -> Error.bug "[Lex_par.get_command_value] inconsistent param"
) "/" tail
)
| l -> Error.run "Lexical parameter are not functionnal"
end (* module Lex_par *)
(* ================================================================================ *)
(* copy from leopar *)
module Timeout = struct
......
......@@ -22,6 +22,10 @@ module String_: sig
(* [to_float]: robust conversion of float to string whatever is the locale *)
val of_float: float -> string
(* [rm_first_char s] returns the string [s] without the first charater if s is not empty.
If s in empty, the empty string is returned *)
val rm_first_char: string -> string
end
......@@ -53,48 +57,10 @@ module File: sig
Blanks lines (empty or only with spaces and tabs) are ignored.
Lines with '%' as the first char are ignored. *)
val read: string -> string list
end
(* ================================================================================ *)
(* [Pid] describes identifier used in pattern graphs *)
module Pid : sig
type t = Pos of int | Neg of int
val compare: t -> t -> int
val to_id: t -> string
val to_string: t -> string
end
(* ================================================================================ *)
(* [Pid_map] is the map used in pattern graphs *)
module Pid_map : sig
include Map.S with type key = Pid.t
val exists: (key -> 'a -> bool) -> 'a t -> bool
val read_ln: string -> (int * string) list
end
(* ================================================================================ *)
(* [Pid_set] *)
module Pid_set : Set.S with type elt = Pid.t
(* ================================================================================ *)
(* [Gid] describes identifier used in full graphs *)
module Gid : sig
type t =
| Old of int
| New of (int * int) (* identifier for "created nodes" *)
| Act of (int * string) (* identifier for "activated nodes" *)
val compare: t -> t -> int
val to_string: t -> string
end
(* ================================================================================ *)
(* [Gid_map] is the map used in full graphs *)
module Gid_map : Map.S with type key = Gid.t
(* ================================================================================ *)
(* [Array_] contains additional functions on the caml [array] type. *)
module Array_: sig
......@@ -120,11 +86,15 @@ module List_: sig
val rm: 'a -> 'a list -> 'a list
val opt: 'a option list -> 'a list
val set: int -> 'a -> 'a list -> 'a list
(** [pos elt list] return [Some index] if [index] is the smallest position in the [list] equals to [elt]. None is returned if [elt] is not in the [list] *)
val pos: 'a -> 'a list -> int option
val opt_map: ('a -> 'b option) -> 'a list -> 'b list
val opt_mapi: (int -> 'a -> 'b option) -> 'a list -> 'b list
val flat_map: ('a -> 'b list) -> 'a list -> 'b list
(* remove [elt] from [list]. raise Not_found if [elt] is not in [list] *)
val remove: 'a -> 'a list -> 'a list
......@@ -230,12 +200,6 @@ module type S =
module Massoc_make (Ord : OrderedType) : S with type key = Ord.t
module Massoc_gid : S with type key = Gid.t
module Massoc_pid : S with type key = Pid.t
module Error: sig
exception Build of (string * Loc.t option)
exception Run of (string * Loc.t option)
......@@ -246,9 +210,6 @@ module Error: sig
val bug: ?loc: Loc.t -> ('a, unit, string, 'b) format4 -> 'a
end
module Id: sig
type name = string
type t = int
......@@ -266,58 +227,6 @@ module Html: sig
val leave: out_channel -> unit
end
module Conll: sig
type line = {
line_num: int;
num: string;
phon: string;
lemma: string;
pos1: string;
pos2: string;
morph: (string * string) list;
deps: (string * string ) list;
}
val line_to_string: line -> string
val root:line
val load: string -> line list
val parse: string -> (int * string) list -> line list
val compare: line -> line -> int
end
(** module for rule that are lexically parametrized *)
module Lex_par: sig
type t
val empty:t
val append: t -> t -> t
val dump: t -> unit
(** [from_lines filename nb_pattern_var nb_command_var strings] *)
val from_lines: ?loc: Loc.t -> int -> int -> string list -> t
(** [load ?loc local_dir_name nb_pattern_var nb_command_var file] *)
val load: ?loc: Loc.t -> string -> int -> int -> string -> t
(** [filter index atom t] returns the subset of [t] which contains only entries
which refers to [atom] at the [index]^th pattern_var.
[None] is returnes if no such entry s founded.
*)
val filter: int -> string -> t -> t option
(** [get_param_value index t] returns the [index]^th param_var. *)
val get_param_value: int -> t -> string
(** [get_command_value index t] supposes that [t] contains iny one element.
It returns the [index]^th command_var. *)
val get_command_value: int -> t -> string
end
module Timeout: sig
exception Stop
......
......@@ -12,6 +12,8 @@ open Printf
open Log
open Grew_base
open Grew_types
open Grew_ast
open Grew_edge
open Grew_fs
......
......@@ -10,6 +10,8 @@
open Grew_ast
open Grew_base
open Grew_types
open Grew_edge
(* ==================================================================================================== *)
......@@ -60,7 +62,7 @@ module Command : sig
(Ast.act_id list * string list) ->
Id.table ->
Label.decl array ->
Ast.suffix list ->
suffix list ->
Ast.command ->
t * (Ast.act_id list * string list)
end (* module Command *)
......@@ -12,126 +12,15 @@ open Log
open Printf
open Grew_base
open Grew_types
open Grew_ast
let rm_first_char = function "" -> "" | s -> String.sub s 1 ((String.length s) - 1)
(* ================================================================================ *)
module Label = struct
(** Global names and display styles are recorded in two aligned arrays *)
let full = ref None
(** Internal representation of labels *)
type t =
| Global of int (* globally defined labels: their names are in the [full] array *)
| Local of int (* locally defined labels: names array should be provided! UNTESTED *)
| No_domain of string (* out of domain label: name in not constrained *)
(** [to_string t] returns a string for the label *)
let to_string ?(locals=[||]) t =
match (!full, t) with
| (_, No_domain s) -> s
| (Some table, Global i) -> table.(i)
| (Some _, Local i) -> fst locals.(i)
| _ -> Error.bug "[Label.to_string] inconsistent data"
let to_int = function
| Global i -> Some i
| _ -> None
(** 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;
}
(** The [default] style value *)
let default = { text="UNSET"; bottom=false; color=None; bgcolor=None; line=Solid }
let styles = ref ([||] : style array)
let get_style = function
| Global i -> !styles.(i)
| Local i -> Log.warning "Style of locally defined labels is not implemented"; default
| No_domain s -> { default with text=s }
(** 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 (rm_first_char s)}
) init_style options
(** [decl] is the type for a label declaration: the name and a list of display styles *)
type decl = string * string list
(* [init decl_list] updates global arrays [full] and [styles] *)
let init 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
full := Some labels_array;
styles := Array.mapi (fun i opt -> parse_option labels_array.(i) opt) (Array.of_list opts)
let to_dep ?(deco=false) t =
let style = get_style t in
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 to_dot ?(deco=false) t =
let style = get_style t in
let dot_items =
(match style.color with Some c -> ["color="^c; "fontcolor="^c] | 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)
let from_string ?loc ?(locals=[||]) string =
match !full with
| None -> No_domain string
| Some table ->
try Global (Id.build ?loc string table)
with Not_found ->
try Local (Array_.dicho_find_assoc string locals)