grew_grs.ml 24.9 KB
Newer Older
pj2m's avatar
pj2m committed
1 2 3
open Printf
open Log

4
open Grew_fs
bguillaum's avatar
bguillaum committed
5 6
open Grew_utils
open Grew_ast
7
open Grew_edge
bguillaum's avatar
bguillaum committed
8 9 10
open Grew_command
open Grew_graph
open Grew_rule
pj2m's avatar
pj2m committed
11 12 13 14 15


module Rewrite_history = struct

  type t = {
16 17 18 19 20
    instance: Instance.t;
    module_name: string;
    good_nf: t list;
    bad_nf: Instance.t list;
  }
pj2m's avatar
pj2m committed
21

22
  let rec is_empty t =
bguillaum's avatar
bguillaum committed
23
    (t.instance.Instance.rules = []) && List.for_all is_empty t.good_nf
bguillaum's avatar
bguillaum committed
24 25

  let rec num_sol = function
26 27
    | { good_nf = []; bad_nf = [] } -> 1
    | { good_nf = [] } -> 0 (* dead branch *)
bguillaum's avatar
bguillaum committed
28
    | { good_nf = l} -> List.fold_left (fun acc t -> acc + (num_sol t)) 0 l
29

30

31 32 33
  (** [save_nfs ?main_feat base_name t] does two things:
      - write PNG files of normal forms
      - returns a list of couples (rules, file)
34
  *)
35
  let save_nfs ?main_feat ~dot base_name t =
36
    let rec loop file_name rules t =
37
      match (t.good_nf, t.bad_nf) with
38
        | [],[] when dot -> Instance.save_dot_png ?main_feat file_name t.instance; [rules, file_name]
39 40 41
        | [],[] -> Instance.save_dep_png ?main_feat file_name t.instance; [rules, file_name]
        | [],_ -> []
        | l, _ ->
42
          List_.foldi_left
43
            (fun i acc son ->
44
              (* Instance.save_dep_png ?main_feat (sprintf "%s_%d" file_name i) son.instance; *)
45 46 47 48
              let nfs = loop
                (sprintf "%s_%d" file_name i)
                (rules @ [t.module_name, son.instance.Instance.rules])
                son in
49 50 51 52 53
              nfs @ acc
            )
            [] l
    in loop base_name [] t

54 55

  let error_html ?main_feat ?(dot=false) ?(init_graph=true) ?header prefix msg inst_opt =
56 57 58 59 60 61
    (* 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
62
      | (Some inst, true) when dot -> Instance.save_dot_png ?main_feat prefix inst
63 64 65
      | (Some inst, true) -> Instance.save_dep_png ?main_feat prefix inst
      | _ -> ()
    );
66 67

    let local = Filename.basename prefix in
68

69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84
    (* All normal forms view *)
    let html_ch = open_out (sprintf "%s.html" prefix) in

    let title = sprintf "Sentence: %s --- ERROR" local in
    let () = Html.enter html_ch ~title ?header prefix in

    if init_graph
    then
      begin
        fprintf html_ch "<h6>Initial graph</h6>\n";
        fprintf html_ch "<div width=100%% style=\"overflow-x:auto\"><IMG SRC=\"%s.png\"></div>\n" local
      end;
    fprintf html_ch "<h2>ERROR: %s</h2>\n" msg;
    Html.leave html_ch;
    close_out html_ch

85 86 87 88 89 90 91
  let save_gr base t =
    let rec loop file_name t =
      match (t.good_nf, t.bad_nf) with
        | [],[] -> File.write (Instance.to_gr t.instance) (file_name^".gr")
        | l, _ -> List_.iteri (fun i son -> loop (sprintf "%s_%d" file_name i) son) l
    in loop base t

92
  let save_html ?main_feat ?(dot=false) ?(init_graph=true) ?(out_gr=false)  ?header ~graph_file prefix t =
pj2m's avatar
pj2m committed
93 94 95 96
    (* 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
97

98 99
    (if init_graph then Instance.save_dep_png ?main_feat prefix t.instance);

100
    let nf_files = save_nfs ?main_feat ~dot prefix t in
101

102 103
    let l = List.length nf_files in

pj2m's avatar
pj2m committed
104
    let local = Filename.basename prefix in
105

pj2m's avatar
pj2m committed
106 107 108
    (* All normal forms view *)
    let html_ch = open_out (sprintf "%s.html" prefix) in

bguillaum's avatar
bguillaum committed
109
    let title = sprintf "Sentence: %s --- %d Normal form%s" local l (if l>1 then "s" else "") in
110
    let () = Html.enter html_ch ~title ?header prefix in
pj2m's avatar
pj2m committed
111

bguillaum's avatar
bguillaum committed
112
    fprintf html_ch "<b>Input file</b>: <a href=\"%s\">%s</a><br/>\n"
113 114 115 116 117
      graph_file (Filename.basename graph_file);

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

bguillaum's avatar
bguillaum committed
118
    if init_graph
pj2m's avatar
pj2m committed
119 120
    then
      begin
121 122
        fprintf html_ch "<h6>Initial graph</h6>\n";
        fprintf html_ch "<div width=100%% style=\"overflow-x:auto\"><IMG SRC=\"%s.png\"></div>\n" local
pj2m's avatar
pj2m committed
123
      end;
124 125 126 127


    List_.iteri
      (fun i (rules_list,file_name) ->
bguillaum's avatar
bguillaum committed
128
        fprintf html_ch "<h6>Solution %d</h6>\n" (i+1);
pj2m's avatar
pj2m committed
129

130
        let local_name = Filename.basename file_name in
131

132 133 134
        if out_gr
        then fprintf html_ch "<p><a href=\"%s.gr\">gr file</a>\n" local_name;

bguillaum's avatar
bguillaum committed
135 136 137 138
        (* the png file *)
        fprintf html_ch "<div width=100%% style=\"overflow-x:auto\"><IMG SRC=\"%s.png\"></div>\n" local_name;

        (* the modules list *)
139
        fprintf html_ch "<b>Modules applied</b>: %d<br/>\n" (List.length rules_list);
140

bguillaum's avatar
bguillaum committed
141
        let id = sprintf "id_%d" (i+1) in
142

143 144
        fprintf html_ch "<a style=\"cursor:pointer;\"\n";
        fprintf html_ch "  onClick=\"if (document.getElementById('%s').style.display == 'none')\n" id;
bguillaum's avatar
bguillaum committed
145 146 147
        fprintf html_ch "      { document.getElementById('%s').style.display = 'block'; document.getElementById('p_%s').innerHTML = 'Hide applied rules'; }\n" id id;
        fprintf html_ch " else { document.getElementById('%s').style.display = 'none';; document.getElementById('p_%s').innerHTML = 'Show applied rules'; }\">" id id;
        fprintf html_ch "         <b><p id=\"p_%s\">Show applied rules</p></b>\n" id;
148
        fprintf html_ch "</a>\n";
bguillaum's avatar
bguillaum committed
149 150 151

        fprintf html_ch " <div id=\"%s\" style=\"display:none;\">\n" id;

152 153 154
        List.iter
          (fun (mod_name,rules) ->
            fprintf html_ch "<p><b><font color=\"red\">%s: </font></b><font color=\"green\">%s</font></p>\n"
155 156 157 158
              mod_name
              (List_.to_string (fun x -> x) ", " rules);
          )
          rules_list;
bguillaum's avatar
bguillaum committed
159 160
        fprintf html_ch " </div>\n"

pj2m's avatar
pj2m committed
161 162
      ) nf_files;
    Html.leave html_ch;
bguillaum's avatar
bguillaum committed
163
    close_out html_ch
pj2m's avatar
pj2m committed
164 165 166 167 168 169 170
end




module Modul = struct
  type t = {
171 172 173 174 175 176 177
    name: string;
    local_labels: (string * string option) array;
    rules: Rule.t list;
    filters: Rule.t list;
    confluent: bool;
    loc: Loc.t;
  }
pj2m's avatar
pj2m committed
178

179 180 181 182
  let check t =
    (* check for duplicate rules *)
    let rec loop already_defined = function
      | [] -> ()
183 184
      | r::_ when List.mem (Rule.get_name r) already_defined ->
        Error.build ~loc:(Rule.get_loc r) "Rule '%s' is defined twice in the same module" (Rule.get_name r)
185 186
      | r::tail -> loop ((Rule.get_name r) :: already_defined) tail in
    loop [] t.rules
pj2m's avatar
pj2m committed
187

188
  let build ast_module =
189 190
    let locals = Array.of_list ast_module.Ast.local_labels in
    Array.sort compare locals;
191
    let rules_or_filters = List.map (Rule.build ~locals ast_module.Ast.mod_dir) ast_module.Ast.rules in
192 193
    let (filters, rules) = List.partition Rule.is_filter rules_or_filters in
    let modul =
194
      {
195 196 197 198 199 200 201
        name = ast_module.Ast.module_id;
        local_labels = locals;
        rules = rules;
        filters = filters;
        confluent = ast_module.Ast.confluent;
        loc = ast_module.Ast.mod_loc;
      } in
202 203 204 205 206
    check modul; modul
end

module Sequence = struct
  type t = {
207 208 209 210
    name: string;
    def: string list;
    loc: Loc.t;
  }
211 212 213

  let check module_list t =
    List.iter
214
      (fun module_name ->
215 216
        if not (List.exists (fun modul -> modul.Modul.name = module_name) module_list)
        then Error.build ~loc:t.loc "sequence \"%s\", refers to the unknown module \"%s\"."
217
          t.name module_name
218 219
      ) t.def

220 221
  let build module_list ast_sequence =
    let sequence =
222
      {
223 224 225 226
        name = ast_sequence.Ast.seq_name;
        def = ast_sequence.Ast.seq_mod;
        loc = ast_sequence.Ast.seq_loc;
      } in
227
    check module_list sequence; sequence
pj2m's avatar
pj2m committed
228 229 230
end

module Grs = struct
231

pj2m's avatar
pj2m committed
232
  type t = {
233 234 235 236 237
    labels: Label.t list;    (* the list of global edge labels *)
    modules: Modul.t list;          (* the ordered list of modules used from rewriting *)
    sequences: Sequence.t list;
  }

238 239
  let sequence_names t = List.map (fun s -> s.Sequence.name) t.sequences

pj2m's avatar
pj2m committed
240 241
  let empty = {labels=[]; modules=[]; sequences=[];}

242 243 244 245
  let check t =
    (* check for duplicate modules *)
    let rec loop already_defined = function
      | [] -> ()
246 247
      | m::_ when List.mem m.Modul.name already_defined ->
        Error.build ~loc:m.Modul.loc "Module '%s' is defined twice" m.Modul.name
248 249 250 251 252 253
      | m::tail -> loop (m.Modul.name :: already_defined) tail in
    loop [] t.modules;

    (* check for duplicate sequences *)
    let rec loop already_defined = function
      | [] -> ()
254 255
      | s::_ when List.mem s.Sequence.name already_defined ->
        Error.build ~loc:s.Sequence.loc "Sequence '%s' is defined twice" s.Sequence.name
256 257 258
      | s::tail -> loop (s.Sequence.name :: already_defined) tail in
    loop [] t.sequences

pj2m's avatar
pj2m committed
259
  let build ast_grs =
260
    Label.init ast_grs.Ast.labels;
261 262
    Domain.init ast_grs.Ast.domain;
    let modules = List.map Modul.build ast_grs.Ast.modules in
263 264 265 266 267 268
    let grs = {
      labels = List.map (fun (l,_) -> Label.from_string l) ast_grs.Ast.labels;
      modules = modules;
      sequences = List.map (Sequence.build modules) ast_grs.Ast.sequences;
    } in
    check grs; grs
pj2m's avatar
pj2m committed
269

bguillaum's avatar
bguillaum committed
270
  let modules_of_sequence grs sequence =
271
    let module_names =
272
      try
273 274
        let seq = List.find (fun s -> s.Sequence.name = sequence) grs.sequences in
        seq.Sequence.def
bguillaum's avatar
bguillaum committed
275 276
      with Not_found -> [sequence] in (* a module name can be used as a singleton sequence *)

277 278 279
    List.map
      (fun name ->
        try List.find (fun m -> m.Modul.name=name) grs.modules
bguillaum's avatar
bguillaum committed
280 281 282 283
        with Not_found -> Log.fcritical "No sequence or module named '%s'" name
      )
      module_names

284
  let rewrite grs sequence instance =
bguillaum's avatar
bguillaum committed
285
    let modules_to_apply = modules_of_sequence grs sequence in
286

pj2m's avatar
pj2m committed
287
    let rec loop instance = function
288 289 290 291 292 293 294 295 296
      | [] -> (* no more modules to apply *)
        {Rewrite_history.instance = instance; module_name = ""; good_nf = []; bad_nf = []; }
      | next::tail ->
        let (good_set, bad_set) =
          Rule.normalize
            next.Modul.name
            ~confluent: next.Modul.confluent
            next.Modul.rules
            next.Modul.filters
297
            (Instance.flatten instance) in
298 299 300 301 302 303 304 305
        let good_list = Instance_set.elements good_set
        and bad_list = Instance_set.elements bad_set in
        {
          Rewrite_history.instance = instance;
          module_name = next.Modul.name;
          good_nf = List.map (fun i -> loop i tail) good_list;
          bad_nf = bad_list;
        } in
bguillaum's avatar
bguillaum committed
306
    loop instance modules_to_apply
307

bguillaum's avatar
bguillaum committed
308 309
  let build_rew_display grs sequence instance =
    let modules_to_apply = modules_of_sequence grs sequence in
pj2m's avatar
pj2m committed
310 311 312

    let rec loop instance = function
      | [] -> Grew_types.Leaf instance.Instance.graph
313
      | next :: tail ->
314 315 316 317 318 319
        let (good_set, bad_set) =
          Rule.normalize
            next.Modul.name
            ~confluent: next.Modul.confluent
            next.Modul.rules
            next.Modul.filters
320
            (Instance.flatten instance) in
321
        let inst_list = Instance_set.elements good_set
322
              (* and bad_list = Instance_set.elements bad_set *) in
pj2m's avatar
pj2m committed
323

324
        match inst_list with
325
          | [{Instance.big_step = None}] ->
326
            Grew_types.Local_normal_form (instance.Instance.graph, next.Modul.name, loop instance tail)
327
          | _ -> Grew_types.Node
328 329 330 331 332 333 334 335 336 337
            (
              instance.Instance.graph,
              next.Modul.name,
              List.map
                (fun inst ->
                  match inst.Instance.big_step with
                    | None -> Error.bug "Cannot have no big_steps and more than one reducts at the same time"
                    | Some bs -> (bs, loop inst tail)
                ) inst_list
            )
pj2m's avatar
pj2m committed
338
    in loop instance modules_to_apply
bguillaum's avatar
bguillaum committed
339

bguillaum's avatar
bguillaum committed
340 341 342
  let rule_iter fct grs =
    List.iter
      (fun modul ->
bguillaum's avatar
bguillaum committed
343 344 345 346 347 348 349
        List.iter (fun rule -> fct modul.Modul.name rule) modul.Modul.rules
      ) grs.modules

  let filter_iter fct grs =
    List.iter
      (fun modul ->
        List.iter (fun filter -> fct modul.Modul.name filter) modul.Modul.filters
bguillaum's avatar
bguillaum committed
350
      ) grs.modules
351
end
pj2m's avatar
pj2m committed
352

bguillaum's avatar
bguillaum committed
353 354 355
module Gr_stat = struct

  (** the type [gr] stores the stats for the rewriting of one gr file *)
356 357
  type t =
    | Stat of ((int * int) StringMap.t * int) (* map: rule_name |-> (min,max) occ, number of solution *)
358
    | Error of string
bguillaum's avatar
bguillaum committed
359

360
  let opt_incr = function None -> Some 1 | Some x -> Some (x+1)
bguillaum's avatar
bguillaum committed
361 362
  let add_one_module modul_opt rules stat =
    match modul_opt with
363
      | Some modul ->
bguillaum's avatar
bguillaum committed
364 365 366
        List.fold_left
          (fun acc rule ->
            let key = sprintf "%s.%s" modul rule in
367 368
            let (old_min, old_max) = try StringMap.find key acc with Not_found -> (None, None) in
            StringMap.add key (opt_incr old_min, opt_incr old_max) acc
bguillaum's avatar
bguillaum committed
369
          ) stat rules
370 371 372
      | None when rules = [] -> stat
      | None -> Log.fcritical "Unconsistent rewrite history"

bguillaum's avatar
bguillaum committed
373 374 375 376 377 378
  let max_stat stat1 stat2 =
    StringMap.fold
      (fun key value acc ->
        let old = try StringMap.find key acc with Not_found -> 0 in
        StringMap.add key (max old value) acc
      ) stat1 stat2
379 380

  let opt_max x y = match (x,y) with
381 382
    | None, v | v, None -> v
    | Some v1, Some v2 -> Some (max v1 v2)
383 384

  let opt_min x y = match (x,y) with
385 386
    | None, v | v, None -> v
    | Some v1, Some v2 -> Some (min v1 v2)
387 388 389 390 391 392 393 394 395

  let min_max_stat stat1 stat2 =
    StringMap.fold
      (fun key (vmin, vmax) acc ->
        let (old_min, old_max) = try StringMap.find key acc with Not_found -> (Some 0, Some 0) in
        StringMap.add key (opt_min old_min vmin, opt_max old_max vmax) acc
      ) stat1 stat2


396

bguillaum's avatar
bguillaum committed
397 398
  let from_rew_history rew_history =
    let rec loop prev_module rh =
399 400 401 402
      let sub_stat =
        match List.map (loop (Some rh.Rewrite_history.module_name)) rh.Rewrite_history.good_nf with
          | [] -> StringMap.empty
          | h::t -> List.fold_left min_max_stat h t in
bguillaum's avatar
bguillaum committed
403
      add_one_module prev_module rh.Rewrite_history.instance.Instance.rules sub_stat
404
    in
405
    Stat
406
      (StringMap.map
407 408
         (function | Some i, Some j -> (i,j) | _ -> Log.critical "None in stat")
         (loop None rew_history),
409
       (Rewrite_history.num_sol rew_history)
410
      )
bguillaum's avatar
bguillaum committed
411

412 413
  let from_rew_history rew_history =
    let rec loop prev_module rh =
414
      let sub_stat =
415
        match (rh.Rewrite_history.good_nf, rh.Rewrite_history.bad_nf) with
416 417 418
          | [],[] -> Some (StringMap.empty)
          | [], _ -> None
          | l, _ ->
419
            match List_.opt_map (loop (Some rh.Rewrite_history.module_name)) l with
420 421
              | [] -> None
              | h::t -> Some (List.fold_left min_max_stat h t) in
422
      match sub_stat with
423 424 425
        | None -> None
        | Some stat -> Some (add_one_module prev_module rh.Rewrite_history.instance.Instance.rules stat)
    in
426
    match loop None rew_history with
427 428
      | None -> Stat (StringMap.empty, Rewrite_history.num_sol rew_history)
      | Some map ->
429 430
        Stat
          (
431 432
            StringMap.map (function Some i, Some j -> (i,j) | _ -> Log.critical "None in stat") map,
            Rewrite_history.num_sol rew_history
433 434 435 436
          )



437
  let save stat_file t =
bguillaum's avatar
bguillaum committed
438
    let out_ch = open_out stat_file in
439
    (match t with
440 441
      | Error msg -> fprintf out_ch "ERROR\n%s" msg
      | Stat (map, num) ->
442
        fprintf out_ch "NUM_SOL:%d\n%!" num;
443
        StringMap.iter
444 445
          (fun rule_name (min_occ,max_occ) ->  fprintf out_ch "%s:%d:%d\n%!" rule_name min_occ max_occ) map
    );
446

bguillaum's avatar
bguillaum committed
447 448
    close_out out_ch

449
  let load stat_file =
450
    let sol = ref 0 in
bguillaum's avatar
bguillaum committed
451 452 453
    try
      let lines = File.read stat_file in
      match lines with
454 455
        | "ERROR" :: msg_lines -> Error (List_.to_string (fun x->x) "\n" msg_lines)
        | _ ->
bguillaum's avatar
bguillaum committed
456
          let map =
457
            List.fold_left
bguillaum's avatar
bguillaum committed
458 459
              (fun acc line ->
                match Str.split (Str.regexp ":") line with
460 461 462
                  | ["NUM_SOL"; num] -> sol := int_of_string num; acc
                  | [modu_rule; vmin; vmax] -> StringMap.add modu_rule (int_of_string vmin, int_of_string vmax) acc
                  | _ -> Log.fcritical "invalid stat line: %s" line
bguillaum's avatar
bguillaum committed
463 464
              ) StringMap.empty lines in
          Stat (map, !sol)
bguillaum's avatar
bguillaum committed
465
    with Sys_error msg -> Error (sprintf "Sys_error: %s" msg)
bguillaum's avatar
bguillaum committed
466 467 468 469
end (* module Gr_stat *)

module Corpus_stat = struct
  (** the [t] type stores stats for a corpus of gr_files *)
470
  (*
bguillaum's avatar
bguillaum committed
471 472
     first key: [m] module name
     second key: [r] rule name
bguillaum's avatar
bguillaum committed
473
     value: [occ_num, file_list] the total number of rule applications and the set of gr files concerned *)
bguillaum's avatar
bguillaum committed
474
  type t = {
475 476
    modules: Modul.t list;                                   (* ordered list of modules in the sequence *)
    map: ((int*int) * StringSet.t) StringMap.t StringMap.t;  (* map: see above *)
477 478
      amb: StringSet.t IntMap.t;                               (* key: nb of sols |-> set: sentence concerned *)
      error: (string * string) list;                           (* (file, msg) *)
479 480
    num: int;                                                (* an integer id relative to the corpus *)
  }
bguillaum's avatar
bguillaum committed
481

bguillaum's avatar
bguillaum committed
482
  let empty ~grs ~seq =
483
    (* let modules = try List.assoc seq grs.Grs.sequences with Not_found -> [seq] in *)
484 485 486 487 488 489 490 491 492 493 494 495 496
    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 ->
                StringMap.add (Rule.get_name rule) ((0,0),StringSet.empty) acc2
              ) StringMap.empty modul.Modul.rules in
          StringMap.add modul.Modul.name rule_map acc
        else acc
      ) StringMap.empty grs.Grs.modules in
bguillaum's avatar
bguillaum committed
497
    { modules=modules; map = map; amb = IntMap.empty; error = []; num = 0 }
498 499

  let add modul rule file (min_occ,max_occ) map =
bguillaum's avatar
bguillaum committed
500
    let old_rule_map = StringMap.find modul map in
501
    let ((old_min,old_max), old_file_set) = StringMap.find rule old_rule_map in
502 503
    StringMap.add
      modul
bguillaum's avatar
bguillaum committed
504 505
      (StringMap.add
         rule
506 507
           ((old_min + min_occ, old_max + max_occ), StringSet.add file old_file_set)
             old_rule_map
bguillaum's avatar
bguillaum committed
508
      ) map
509 510

  let add_gr_stat base_name gr_stat t =
511
    match gr_stat with
512 513 514
      | Gr_stat.Error msg -> { t with error = (base_name, msg) :: t.error; num = t.num+1 }
      | Gr_stat.Stat (map, sol) ->
        let new_map =
515
          StringMap.fold
516
            (fun modul_rule (min_occ,max_occ) acc ->
517
              match Str.split (Str.regexp "\\.") modul_rule with
518 519
                | [modul; rule] -> add modul rule base_name (min_occ,max_occ) acc
                | _ -> Log.fcritical "illegal modul_rule spec \"%s\"" modul_rule
520
            ) map t.map in
521 522 523
        let new_amb =
          let old = try IntMap.find sol t.amb with Not_found -> StringSet.empty in
          IntMap.add sol (StringSet.add base_name old) t.amb in
bguillaum's avatar
bguillaum committed
524
        { t with map = new_map; num = t.num+1; amb=new_amb; }
bguillaum's avatar
bguillaum committed
525 526 527



528
  let unfoldable_set output_dir out_ch ?(bound=10) id file_set =
bguillaum's avatar
bguillaum committed
529
    let counter = ref 0 in
530

bguillaum's avatar
bguillaum committed
531
    StringSet.iter
532
      (fun file ->
bguillaum's avatar
bguillaum committed
533 534 535
        if !counter = bound
        then fprintf out_ch "<div id=\"%s\" style=\"display:none;\">\n" id;
        incr counter;
536 537 538 539 540 541

        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
542 543
        fprintf out_ch "%s &nbsp;&nbsp;\n" link
      ) file_set;
544

bguillaum's avatar
bguillaum committed
545
    if (!counter > bound)
546
    then
bguillaum's avatar
bguillaum committed
547 548 549 550 551 552 553 554 555 556
      begin
        fprintf out_ch "</div>\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
        fprintf out_ch "  <div>\n";
        fprintf out_ch "    <a style=\"cursor:pointer;\" onClick=\"if (document.getElementById('%s').style.display == 'none') { %s } else { %s }\">\n" id if_part else_part;
        fprintf out_ch "      <b><p id=\"p_%s\">+ Show all +</p></b>\n" id;
        fprintf out_ch "    </a>\n";
        fprintf out_ch "  </div>\n";
      end
bguillaum's avatar
bguillaum committed
557

558

bguillaum's avatar
bguillaum committed
559

bguillaum's avatar
bguillaum committed
560 561


562
  let save_html ~title ~grs_file ~input_dir ~output_dir t =
bguillaum's avatar
bguillaum committed
563
   (*  a fucntion to get the ration wrt the full set [t] *)
564 565
    let ratio nb = (float nb) /. (float t.num) *. 100. in

bguillaum's avatar
bguillaum committed
566
   (* put the css file the [output_dir] *)
567 568
    ignore(Sys.command("cp "^(Filename.concat DATA_DIR "style.css")^" "^(Filename.concat output_dir "style.css")));

bguillaum's avatar
bguillaum committed
569
   (* output of index.html *)
570 571 572 573 574 575 576 577
    let out_ch = open_out (Filename.concat output_dir "index.html") in

    fprintf out_ch "<head>\n";
    fprintf out_ch "  <link rel=\"stylesheet\" href=\"style.css\" type=\"text/css\">\n";
    fprintf out_ch "  <title>%s</title>\n" title;
    fprintf out_ch "  <meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" />\n";
    fprintf out_ch "</head>\n";

bguillaum's avatar
bguillaum committed
578 579 580 581
    fprintf out_ch "<a href=\"sentences.html\">Sentences</a> -- Rewriting stats -- <a href=\"doc/index.html\">GRS documentation</a>\n";

    fprintf out_ch "<h1>%s</h1>\n" (Str.global_replace (Str.regexp "#") " " title);
    fprintf out_ch "<h2>Rewriting stats</h2>\n";
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

    fprintf out_ch "<center><table cellpadding=3 cellspacing=0 width=95%%>\n";
    List.iter
      (fun modul ->
        let modul_name = modul.Modul.name in
        let rules = StringMap.find modul_name t.map in
        fprintf out_ch "<tr><td colspan=\"5\" style=\"padding: 0px;\"><h6>Module %s</h6></td></tr>\n" modul_name;
        fprintf out_ch "<tr><th class=\"first\">Rule</th><th>#occ(min/max)</th><th>#files</th><th>Ratio</th><th>Files</th></tr>\n";
        let ((min_occ, max_occ), full_sent) =
          StringMap.fold
            (fun _ ((v_min,v_max), file_set) ((acc_min,acc_max), acc_sent) ->
              ((acc_min+v_min, acc_max+v_max), StringSet.union acc_sent file_set)
            )
            rules ((0,0),StringSet.empty) in
        let tot_sent = StringSet.cardinal full_sent in
        fprintf out_ch "<tr>\n";
        fprintf out_ch "<td class=\"first_total\">Total for module</td>\n";
        fprintf out_ch "<td class=\"total\">%d/%d</td>" min_occ max_occ;
        fprintf out_ch "<td class=\"total\">%d</td>" tot_sent;
        fprintf out_ch "<td class=\"total\">%.2f%%</td>" (ratio tot_sent);
        fprintf out_ch "<td class=\"total\">&nbsp;</td>\n";
        fprintf out_ch "</tr>\n";

        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) = StringMap.find rule_name rules in

            let id = sprintf "%s_%s" modul_name rule_name in
            let file_num = StringSet.cardinal file_set in

            fprintf out_ch "<tr>\n";
            fprintf out_ch "  <td class=\"first_stats\"  valign=top><a href=\"doc/%s.html\">%s</a></td>\n"
              id
              rule_name;
            fprintf out_ch "  <td class=\"stats\"  valign=top>%d/%d</td>\n" min_occ max_occ;
            fprintf out_ch "  <td class=\"stats\"  valign=top>%d</td>\n" file_num;
            fprintf out_ch "  <td class=\"stats\"  valign=top>%.2f%%</td>\n" (ratio file_num);

            fprintf out_ch "  <td class=\"stats\">\n";
            (if file_num = 0
             then fprintf out_ch "  &nbsp;"
             else unfoldable_set output_dir out_ch id file_set);
            fprintf out_ch "  </td>\n";
            fprintf out_ch "</tr>\n";
          ) modul.Modul.rules
      ) t.modules;

   (* add a subtable for sentence ambiguity *)
bguillaum's avatar
bguillaum committed
631 632 633
    if not (IntMap.is_empty t.amb)
    then
      begin
bguillaum's avatar
bguillaum committed
634
        fprintf out_ch "<tr><td colspan=5><h6>Rewriting ambiguity</h6></td></tr>\n";
bguillaum's avatar
bguillaum committed
635
        fprintf out_ch "<tr><th class=\"first\" >Number of normal forms</th><th colspan=2 width=20>#files</th><th >Ratio</th><th>Files</th></tr>\n";
636

bguillaum's avatar
bguillaum committed
637
        IntMap.iter
638
          (fun num set ->
bguillaum's avatar
bguillaum committed
639
            let id = sprintf "amb_%d" num in
bguillaum's avatar
bguillaum committed
640 641
            let num_files = StringSet.cardinal set in
            fprintf out_ch "<tr>\n";
bguillaum's avatar
bguillaum committed
642 643 644 645
            fprintf out_ch "  <td class=\"first_stats\">%d</td>\n" num;
            fprintf out_ch "  <td class=\"stats\" colspan=2>%d</td>\n" num_files;
            fprintf out_ch "  <td class=\"stats\">%.2f%%</td>\n" (ratio num_files);
            fprintf out_ch "  <td class=\"stats\">";
646 647 648

            unfoldable_set output_dir out_ch id set;

bguillaum's avatar
bguillaum committed
649 650
            fprintf out_ch "  </td>\n";
            fprintf out_ch "</tr>\n") t.amb
bguillaum's avatar
bguillaum committed
651 652
      end;

653
    (* add a subtable for sentence that produces an error *)
bguillaum's avatar
bguillaum committed
654
    (match List.length t.error with
655 656
      | 0 -> ()
      | nb_errors ->
bguillaum's avatar
bguillaum committed
657
        fprintf out_ch "<tr><td colspan=5><h6>ERRORS</h6></td></tr>\n";
bguillaum's avatar
bguillaum committed
658
        fprintf out_ch "<tr><th class=\"first\" >Rule</th><th colspan=2 width=20>#files</th><th >Ratio</th><th>Files</th></tr>\n";
659

bguillaum's avatar
bguillaum committed
660 661 662 663 664
        fprintf out_ch "<tr>\n";
        fprintf out_ch "<td class=\"first_stats\">Errors</td>\n";
        fprintf out_ch "<td class=\"stats\" colspan=2>%d</td>\n" nb_errors;
        fprintf out_ch "<td class=\"stats\">%.2f%%</td>\n" (ratio nb_errors);
        fprintf out_ch "<td class=\"stats\">";
665 666 667 668

        match t.error with
          | [] -> fprintf out_ch "&nbsp;"
          | l ->
bguillaum's avatar
bguillaum committed
669 670
            List.iter
              (fun (file,err) ->
671
                if Sys.file_exists (Filename.concat output_dir (sprintf "%s.html" file))
bguillaum's avatar
bguillaum committed
672 673
                then fprintf out_ch "<a href=\"%s.html\">%s</a>: %s<br/>" file file err
                else fprintf out_ch "%s: %s<br/>" file err
674 675 676
              )
              (List.rev l);

bguillaum's avatar
bguillaum committed
677 678
            fprintf out_ch "</td>\n";
            fprintf out_ch "</tr>");
bguillaum's avatar
bguillaum committed
679

bguillaum's avatar
bguillaum committed
680
    fprintf out_ch "</table></center>\n";
681
    close_out out_ch
bguillaum's avatar
bguillaum committed
682
end (* module Stat *)