diff --git a/src/grew_grs.ml b/src/grew_grs.ml index c5067580eae5f507fbb60277f4ec2c19c51cc70f..c5d78efa14c06743884470cbbeec863a4d1c30f9 100644 --- a/src/grew_grs.ml +++ b/src/grew_grs.ml @@ -41,24 +41,6 @@ module Rewrite_history = struct | { good_nf = [] } -> 1 | { good_nf = l} -> List.fold_left (fun acc t -> acc + (num_sol t)) 0 l - let save_nfs ?domain ?filter ?main_feat ~dot base_name t = - let rec loop file_name rules t = - match t.good_nf with - | [] when dot -> Instance.save_dot_png ?domain ?filter ?main_feat file_name t.instance; [rules, file_name] - | [] -> ignore (Instance.save_dep_png ?domain ?filter ?main_feat file_name t.instance); [rules, file_name] - | l -> - List_.foldi_left - (fun i acc son -> - (* Instance.save_dep_png ?main_feat (sprintf "%s_%d" file_name i) son.instance; *) - let nfs = loop - (sprintf "%s_%d" file_name i) - (rules @ [t.module_name, son.instance.Instance.rules]) - son in - nfs @ acc - ) - [] l in - loop base_name [] t - let save_gr ?domain base t = let rec loop file_name t = match t.good_nf with diff --git a/src/grew_grs.mli b/src/grew_grs.mli index 15418c21e38dedc3954177fa1f36cf76473a7cad..b6b32b039c3c48d873064663acd684e80f0dfff2 100644 --- a/src/grew_grs.mli +++ b/src/grew_grs.mli @@ -29,19 +29,6 @@ module Rewrite_history: sig val num_sol: t -> int - (** [save_nfs ?main_feat base_name t] does two things: - - write PNG files of normal forms - - returns a list of couples (rules, file) - *) - val save_nfs: - ?domain:Domain.t -> - ?filter: string list -> - ?main_feat: string -> - dot: bool -> - string -> - t -> - ((string * string list) list * string) 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: ?domain:Domain.t -> string -> t -> unit diff --git a/src/grew_html.ml b/src/grew_html.ml deleted file mode 100644 index bd8a92604535394a7adef60f1de3c6555fb38917..0000000000000000000000000000000000000000 --- a/src/grew_html.ml +++ /dev/null @@ -1,1015 +0,0 @@ -(**********************************************************************************) -(* 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 -open Grew_domain -open Grew_graph -open Grew_rule -open Grew_grs - -let html_header ?css_file ?title ?(add_lines=[]) buff = - let wnl fmt = Printf.ksprintf (fun x -> Printf.bprintf buff "%s\n" x) fmt in - - wnl ""; - - wnl ""; - wnl " "; - wnl " "; - (match css_file with - | Some file -> wnl " " file - | None -> () - ); - (match title with - | Some t -> wnl " %s" (Str.global_replace (Str.regexp "#") " " t) - | None -> () - ); - List.iter (fun line -> wnl " %s" line) add_lines; - wnl " "; - -(* ================================================================================*) -module Html_doc = struct - - let string_of_concat_item = function - | Ast.Qfn_item id -> sprintf "%s" (Ast.dump_feature_ident id) - | Ast.String_item s -> sprintf "\"%s\"" s - | Ast.Param_item var -> sprintf "%s" var - - let buff_html_command ?(li_html=false) buff (u_command,_) = - bprintf buff " "; - if li_html then bprintf buff "
  • "; - bprintf buff "%s" (Ast.string_of_u_command u_command); - if li_html then bprintf buff "
  • \n" else bprintf buff ";\n" - - let html_feature (u_feature,_) = - match u_feature.Ast.kind with - | Ast.Equality values -> - sprintf "%s=%s" u_feature.Ast.name (List_.to_string (fun x->x) "|" values) - | Ast.Disequality [] -> - sprintf "%s=*" u_feature.Ast.name - | Ast.Absent -> - sprintf "!%s" u_feature.Ast.name - | Ast.Disequality values -> - sprintf "%s<>%s" u_feature.Ast.name (List_.to_string (fun x->x) "|" values) - | Ast.Equal_param index -> - sprintf "%s=%s" u_feature.Ast.name index - - let buff_html_node buff (u_node,_) = - bprintf buff " %s [" u_node.Ast.node_id; - bprintf buff "%s" (String.concat ", " (List.map html_feature u_node.Ast.fs)); - bprintf buff "];\n" - - let buff_html_edge buff (u_edge,_) = - bprintf buff " "; - bprintf buff "%s" (match u_edge.Ast.edge_id with Some n -> n^": " | None -> ""); - match u_edge.Ast.edge_label_cst with - | Ast.Pos_list l -> bprintf buff "%s -[%s]-> %s;\n" u_edge.Ast.src (List_.to_string (fun x->x) "|" l) u_edge.Ast.tar - | Ast.Neg_list l -> bprintf buff "%s -[^%s]-> %s;\n" u_edge.Ast.src (List_.to_string (fun x->x) "|" l) u_edge.Ast.tar - | Ast.Regexp re -> bprintf buff "%s -[re\"%s\"]-> %s;\n" u_edge.Ast.src re u_edge.Ast.tar - - let buff_html_const buff (u_const,_) = - bprintf buff " "; - (match u_const with - | Ast.Cst_out (ident, Ast.Neg_list []) -> - bprintf buff "%s -> *" ident - | Ast.Cst_out (ident, Ast.Pos_list labels) -> - bprintf buff "%s -[%s]-> *" ident (List_.to_string (fun x->x) "|" labels) - | Ast.Cst_out (ident, Ast.Neg_list labels) -> - bprintf buff "%s -[^%s]-> *" ident (List_.to_string (fun x->x) "|" labels) - | Ast.Cst_out (ident, Ast.Regexp re) -> - bprintf buff "%s -[re\"%s\"]-> *" ident re - - | Ast.Cst_in (ident, Ast.Neg_list []) -> - bprintf buff "* -> %s" ident - | Ast.Cst_in (ident, Ast.Pos_list labels) -> - bprintf buff "* -[%s]-> %s" (List_.to_string (fun x->x) "|" labels) ident - | Ast.Cst_in (ident, Ast.Neg_list labels) -> - bprintf buff "* -[^%s]-> %s" (List_.to_string (fun x->x) "|" labels) ident - | Ast.Cst_in (ident, Ast.Regexp re) -> - bprintf buff "* -[re\"%s\"]-> %s" re ident - - | Ast.Features_eq (feat_id_l, feat_id_r) -> - bprintf buff "%s = %s" (Ast.dump_feature_ident feat_id_l) (Ast.dump_feature_ident feat_id_r); - | Ast.Features_diseq (feat_id_l, feat_id_r) -> - bprintf buff "%s <> %s" (Ast.dump_feature_ident feat_id_l) (Ast.dump_feature_ident feat_id_r); - | Ast.Features_ineq (ineq, feat_id_l, feat_id_r) -> - bprintf buff "%s %s %s" (Ast.dump_feature_ident feat_id_l) (Ast.string_of_ineq ineq) (Ast.dump_feature_ident feat_id_r) - | Ast.Feature_ineq_cst (ineq, feat_id_l, constant) -> - bprintf buff "%s %s %f" (Ast.dump_feature_ident feat_id_l) (Ast.string_of_ineq ineq) constant - - | Ast.Feature_eq_cst (feat_id_l, value) -> - bprintf buff "%s = \"%s\"" (Ast.dump_feature_ident feat_id_l) value; - | Ast.Feature_diff_cst (feat_id_l, value) -> - bprintf buff "%s ≠ \"%s\"" (Ast.dump_feature_ident feat_id_l) value; - - | Ast.Feature_eq_float (feat_id_l, value) -> - bprintf buff "%s = %g" (Ast.dump_feature_ident feat_id_l) value; - | Ast.Feature_diff_float (feat_id_l, value) -> - bprintf buff "%s ≠ %g" (Ast.dump_feature_ident feat_id_l) value; - - | Ast.Feature_eq_regexp (feat_id, regexp) -> - bprintf buff "%s == \"%s\"" (Ast.dump_feature_ident feat_id) regexp - | Ast.Immediate_prec (id1, id2) -> - bprintf buff "%s < %s" id1 id2 - | Ast.Large_prec (id1, id2) -> - bprintf buff "%s << %s" id1 id2 - ); - bprintf buff "\n" - - let buff_html_pos_basic buff pos_basic = - bprintf buff " match {\n"; - List.iter (buff_html_node buff) pos_basic.Ast.pat_nodes; - List.iter (buff_html_edge buff) pos_basic.Ast.pat_edges; - List.iter (buff_html_const buff) pos_basic.Ast.pat_const; - bprintf buff " }\n" - - let buff_html_neg_basic buff neg_basic = - bprintf buff " without {\n"; - List.iter (buff_html_node buff) neg_basic.Ast.pat_nodes; - List.iter (buff_html_edge buff) neg_basic.Ast.pat_edges; - List.iter (buff_html_const buff) neg_basic.Ast.pat_const; - bprintf buff " }\n" - - let to_html_rules rules = - let buff = Buffer.create 32 in - List.iter - (fun rule -> - (* the first line: (lex_)rule / filter *) - (match (rule.Ast.commands, rule.Ast.param) with - | (_,None) -> - bprintf buff "rule %s {\n" rule.Ast.rule_id - | (_,Some (files, vars)) -> - let param = - match files with - | [] -> sprintf "(feature %s)" (String.concat ", " vars) - | l -> sprintf "(feature %s; %s)" - (String.concat ", " vars) - (String.concat ", " (List.map (fun f -> sprintf "file \"%s\"" f) l)) in - bprintf buff "lex_rule %s %s {\n" rule.Ast.rule_id param - ); - - (* the match part *) - buff_html_pos_basic buff rule.Ast.pattern.Ast.pat_pos; - - (* the without parts *) - List.iter (buff_html_neg_basic buff) rule.Ast.pattern.Ast.pat_negs; - - (* the commands part *) - bprintf buff " commands {\n"; - List.iter (buff_html_command buff) rule.Ast.commands; - bprintf buff " }\n"; - - bprintf buff "}\n"; - ) rules; - Buffer.contents buff - - - let doc_to_html string = - if Str.string_match (Str.regexp "^ \\* ") string 0 - then sprintf "%s" (String.sub string 4 ((String.length string)-4)) - else - List.fold_left - (fun acc (re,str) -> Str.global_replace (Str.regexp re) str acc) - string - [ - "\\[", ""; - "\\]", ""; - "~", " "; - ] - - let of_opt_color = function - | [] -> "black" - | c::_ -> String.sub c 1 ((String.length c) - 1) - - let module_page_text ~corpus prev next module_ = - let buff = Buffer.create 32 in - let wnl fmt = Printf.ksprintf (fun x -> Printf.bprintf buff "%s\n" x) fmt in - let w fmt = Printf.ksprintf (fun x -> Printf.bprintf buff "%s" x) fmt in - - let title = sprintf "Grew -- Module %s" module_.Ast.module_id in - html_header ~css_file:"style.css" ~title buff; - - wnl " "; - if corpus - then wnl "Sentences -- Rewriting stats -- GRS documentation"; - - wnl "
    "; - w " "; - (match prev with Some p -> w " Previous" p | _ -> ()); - w " Up"; - (match next with Some n -> w " Next" n | _ -> ()); - wnl "
    "; - - wnl "

    Module
    %s


    " module_.Ast.module_id; - List.iter (fun s -> wnl " %s
    " (doc_to_html s)) module_.Ast.module_doc; - wnl "
    %d Rules
    " (List.length module_.Ast.rules); - wnl " "; - List.iter - (fun rule -> - wnl " "; - wnl " " module_.Ast.module_id rule.Ast.rule_id rule.Ast.rule_id; - (match rule.Ast.rule_doc with [] -> () | l::_ -> wnl " " (doc_to_html l)); - wnl " "; - ) module_.Ast.rules; - wnl "
    %s%s
    "; - wnl " "; - wnl ""; - Buffer.contents buff - - let rule_page_text ~corpus ~dep prev next rule_ module_ = - let rid = rule_.Ast.rule_id in - let mid = module_.Ast.module_id in - - let buff = Buffer.create 32 in - let wnl fmt = Printf.ksprintf (fun x -> Printf.bprintf buff "%s\n" x) fmt in - let w fmt = Printf.ksprintf (fun x -> Printf.bprintf buff "%s" x) fmt in - - let title = sprintf "Grew -- Rule %s/%s" mid rid in - html_header ~css_file:"style.css" ~title buff; - - wnl " "; - if corpus - then wnl "Sentences -- Rewriting stats -- GRS documentation"; - - wnl "
    "; - w " "; - (match prev with Some p -> w " Previous" mid p | _ -> ()); - w " Up" mid; - (match next with Some n -> w " Next" mid n | _ -> ()); - wnl "
    "; - - wnl "

    Rule %s.
    %s

    " mid mid rid; - List.iter (fun s -> wnl " %s
    " (doc_to_html s)) rule_.Ast.rule_doc; - - wnl "
    Code
    "; - wnl "
    ";
    -    w "%s" (to_html_rules [rule_]);
    -    wnl "
    "; - - if dep - then - begin - wnl "
    Pattern
    "; - wnl "
    ";
    -        w "" (sprintf "%s_%s-patt.png" mid rid);
    -        wnl "
    " - end; - - let output_table args lines = - wnl " "; - wnl " %s" (List_.to_string (fun x -> sprintf "" x) "" args); - List.iter - (fun l -> wnl "%s" - (List_.to_string (fun x -> sprintf "" x) "" (Str.split (Str.regexp "#+") l)) - ) lines; - wnl "
    %s
    %s
    " in - - (match rule_.Ast.param with - | None -> () - | Some (files, args) -> - wnl "
    Lexical parameters
    "; - - (* output local lexical parameters (if any) *) - (match rule_.Ast.lex_par with - | None -> () - | Some lines -> - wnl "Local parameters
    "; - output_table args lines - ); - - (* output external lexical parameters (if any) *) - List.iter - (fun file -> - let filename = Filename.concat module_.Ast.mod_dir file in - wnl "File: %s
    " file; - let lines = - try File.read filename - with Sys_error msg -> wnl "Error: %s" msg; [] in - output_table args lines - ) files - ); - wnl " "; - wnl ""; - Buffer.contents buff - - - let sequences_text ~corpus ast = - let buff = Buffer.create 32 in - let wnl fmt = Printf.ksprintf (fun x -> Printf.bprintf buff "%s\n" x) fmt in - - let title = sprintf "Grew -- List of sequences" in - html_header ~css_file:"style.css" ~title buff; - - wnl " "; - if corpus - then wnl "Sentences -- Rewriting stats -- GRS documentation"; - - wnl "
     Up
    "; - wnl "

    List of sequences

    "; - List.iter - (fun ast_seq -> - wnl "
    %s
    " ast_seq.Ast.strat_name; - List.iter (fun l -> wnl "

    %s

    " (doc_to_html l)) ast_seq.Ast.strat_doc; - wnl "
    "; - wnl "%s" (Ast.strat_def_to_string ast_seq.Ast.strat_def); - wnl "
    "; - - ) ast.Ast.strategies; - wnl " "; - wnl ""; - Buffer.contents buff - - - - let index_modules_text ast = - let buff = Buffer.create 32 in - let wnl fmt = Printf.ksprintf (fun x -> Printf.bprintf buff "%s\n" x) fmt in - - let title = sprintf "Grew -- Index of modules" in - html_header ~css_file:"style.css" ~title buff; - - wnl " "; - wnl "
     Up
    "; - wnl "

    Index of modules

    "; - wnl " "; - List.iter - (fun initial -> - match List.filter (fun mod_ -> Char.uppercase_ascii mod_.Ast.module_id.[0] = initial) ast.Ast.modules with - | [] -> () - | l -> - wnl "" (Char.escaped initial); - List.iter - (fun mod_ -> - wnl ""; - wnl "" mod_.Ast.module_id mod_.Ast.module_id; - (match mod_.Ast.module_doc with [] -> () | h::_ -> wnl "\n" (doc_to_html h)); - wnl ""; - ) l - ) ['A';'B';'C';'D';'E';'F';'G';'H';'I';'J';'K';'L';'M';'N';'O';'P';'Q';'R';'S';'T';'U';'V';'W';'X';'Y';'Z']; - wnl " "; - wnl ""; - Buffer.contents buff - - - let domain_text ~corpus ast = - let buff = Buffer.create 32 in - let wnl fmt = Printf.ksprintf (fun x -> Printf.bprintf buff "%s\n" x) fmt in - let w fmt = Printf.ksprintf (fun x -> Printf.bprintf buff "%s" x) fmt in - - let title = sprintf "Grew -- Features domain" in - html_header ~css_file:"style.css" ~title buff; - - wnl " "; - if corpus - then wnl "Sentences -- Rewriting stats -- GRS documentation"; - - wnl "
     Up
    "; - - wnl "
    Features
    "; - wnl " "; - List.iter - (function - | Ast.Closed (feat_name,values) -> wnl "%s : %s
    " feat_name (String.concat " | " values) - | Ast.Open feat_name -> wnl " %s : *
    " feat_name - | Ast.Num feat_name -> wnl " %s : #
    " feat_name - ) ast.Ast.feature_domain; - wnl "
    "; - - wnl "
    Labels
    "; - wnl " "; - (match ast.Ast.label_domain with - | [] -> wnl "No labels defined!" - | (l,c)::t -> w "%s" (of_opt_color c) l; - List.iter - (fun (lab,color) -> - w ", %s" (of_opt_color color) lab; - ) t; - wnl ""); - wnl " "; - - wnl " "; - wnl ""; - Buffer.contents buff - - let build ~dep ~corpus output_dir grs = - let filename = Old_grs.get_filename grs in - let ast = Old_grs.get_ast grs in - ignore(Sys.command ("rm -rf "^output_dir)); - ignore(Sys.command ("mkdir "^output_dir)); - (* ignore(Sys.command ("cp "^DATA_DIR^"/style.css "^output_dir)); *) - - (** index.html **) - let index = Filename.concat output_dir "index.html" in - - (* let table = create_modules_table ast.Ast.modules in *) - - let buff = Buffer.create 32 in - let wnl fmt = Printf.ksprintf (fun x -> Printf.bprintf buff "%s\n" x) fmt in - - let title = sprintf "Grew -- Graph Rewriting System: %s" (Filename.basename filename) in - html_header ~css_file:"style.css" ~title buff; - - wnl " "; - if corpus - then wnl "Sentences -- Rewriting stats -- GRS documentation"; - - wnl "

    Graph Rewriting System: %s

    " (Filename.basename filename); - wnl "
    full path: %s
    " filename; - - wnl "Domain
    "; - wnl "Index of modules
    "; - wnl "List of sequences
    "; - - wnl "
    Modules
    "; - wnl "
    %s
    %s%s
    "; - List.iter - (fun m -> - wnl ""; - wnl "" m.Ast.module_id m.Ast.module_id; - (match m.Ast.module_doc with [] -> () | h::_ -> wnl "\n" (doc_to_html h)); - wnl "" - ) ast.Ast.modules; - - wnl "
    %s%s
    "; - wnl ""; - wnl ""; - - let index_out_ch = open_out index in - output_string index_out_ch (Buffer.contents buff); - close_out index_out_ch; - - (** Sequences.html **) - let sequences = Filename.concat output_dir "sequences.html" in - - let sequences_out_ch = open_out sequences in - output_string sequences_out_ch (sequences_text ~corpus ast); - close_out sequences_out_ch; - - (** Modules.html **) - let modules = Filename.concat output_dir "modules.html" in - - let modules_out_ch = open_out modules in - output_string modules_out_ch (index_modules_text ast); - close_out modules_out_ch; - - (** domain.html **) - let domain = Filename.concat output_dir "domain.html" in - - let domain_out_ch = open_out domain in - begin - match ast.Ast.domain with - | Some dom -> output_string domain_out_ch (domain_text ~corpus dom) - | None -> output_string domain_out_ch "No domain defined" - end; - close_out domain_out_ch; - - (** Modules + rules **) - let modules_array = Array.of_list ast.Ast.modules in - for i = 0 to (Array.length modules_array -1) do - let page = Filename.concat output_dir (modules_array.(i).Ast.module_id^".html") in - let page_out_ch = open_out page in - output_string page_out_ch - (module_page_text ~corpus - (try Some (modules_array.(i-1).Ast.module_id) with _ -> None) - (try Some (modules_array.(i+1).Ast.module_id) with _ -> None) - modules_array.(i) - ); - close_out page_out_ch; - - let rules_array = Array.of_list modules_array.(i).Ast.rules in - for j = 0 to (Array.length rules_array -1) do - - let page = Filename.concat output_dir (modules_array.(i).Ast.module_id^"_"^rules_array.(j).Ast.rule_id^".html") in - let page_out_ch = open_out page in - output_string page_out_ch - (rule_page_text ~corpus - ~dep - (try Some (rules_array.(j-1).Ast.rule_id) with _ -> None) - (try Some (rules_array.(j+1).Ast.rule_id) with _ -> None) - rules_array.(j) - modules_array.(i) - ); - close_out page_out_ch; - done; - done -end (* module Html_doc *) - -(* ================================================================================ *) -module Html_rh = struct - let build ?domain ?filter ?main_feat ?(dot=false) ?(init_graph=true) ?(out_gr=false) ?header ?graph_file prefix t = - - (* remove files from previous runs *) - let _ = Unix.system (sprintf "rm -f %s*.html" prefix) in - let _ = Unix.system (sprintf "rm -f %s*.dep" prefix) in - let _ = Unix.system (sprintf "rm -f %s*.png" prefix) in - - ( - if init_graph - then ignore (Instance.save_dep_png ?domain ?filter ?main_feat prefix t.Rewrite_history.instance) - ); - - let nf_files = Rewrite_history.save_nfs ?domain ?filter ?main_feat ~dot prefix t in - - let l = List.length nf_files in - - let local = Filename.basename prefix in - - let buff = Buffer.create 32 in - let wnl fmt = Printf.ksprintf (fun x -> Printf.bprintf buff "%s\n" x) fmt in - - let title = sprintf "Sentence: %s --- %d Normal form%s" local l (if l>1 then "s" else "") in - html_header ~css_file:"style.css" ~title buff; - - wnl ""; - wnl "Sentences -- Rewriting stats -- GRS documentation"; - - wnl "

    %s

    " title; - - begin - match header with - | Some h -> wnl "%s
    " h - | None -> () - end; - - begin - match graph_file with - | Some gf -> - wnl "Input file: %s
    " - gf (Filename.basename gf) - | None -> () - end; - - wnl "Input sentence: %s


    " - (G_graph.to_sentence ?main_feat t.Rewrite_history.instance.Instance.graph); - - if init_graph - then - begin - wnl "
    Initial graph
    "; - wnl "
    " local - end; - - List.iteri - (fun i (rules_list,file_name) -> - wnl "
    Solution %d
    " (i+1); - - let local_name = Filename.basename file_name in - - if out_gr - then wnl "

    gr file" local_name; - - (* the png file *) - wnl "

    " local_name; - - (* the modules list *) - wnl "Modules applied: %d
    " (List.length rules_list); - - let id = sprintf "id_%d" (i+1) in - - wnl "" id id; - wnl "

    Show applied rules

    " id; - wnl "
    "; - - wnl "
    " id; - - List.iter - (fun (mod_name,rules) -> - wnl "

    %s: %s

    " - mod_name - (List_.to_string (fun x -> x) ", " rules); - ) - rules_list; - wnl "
    " - - ) nf_files; - - wnl ""; - wnl ""; - - let out_ch = open_out (sprintf "%s.html" prefix) in - fprintf out_ch "%s" (Buffer.contents buff); - close_out out_ch - - - - let error ?domain ?main_feat ?(dot=false) ?(init_graph=true) ?header prefix msg graph_opt = - (* remove files from previous runs *) - let _ = Unix.system (sprintf "rm -f %s*.html" prefix) in - let _ = Unix.system (sprintf "rm -f %s*.dep" prefix) in - let _ = Unix.system (sprintf "rm -f %s*.png" prefix) in - - (match graph_opt, init_graph with - | (Some graph, true) when dot -> Instance.save_dot_png ?domain ?main_feat prefix (Instance.from_graph graph) - | (Some graph, true) -> ignore (Instance.save_dep_png ?domain ?main_feat prefix (Instance.from_graph graph)) - | _ -> () - ); - - let local = Filename.basename prefix in - - let buff = Buffer.create 32 in - let wnl fmt = Printf.ksprintf (fun x -> Printf.bprintf buff "%s\n" x) fmt in - - let title = sprintf "Sentence: %s --- ERROR" local in - html_header ~css_file:"style.css" ~title buff; - - wnl ""; - wnl "Sentences -- Rewriting stats -- GRS documentation"; - - wnl "

    %s

    " title; - - if init_graph - then - begin - wnl "
    Initial graph
    "; - wnl "
    " local - end; - - wnl "

    ERROR: %s

    " msg; - wnl "\n"; - - let out_ch = open_out (sprintf "%s.html" prefix) in - fprintf out_ch "%s" (Buffer.contents buff); - close_out out_ch -end (* module Html_rh *) - -(* ================================================================================*) -module Html_sentences = struct - let build ~title output_dir sentences = - let buff = Buffer.create 32 in - let wnl fmt = Printf.ksprintf (fun x -> Printf.bprintf buff "%s\n" x) fmt in - - html_header ~css_file:"style.css" ~title buff; - - wnl " "; - wnl "Sentences -- Rewriting stats -- GRS documentation"; - wnl "

    %s

    " (Str.global_replace (Str.regexp "#") " " title); - - wnl "

    Sentences list

    "; - - wnl "
    "; - wnl ""; - - List.iter - (fun (rewrited, base_name, amb, sentence) -> - wnl ""; - wnl " " amb; - if rewrited - then wnl " " base_name base_name - else wnl " " base_name; - wnl " " sentence; - wnl ""; - ) sentences; - - wnl "
    Number of normal formsSentence IdSentence
    %d%s%s%s
    "; - wnl ""; - wnl ""; - - let out_ch = open_out (Filename.concat output_dir "sentences.html") in - fprintf out_ch "%s" (Buffer.contents buff); - close_out out_ch -end (* module Html_sentences *) - -(* ================================================================================*) -module Gr_stat = struct - - (** the type [gr] stores the stats for the rewriting of one gr file *) - type t = - | Stat of ((int * int) String_map.t * int) (* map: rule_name |-> (min,max) occ, number of solution *) - | Error of string - - let opt_incr = function None -> Some 1 | Some x -> Some (x+1) - let add_one_module modul_opt rules stat = - match modul_opt with - | Some modul -> - List.fold_left - (fun acc rule -> - let key = sprintf "%s.%s" modul rule in - let (old_min, old_max) = try String_map.find key acc with Not_found -> (None, None) in - String_map.add key (opt_incr old_min, opt_incr old_max) acc - ) stat rules - | None when rules = [] -> stat - | None -> Log.fcritical "Unconsistent rewrite history" - - let max_stat stat1 stat2 = - String_map.fold - (fun key value acc -> - let old = try String_map.find key acc with Not_found -> 0 in - String_map.add key (max old value) acc - ) stat1 stat2 - - let opt_max x y = match (x,y) with - | None, v | v, None -> v - | Some v1, Some v2 -> Some (max v1 v2) - - let opt_min x y = match (x,y) with - | None, v | v, None -> v - | Some v1, Some v2 -> Some (min v1 v2) - - let min_max_stat stat1 stat2 = - String_map.fold - (fun key (vmin, vmax) acc -> - let (old_min, old_max) = try String_map.find key acc with Not_found -> (Some 0, Some 0) in - String_map.add key (opt_min old_min vmin, opt_max old_max vmax) acc - ) stat1 stat2 - - - - let from_rew_history rew_history = - let rec loop prev_module rh = - let sub_stat = - match List.map (loop (Some rh.Rewrite_history.module_name)) rh.Rewrite_history.good_nf with - | [] -> String_map.empty - | h::t -> List.fold_left min_max_stat h t in - add_one_module prev_module rh.Rewrite_history.instance.Instance.rules sub_stat - in - Stat - (String_map.map - (function | Some i, Some j -> (i,j) | _ -> Log.critical "None in stat") - (loop None rew_history), - (Rewrite_history.num_sol rew_history) - ) - - let from_rew_history rew_history = - let rec loop prev_module rh = - let sub_stat = - match rh.Rewrite_history.good_nf with - | [] -> Some (String_map.empty) - | l -> - match List_.opt_map (loop (Some rh.Rewrite_history.module_name)) l with - | [] -> None - | h::t -> Some (List.fold_left min_max_stat h t) in - match sub_stat with - | None -> None - | Some stat -> Some (add_one_module prev_module rh.Rewrite_history.instance.Instance.rules stat) - in - match loop None rew_history with - | None -> Stat (String_map.empty, Rewrite_history.num_sol rew_history) - | Some map -> - Stat - ( - String_map.map (function Some i, Some j -> (i,j) | _ -> Log.critical "None in stat") map, - Rewrite_history.num_sol rew_history - ) - - - - let save stat_file t = - let out_ch = open_out stat_file in - (match t with - | Error msg -> fprintf out_ch "ERROR\n%s" msg - | Stat (map, num) -> - fprintf out_ch "NUM_SOL:%d\n%!" num; - String_map.iter - (fun rule_name (min_occ,max_occ) -> fprintf out_ch "%s:%d:%d\n%!" rule_name min_occ max_occ) map - ); - - close_out out_ch - - let load stat_file = - let sol = ref 0 in - try - let lines = File.read stat_file in - match lines with - | "ERROR" :: msg_lines -> Error (List_.to_string (fun x->x) "\n" msg_lines) - | _ -> - let map = - List.fold_left - (fun acc line -> - match Str.split (Str.regexp ":") line with - | ["NUM_SOL"; num] -> sol := int_of_string num; acc - | [modu_rule; vmin; vmax] -> String_map.add modu_rule (int_of_string vmin, int_of_string vmax) acc - | _ -> Log.fcritical "invalid stat line: %s" line - ) String_map.empty lines in - Stat (map, !sol) - with Sys_error msg -> Error (sprintf "Sys_error: %s" msg) -end (* module Gr_stat *) - -(* ================================================================================*) -module Corpus_stat = struct - (** the [t] type stores stats for a corpus of gr_files *) - (* - first key: [m] module name - second key: [r] rule name - value: [occ_num, file_list] the total number of rule applications and the set of gr files concerned *) - type t = { - modules: Modul.t list; (* ordered list of modules in the sequence *) - map: ((int*int) * String_set.t) String_map.t String_map.t; (* map: see above *) - amb: String_set.t Int_map.t; (* key: nb of sols |-> set: sentence concerned *) - error: (string * string) list; (* (file, msg) *) - num: int; (* an integer id relative to the corpus *) - } - - let empty ~grs ~seq = - (* let modules = try List.assoc seq grs.Grs.sequences with Not_found -> [seq] in *) - let modules = [] (* Grs.modules_of_sequence grs seq *) in - let map = List.fold_left - (fun acc modul -> - if List.exists (fun m -> modul.Modul.name = m.Modul.name) modules - then - let rule_map = - List.fold_left - (fun acc2 rule -> - String_map.add (Rule.get_name rule) ((0,0),String_set.empty) acc2 - ) String_map.empty modul.Modul.rules in - String_map.add modul.Modul.name rule_map acc - else acc - ) String_map.empty (Old_grs.get_modules grs) in - { modules=modules; map = map; amb = Int_map.empty; error = []; num = 0 } - - let add modul rule file (min_occ,max_occ) map = - let old_rule_map = String_map.find modul map in - let ((old_min,old_max), old_file_set) = String_map.find rule old_rule_map in - String_map.add - modul - (String_map.add - rule - ((old_min + min_occ, old_max + max_occ), String_set.add file old_file_set) - old_rule_map - ) map - - let add_gr_stat base_name gr_stat t = - match gr_stat with - | Gr_stat.Error msg -> { t with error = (base_name, msg) :: t.error; num = t.num+1 } - | Gr_stat.Stat (map, sol) -> - let new_map = - String_map.fold - (fun modul_rule (min_occ,max_occ) acc -> - match Str.split (Str.regexp "\\.") modul_rule with - | [modul; rule] -> add modul rule base_name (min_occ,max_occ) acc - | _ -> Log.fcritical "illegal modul_rule spec \"%s\"" modul_rule - ) map t.map in - let new_amb = - let old = try Int_map.find sol t.amb with Not_found -> String_set.empty in - Int_map.add sol (String_set.add base_name old) t.amb in - { t with map = new_map; num = t.num+1; amb=new_amb; } - - let unfoldable_set output_dir buff ?(bound=10) id file_set = - let counter = ref 0 in - - String_set.iter - (fun file -> - if !counter = bound - then bprintf buff "
    \n" id; - incr counter; - - let link = - if Sys.file_exists (Filename.concat output_dir (sprintf "%s.html" file)) - then sprintf "%s" file file - else file in - - bprintf buff "%s   \n" link - ) file_set; - - if (!counter > bound) - then - begin - bprintf buff "
    \n"; - let if_part = sprintf "document.getElementById('%s').style.display = 'block'; document.getElementById('p_%s').innerHTML = '- Show first %d -';" id id bound in - let else_part = sprintf "document.getElementById('%s').style.display = 'none'; document.getElementById('p_%s').innerHTML = '+ Show all +';" id id in - bprintf buff "
    \n"; - bprintf buff " \n" id if_part else_part; - bprintf buff "

    + Show all +

    \n" id; - bprintf buff "
    \n"; - bprintf buff "
    \n"; - end - - - - - - let save_html ~title ~grs_file ~input_dir ~output_dir t = - (* a fucntion to get the ration wrt the full set [t] *) - let ratio nb = (float nb) /. (float t.num) *. 100. in - - (* put the css file the [output_dir] *) - (* ignore(Sys.command("cp "^(Filename.concat DATA_DIR "style.css")^" "^(Filename.concat output_dir "style.css"))); *) - - let buff = Buffer.create 32 in - let wnl fmt = Printf.ksprintf (fun x -> Printf.bprintf buff "%s\n" x) fmt in - let w fmt = Printf.ksprintf (fun x -> Printf.bprintf buff "%s" x) fmt in - - html_header ~css_file:"style.css" ~title buff; - - wnl "Sentences -- Rewriting stats -- GRS documentation"; - - wnl "

    %s

    " (Str.global_replace (Str.regexp "#") " " title); - wnl "

    Rewriting stats

    "; - - wnl "
    "; - List.iter - (fun modul -> - let modul_name = modul.Modul.name in - let rules = String_map.find modul_name t.map in - wnl "" modul_name; - wnl ""; - let ((min_occ, max_occ), full_sent) = - String_map.fold - (fun _ ((v_min,v_max), file_set) ((acc_min,acc_max), acc_sent) -> - ((acc_min+v_min, acc_max+v_max), String_set.union acc_sent file_set) - ) - rules ((0,0),String_set.empty) in - let tot_sent = String_set.cardinal full_sent in - wnl ""; - wnl " "; - wnl " " min_occ max_occ; - wnl " " tot_sent; - wnl " " (ratio tot_sent); - wnl " "; - wnl ""; - - List.iter (* iteration on list to keep the same order in html output and in grs input *) - (fun rule -> - let rule_name = Rule.get_name rule in - let ((min_occ, max_occ), file_set) = String_map.find rule_name rules in - - let id = sprintf "%s_%s" modul_name rule_name in - let file_num = String_set.cardinal file_set in - - wnl ""; - wnl " " id rule_name; - wnl " " min_occ max_occ; - wnl " " file_num; - wnl " " (ratio file_num); - - wnl " "; - wnl ""; - ) modul.Modul.rules - ) t.modules; - - (* add a subtable for sentence ambiguity *) - if (List.for_all (fun m -> m.Modul.deterministic) t.modules) || (Int_map.is_empty t.amb) - then () - else - begin - wnl ""; - wnl ""; - - Int_map.iter - (fun num set -> - let id = sprintf "amb_%d" num in - let num_files = String_set.cardinal set in - wnl ""; - wnl " " num; - wnl " " num_files; - wnl " " (ratio num_files); - w " "; - wnl "") t.amb - end; - - (* add a subtable for sentence that produces an error *) - (match List.length t.error with - | 0 -> () - | nb_errors -> - wnl ""; - wnl ""; - - wnl ""; - wnl ""; - wnl "" nb_errors; - wnl "" (ratio nb_errors); - w ""; - wnl ""); - - wnl "
    Module %s
    Rule#occ(min/max)#filesRatioFiles
    Total for module%d/%d%d%.2f%% 
    %s%d/%d%d%.2f%%"; - (if file_num = 0 - then w "  " - else unfoldable_set output_dir buff id file_set); - wnl "
    Rewriting ambiguity
    Number of normal forms#filesRatioFiles
    %d%d%.2f%%"; - - unfoldable_set output_dir buff id set; - - wnl "
    ERRORS
    Rule#filesRatioFiles
    Errors%d%.2f%%"; - - match t.error with - | [] -> w " " - | l -> - List.iter - (fun (file,err) -> - if Sys.file_exists (Filename.concat output_dir (sprintf "%s.html" file)) - then w "%s: %s
    " file file err - else wnl "%s: %s
    " file err - ) - (List.rev l); - - wnl "
    "; - wnl " "; - wnl ""; - - let out_ch = open_out (Filename.concat output_dir "index.html") in - fprintf out_ch "%s" (Buffer.contents buff); - close_out out_ch -end (* module Stat *) diff --git a/src/grew_html.mli b/src/grew_html.mli deleted file mode 100644 index ccdcf5ca0b6c7e2b07eb3fb0abd1923dd887d172..0000000000000000000000000000000000000000 --- a/src/grew_html.mli +++ /dev/null @@ -1,81 +0,0 @@ -(**********************************************************************************) -(* 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_types -open Grew_domain -open Grew_rule -open Grew_grs -open Grew_graph - -(* ================================================================================ *) -module Html_doc : sig - (* dep is a flag which is true iff dep file are shown in doc (iff dep2pict is available) *) - val build: dep:bool -> corpus:bool -> string -> Old_grs.t -> unit -end (* module Html_doc *) - -(* ================================================================================ *) -module Html_sentences : sig - val build: title:string -> string -> (bool * string * int * string) list -> unit -end (* module Html_sentences *) - -(* ================================================================================ *) -module Html_rh: sig - - val build: - ?domain:Domain.t -> - ?filter: string list -> - ?main_feat: string -> - ?dot: bool -> - ?init_graph:bool -> - ?out_gr:bool -> - ?header:string -> - ?graph_file:string -> - string -> - Rewrite_history.t -> - unit - - val error: - ?domain: Domain.t -> - ?main_feat: string -> - ?dot: bool -> - ?init_graph:bool -> - ?header:string -> - string -> - string -> - G_graph.t option -> - unit -end (* module Html_rh *) - -(* ================================================================================ *) -module Gr_stat: sig - type t - - val from_rew_history: Rewrite_history.t -> t - - val save: string -> t -> unit - - val load: string -> t -end (* module Gr_stat *) - -(* ================================================================================ *) -module Corpus_stat: sig - type t - - val empty: grs:Old_grs.t -> seq:string -> t - - val add_gr_stat: string -> Gr_stat.t -> t -> t - - val save_html: - title: string -> - grs_file: string -> - input_dir:string -> - output_dir:string -> - t -> unit -end (* module Corpus_stat *) diff --git a/src/grew_rule.ml b/src/grew_rule.ml index 13f9770353b765ced21acb1df19ff86a5b6f28f3..39d9f302394e08b30777ef4bf5e916af2dcf3c2a 100644 --- a/src/grew_rule.ml +++ b/src/grew_rule.ml @@ -11,8 +11,6 @@ open Log open Printf -open Dep2pict - open Grew_base open Grew_types open Grew_ast @@ -59,18 +57,6 @@ module Instance = struct let save_dot_png ?domain ?filter ?main_feat base t = ignore (Dot.to_png_file (G_graph.to_dot ?domain ?main_feat t.graph) (base^".png")) - - let save_dep_png ?domain ?filter ?main_feat base t = - let dep = G_graph.to_dep ?domain ?filter ?main_feat t.graph in - let d2p = Dep2pict.from_dep ~dep in - let _ = Dep2pict.save_png ~filename: (base^".png") d2p in - Dep2pict.highlight_shift () - - let save_dep_svg ?domain ?filter ?main_feat base t = - let dep = G_graph.to_dep ?domain ?filter ?main_feat t.graph in - let d2p = Dep2pict.from_dep ~dep in - let _ = Dep2pict.save_svg ~filename: (base^".png") d2p in - Dep2pict.highlight_shift () end (* module Instance *) (* ================================================================================ *) diff --git a/src/grew_rule.mli b/src/grew_rule.mli index efdb49b51b13dec9cef1f71c2c68697fc965d60d..325f4665b98c370618bb3113653d54376fcfdbd8 100644 --- a/src/grew_rule.mli +++ b/src/grew_rule.mli @@ -45,11 +45,6 @@ module Instance : sig (** [to_conll_string t] returns a string which contains the "conll" code of the current graph *) val to_conll_string: ?domain:Domain.t -> t -> string - (** [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: ?domain:Domain.t -> ?filter: string list -> ?main_feat: string -> string -> t -> float option - val save_dep_svg: ?domain:Domain.t -> ?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: ?domain:Domain.t -> ?filter: string list -> ?main_feat: string -> string -> t -> unit end (* module Instance *) diff --git a/src/libgrew.ml b/src/libgrew.ml index c84943075d2c8801d44883981d7d45cac28b8e9e..14d6d25819ab4f15e607286fca449bc7acdcc800 100644 --- a/src/libgrew.ml +++ b/src/libgrew.ml @@ -251,20 +251,6 @@ module Old_grs = struct Grew_grs.Old_grs.sequence_names grs ) () - let build_html_doc ?(corpus=false) dir (grs : Grew_grs.Old_grs.t) = - handle ~name:"Old_grs.build_doc [with Dep2pict]" - (fun () -> - Grew_html.Html_doc.build ~corpus ~dep:true dir grs; - - (* draw pattern graphs for all rules *) - let fct module_ rule_ = - let dep_code = Grew_rule.Rule.to_dep ?domain:(Grew_grs.Old_grs.get_domain grs) rule_ in - let dep_png_file = sprintf "%s/%s_%s-patt.png" dir module_ (Grew_rule.Rule.get_name rule_) in - let d2p = Dep2pict.Dep2pict.from_dep ~dep:dep_code in - Dep2pict.Dep2pict.save_png ~filename:dep_png_file d2p in - Grew_grs.Old_grs.rule_iter fct grs - ) () - let get_domain grs = Grew_grs.Old_grs.get_domain grs let to_json t = @@ -357,9 +343,6 @@ module Rewrite = struct let num_sol rh = handle ~name:"Rewrite.num_sol" (fun () -> Grew_grs.Rewrite_history.num_sol rh) () - let write_stat filename rew_hist = - handle ~name:"Rewrite.write_stat" (fun () -> Grew_html.Gr_stat.save filename (Grew_html.Gr_stat.from_rew_history rew_hist)) () - let save_index ~dirname ~base_names = handle ~name:"Rewrite.save_index" (fun () -> let out_ch = open_out (Filename.concat dirname "index") in @@ -387,31 +370,4 @@ module Rewrite = struct let conll_dep_string ?domain ?keep_empty_rh rew_hist = handle ~name:"Rewrite.conll_dep_string" (fun () -> Grew_grs.Rewrite_history.conll_dep_string ?domain ?keep_empty_rh rew_hist) () - - let write_html ?domain ?(no_init=false) ?(out_gr=false) ?filter ?main_feat ?dot ~header ?graph_file rew_hist output_base = - handle ~name:"Rewrite.write_html" (fun () -> - ignore ( - Grew_html.Html_rh.build ?domain ?filter ?main_feat ?dot ~out_gr ~init_graph: (not no_init) ~header ?graph_file output_base rew_hist - ) - ) () - - let error_html ?domain ?(no_init=false) ?main_feat ?dot ~header msg ?init output_base = - handle ~name:"Rewrite.error_html" (fun () -> - ignore ( - Grew_html.Html_rh.error ?domain ?main_feat ?dot ~init_graph: (not no_init) ~header output_base msg init - ) - ) () - - let make_index ~title ~grs_file ~html ~grs ~seq ~input_dir ~output_dir ~base_names = - handle ~name:"Rewrite.make_index" (fun () -> - let init = Grew_html.Corpus_stat.empty grs seq in - let corpus_stat = - Array.fold_left - (fun acc base_name -> - Grew_html.Corpus_stat.add_gr_stat base_name (Grew_html.Gr_stat.load (Filename.concat output_dir (base_name^".stat"))) acc - ) init base_names in - Grew_html.Corpus_stat.save_html title grs_file input_dir output_dir corpus_stat - ) () - - let html_sentences ~title = handle ~name:"Rewrite.html_sentences" (fun () -> Grew_html.Html_sentences.build ~title) () end diff --git a/src/libgrew.mli b/src/libgrew.mli index e9562b193c3627503dbca55fafac937c3ec6aec0..9b7d9ab39a9b2ac62d02bf3be45832523a9ea0f8 100644 --- a/src/libgrew.mli +++ b/src/libgrew.mli @@ -122,10 +122,6 @@ module Old_grs: sig (** [get_sequence_names t] returns the list of sequence names defined in a GRS *) val get_sequence_names: t -> string list - (** [build_html_doc ?corpus directory t] - @[corpus] is a flag (default is [false]) for complete html doc with corpus sentence. *) - val build_html_doc: ?corpus:bool -> string -> t -> unit - val get_domain: t -> Domain.t option val to_json: t -> string @@ -168,8 +164,6 @@ module Rewrite: sig @param gr the grapth to rewrite @param grs the graph rewriting system @param seq the name of the sequence to apply *) - - (* OBSOLETE val old_display: gr:Graph.t -> grs:Old_grs.t -> seq:string -> display *) val display: gr:Graph.t -> grs:Grs.t -> strat:string -> display val at_least_one: grs:Grs.t -> strat:string -> bool @@ -177,17 +171,12 @@ module Rewrite: sig val set_timeout: float option -> unit - (* OBSOLETE val rewrite: gr:Graph.t -> grs:Old_grs.t -> seq:string -> history *) - - (* OBSOLETE val old_simple_rewrite: gr:Graph.t -> grs:Old_grs.t -> strat:string -> Graph.t list *) val simple_rewrite: gr:Graph.t -> grs:Grs.t -> strat:string -> Graph.t list val is_empty: history -> bool val num_sol: history -> int - val write_stat: string -> history -> unit - val save_gr: ?domain:Domain.t -> string -> history -> unit val save_conll: ?domain:Domain.t -> string -> history -> unit @@ -210,12 +199,4 @@ module Rewrite: sig val conll_dep_string: ?domain:Domain.t -> ?keep_empty_rh:bool -> history -> string option val save_index: dirname:string -> base_names: string array -> unit - - val write_html: ?domain:Domain.t -> ?no_init: bool -> ?out_gr: bool -> ?filter: string list -> ?main_feat: string -> ?dot: bool -> header: string -> ?graph_file: string -> history -> string -> unit - - val error_html: ?domain:Domain.t -> ?no_init:bool -> ?main_feat:string -> ?dot: bool -> header: string -> string -> ?init:Graph.t -> string -> unit - - (* OBSOLETE val make_index: title: string -> grs_file: string -> html: bool -> grs: Old_grs.t -> seq: string -> input_dir: string -> output_dir: string -> base_names: string array -> unit *) - - val html_sentences: title:string -> string -> (bool * string * int * string) list -> unit end