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