Commit 605c253d authored by bguillaum's avatar bguillaum

new highlight of the matching of rules with background yellow

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@8321 7838e531-6607-4d57-9587-6c381814729c
parent 07406e97
......@@ -98,7 +98,7 @@ module Label = struct
@ (match style.line with
| Dot -> ["style=dot"]
| Dash -> ["style=dash"]
| Solid when deco -> ["style=dot"]
| Solid when deco -> ["bgcolor=yellow"]
| Solid -> []) in
sprintf "{ label = \"%s\"; %s}" style.text (String.concat "; " dep_items)
......
......@@ -92,6 +92,12 @@ module G_feature = struct
match Str.split (Str.regexp ":C:") string_val with
| [] -> Error.bug "[G_feature.to_dot] feature value '%s'" string_val
| fv::_ -> sprintf "%s=%s" feat_name fv
let buff_dot buff (feat_name, feat_val) =
let string_val = string_of_value feat_val in
match Str.split (Str.regexp ":C:") string_val with
| [] -> Error.bug "[G_feature.to_dot] feature value '%s'" string_val
| fv::_ -> bprintf buff "<TR><TD ALIGN=\"right\">%s</TD><TD>=</TD><TD ALIGN=\"left\">%s</TD></TR>\n" feat_name fv
end
(* ==================================================================================================== *)
......@@ -217,35 +223,77 @@ module G_fs = struct
let main_list = match main_feat with
| None -> ["phon"]
| Some string -> Str.split (Str.regexp "\\( *; *\\)\\|#") string in
let rec loop = function
| [] -> (None, t)
| feat_name :: tail ->
match List_.sort_assoc feat_name t with
| Some atom -> (Some atom, List_.sort_remove_assoc feat_name t)
| Some atom -> (Some (feat_name, atom), List_.sort_remove_assoc feat_name t)
| None -> loop tail in
loop main_list
let to_dot ?main_feat t =
match get_main ?main_feat t with
| (None, _) -> List_.to_string G_feature.to_dot "\\n" t
| (Some atom, sub) ->
sprintf "{%s|%s}" (string_of_value atom) (List_.to_string G_feature.to_dot "\\n" sub)
let to_dot ?(decorated_feat=("",[])) ?main_feat t =
printf "DEBUG: decorated_feat=[%s]\n%!" (String.concat ";" (snd decorated_feat));
let buff = Buffer.create 32 in
bprintf buff "<TABLE BORDER=\"0\" CELLBORDER=\"0\" CELLSPACING=\"0\">\n";
let () = match (fst decorated_feat) with
| "" -> ()
| pid -> bprintf buff "<TR><TD COLSPAN=\"3\" BGCOLOR=\"yellow\"><B>[%s]</B></TD></TR>\n" pid in
let next =
match get_main ?main_feat t with
| (None, sub) -> sub
| (Some (feat_name,atom), sub) ->
if List.mem feat_name (snd decorated_feat)
then bprintf buff "<TR><TD COLSPAN=\"3\" BGCOLOR=\"yellow\"><B>%s</B></TD></TR>\n" (string_of_value atom)
else bprintf buff "<TR><TD COLSPAN=\"3\"><B>%s</B></TD></TR>\n" (string_of_value atom);
sub in
List.iter
(fun g_feat ->
G_feature.buff_dot buff g_feat
) next;
bprintf buff "</TABLE>\n";
Buffer.contents buff
let to_word ?main_feat t =
match get_main ?main_feat t with
| (None, _) -> "#"
| (Some atom, _) -> string_of_value atom
| (Some (_,atom), _) -> string_of_value atom
let to_dep ?position ?main_feat ?filter t =
let to_dep ?(decorated_feat=("",[])) ?position ?main_feat ?filter t =
let (main_opt, sub) = get_main ?main_feat t in
let last = match position with Some f when f > 0. -> [("position", Float f)] | _ -> [] in
let reduced_sub = match filter with
| None -> sub @ last
| Some l -> (List.filter (fun (fn,_) -> List.mem fn l) sub) @ last in
sprintf " word=\"%s\"; subword=\"%s\""
(match main_opt with Some atom -> string_of_value atom | None -> "_")
(List_.to_string G_feature.to_string "#" reduced_sub)
let (pid_name, feat_list) = decorated_feat in
let main = match main_opt with
| None -> []
| Some (feat_name, atom) ->
[ if List.mem feat_name (snd decorated_feat)
then sprintf "%s:B:yellow" (string_of_value atom)
else string_of_value atom] in
let word_list = match pid_name with
| "" -> main
| _ -> (sprintf "[%s]:B:yellow" pid_name)::main in
let word = match word_list with
| [] -> "_"
| l -> String.concat "#" l in
let last = match position with
| Some f when f > 0. -> [G_feature.to_string ("position", Float f)]
| _ -> [] in
let lines = List.fold_left
(fun acc (feat_name, atom) ->
if List.mem feat_name (snd decorated_feat)
then (sprintf "%s:B:yellow" (G_feature.to_string (feat_name, atom))) :: acc
else
match filter with
| Some filt_list when not (List.mem feat_name filt_list) -> acc
| _ -> (G_feature.to_string (feat_name, atom)) :: acc
) last sub in
let subword = String.concat "#" (List.rev lines) in
sprintf " word=\"%s\"; subword=\"%s\"" word subword
let to_conll ?exclude t =
let reduced_t = match exclude with
......@@ -283,6 +331,8 @@ module P_fs = struct
let unsorted = List.map (P_feature.build ?pat_vars) ast_fs in
List.sort P_feature.compare unsorted
let feat_list t = List.map P_feature.get_name t
let to_string t = List_.to_string P_feature.to_string "\\n" t
let to_dep ?filter param_names t =
......
......@@ -39,9 +39,9 @@ module G_fs: sig
val get_float_feat: string -> t -> float option
val to_gr: t -> string
val to_dot: ?main_feat: string -> t -> string
val to_dot: ?decorated_feat:(string * string list) -> ?main_feat: string -> t -> string
val to_word: ?main_feat: string -> t -> string
val to_dep: ?position:float -> ?main_feat: string -> ?filter: string list -> t -> string
val to_dep: ?decorated_feat:(string * string list) -> ?position:float -> ?main_feat: string -> ?filter: string list -> t -> string
val to_raw: t -> (string * string) list
val to_conll: ?exclude: string list -> t -> string
......@@ -74,6 +74,7 @@ module P_fs: sig
val to_dot: t -> string
val feat_list: t -> string list
exception Fail
......
......@@ -190,11 +190,30 @@ end (* module P_graph *)
(* ==================================================================================================== *)
module G_deco = struct
type t = {
nodes: Gid.t list;
edges: (Gid.t * G_edge.t * Gid.t) list;
nodes: (Gid.t * (string * string list)) list; (* a list of (node, (pattern_id, features of nodes implied in the step)) *)
edges: (Gid.t * G_edge.t * Gid.t) list; (* an edge list *)
}
let empty = {nodes=[]; edges=[]}
let dump t =
printf "|nodes|=%d\n" (List.length t.nodes);
List.iter
(fun (gid, (pid,list)) ->
printf " - %s %s %s\n"
(Gid.to_string gid)
pid
(String.concat "/" list)
) t.nodes;
printf "|edges|=%d\n" (List.length t.edges);
List.iter
(fun (src, edge, tar) ->
printf " - %s --[%s]--> %s\n"
(Gid.to_string src)
(G_edge.to_string edge)
(Gid.to_string tar)
) t.edges
end (* module G_deco *)
(* ==================================================================================================== *)
......@@ -653,11 +672,12 @@ module G_graph = struct
(* nodes *)
List.iter
(fun (id, node) ->
let decorated_feat = try List.assoc id deco.G_deco.nodes with Not_found -> ("",[]) in
let fs = G_node.get_fs node in
let dep_fs = G_fs.to_dep ~position:(G_node.get_position node) ?filter ?main_feat fs in
let style = match (List.mem id deco.G_deco.nodes, G_fs.get_string_atom "void" fs) with
| (true, _) -> "; forecolor=red; subcolor=red; "
| (false, Some "y") -> "; forecolor=red; subcolor=red; "
let dep_fs = G_fs.to_dep ~decorated_feat ~position:(G_node.get_position node) ?filter ?main_feat fs in
let style = match G_fs.get_string_atom "void" fs with
| Some "y" -> "; forecolor=red; subcolor=red; "
| _ -> "" in
bprintf buff "N_%s { %s%s }\n" (Gid.to_string id) dep_fs style
) snodes;
......@@ -679,6 +699,10 @@ module G_graph = struct
(* -------------------------------------------------------------------------------- *)
let to_dot ?main_feat ?(deco=G_deco.empty) graph =
printf "<==== [G_graph.to_dot] ====>\n";
G_deco.dump deco;
let buff = Buffer.create 32 in
bprintf buff "digraph G {\n";
......@@ -688,10 +712,14 @@ module G_graph = struct
(* nodes *)
Gid_map.iter
(fun id node ->
bprintf buff " N_%s [label=\"%s\", color=%s]\n"
let decorated_feat =
try List.assoc id deco.G_deco.nodes
with Not_found -> ("",[]) in
bprintf buff " N_%s [label=<%s>, color=%s]\n"
(Gid.to_string id)
(G_fs.to_dot ?main_feat (G_node.get_fs node))
(if List.mem id deco.G_deco.nodes then "red" else "black")
(G_fs.to_dot ~decorated_feat ?main_feat (G_node.get_fs node))
(* TODO: add bgcolor in dot output *)
(if List.mem_assoc id deco.G_deco.nodes then "red" else "black")
) graph.map;
(* edges *)
......
......@@ -28,11 +28,14 @@ end (* module P_deco *)
(* ==================================================================================================== *)
module G_deco: sig
type t =
{ nodes: Gid.t list;
{ nodes: (Gid.t * (string * string list)) list;
edges: (Gid.t * G_edge.t * Gid.t) list;
}
val empty:t
val dump: t -> unit
end (* module G_deco *)
(* ==================================================================================================== *)
......
......@@ -325,7 +325,7 @@ module Rule = struct
(* ====================================================================== *)
type matching = {
n_match: Gid.t Pid_map.t; (* partial fct: pattern nodes |--> graph nodes *)
n_match: Gid.t Pid_map.t; (* partial fct: pattern nodes |--> graph nodes *)
e_match: (string*(Gid.t*Label.t*Gid.t)) list; (* edge matching: edge ident |--> (src,label,tar) *)
a_match: (Gid.t*Label.t*Gid.t) list; (* anonymous edge mached *)
m_param: Lex_par.t option;
......@@ -342,8 +342,13 @@ module Rule = struct
let a_match_add edge matching = {matching with a_match = edge::matching.a_match }
let up_deco matching =
{ G_deco.nodes = Pid_map.fold (fun _ gid acc -> gid::acc) matching.n_match [];
let up_deco rule matching =
{ G_deco.nodes =
Pid_map.fold
(fun pid gid acc ->
let pnode = P_graph.find pid rule.pos.graph in
(gid, (P_node.get_name pnode, P_fs.feat_list (P_node.get_fs pnode))) ::acc
) matching.n_match [];
G_deco.edges = List.fold_left (fun acc (_,edge) -> edge::acc) matching.a_match matching.e_match;
}
......@@ -359,14 +364,18 @@ module Rule = struct
let down_deco (matching,created_nodes) commands =
let feat_to_highlight = List.fold_left
(fun acc -> function
| (Command.UPDATE_FEAT (tar_cn,feat_name,_),loc) ->
(* | (Command.SHIFT_EDGE (_,tar_cn),loc) *)
let gid = find tar_cn (matching, created_nodes) in
let old_feat_list = try Gid_map.find gid acc with Not_found -> [] in
Gid_map.add gid (feat_name :: old_feat_list) acc
| _ -> acc
) Gid_map.empty commands in
{
G_deco.nodes = List.fold_left
(fun acc -> function
| (Command.UPDATE_FEAT (tar_cn,_,_),loc)
| (Command.SHIFT_EDGE (_,tar_cn),loc) ->
(find tar_cn (matching, created_nodes)) :: acc
| _ -> acc
) [] commands;
G_deco.nodes = List.map (fun (gid,feat_list) -> (gid, ("",feat_list))) (Gid_map.bindings feat_to_highlight);
G_deco.edges = List.fold_left
(fun acc -> function
| (Command.ADD_EDGE (src_cn,tar_cn,edge),loc) ->
......@@ -731,7 +740,7 @@ module Rule = struct
let rule_app = {
Grew_types.rule_name = rule.name;
up = up_deco matching;
up = up_deco rule matching;
down = down_deco (matching,created_nodes) rule.commands
} in
......
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