grew_html.ml 45.3 KB
Newer Older
bguillaum's avatar
bguillaum committed
1 2 3 4 5 6 7 8 9 10
(**********************************************************************************)
(*    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                                                   *)
(**********************************************************************************)

bguillaum's avatar
bguillaum committed
11
open Printf
bguillaum's avatar
bguillaum committed
12
open Log
bguillaum's avatar
bguillaum committed
13

bguillaum's avatar
bguillaum committed
14
open Grew_base
bguillaum's avatar
bguillaum committed
15
open Grew_types
bguillaum's avatar
bguillaum committed
16
open Grew_ast
bguillaum's avatar
bguillaum committed
17
open Grew_graph
bguillaum's avatar
bguillaum committed
18 19 20 21
open Grew_rule
open Grew_grs


bguillaum's avatar
bguillaum committed
22
let html_header ?css_file ?title ?(add_lines=[]) buff =
bguillaum's avatar
bguillaum committed
23 24 25 26 27 28
  let wnl fmt = Printf.ksprintf (fun x -> Printf.bprintf buff "%s\n" x) fmt in

  wnl "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">";

  wnl "<html>";
  wnl "  <head>";
bguillaum's avatar
bguillaum committed
29
  wnl "    <meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\">";
bguillaum's avatar
bguillaum committed
30 31 32 33
  (match css_file with
    | Some file -> wnl "    <link rel=\"stylesheet\" href=\"%s\" type=\"text/css\">" file
    | None -> ()
  );
bguillaum's avatar
bguillaum committed
34 35 36 37
  (match title with
    | Some t -> wnl "    <title>%s</title>" (Str.global_replace (Str.regexp "#") " " t)
    | None -> ()
  );
bguillaum's avatar
bguillaum committed
38
  List.iter (fun line -> wnl "    %s" line) add_lines;
bguillaum's avatar
bguillaum committed
39
  wnl "  </head>";
bguillaum's avatar
bguillaum committed
40

bguillaum's avatar
bguillaum committed
41
(* ================================================================================*)
bguillaum's avatar
bguillaum committed
42
module Html_doc = struct
pj2m's avatar
pj2m committed
43

bguillaum's avatar
bguillaum committed
44
  let string_of_concat_item = function
45
    | Ast.Qfn_item id -> sprintf "%s" (Ast.dump_feature_ident id)
bguillaum's avatar
bguillaum committed
46 47
    | Ast.String_item s -> sprintf "\"%s\"" s
    | Ast.Param_item var -> sprintf "%s" var
bguillaum's avatar
bguillaum committed
48

bguillaum's avatar
bguillaum committed
49 50 51 52
  let buff_html_command ?(li_html=false) buff (u_command,_) =
    bprintf buff "      ";
    if li_html then bprintf buff "<li>";
    (match u_command with
53
    | Ast.Del_edge_expl (n1,n2,label) ->
54
      bprintf buff "del_edge %s -[%s]-> %s" (Ast.dump_command_node_ident n1) label (Ast.dump_command_node_ident n2)
bguillaum's avatar
bguillaum committed
55
    | Ast.Del_edge_name name -> bprintf buff "del_edge %s" name
56
    | Ast.Add_edge (n1,n2,label) ->
57
      bprintf buff "add_edge %s -[%s]-> %s" (Ast.dump_command_node_ident n1) label (Ast.dump_command_node_ident n2)
58

bguillaum's avatar
bguillaum committed
59
    | Ast.Shift_in (n1,n2,([],true)) ->
60
      bprintf buff "shift_in %s ==> %s" (Ast.dump_command_node_ident n1) (Ast.dump_command_node_ident n2)
bguillaum's avatar
bguillaum committed
61
    | Ast.Shift_in (n1,n2,(labels,false)) ->
62
      bprintf buff "shift_in %s =[%s]=> %s" (Ast.dump_command_node_ident n1) (Ast.dump_command_node_ident n2) (List_.to_string (fun x->x) "|" labels)
bguillaum's avatar
bguillaum committed
63
    | Ast.Shift_in (n1,n2,(labels,true)) ->
64 65
      bprintf buff "shift_in %s =[^%s]=> %s" (Ast.dump_command_node_ident n1) (Ast.dump_command_node_ident n2) (List_.to_string (fun x->x) "|" labels)

bguillaum's avatar
bguillaum committed
66
    | Ast.Shift_out (n1,n2,([],true)) ->
67
      bprintf buff "shift_out %s ==> %s" (Ast.dump_command_node_ident n1) (Ast.dump_command_node_ident n2)
bguillaum's avatar
bguillaum committed
68
    | Ast.Shift_out (n1,n2,(labels,false)) ->
69
      bprintf buff "shift_out %s =[%s]=> %s" (Ast.dump_command_node_ident n1) (Ast.dump_command_node_ident n2) (List_.to_string (fun x->x) "|" labels)
bguillaum's avatar
bguillaum committed
70
    | Ast.Shift_out (n1,n2,(labels,true)) ->
71 72
      bprintf buff "shift_out %s =[^%s]=> %s" (Ast.dump_command_node_ident n1) (Ast.dump_command_node_ident n2) (List_.to_string (fun x->x) "|" labels)

bguillaum's avatar
bguillaum committed
73
    | Ast.Shift_edge (n1,n2,([],true)) ->
74
      bprintf buff "shift %s ==> %s" (Ast.dump_command_node_ident n1) (Ast.dump_command_node_ident n2)
bguillaum's avatar
bguillaum committed
75
    | Ast.Shift_edge (n1,n2,(labels,false)) ->
76
      bprintf buff "shift %s =[%s]=> %s" (Ast.dump_command_node_ident n1) (Ast.dump_command_node_ident n2) (List_.to_string (fun x->x) "|" labels)
bguillaum's avatar
bguillaum committed
77
    | Ast.Shift_edge (n1,n2,(labels,true)) ->
78 79
      bprintf buff "shift %s =[^%s]=> %s" (Ast.dump_command_node_ident n1) (Ast.dump_command_node_ident n2) (List_.to_string (fun x->x) "|" labels)

80 81 82 83
    | Ast.Merge_node (n1,n2) -> bprintf buff "merge %s ==> %s" (Ast.dump_command_node_ident n1) (Ast.dump_command_node_ident n2)
    | Ast.New_neighbour (n1,n2,label) -> bprintf buff "add_node %s: <-[%s]- %s" n1 label (Ast.dump_command_node_ident n2)
    | Ast.Activate act_id -> bprintf buff "activate %s" (Ast.dump_command_node_ident act_id)
    | Ast.Del_node act_id -> bprintf buff "del_node %s" (Ast.dump_command_node_ident act_id)
84
    | Ast.Update_feat ((act_id, feat_name),item_list) ->
85
      bprintf buff "%s.%s = %s" (Ast.dump_command_node_ident act_id) feat_name (List_.to_string string_of_concat_item " + " item_list)
86
    | Ast.Del_feat (act_id, feat_name) ->
87
      bprintf buff "del_feat %s.%s" (Ast.dump_command_node_ident act_id) feat_name
bguillaum's avatar
bguillaum committed
88 89
    );
    if li_html then bprintf buff "</li>\n" else bprintf buff ";\n"
bguillaum's avatar
bguillaum committed
90

bguillaum's avatar
bguillaum committed
91
  let html_feature (u_feature,_) =
bguillaum's avatar
bguillaum committed
92 93
    match u_feature.Ast.kind with
    | Ast.Equality values ->
bguillaum's avatar
bguillaum committed
94 95 96
        sprintf "%s=%s" u_feature.Ast.name (List_.to_string (fun x->x) "|" values)
    | Ast.Disequality [] ->
        sprintf "%s=*" u_feature.Ast.name
bguillaum's avatar
bguillaum committed
97 98
    | Ast.Absent ->
        sprintf "!%s" u_feature.Ast.name
bguillaum's avatar
bguillaum committed
99
    | Ast.Disequality values ->
bguillaum's avatar
bguillaum committed
100
        sprintf "%s<>%s" u_feature.Ast.name (List_.to_string (fun x->x) "|" values)
bguillaum's avatar
bguillaum committed
101
    | Ast.Equal_param index ->
bguillaum's avatar
bguillaum committed
102 103
        sprintf "%s=%s" u_feature.Ast.name index

bguillaum's avatar
bguillaum committed
104 105 106 107 108 109 110 111
  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 -> "");
bguillaum's avatar
bguillaum committed
112 113 114
    match u_edge.Ast.edge_label_cst with
    | (l,true) -> bprintf buff "%s -[^%s]-> %s;\n" u_edge.Ast.src (List_.to_string (fun x->x) "|" l) u_edge.Ast.tar
    | (l,false) -> bprintf buff "%s -[%s]-> %s;\n" u_edge.Ast.src (List_.to_string (fun x->x) "|" l) u_edge.Ast.tar
bguillaum's avatar
bguillaum committed
115

bguillaum's avatar
bguillaum committed
116 117 118
  let buff_html_const buff (u_const,_) =
    bprintf buff "      ";
    (match u_const with
119
    | Ast.Cst_out (ident, ([],false)) ->
120
      bprintf buff "%s -> *" ident
121 122 123 124 125 126 127 128
    | Ast.Cst_out (ident, (labels,false)) ->
      bprintf buff "%s -[%s]-> *" ident (List_.to_string (fun x->x) "|" labels)
    | Ast.Cst_out (ident, (labels,true)) ->
      bprintf buff "%s -[^%s]-> *" ident (List_.to_string (fun x->x) "|" labels)

    | Ast.Cst_in (ident, ([],false)) ->
      bprintf buff "* -> %s" ident
    | Ast.Cst_in (ident, (labels,false)) ->
129
      bprintf buff "* -[%s]-> %s" (List_.to_string (fun x->x) "|" labels) ident
130 131 132
    | Ast.Cst_in (ident, (labels,true)) ->
      bprintf buff "* -[^%s]-> %s" (List_.to_string (fun x->x) "|" labels) ident

133 134 135 136 137 138
    | Ast.Feature_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.Feature_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.Feature_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)
139
    );
bguillaum's avatar
bguillaum committed
140 141
    bprintf buff "\n"

bguillaum's avatar
bguillaum committed
142
  let buff_html_pos_basic buff pos_basic =
bguillaum's avatar
bguillaum committed
143
    bprintf buff "    <font color=\"purple\">match</font> <b>{</b>\n";
bguillaum's avatar
bguillaum committed
144 145 146
    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;
bguillaum's avatar
bguillaum committed
147
    bprintf buff "    <b>}</b>\n"
bguillaum's avatar
bguillaum committed
148

bguillaum's avatar
bguillaum committed
149
  let buff_html_neg_basic buff neg_basic =
bguillaum's avatar
bguillaum committed
150
    bprintf buff "    <font color=\"purple\">without</font> <b>{</b>\n";
bguillaum's avatar
bguillaum committed
151 152 153
    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;
bguillaum's avatar
bguillaum committed
154 155 156 157
    bprintf buff "    <b>}</b>\n"

  let to_html_rules rules =
    let buff = Buffer.create 32 in
bguillaum's avatar
bguillaum committed
158
    List.iter
bguillaum's avatar
bguillaum committed
159
      (fun rule ->
160
        (* the first line: (lex_)rule / filter *)
bguillaum's avatar
bguillaum committed
161
        (match (rule.Ast.commands, rule.Ast.param) with
bguillaum's avatar
bguillaum committed
162
          | ([], None) ->
bguillaum's avatar
bguillaum committed
163
            bprintf buff "<font color=\"purple\">filter</font> %s <b>{</b>\n" rule.Ast.rule_id
bguillaum's avatar
bguillaum committed
164
          | (_,None) ->
bguillaum's avatar
bguillaum committed
165
            bprintf buff "<font color=\"purple\">rule</font> %s <b>{</b>\n" rule.Ast.rule_id
166
          | (_,Some (files, vars)) ->
bguillaum's avatar
bguillaum committed
167 168
            let param =
              match files with
169
                | [] -> sprintf "(feature %s)" (String.concat ", " vars)
bguillaum's avatar
bguillaum committed
170 171
                | l ->  sprintf "(feature %s; %s)"
                  (String.concat ", " vars)
172
                  (String.concat ", " (List.map (fun f -> sprintf "file \"%s\"" f) l)) in
bguillaum's avatar
bguillaum committed
173 174
            bprintf buff "<font color=\"purple\">lex_rule</font> %s %s <b>{</b>\n" rule.Ast.rule_id param
        );
bguillaum's avatar
bguillaum committed
175 176

        (* the match part *)
bguillaum's avatar
bguillaum committed
177
        buff_html_pos_basic buff rule.Ast.pos_basic;
bguillaum's avatar
bguillaum committed
178 179

        (* the without parts *)
bguillaum's avatar
bguillaum committed
180
        List.iter (buff_html_neg_basic buff) rule.Ast.neg_basics;
bguillaum's avatar
bguillaum committed
181 182

        (*  the commands part *)
bguillaum's avatar
bguillaum committed
183 184 185 186 187
        (match rule.Ast.commands with
          | [] -> ()  (* filter *)
          | list ->
            bprintf buff "    <font color=\"purple\">commands</font> <b>{</b>\n";
            List.iter (buff_html_command buff) list;
bguillaum's avatar
bguillaum committed
188
            bprintf buff "    <b>}</b>\n");
bguillaum's avatar
bguillaum committed
189

bguillaum's avatar
bguillaum committed
190
        bprintf buff "<b>}</b>\n";
bguillaum's avatar
bguillaum committed
191 192 193 194 195 196 197
      ) rules;
    Buffer.contents buff


  let doc_to_html string =
    if Str.string_match (Str.regexp "^  \\* ") string 0
    then sprintf "<font color=\"green\"><i>%s</i></font>" (String.sub string 4 ((String.length string)-4))
bguillaum's avatar
bguillaum committed
198
    else
bguillaum's avatar
bguillaum committed
199 200 201 202 203 204 205 206 207 208
      List.fold_left
        (fun acc (re,str) -> Str.global_replace (Str.regexp re) str acc)
        string
        [
          "\\[", "<b>";
          "\\]", "</b>";
          "~", "&nbsp;";
        ]

  let of_opt_color = function
209 210
    | [] -> "black"
    | c::_ -> String.sub c 1 ((String.length c) - 1)
bguillaum's avatar
bguillaum committed
211

212
  let module_page_text ~corpus prev next module_ =
bguillaum's avatar
bguillaum committed
213 214 215 216
    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

bguillaum's avatar
bguillaum committed
217
    let title = sprintf "Grew -- Module %s" module_.Ast.module_id in
bguillaum's avatar
bguillaum committed
218
    html_header ~css_file:"style.css" ~title buff;
bguillaum's avatar
bguillaum committed
219

bguillaum's avatar
bguillaum committed
220
    wnl "  <body>";
221 222
    if corpus
    then wnl "<a href=\"../sentences.html\">Sentences</a> -- <a href=\"../index.html\">Rewriting stats</a> -- GRS documentation";
bguillaum's avatar
bguillaum committed
223

bguillaum's avatar
bguillaum committed
224 225
    wnl "    <div class=\"navbar\">";
    w "      ";
bguillaum's avatar
bguillaum committed
226 227 228
    (match prev with Some p -> w "&nbsp;<a href=\"%s.html\">Previous</a>" p | _ -> ());
    w "&nbsp;<a href=\"index.html\">Up</a>";
    (match next with Some n -> w "&nbsp;<a href=\"%s.html\">Next</a>" n | _ -> ());
bguillaum's avatar
bguillaum committed
229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246
    wnl "    </div>";

    wnl "    <center><h1>Module <div class=\"module_title\">%s</div></h1></center><br/>" module_.Ast.module_id;
    List.iter (fun s -> wnl "    %s<br/>" (doc_to_html s)) module_.Ast.module_doc;
    wnl "    <h6>%d Rules</h6>" (List.length module_.Ast.rules);
    wnl "    <table class=\"indextable\">";
    List.iter
      (fun rule ->
        wnl "      <tr>";
        wnl "        <td width=\"200px\"><a href=\"%s_%s.html\">%s</a></td>" module_.Ast.module_id rule.Ast.rule_id rule.Ast.rule_id;
        (match rule.Ast.rule_doc with [] -> () | l::_ -> wnl "        <td>%s</td>" (doc_to_html l));
        wnl "      </tr>";
      ) module_.Ast.rules;
    wnl "    </table>";
    wnl "  </body>";
    wnl "</html>";
    Buffer.contents buff

247
  let rule_page_text ~corpus ~dep prev next rule_ module_ =
bguillaum's avatar
bguillaum committed
248 249
    let rid = rule_.Ast.rule_id in
    let mid = module_.Ast.module_id in
bguillaum's avatar
bguillaum committed
250

bguillaum's avatar
bguillaum committed
251 252 253
    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
pj2m's avatar
pj2m committed
254

bguillaum's avatar
bguillaum committed
255
    let title = sprintf "Grew -- Rule %s/%s" mid rid in
bguillaum's avatar
bguillaum committed
256
    html_header ~css_file:"style.css" ~title buff;
pj2m's avatar
pj2m committed
257

bguillaum's avatar
bguillaum committed
258
    wnl "  <body>";
259 260
    if corpus
    then wnl "<a href=\"../sentences.html\">Sentences</a> -- <a href=\"../index.html\">Rewriting stats</a> -- GRS documentation";
bguillaum's avatar
bguillaum committed
261

bguillaum's avatar
bguillaum committed
262 263
    wnl "    <div class=\"navbar\">";
    w "      ";
bguillaum's avatar
bguillaum committed
264
    (match prev with Some p -> w "&nbsp;<a href=\"%s_%s.html\">Previous</a>" mid p | _ -> ());
bguillaum's avatar
bguillaum committed
265
    w "&nbsp;<a href=\"%s.html\">Up</a>" mid;
bguillaum's avatar
bguillaum committed
266
    (match next with Some n -> w "&nbsp;<a href=\"%s_%s.html\">Next</a>" mid n | _ -> ());
bguillaum's avatar
bguillaum committed
267
    wnl "    </div>";
pj2m's avatar
pj2m committed
268

bguillaum's avatar
bguillaum committed
269 270 271 272 273 274 275
    wnl "<center><h1>Rule <a href=\"%s.html\">%s</a>.<div class=\"module_title\">%s</div></h1></center>" mid mid rid;
    List.iter (fun s -> wnl "    %s<br/>" (doc_to_html s)) rule_.Ast.rule_doc;

    wnl "<h6>Code</h6>";
    wnl "<pre>";
    w "%s" (to_html_rules [rule_]);
    wnl "</pre>";
bguillaum's avatar
bguillaum committed
276 277 278

    if dep
    then
279 280 281 282 283 284
      begin
        wnl "<h6>Pattern</h6>";
        wnl "<pre>";
        w "<IMG src=\"%s\">" (sprintf "%s_%s-patt.png" mid rid);
        wnl "</pre>"
      end;
bguillaum's avatar
bguillaum committed
285

286 287 288
    let output_table args lines =
      wnl "    <table border=\"1\" cellspacing=\"0\" cellpadding=\"3\">";
      wnl "    <tr>%s</tr>" (List_.to_string (fun x -> sprintf "<th bgcolor=\"#cccccc\">%s</th>" x) "" args);
bguillaum's avatar
bguillaum committed
289 290
      List.iter
        (fun l -> wnl "<tr>%s</tr>"
291 292 293 294
          (List_.to_string (fun x -> sprintf "<td>%s</td>" x) "" (Str.split (Str.regexp "#+") l))
        ) lines;
      wnl "    </table>" in

bguillaum's avatar
bguillaum committed
295 296
    (match rule_.Ast.param with
      | None -> ()
bguillaum's avatar
bguillaum committed
297
      | Some (files, args) ->
bguillaum's avatar
bguillaum committed
298
        wnl "<h6>Lexical parameters</h6>";
299 300

        (* output local lexical parameters (if any) *)
bguillaum's avatar
bguillaum committed
301
        (match rule_.Ast.lex_par with
302
          | None -> ()
bguillaum's avatar
bguillaum committed
303
          | Some lines ->
bguillaum's avatar
bguillaum committed
304
            wnl "<b>Local parameters</b><br/>";
bguillaum's avatar
bguillaum committed
305
            output_table args lines
306 307 308 309 310 311
        );

        (* output external lexical parameters (if any) *)
        List.iter
          (fun file ->
            let filename = Filename.concat module_.Ast.mod_dir file in
bguillaum's avatar
bguillaum committed
312
            wnl "<b>File:</b> %s<br/>" file;
bguillaum's avatar
bguillaum committed
313
            let lines =
314 315 316 317 318
              try File.read filename
              with Sys_error msg -> wnl "<font color=\"red\">Error: %s</font>" msg; [] in
            output_table args lines
          ) files
    );
bguillaum's avatar
bguillaum committed
319 320 321 322 323
    wnl "  </body>";
    wnl "</html>";
    Buffer.contents buff


324
  let sequences_text ~corpus ast =
bguillaum's avatar
bguillaum committed
325 326
    let buff = Buffer.create 32 in
    let wnl fmt = Printf.ksprintf (fun x -> Printf.bprintf buff "%s\n" x) fmt in
bguillaum's avatar
bguillaum committed
327 328

    let title = sprintf "Grew -- List of sequences" in
bguillaum's avatar
bguillaum committed
329
    html_header ~css_file:"style.css" ~title buff;
bguillaum's avatar
bguillaum committed
330

bguillaum's avatar
bguillaum committed
331
    wnl "  <body>";
332 333
    if corpus
    then wnl "<a href=\"../sentences.html\">Sentences</a> -- <a href=\"../index.html\">Rewriting stats</a> -- GRS documentation";
bguillaum's avatar
bguillaum committed
334

bguillaum's avatar
bguillaum committed
335 336 337
    wnl "  <div class=\"navbar\">&nbsp;<a href=\"index.html\">Up</a></div>";
    wnl "  <center><h1>List of sequences</h1></center>";
    List.iter
338 339 340
      (function
        | Ast.New _ -> failwith "Wait..."
        | Ast.Old seq ->
bguillaum's avatar
bguillaum committed
341 342 343 344 345 346
        wnl "<h6>%s</h6>" seq.Ast.seq_name;
        List.iter (fun l -> wnl "<p>%s</p>" (doc_to_html l)) seq.Ast.seq_doc;

        wnl "<div class=\"code\">";
        wnl "%s" (String.concat " ⇨ " (List.map (fun x -> sprintf "<a href=\"%s.html\">%s</a>" x x) seq.Ast.seq_mod));
        wnl "</div>";
bguillaum's avatar
bguillaum committed
347

bguillaum's avatar
bguillaum committed
348 349 350 351 352 353 354
      ) ast.Ast.sequences;
    wnl "  </body>";
    wnl "</html>";
    Buffer.contents buff



bguillaum's avatar
bguillaum committed
355
  let index_modules_text ast =
bguillaum's avatar
bguillaum committed
356 357
    let buff = Buffer.create 32 in
    let wnl fmt = Printf.ksprintf (fun x -> Printf.bprintf buff "%s\n" x) fmt in
bguillaum's avatar
bguillaum committed
358 359

    let title = sprintf "Grew -- Index of modules" in
bguillaum's avatar
bguillaum committed
360
    html_header ~css_file:"style.css" ~title buff;
bguillaum's avatar
bguillaum committed
361

bguillaum's avatar
bguillaum committed
362
    wnl "  <body>";
bguillaum's avatar
bguillaum committed
363 364 365 366 367 368 369
    wnl "  <div class=\"navbar\">&nbsp;<a href=\"index.html\">Up</a></div>";
    wnl "  <center><h1>Index of modules</h1></center>";
    wnl "  <table width=100%%>";
    List.iter
      (fun initial ->
        match List.filter (fun mod_ -> Char.uppercase mod_.Ast.module_id.[0] = initial) ast.Ast.modules  with
          | [] -> ()
bguillaum's avatar
bguillaum committed
370
          | l ->
bguillaum's avatar
bguillaum committed
371 372
            wnl "<tr><td colspan=2 ><h6>%s</h6></td></tr>" (Char.escaped initial);
            List.iter
bguillaum's avatar
bguillaum committed
373
              (fun mod_ ->
bguillaum's avatar
bguillaum committed
374 375 376 377 378 379 380 381 382 383
                wnl "<tr>";
                wnl "<td width=\"200px\"><a href=\"%s.html\">%s</a></td>" mod_.Ast.module_id mod_.Ast.module_id;
                (match mod_.Ast.module_doc with [] -> () | h::_ -> wnl "<td>%s</td>\n" (doc_to_html h));
                wnl "</tr>";
              ) 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 "  </body>";
    wnl "</html>";
    Buffer.contents buff

bguillaum's avatar
bguillaum committed
384

385
  let domain_text ~corpus ast =
bguillaum's avatar
bguillaum committed
386 387 388
    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
bguillaum's avatar
bguillaum committed
389 390

    let title = sprintf "Grew -- Features domain" in
bguillaum's avatar
bguillaum committed
391
    html_header ~css_file:"style.css" ~title buff;
bguillaum's avatar
bguillaum committed
392

bguillaum's avatar
bguillaum committed
393
    wnl "  <body>";
394 395
    if corpus
    then wnl "<a href=\"../sentences.html\">Sentences</a> -- <a href=\"../index.html\">Rewriting stats</a> -- GRS documentation";
bguillaum's avatar
bguillaum committed
396

bguillaum's avatar
bguillaum committed
397 398 399 400 401 402
    wnl "  <div class=\"navbar\">&nbsp;<a href=\"index.html\">Up</a></div>";

    wnl "  <h6>Features</h6>";
    wnl "  <code class=\"code\">";
    List.iter
      (function
bguillaum's avatar
bguillaum committed
403 404
        | Domain.Closed (feat_name,values) -> wnl "<b>%s</b> : %s<br/>" feat_name (String.concat " | " values)
        | Domain.Open feat_name -> wnl "    <b>%s</b> : *<br/>" feat_name
bguillaum's avatar
bguillaum committed
405
        | Domain.Num feat_name -> wnl "    <b>%s</b> : #<br/>" feat_name
bguillaum's avatar
bguillaum committed
406 407 408 409 410 411 412
      ) ast.Ast.domain;
    wnl "  </code>";

    wnl "  <h6>Labels</h6>";
    wnl "  <code class=\"code\">";
    (match ast.Ast.labels with
      | [] -> wnl "No labels defined!"
bguillaum's avatar
bguillaum committed
413
      | (l,c)::t -> w "<font color=\"%s\">%s</font>" (of_opt_color c) l;
bguillaum's avatar
bguillaum committed
414
        List.iter
bguillaum's avatar
bguillaum committed
415 416
          (fun (lab,color) ->
            w ", <font color=\"%s\">%s</font>" (of_opt_color color) lab;
bguillaum's avatar
bguillaum committed
417 418 419
          ) t;
        wnl "");
    wnl "  </code>";
bguillaum's avatar
bguillaum committed
420

bguillaum's avatar
bguillaum committed
421 422 423 424
    wnl "  </body>";
    wnl "</html>";
    Buffer.contents buff

425
  let build ~dep ~corpus output_dir grs =
bguillaum's avatar
bguillaum committed
426 427
    let filename = Grs.get_filename grs in
    let ast = Grs.get_ast grs in
bguillaum's avatar
bguillaum committed
428 429 430
    ignore(Sys.command ("rm -rf "^output_dir));
    ignore(Sys.command ("mkdir "^output_dir));
    ignore(Sys.command ("cp "^DATA_DIR^"/style.css "^output_dir));
bguillaum's avatar
bguillaum committed
431

bguillaum's avatar
bguillaum committed
432 433
    (** index.html **)
    let index = Filename.concat output_dir "index.html" in
bguillaum's avatar
bguillaum committed
434

bguillaum's avatar
bguillaum committed
435 436 437 438
    (* 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
bguillaum's avatar
bguillaum committed
439

bguillaum's avatar
bguillaum committed
440
    let title = sprintf "Grew -- Graph Rewriting System: %s" (Filename.basename filename) in
bguillaum's avatar
bguillaum committed
441
    html_header ~css_file:"style.css" ~title buff;
442

bguillaum's avatar
bguillaum committed
443
    wnl "  <body>";
444 445
    if corpus
    then wnl "<a href=\"../sentences.html\">Sentences</a> -- <a href=\"../index.html\">Rewriting stats</a> -- GRS documentation";
446

bguillaum's avatar
bguillaum committed
447 448
    wnl "<h1>Graph Rewriting System: %s</h1>" (Filename.basename filename);
    wnl "<center><b>full path</b>: %s</center>" filename;
449

bguillaum's avatar
bguillaum committed
450 451 452 453 454 455 456
    wnl "<a href=domain.html>Domain</a><br/>";
    wnl "<a href=modules.html>Index of modules</a><br/>";
    wnl "<a href=sequences.html>List of sequences</a><br/>";

    wnl "<h6>Modules</h6>";
    wnl "<table class=\"indextable\">";
    List.iter
bguillaum's avatar
bguillaum committed
457
      (fun m ->
bguillaum's avatar
bguillaum committed
458 459 460 461 462
        wnl "<tr>";
        wnl "<td width=\"200px\"><a href=\"%s.html\">%s</a></td>" m.Ast.module_id m.Ast.module_id;
        (match m.Ast.module_doc with [] -> () | h::_ -> wnl "<td>%s</td>\n" (doc_to_html h));
        wnl "</tr>"
      ) ast.Ast.modules;
bguillaum's avatar
bguillaum committed
463

bguillaum's avatar
bguillaum committed
464 465 466 467 468 469 470
    wnl "</table>";
    wnl "</body>";
    wnl "</html>";

    let index_out_ch = open_out index in
    output_string index_out_ch (Buffer.contents buff);
    close_out index_out_ch;
bguillaum's avatar
bguillaum committed
471

bguillaum's avatar
bguillaum committed
472 473
    (** Sequences.html **)
    let sequences = Filename.concat output_dir "sequences.html" in
bguillaum's avatar
bguillaum committed
474

bguillaum's avatar
bguillaum committed
475
    let sequences_out_ch = open_out sequences in
476
    output_string sequences_out_ch (sequences_text ~corpus ast);
bguillaum's avatar
bguillaum committed
477
    close_out sequences_out_ch;
bguillaum's avatar
bguillaum committed
478

bguillaum's avatar
bguillaum committed
479 480
    (** Modules.html **)
    let modules = Filename.concat output_dir "modules.html" in
bguillaum's avatar
bguillaum committed
481

bguillaum's avatar
bguillaum committed
482 483 484
    let modules_out_ch = open_out modules in
    output_string modules_out_ch (index_modules_text ast);
    close_out modules_out_ch;
bguillaum's avatar
bguillaum committed
485

bguillaum's avatar
bguillaum committed
486 487
    (** domain.html **)
    let domain = Filename.concat output_dir "domain.html" in
bguillaum's avatar
bguillaum committed
488

bguillaum's avatar
bguillaum committed
489
    let domain_out_ch = open_out domain in
490
    output_string domain_out_ch (domain_text ~corpus ast);
bguillaum's avatar
bguillaum committed
491
    close_out domain_out_ch;
bguillaum's avatar
bguillaum committed
492

bguillaum's avatar
bguillaum committed
493 494 495 496 497
    (** 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
bguillaum's avatar
bguillaum committed
498
      output_string page_out_ch
499
        (module_page_text ~corpus
bguillaum's avatar
bguillaum committed
500
           (try Some (modules_array.(i-1).Ast.module_id) with _ -> None)
bguillaum's avatar
bguillaum committed
501 502 503 504
           (try Some (modules_array.(i+1).Ast.module_id) with _ -> None)
           modules_array.(i)
        );
      close_out page_out_ch;
bguillaum's avatar
bguillaum committed
505

bguillaum's avatar
bguillaum committed
506 507
      let rules_array = Array.of_list modules_array.(i).Ast.rules in
      for j = 0 to (Array.length rules_array -1) do
bguillaum's avatar
bguillaum committed
508

bguillaum's avatar
bguillaum committed
509 510
        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
bguillaum's avatar
bguillaum committed
511
        output_string page_out_ch
512
          (rule_page_text ~corpus
bguillaum's avatar
bguillaum committed
513
             ~dep
bguillaum's avatar
bguillaum committed
514
             (try Some (rules_array.(j-1).Ast.rule_id) with _ -> None)
bguillaum's avatar
bguillaum committed
515 516 517
             (try Some (rules_array.(j+1).Ast.rule_id) with _ -> None)
             rules_array.(j)
             modules_array.(i)
bguillaum's avatar
bguillaum committed
518 519 520
          );
        close_out page_out_ch;
      done;
bguillaum's avatar
bguillaum committed
521
    done
bguillaum's avatar
bguillaum committed
522 523
end (* module Html_doc *)

bguillaum's avatar
bguillaum committed
524
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
525
module Html_rh = struct
bguillaum's avatar
bguillaum committed
526
  let build ?filter ?main_feat ?(dot=false) ?(init_graph=true) ?(out_gr=false) ?header ?graph_file prefix t =
bguillaum's avatar
bguillaum committed
527 528 529 530 531 532

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

bguillaum's avatar
bguillaum committed
533 534 535 536
    (
      if init_graph
      then ignore (Instance.save_dep_png ?filter ?main_feat prefix t.Rewrite_history.instance)
    );
bguillaum's avatar
bguillaum committed
537

538
    let nf_files = Rewrite_history.save_nfs ?filter ?main_feat ~dot prefix t in
bguillaum's avatar
bguillaum committed
539 540 541 542 543 544 545 546 547

    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
bguillaum's avatar
bguillaum committed
548
    html_header ~css_file:"style.css" ~title buff;
bguillaum's avatar
bguillaum committed
549 550 551 552 553 554 555 556

    wnl "<body>";
    wnl "<a href=\"sentences.html\">Sentences</a> -- <a href=\"index.html\">Rewriting stats</a> -- <a href=\"doc/index.html\">GRS documentation</a>";

    wnl "<h1>%s</h1>" title;

    begin
      match header with
bguillaum's avatar
bguillaum committed
557
        | Some h -> wnl "%s<br/>" h
bguillaum's avatar
bguillaum committed
558 559 560
        | None -> ()
    end;

bguillaum's avatar
bguillaum committed
561 562 563 564 565 566 567
    begin
      match graph_file with
        | Some gf ->
          wnl "<b>Input file</b>: <a href=\"%s\">%s</a><br/>"
            gf (Filename.basename gf)
        | None -> ()
    end;
bguillaum's avatar
bguillaum committed
568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632

    wnl "<b>Input sentence</b>: <font color=\"green\"><i>%s</i></font></p><br/>"
      (G_graph.to_sentence ?main_feat t.Rewrite_history.instance.Instance.graph);

    if init_graph
    then
      begin
        wnl "<h6>Initial graph</h6>";
        wnl "<div width=100%% style=\"overflow-x:auto\"><IMG SRC=\"%s.png\"></div>" local
      end;

    List_.iteri
      (fun i (rules_list,file_name) ->
        wnl "<h6>Solution %d</h6>" (i+1);

        let local_name = Filename.basename file_name in

        if out_gr
        then wnl "<p><a href=\"%s.gr\">gr file</a>" local_name;

        (* the png file *)
        wnl "<div width=100%% style=\"overflow-x:auto\"><IMG SRC=\"%s.png\"></div>" local_name;

        (* the modules list *)
        wnl "<b>Modules applied</b>: %d<br/>" (List.length rules_list);

        let id = sprintf "id_%d" (i+1) in

        wnl "<a style=\"cursor:pointer;\"";
        wnl "  onClick=\"if (document.getElementById('%s').style.display == 'none')" id;
        wnl "      { document.getElementById('%s').style.display = 'block'; document.getElementById('p_%s').innerHTML = 'Hide applied rules'; }" id id;
        wnl " else { document.getElementById('%s').style.display = 'none';; document.getElementById('p_%s').innerHTML = 'Show applied rules'; }\">" id id;
        wnl "         <b><p id=\"p_%s\">Show applied rules</p></b>" id;
        wnl "</a>";

        wnl " <div id=\"%s\" style=\"display:none;\">" id;

        List.iter
          (fun (mod_name,rules) ->
            wnl "<p><b><font color=\"red\">%s: </font></b><font color=\"green\">%s</font></p>"
              mod_name
              (List_.to_string (fun x -> x) ", " rules);
          )
          rules_list;
        wnl " </div>"

      ) nf_files;

    wnl "</body>";
    wnl "</html>";

    let out_ch = open_out (sprintf "%s.html" prefix) in
    fprintf out_ch "%s" (Buffer.contents buff);
    close_out out_ch



  let error ?main_feat ?(dot=false) ?(init_graph=true) ?header prefix msg inst_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 inst_opt, init_graph with
      | (Some inst, true) when dot -> Instance.save_dot_png ?main_feat prefix inst
bguillaum's avatar
bguillaum committed
633
      | (Some inst, true) -> ignore (Instance.save_dep_png ?main_feat prefix inst)
bguillaum's avatar
bguillaum committed
634 635 636 637 638 639 640 641 642
      | _ -> ()
    );

    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
bguillaum's avatar
bguillaum committed
643
    html_header ~css_file:"style.css" ~title buff;
bguillaum's avatar
bguillaum committed
644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662

    wnl "<body>";
    wnl "<a href=\"sentences.html\">Sentences</a> -- <a href=\"index.html\">Rewriting stats</a> -- <a href=\"doc/index.html\">GRS documentation</a>";

    wnl "<h1>%s</h1>" title;

    if init_graph
    then
      begin
        wnl "<h6>Initial graph</h6>";
        wnl "<div width=100%% style=\"overflow-x:auto\"><IMG SRC=\"%s.png\"></div>" local
      end;

    wnl "<h2>ERROR: %s</h2>" msg;
    wnl "</body>\n</html>";

    let out_ch = open_out (sprintf "%s.html" prefix) in
    fprintf out_ch "%s" (Buffer.contents buff);
    close_out out_ch
bguillaum's avatar
bguillaum committed
663
end (* module Html_rh *)
bguillaum's avatar
bguillaum committed
664

bguillaum's avatar
bguillaum committed
665
(* ================================================================================*)
bguillaum's avatar
bguillaum committed
666
module Html_sentences = struct
bguillaum's avatar
bguillaum committed
667
  let build ~title output_dir sentences =
bguillaum's avatar
bguillaum committed
668
    let buff = Buffer.create 32 in
bguillaum's avatar
bguillaum committed
669
    let wnl fmt = Printf.ksprintf (fun x -> Printf.bprintf buff "%s\n" x) fmt in
bguillaum's avatar
bguillaum committed
670

bguillaum's avatar
bguillaum committed
671
    html_header ~css_file:"style.css" ~title buff;
bguillaum's avatar
bguillaum committed
672 673 674

    wnl "  <body>";
    wnl "Sentences -- <a href=\"index.html\">Rewriting stats</a> -- <a href=\"doc/index.html\">GRS documentation</a>";
bguillaum's avatar
bguillaum committed
675 676 677
    wnl "<h1>%s</h1>" (Str.global_replace (Str.regexp "#") " " title);

     wnl "<h2>Sentences list</h2>";
bguillaum's avatar
bguillaum committed
678

bguillaum's avatar
bguillaum committed
679
    wnl "<center><table cellpadding=3 cellspacing=0 width=\"95%%\">";
bguillaum's avatar
bguillaum committed
680
    wnl "<tr><th class=\"first\">Number of normal forms</th><th>Sentence Id</th><th>Sentence</th></tr>";
bguillaum's avatar
bguillaum committed
681 682

    List.iter
bguillaum's avatar
bguillaum committed
683
      (fun (rewrited, base_name, amb, sentence) ->
bguillaum's avatar
bguillaum committed
684 685
        wnl "<tr>";
        wnl "    <td class=\"first_stats\">%d</td>" amb;
bguillaum's avatar
bguillaum committed
686 687 688 689
        if rewrited
        then wnl "    <td class=\"stats\"><a href=\"%s.html\">%s</a></td>" base_name base_name
        else wnl "    <td class=\"stats\">%s</td>" base_name;
        wnl "  <td class=\"stats\">%s</td>" sentence;
bguillaum's avatar
bguillaum committed
690
        wnl "</tr>";
bguillaum's avatar
bguillaum committed
691 692
      ) sentences;

bguillaum's avatar
bguillaum committed
693 694 695
    wnl "</table></center>";
    wnl "</body>";
    wnl "</html>";
bguillaum's avatar
bguillaum committed
696 697 698 699

    let out_ch = open_out (Filename.concat output_dir "sentences.html") in
    fprintf out_ch "%s" (Buffer.contents buff);
    close_out out_ch
bguillaum's avatar
bguillaum committed
700 701
end (* module Html_sentences *)

bguillaum's avatar
bguillaum committed
702
(* ================================================================================*)
bguillaum's avatar
bguillaum committed
703 704 705 706
module Gr_stat = struct

  (** the type [gr] stores the stats for the rewriting of one gr file *)
  type t =
bguillaum's avatar
bguillaum committed
707
    | Stat of ((int * int) String_map.t * int) (* map: rule_name |-> (min,max) occ, number of solution *)
bguillaum's avatar
bguillaum committed
708 709 710 711 712 713 714 715 716
    | 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
bguillaum's avatar
bguillaum committed
717 718
            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
bguillaum's avatar
bguillaum committed
719 720 721 722 723
          ) stat rules
      | None when rules = [] -> stat
      | None -> Log.fcritical "Unconsistent rewrite history"

  let max_stat stat1 stat2 =
bguillaum's avatar
bguillaum committed
724
    String_map.fold
bguillaum's avatar
bguillaum committed
725
      (fun key value acc ->
bguillaum's avatar
bguillaum committed
726 727
        let old = try String_map.find key acc with Not_found -> 0 in
        String_map.add key (max old value) acc
bguillaum's avatar
bguillaum committed
728 729 730 731 732 733 734 735 736 737 738
      ) 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 =
bguillaum's avatar
bguillaum committed
739
    String_map.fold
bguillaum's avatar
bguillaum committed
740
      (fun key (vmin, vmax) acc ->
bguillaum's avatar
bguillaum committed
741 742
        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
bguillaum's avatar
bguillaum committed
743 744 745 746 747 748 749 750
      ) 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
bguillaum's avatar
bguillaum committed
751
          | [] -> String_map.empty
bguillaum's avatar
bguillaum committed
752 753 754 755
          | 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
bguillaum's avatar
bguillaum committed
756
      (String_map.map
bguillaum's avatar
bguillaum committed
757 758 759 760 761 762 763 764 765
         (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, rh.Rewrite_history.bad_nf) with
bguillaum's avatar
bguillaum committed
766
          | [],[] -> Some (String_map.empty)
bguillaum's avatar
bguillaum committed
767 768 769 770 771 772 773 774 775 776
          | [], _ -> None
          | 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
bguillaum's avatar
bguillaum committed
777
      | None -> Stat (String_map.empty, Rewrite_history.num_sol rew_history)
bguillaum's avatar
bguillaum committed
778 779 780
      | Some map ->
        Stat
          (
bguillaum's avatar
bguillaum committed
781
            String_map.map (function Some i, Some j -> (i,j) | _ -> Log.critical "None in stat") map,
bguillaum's avatar
bguillaum committed
782 783 784 785 786 787 788 789 790 791 792
            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;
bguillaum's avatar
bguillaum committed
793
        String_map.iter
bguillaum's avatar
bguillaum committed
794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810
          (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
bguillaum's avatar
bguillaum committed
811
                  | [modu_rule; vmin; vmax] -> String_map.add modu_rule (int_of_string vmin, int_of_string vmax) acc
bguillaum's avatar
bguillaum committed
812
                  | _ -> Log.fcritical "invalid stat line: %s" line
bguillaum's avatar
bguillaum committed
813
              ) String_map.empty lines in
bguillaum's avatar
bguillaum committed
814 815 816 817
          Stat (map, !sol)
    with Sys_error msg -> Error (sprintf "Sys_error: %s" msg)
end (* module Gr_stat *)

bguillaum's avatar
bguillaum committed
818
(* ================================================================================*)
bguillaum's avatar
bguillaum committed
819 820 821 822 823 824 825 826
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 *)
bguillaum's avatar
bguillaum committed
827 828
    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 *)
bguillaum's avatar
bguillaum committed
829
    error: (string * string) list;                           (* (file, msg) *)
bguillaum's avatar
bguillaum committed
830 831 832 833 834 835 836 837 838 839 840 841 842
    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 ->
bguillaum's avatar
bguillaum committed
843 844 845
                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
bguillaum's avatar
bguillaum committed
846
        else acc
bguillaum's avatar
bguillaum committed
847 848
      ) String_map.empty (Grs.get_modules grs) in
    { modules=modules; map = map; amb = Int_map.empty; error = []; num = 0 }
bguillaum's avatar
bguillaum committed
849 850

  let add modul rule file (min_occ,max_occ) map =
bguillaum's avatar
bguillaum committed
851 852 853
    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
bguillaum's avatar
bguillaum committed
854
      modul
bguillaum's avatar
bguillaum committed
855
      (String_map.add
bguillaum's avatar
bguillaum committed
856
         rule
bguillaum's avatar
bguillaum committed
857
           ((old_min + min_occ, old_max + max_occ), String_set.add file old_file_set)
bguillaum's avatar
bguillaum committed
858 859 860 861 862 863 864 865
             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 =
bguillaum's avatar
bguillaum committed
866
          String_map.fold
bguillaum's avatar
bguillaum committed
867 868 869 870 871 872
            (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 =
bguillaum's avatar
bguillaum committed
873 874
          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
bguillaum's avatar
bguillaum committed
875 876
        { t with map = new_map; num = t.num+1; amb=new_amb; }

bguillaum's avatar
bguillaum committed
877
  let unfoldable_set output_dir buff ?(bound=10) id file_set =
bguillaum's avatar
bguillaum committed
878 879
    let counter = ref 0 in

bguillaum's avatar
bguillaum committed
880
    String_set.iter
bguillaum's avatar
bguillaum committed
881 882
      (fun file ->
        if !counter = bound
bguillaum's avatar
bguillaum committed
883
        then bprintf buff "<div id=\"%s\" style=\"display:none;\">\n" id;
bguillaum's avatar
bguillaum committed
884 885 886 887 888 889 890
        incr counter;

        let link =
          if Sys.file_exists (Filename.concat output_dir (sprintf "%s.html" file))
          then sprintf "<a href=\"%s.html\">%s</a>" file file
          else file in

bguillaum's avatar
bguillaum committed
891
        bprintf buff "%s &nbsp;&nbsp;\n" link
bguillaum's avatar
bguillaum committed
892 893 894 895 896
      ) file_set;

    if (!counter > bound)
    then
      begin
bguillaum's avatar
bguillaum committed
897
        bprintf buff "</div>\n";
bguillaum's avatar
bguillaum committed
898 899
        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
bguillaum's avatar
bguillaum committed
900 901 902 903 904
        bprintf buff "  <div>\n";
        bprintf buff "    <a style=\"cursor:pointer;\" onClick=\"if (document.getElementById('%s').style.display == 'none') { %s } else { %s }\">\n" id if_part else_part;
        bprintf buff "      <b><p id=\"p_%s\">+ Show all +</p></b>\n" id;
        bprintf buff "    </a>\n";
        bprintf buff "  </div>\n";
bguillaum's avatar
bguillaum committed
905 906
      end

bguillaum's avatar
bguillaum committed
907

bguillaum's avatar
bguillaum committed
908

bguillaum's avatar
bguillaum committed
909 910 911 912 913 914 915 916 917


  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")));

bguillaum's avatar
bguillaum committed
918 919 920
    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
bguillaum's avatar
bguillaum committed
921

bguillaum's avatar
bguillaum committed
922
    html_header ~css_file:"style.css" ~title buff;
bguillaum's avatar
bguillaum committed
923

bguillaum's avatar
bguillaum committed
924
    wnl "<a href=\"sentences.html\">Sentences</a> -- Rewriting stats -- <a href=\"doc/index.html\">GRS documentation</a>";
bguillaum's avatar
bguillaum committed
925

bguillaum's avatar
bguillaum committed
926 927
    wnl "<h1>%s</h1>" (Str.global_replace (Str.regexp "#") " " title);
    wnl "<h2>Rewriting stats</h2>";
bguillaum's avatar
bguillaum committed
928

bguillaum's avatar
bguillaum committed
929
    wnl "<center><table cellpadding=3 cellspacing=0 width=\"95%%\">";