Commit 5699a5ca authored by bguillaum's avatar bguillaum

add functions for the -annot mode

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@8124 7838e531-6607-4d57-9587-6c381814729c
parent f3631754
......@@ -4,28 +4,21 @@ open Printf
open Grew_utils
open Grew_ast
let rm_first_char = function "" -> "" | s -> String.sub s 1 ((String.length s) - 1)
(* ================================================================================ *)
module Label = struct
(* [decl] is the type for a label declaration: the name and a list of display options *)
type decl = string * string list
(* Global names and display options are recorded in two aligned arrays *)
(** Global names and display styles are recorded in two aligned arrays *)
let full = ref None
let options = ref [||]
(* Internal representation of labels *)
(** Internal representation of labels *)
type t =
| Global of int
| Local of int
| No_domain of string
(* [init string_edge_list] updates global arrays [full] and [options] *)
let init string_edge_list =
let slist = List.sort (fun (x,_) (y,_) -> compare x y) string_edge_list in
let (labels, opts) = List.split slist in
full := Some (Array.of_list labels);
options := Array.of_list opts
| 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
......@@ -37,6 +30,79 @@ module Label = struct
| 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 -> ["style=dot"]
| 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
......@@ -45,10 +111,6 @@ module Label = struct
with Not_found ->
try Local (Array_.dicho_find_assoc string locals)
with Not_found -> Error.build "[Label.from_string] unknown edge label '%s'" string
let get_options = function
| Global l -> !options.(l)
| _ -> []
end (* module Label *)
......@@ -68,37 +130,14 @@ module G_edge = struct
| (true, _) -> Error.build "Negative edge spec are forbidden in graphs%s" (Loc.to_string loc)
| (false, _) -> Error.build "Only atomic edge valus are allowed in graphs%s" (Loc.to_string loc)
let rm_first_char = function "" -> "" | s -> String.sub s 1 ((String.length s) - 1)
let to_dep ?(deco=false) t = Label.to_dep ~deco t
let to_dot ?(deco=false) t = Label.to_dot ~deco t
let color_of_option = function
| [] -> None
| c::_ -> Some (rm_first_char c)
let to_dot ?(deco=false) l =
match color_of_option (Label.get_options l) with
| None -> Printf.sprintf "[label=\"%s\", color=%s]" (Label.to_string l) (if deco then "red" else "black")
| Some c -> Printf.sprintf "[label=\"%s\", fontcolor=%s, color=%s]" (Label.to_string l) c (if deco then "red" else "black")
let position_of_option options =
if List.mem "@bottom" options
then "bottom; "
else ""
let to_dep ?(deco=false) l =
let string = Label.to_string l in
let options = Label.get_options l in
let (prefix, label) = match Str.bounded_split (Str.regexp ":") string 2 with
| ["S"; l] -> (Some "S", l)
| ["D"; l] -> (Some "D", l)
| _ -> (None, string) in
let pos = if List.mem "@bottom" options || prefix = Some "D" then "; bottom" else "" in
let style = if deco then "; style=dot" else "" in
let color = match (List.filter (fun x -> x <> "@bottom") options, prefix) with
| (c::_, _) -> let col = rm_first_char c in sprintf "; color=%s; forecolor=%s" col col
| ([], Some "S") -> "; color=red; forecolor=red"
| ([], Some "D") -> "; color=blue; forecolor=blue"
| _ -> "" in
sprintf "{ label = \"%s\"%s%s%s}" label pos style color
end (* module G_edge *)
......
......@@ -156,6 +156,12 @@ module G_fs = struct
let get_atom = List_.sort_assoc
let get_annot_info fs =
match List.filter (fun (fn,value) -> String.length fn > 1 && String.sub fn 0 2 = "__") fs with
| [] -> None
| [(fn,value)] -> Some (fn,conll_string_of_value value)
| _ -> Error.build "[Fs.get_annot_info] More than one annot feature in the same feature structure"
let get_string_atom feat_name t =
match List_.sort_assoc feat_name t with
| None -> None
......
......@@ -35,6 +35,11 @@ module G_fs: sig
val to_raw: t -> (string * string) list
val to_conll: ?exclude: string list -> t -> string
(** [get_annot_info fs] searches for a feature with name starting with "__".
It returns the feature_name and the string representation of its feature value.
raise an [Build] exception if there is more than one such feature. *)
val get_annot_info: t -> (string * string) option
val to_string: t -> string
val build: Ast.feature list -> t
......
......@@ -236,6 +236,19 @@ module G_graph = struct
let node = Gid_map.find node_id graph.map in
Massoc_gid.exists (fun _ e -> P_edge.compatible p_edge e) (G_node.get_next node)
let get_annot_info graph =
let annot_info =
Gid_map.fold
(fun _ node acc ->
match (G_node.get_annot_info node, acc) with
| (None,_) -> acc
| (Some (f,v), None) -> Some (f,v,G_node.get_position node)
| (Some _, Some _) -> Error.build "[G_node.get_annot_info] Two nodes with annot info"
) graph.map None in
match annot_info with
| Some x -> x
| None -> Error.build "[G_node.get_annot_info] No nodes with annot info"
(* -------------------------------------------------------------------------------- *)
let map_add_edge map id_src label id_tar =
let node_src =
......
......@@ -88,6 +88,7 @@ module G_graph: sig
(** [edge_out t id edge] returns true iff there is an out-edge from the node [id] with a label compatible with [edge] *)
val edge_out: t -> Gid.t -> P_edge.t -> bool
val get_annot_info: t -> (string * string * float)
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
(* Build functions *)
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
......
......@@ -31,7 +31,7 @@ module Rewrite_history = struct
let rec loop file_name rules t =
match (t.good_nf, t.bad_nf) with
| [],[] when dot -> Instance.save_dot_png ?filter ?main_feat file_name t.instance; [rules, file_name]
| [],[] -> Instance.save_dep_png ?filter ?main_feat file_name t.instance; [rules, file_name]
| [],[] -> ignore (Instance.save_dep_png ?filter ?main_feat file_name t.instance); [rules, file_name]
| [],_ -> []
| l, _ ->
List_.foldi_left
......@@ -69,6 +69,21 @@ module Rewrite_history = struct
| _ -> Error.run "Not a single rewriting"
in loop t
let save_annot 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 (Filename.concat out_dir a) alt_1.instance in
let hpb = Instance.save_dep_svg (Filename.concat out_dir b) alt_2.instance in
let (afn,afv,apos) = G_graph.get_annot_info alt_1.instance.Instance.graph
and (bfn,bfv,bpos) = G_graph.get_annot_info alt_2.instance.Instance.graph in
(base_name,i,(afn,afv,apos),(bfn,bfv,bpos),(hpa,hpb))
| _ -> Error.run "Not two alternatives in an annotation rewriting in %s" base_name
) t.good_nf
let save_det_conll ?header base t =
let rec loop t =
match (t.good_nf, t.bad_nf) with
......
......@@ -27,6 +27,9 @@ module Rewrite_history: sig
t ->
((string * string list) list * string) list
(** [save_annot out_dir base_name t] writes a set of svg_file for an annotation folder. *)
val save_annot: string -> string -> t -> (string * int * (string*string*float) * (string*string*float) * (float option * float option)) list
(** [save_gr base_name t] saves one gr_file for each normal form defined in [t].
Output files are named according to [base_name] and the Gorn adress in the rewriting tree. *)
val save_gr: string -> t -> unit
......
This diff is collapsed.
......@@ -61,3 +61,7 @@ module Corpus_stat: sig
output_dir:string ->
t -> unit
end
module Html_annot: sig
val build: string -> string -> (string * Rewrite_history.t) list -> unit
end
......@@ -40,6 +40,8 @@ module G_node = struct
| Some l -> Some {t with next = l}
| None -> None
let get_annot_info t = G_fs.get_annot_info t.fs
let build ?def_position (ast_node, loc) =
let fs = G_fs.build ast_node.Ast.fs in
let position = match (ast_node.Ast.position, def_position) with
......
......@@ -37,6 +37,8 @@ module G_node: sig
val position_comp: t -> t -> int
val get_annot_info: t -> (string * string) option
val build_neighbour: t -> t
val rename: (Gid.t * Gid.t) list -> t -> t
......
......@@ -58,9 +58,20 @@ module Instance = struct
IFDEF DEP2PICT THEN
let save_dep_png ?filter ?main_feat base t =
ignore (Dep2pict.Dep2pict.fromDepStringToPng (G_graph.to_dep ?filter ?main_feat t.graph) (base^".png"))
let (_,_,highlight_position) =
Dep2pict.Dep2pict.fromDepStringToPng_with_pos
(G_graph.to_dep ?filter ?main_feat t.graph) (base^".png") in
highlight_position
let save_dep_svg ?filter ?main_feat base t =
let (_,_,highlight_position) =
Dep2pict.Dep2pict.fromDepStringToSvgFile_with_pos
(G_graph.to_dep ?filter ?main_feat t.graph) (base^".svg") in
highlight_position
ELSE
let save_dep_png ?filter ?main_feat base t = ()
let save_dep_png ?filter ?main_feat base t = None
let save_dep_svg ?filter ?main_feat base t = None
ENDIF
end (* module Instance *)
......@@ -836,20 +847,19 @@ module Rule = struct
(* type: Instance.t -> t list -> Instance_set.t *)
let normalize_instance modul_name instance rules =
let rec loop to_do nf =
if to_do = Instance_set.empty
then nf
let rec loop to_do_set nf_set =
if to_do_set = Instance_set.empty
then nf_set
else
let (new_to_do,new_nf) =
let (new_to_do_set,new_nf_set) =
Instance_set.fold
(fun v (to_do1,nf1) ->
let step_of_v = one_step v rules in
if step_of_v = [] (* nothing came out of v*)
then (to_do1,Instance_set.add (Instance.rev_steps v) nf1)
else (List.fold_left (fun acc v1 -> Instance_set.add v1 acc) to_do1 step_of_v,nf1)
(fun v (to_do_set_acc,nf_set_acc) ->
match one_step v rules with
| [] -> (to_do_set_acc,Instance_set.add (Instance.rev_steps v) nf_set_acc)
| step_of_v -> (List.fold_left (fun acc v1 -> Instance_set.add v1 acc) to_do_set_acc step_of_v, nf_set_acc)
)
to_do (Instance_set.empty,nf) in
loop new_to_do new_nf in
to_do_set (Instance_set.empty,nf_set) in
loop new_to_do_set new_nf_set in
let nfs = loop (Instance_set.singleton instance) Instance_set.empty in
let reduced_nfs = filter_equal_nfs nfs in
......@@ -857,9 +867,9 @@ module Rule = struct
let nfs_card = Instance_set.cardinal nfs in
if reduced_nfs_card < nfs_card
then Log.fwarning "In module \"%s\", %d nf are produced, only %d different ones" modul_name nfs_card reduced_nfs_card;
reduced_nfs
(* [filter_instance instance filters] return a boolean:
- true iff the instance does NOT match any pattern in [filters] *)
let filter_instance filters instance =
......
......@@ -35,7 +35,8 @@ module Instance : sig
(** [save_dep_png base t] writes a file "base.png" with the dep representation of [t].
NB: if the Dep2pict is not available, nothing is done *)
val save_dep_png: ?filter: string list -> ?main_feat: string -> string -> t -> unit
val save_dep_png: ?filter: string list -> ?main_feat: string -> string -> t -> float option
val save_dep_svg: ?filter: string list -> ?main_feat: string -> string -> t -> float option
(** [save_dot_png base t] writes a file "base.png" with the dot representation of [t] *)
val save_dot_png: ?filter: string list -> ?main_feat: string -> string -> t -> unit
......
......@@ -71,6 +71,9 @@ module File = struct
let read file =
let in_ch = open_in file in
(* if the input file contains an UTF-8 byte order mark (EF BB BF), skip 3 bytes, else get back to 0 *)
(match input_byte in_ch with 0xEF -> seek_in in_ch 3 | _ -> seek_in in_ch 0);
let rev_lines = ref [] in
try
while true do
......@@ -86,6 +89,9 @@ module File = struct
(* [read_ln file] returns a list of couples (line_num, line). Blank lines and lines starting with '%' are ignored. *)
let read_ln file =
let in_ch = open_in file in
(* if the input file contains an UTF-8 byte order mark (EF BB BF), skip 3 bytes, else get back to 0 *)
(match input_byte in_ch with 0xEF -> seek_in in_ch 3 | _ -> seek_in in_ch 0);
let cpt = ref 0 in
let rev_lines = ref [] in
try
......@@ -388,6 +394,14 @@ module List_ = struct
(fun (acc,i) elt -> (f i acc elt, i+1))
(init,0) l
)
let prev_next_iter fct list =
let int_fct prev next elt = fct ?prev ?next elt in
let rec loop prev = function
| [] -> ()
| [last] -> int_fct prev None last
| head::snd::tail -> int_fct prev (Some snd) head; loop (Some head) (snd::tail)
in loop None list
end (* module List_ *)
(* ================================================================================ *)
......
......@@ -153,6 +153,8 @@ module List_: sig
val sort_remove_assoc: 'a -> ('a * 'b) list -> ('a * 'b) list
val foldi_left: (int -> 'a -> 'b -> 'a) -> 'a -> 'b list -> 'a
val prev_next_iter: (?prev:'a -> ?next:'a -> 'a -> unit) -> 'a list -> unit
end
module type OrderedType =
......
......@@ -63,8 +63,8 @@ let build_html_doc ?(corpus=false) dir grs =
(* draw pattern graphs for all rules and all filters *)
let fct module_ rule_ =
let dep_code = Rule.to_dep rule_ in
let dep_svg_file = sprintf "%s/%s_%s-patt.png" dir module_ (Rule.get_name rule_) in
ignore (Dep2pict.Dep2pict.fromDepStringToPng dep_code dep_svg_file) in
let dep_png_file = sprintf "%s/%s_%s-patt.png" dir module_ (Rule.get_name rule_) in
ignore (Dep2pict.Dep2pict.fromDepStringToPng dep_code dep_png_file) in
Grs.rule_iter fct grs;
Grs.filter_iter fct grs
) ()
......@@ -151,12 +151,16 @@ let display ~gr ~grs ~seq =
let write_stat filename rew_hist =
handle ~name:"write_stat" (fun () -> Gr_stat.save filename (Gr_stat.from_rew_history rew_hist)) ()
let write_annot static_dir annot_dir base_name_rew_hist_list =
handle ~name:"write_annot" (fun () -> Html_annot.build static_dir annot_dir base_name_rew_hist_list) ()
let save_index ~dirname ~base_names =
handle ~name:"save_index" (fun () ->
let out_ch = open_out (Filename.concat dirname "index") in
List.iter (fun f -> fprintf out_ch "%s\n" f) base_names;
close_out out_ch
) ()
let save_graph_conll filename graph =
handle ~name:"save_graph_conll" (fun () ->
let out_ch = open_out filename in
......
......@@ -92,6 +92,8 @@ val raw_graph: Instance.t ->
val save_index: dirname:string -> base_names: string list -> unit
val write_annot: string -> string -> (string * Rewrite_history.t) list -> unit
val write_html:
?no_init: bool ->
?out_gr: bool ->
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment