grew_grs.ml 24.4 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

      IFDEF DEP2PICT THEN
31

32 33 34
  (** [save_nfs ?main_feat base_name t] does two things:
      - write PNG files of normal forms
      - returns a list of couples (rules, file)
35 36
  *)
  let save_nfs ?main_feat base_name t =
37
    let rec loop file_name rules t =
38
      match (t.good_nf, t.bad_nf) with
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 56 57 58 59 60
  let error_html ?main_feat ?(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
61 62 63
      | (Some inst, true) -> Instance.save_dep_png ?main_feat prefix inst
      | _ -> ()
    );
64 65

    let local = Filename.basename prefix in
66

67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82
    (* 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

83
  let save_html ?main_feat ?(init_graph=true) ?header ~graph_file prefix t =
pj2m's avatar
pj2m committed
84 85 86 87
    (* 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
88

89 90
    (if init_graph then Instance.save_dep_png ?main_feat prefix t.instance);

91
    let nf_files = save_nfs ?main_feat prefix t in
92

93 94
    let l = List.length nf_files in

pj2m's avatar
pj2m committed
95
    let local = Filename.basename prefix in
96

pj2m's avatar
pj2m committed
97 98 99
    (* All normal forms view *)
    let html_ch = open_out (sprintf "%s.html" prefix) in

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

103 104 105 106 107 108
    fprintf html_ch "<b>Input file</b>: <a href=\"%s\">%s</a></h2><br/>\n"
      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
109
    if init_graph
pj2m's avatar
pj2m committed
110 111
    then
      begin
112 113
        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
114
      end;
115 116 117 118


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

121
        let local_name = Filename.basename file_name in
122

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

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

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

131 132
        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
133 134 135
        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;
136
        fprintf html_ch "</a>\n";
bguillaum's avatar
bguillaum committed
137 138 139

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

140 141 142
        List.iter
          (fun (mod_name,rules) ->
            fprintf html_ch "<p><b><font color=\"red\">%s: </font></b><font color=\"green\">%s</font></p>\n"
143 144 145 146
              mod_name
              (List_.to_string (fun x -> x) ", " rules);
          )
          rules_list;
bguillaum's avatar
bguillaum committed
147 148
        fprintf html_ch " </div>\n"

149

pj2m's avatar
pj2m committed
150 151
      ) nf_files;
    Html.leave html_ch;
bguillaum's avatar
bguillaum committed
152
    close_out html_ch
153
      ENDIF
pj2m's avatar
pj2m committed
154 155 156 157 158 159 160
end




module Modul = struct
  type t = {
161 162 163 164 165 166 167
    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
168

169 170 171 172
  let check t =
    (* check for duplicate rules *)
    let rec loop already_defined = function
      | [] -> ()
173 174
      | 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)
175 176
      | r::tail -> loop ((Rule.get_name r) :: already_defined) tail in
    loop [] t.rules
pj2m's avatar
pj2m committed
177

178
  let build ast_module =
179 180
    let locals = Array.of_list ast_module.Ast.local_labels in
    Array.sort compare locals;
181
    let rules_or_filters = List.map (Rule.build ~locals ast_module.Ast.mod_dir) ast_module.Ast.rules in
182 183
    let (filters, rules) = List.partition Rule.is_filter rules_or_filters in
    let modul =
184
      {
185 186 187 188 189 190 191
        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
192 193 194 195 196
    check modul; modul
end

module Sequence = struct
  type t = {
197 198 199 200
    name: string;
    def: string list;
    loc: Loc.t;
  }
201 202 203

  let check module_list t =
    List.iter
204
      (fun module_name ->
205 206
        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\"."
207
          t.name module_name
208 209
      ) t.def

210 211
  let build module_list ast_sequence =
    let sequence =
212
      {
213 214 215 216
        name = ast_sequence.Ast.seq_name;
        def = ast_sequence.Ast.seq_mod;
        loc = ast_sequence.Ast.seq_loc;
      } in
217
    check module_list sequence; sequence
pj2m's avatar
pj2m committed
218 219 220
end

module Grs = struct
221

pj2m's avatar
pj2m committed
222
  type t = {
223 224 225 226 227
    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;
  }

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

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

232 233 234 235
  let check t =
    (* check for duplicate modules *)
    let rec loop already_defined = function
      | [] -> ()
236 237
      | m::_ when List.mem m.Modul.name already_defined ->
        Error.build ~loc:m.Modul.loc "Module '%s' is defined twice" m.Modul.name
238 239 240 241 242 243
      | m::tail -> loop (m.Modul.name :: already_defined) tail in
    loop [] t.modules;

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

pj2m's avatar
pj2m committed
249
  let build ast_grs =
250
    Label.init ast_grs.Ast.labels;
251 252
    Domain.init ast_grs.Ast.domain;
    let modules = List.map Modul.build ast_grs.Ast.modules in
253 254 255 256 257 258
    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
259

bguillaum's avatar
bguillaum committed
260
  let modules_of_sequence grs sequence =
261
    let module_names =
262
      try
263 264
        let seq = List.find (fun s -> s.Sequence.name = sequence) grs.sequences in
        seq.Sequence.def
bguillaum's avatar
bguillaum committed
265 266
      with Not_found -> [sequence] in (* a module name can be used as a singleton sequence *)

267 268 269
    List.map
      (fun name ->
        try List.find (fun m -> m.Modul.name=name) grs.modules
bguillaum's avatar
bguillaum committed
270 271 272 273
        with Not_found -> Log.fcritical "No sequence or module named '%s'" name
      )
      module_names

274
  let rewrite grs sequence instance =
bguillaum's avatar
bguillaum committed
275
    let modules_to_apply = modules_of_sequence grs sequence in
276

pj2m's avatar
pj2m committed
277
    let rec loop instance = function
278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295
      | [] -> (* 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
            (Instance.clear instance) in
        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
296
    loop instance modules_to_apply
297

bguillaum's avatar
bguillaum committed
298 299
  let build_rew_display grs sequence instance =
    let modules_to_apply = modules_of_sequence grs sequence in
pj2m's avatar
pj2m committed
300 301 302

    let rec loop instance = function
      | [] -> Grew_types.Leaf instance.Instance.graph
303
      | next :: tail ->
304 305 306 307 308 309 310 311
        let (good_set, bad_set) =
          Rule.normalize
            next.Modul.name
            ~confluent: next.Modul.confluent
            next.Modul.rules
            next.Modul.filters
            (Instance.clear instance) in
        let inst_list = Instance_set.elements good_set
312
              (* and bad_list = Instance_set.elements bad_set *) in
pj2m's avatar
pj2m committed
313

314
        match inst_list with
315
          | [{Instance.big_step = None}] ->
316
            Grew_types.Local_normal_form (instance.Instance.graph, next.Modul.name, loop instance tail)
317
          | _ -> Grew_types.Node
318 319 320 321 322 323 324 325 326 327
            (
              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
328
    in loop instance modules_to_apply
bguillaum's avatar
bguillaum committed
329

bguillaum's avatar
bguillaum committed
330 331 332
  let rule_iter fct grs =
    List.iter
      (fun modul ->
bguillaum's avatar
bguillaum committed
333 334 335 336 337 338 339
        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
340
      ) grs.modules
341
end
pj2m's avatar
pj2m committed
342

bguillaum's avatar
bguillaum committed
343 344 345
module Gr_stat = struct

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

350
  let opt_incr = function None -> Some 1 | Some x -> Some (x+1)
bguillaum's avatar
bguillaum committed
351 352
  let add_one_module modul_opt rules stat =
    match modul_opt with
353
      | Some modul ->
bguillaum's avatar
bguillaum committed
354 355 356
        List.fold_left
          (fun acc rule ->
            let key = sprintf "%s.%s" modul rule in
357 358
            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
359
          ) stat rules
360 361 362
      | None when rules = [] -> stat
      | None -> Log.fcritical "Unconsistent rewrite history"

bguillaum's avatar
bguillaum committed
363 364 365 366 367 368
  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
369 370

  let opt_max x y = match (x,y) with
371 372
    | None, v | v, None -> v
    | Some v1, Some v2 -> Some (max v1 v2)
373 374

  let opt_min x y = match (x,y) with
375 376
    | None, v | v, None -> v
    | Some v1, Some v2 -> Some (min v1 v2)
377 378 379 380 381 382 383 384 385

  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


386

bguillaum's avatar
bguillaum committed
387 388
  let from_rew_history rew_history =
    let rec loop prev_module rh =
389 390 391 392
      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
393
      add_one_module prev_module rh.Rewrite_history.instance.Instance.rules sub_stat
394
    in
395
    Stat
396
      (StringMap.map
397 398
         (function | Some i, Some j -> (i,j) | _ -> Log.critical "None in stat")
         (loop None rew_history),
399
       (Rewrite_history.num_sol rew_history)
400
      )
bguillaum's avatar
bguillaum committed
401

402 403
  let from_rew_history rew_history =
    let rec loop prev_module rh =
404
      let sub_stat =
405
        match (rh.Rewrite_history.good_nf, rh.Rewrite_history.bad_nf) with
406 407 408
          | [],[] -> Some (StringMap.empty)
          | [], _ -> None
          | l, _ ->
409
            match List_.opt_map (loop (Some rh.Rewrite_history.module_name)) l with
410 411
              | [] -> None
              | h::t -> Some (List.fold_left min_max_stat h t) in
412
      match sub_stat with
413 414 415
        | None -> None
        | Some stat -> Some (add_one_module prev_module rh.Rewrite_history.instance.Instance.rules stat)
    in
416
    match loop None rew_history with
417 418
      | None -> Stat (StringMap.empty, Rewrite_history.num_sol rew_history)
      | Some map ->
419 420
        Stat
          (
421 422
            StringMap.map (function Some i, Some j -> (i,j) | _ -> Log.critical "None in stat") map,
            Rewrite_history.num_sol rew_history
423 424 425 426
          )



427
  let save stat_file t =
bguillaum's avatar
bguillaum committed
428
    let out_ch = open_out stat_file in
429
    (match t with
430 431
      | Error msg -> fprintf out_ch "ERROR\n%s" msg
      | Stat (map, num) ->
432
        fprintf out_ch "NUM_SOL:%d\n%!" num;
433
        StringMap.iter
434 435
          (fun rule_name (min_occ,max_occ) ->  fprintf out_ch "%s:%d:%d\n%!" rule_name min_occ max_occ) map
    );
436

bguillaum's avatar
bguillaum committed
437 438
    close_out out_ch

439
  let load stat_file =
440
    let sol = ref 0 in
bguillaum's avatar
bguillaum committed
441 442 443
    try
      let lines = File.read stat_file in
      match lines with
444 445
        | "ERROR" :: msg_lines -> Error (List_.to_string (fun x->x) "\n" msg_lines)
        | _ ->
bguillaum's avatar
bguillaum committed
446
          let map =
447
            List.fold_left
bguillaum's avatar
bguillaum committed
448 449
              (fun acc line ->
                match Str.split (Str.regexp ":") line with
450 451 452
                  | ["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
453 454
              ) StringMap.empty lines in
          Stat (map, !sol)
bguillaum's avatar
bguillaum committed
455
    with Sys_error msg -> Error (sprintf "Sys_error: %s" msg)
bguillaum's avatar
bguillaum committed
456 457 458 459
end (* module Gr_stat *)

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

bguillaum's avatar
bguillaum committed
472
  let empty ~grs ~seq =
473
    (* let modules = try List.assoc seq grs.Grs.sequences with Not_found -> [seq] in *)
474 475 476 477 478 479 480 481 482 483 484 485 486
    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
487
    { modules=modules; map = map; amb = IntMap.empty; error = []; num = 0 }
488 489

  let add modul rule file (min_occ,max_occ) map =
bguillaum's avatar
bguillaum committed
490
    let old_rule_map = StringMap.find modul map in
491
    let ((old_min,old_max), old_file_set) = StringMap.find rule old_rule_map in
492 493
    StringMap.add
      modul
bguillaum's avatar
bguillaum committed
494 495
      (StringMap.add
         rule
496 497
           ((old_min + min_occ, old_max + max_occ), StringSet.add file old_file_set)
             old_rule_map
bguillaum's avatar
bguillaum committed
498
      ) map
499 500

  let add_gr_stat base_name gr_stat t =
501
    match gr_stat with
502 503 504
      | Gr_stat.Error msg -> { t with error = (base_name, msg) :: t.error; num = t.num+1 }
      | Gr_stat.Stat (map, sol) ->
        let new_map =
505
          StringMap.fold
506
            (fun modul_rule (min_occ,max_occ) acc ->
507
              match Str.split (Str.regexp "\\.") modul_rule with
508 509
                | [modul; rule] -> add modul rule base_name (min_occ,max_occ) acc
                | _ -> Log.fcritical "illegal modul_rule spec \"%s\"" modul_rule
510
            ) map t.map in
511 512 513
        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
514
        { t with map = new_map; num = t.num+1; amb=new_amb; }
bguillaum's avatar
bguillaum committed
515 516 517



518
  let unfoldable_set output_dir out_ch ?(bound=10) id file_set =
bguillaum's avatar
bguillaum committed
519
    let counter = ref 0 in
520

bguillaum's avatar
bguillaum committed
521
    StringSet.iter
522
      (fun file ->
bguillaum's avatar
bguillaum committed
523 524 525
        if !counter = bound
        then fprintf out_ch "<div id=\"%s\" style=\"display:none;\">\n" id;
        incr counter;
526 527 528 529 530 531

        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
532 533
        fprintf out_ch "%s &nbsp;&nbsp;\n" link
      ) file_set;
534

bguillaum's avatar
bguillaum committed
535
    if (!counter > bound)
536
    then
bguillaum's avatar
bguillaum committed
537 538 539 540 541 542 543 544 545 546
      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
547

548

bguillaum's avatar
bguillaum committed
549

bguillaum's avatar
bguillaum committed
550 551


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

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

bguillaum's avatar
bguillaum committed
559
   (* output of index.html *)
560 561 562 563 564 565 566 567 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
    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";

    fprintf out_ch "<h1>%s</h1>\n" title;
    fprintf out_ch "<b>Grs file</b>:<a href =\"%s\">%s</a> -- <a href=\"doc/index.html\">Documentation</a><br/>\n" (Filename.basename grs_file) (Filename.basename grs_file);
    fprintf out_ch "<b>Input dir</b>: %s<br/>\n" input_dir;
    fprintf out_ch "<b>%d Sentences</b><br/>\n<br/>\n" t.num;

    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
621 622 623
    if not (IntMap.is_empty t.amb)
    then
      begin
bguillaum's avatar
bguillaum committed
624
        fprintf out_ch "<tr><td colspan=5><h6>Rewriting ambiguity</h6></td></tr>\n";
bguillaum's avatar
bguillaum committed
625
        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";
626

bguillaum's avatar
bguillaum committed
627
        IntMap.iter
628
          (fun num set ->
bguillaum's avatar
bguillaum committed
629
            let id = sprintf "amb_%d" num in
bguillaum's avatar
bguillaum committed
630 631
            let num_files = StringSet.cardinal set in
            fprintf out_ch "<tr>\n";
bguillaum's avatar
bguillaum committed
632 633 634 635
            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\">";
636 637 638

            unfoldable_set output_dir out_ch id set;

bguillaum's avatar
bguillaum committed
639 640
            fprintf out_ch "  </td>\n";
            fprintf out_ch "</tr>\n") t.amb
bguillaum's avatar
bguillaum committed
641 642
      end;

643
    (* add a subtable for sentence that produces an error *)
bguillaum's avatar
bguillaum committed
644
    (match List.length t.error with
645 646
      | 0 -> ()
      | nb_errors ->
bguillaum's avatar
bguillaum committed
647
        fprintf out_ch "<tr><td colspan=5><h6>ERRORS</h6></td></tr>\n";
bguillaum's avatar
bguillaum committed
648
        fprintf out_ch "<tr><th class=\"first\" >Rule</th><th colspan=2 width=20>#files</th><th >Ratio</th><th>Files</th></tr>\n";
649

bguillaum's avatar
bguillaum committed
650 651 652 653 654
        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\">";
655 656 657 658

        match t.error with
          | [] -> fprintf out_ch "&nbsp;"
          | l ->
bguillaum's avatar
bguillaum committed
659 660
            List.iter
              (fun (file,err) ->
661
                if Sys.file_exists (Filename.concat output_dir (sprintf "%s.html" file))
bguillaum's avatar
bguillaum committed
662 663
                then fprintf out_ch "<a href=\"%s.html\">%s</a>: %s<br/>" file file err
                else fprintf out_ch "%s: %s<br/>" file err
664 665 666
              )
              (List.rev l);

bguillaum's avatar
bguillaum committed
667 668
            fprintf out_ch "</td>\n";
            fprintf out_ch "</tr>");
bguillaum's avatar
bguillaum committed
669

bguillaum's avatar
bguillaum committed
670
    fprintf out_ch "</table></center>\n";
671
    close_out out_ch
bguillaum's avatar
bguillaum committed
672
end (* module Stat *)