grs.ml 7.91 KB
Newer Older
pj2m's avatar
pj2m committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
open Printf
open Log

open Utils
open Rule
open Command
open Grew_edge 
open Graph


module Rewrite_history = struct

  type t = {
      instance: Instance.t;
      module_name: string; 
      good_nf: t list; 
      bad_nf: Instance.t list;
    }

  let rec get_nfs t =
    match t.good_nf with 
    | [] -> [([], t.instance)]
    | l -> 
24
25
26
27
28
29
30
31
        List.flatten
          (List_.mapi 
             (fun i t' ->
               List.map 
                 (fun (path,x) -> (i::path,x)) 
                 (get_nfs t') 
             ) l
          )
pj2m's avatar
pj2m committed
32
33

  (* warning: path are returned in reverse order *)
bguillaum's avatar
bguillaum committed
34
  let save_all_dep ?main_feat ?(init_graph=true) base_name t = 
pj2m's avatar
pj2m committed
35
36
37
    let nfs = ref [] in
    let rec loop first (rev_path, rev_rules) t =
      let file = 
38
39
40
        match List.rev rev_path with
        | [] -> base_name 
        | l -> sprintf "%s_%s" base_name (List_.to_string string_of_int "_" l) in
pj2m's avatar
pj2m committed
41
42

      begin
bguillaum's avatar
bguillaum committed
43
44
        match (first, init_graph) with
        | (true, true)
45
          -> Instance.save_dep_png ?main_feat file t.instance
bguillaum's avatar
bguillaum committed
46
        | _ when t.good_nf = []  (* t is a leaf of the tree history *)
47
48
          -> Instance.save_dep_png ?main_feat file t.instance
        | _ -> ()
pj2m's avatar
pj2m committed
49
      end;
50
      
pj2m's avatar
pj2m committed
51
52
53
      match t.good_nf with
      | [] -> nfs := (rev_path,List.rev rev_rules,file) :: !nfs
      | l ->
54
55
56
57
          List_.iteri 
            (fun i t' ->
              loop false (i::rev_path,(t.module_name, t'.instance.Instance.rules)::rev_rules) t'
            ) l in
pj2m's avatar
pj2m committed
58
59
60
    loop true ([],[]) t;
    List.rev !nfs
      
61
  let save_html ?main_feat ?(init_graph=true) ?header prefix t =
62
    
pj2m's avatar
pj2m committed
63
    let stats = ref [] in
64
    
pj2m's avatar
pj2m committed
65
66
67
68
69
    (* 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
70
    let nf_files = save_all_dep ?main_feat ~init_graph prefix t in
71
72
    let l = List.length nf_files in

pj2m's avatar
pj2m committed
73
74
75
76
77
    let local = Filename.basename prefix in
    
    (* All normal forms view *)
    let html_ch = open_out (sprintf "%s.html" prefix) in

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

bguillaum's avatar
bguillaum committed
81
    if init_graph
pj2m's avatar
pj2m committed
82
83
    then
      begin
84
85
        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
86
87
      end;
    
bguillaum's avatar
bguillaum committed
88
89
90
    List_.iteri 
      (fun i (_,rules_list,file_name) -> 
        fprintf html_ch "<h6>Solution %d</h6>\n" (i+1);
pj2m's avatar
pj2m committed
91

92
        let local_name = Filename.basename file_name in
bguillaum's avatar
bguillaum committed
93
94
95
96
97
        
        (* the png file *)
        fprintf html_ch "<div width=100%% style=\"overflow-x:auto\"><IMG SRC=\"%s.png\"></div>\n" local_name;

        (* the modules list *)
98
        fprintf html_ch "<b>Modules applied</b>: %d<br/>\n" (List.length rules_list);
bguillaum's avatar
bguillaum committed
99
100
101
102
103
104
105
        
        let id =sprintf "id_%d" (i+1) in
        
        fprintf html_ch "<a style=\"cursor:pointer;\" onClick=\"if (document.getElementById('%s').style.display == 'none') { document.getElementById('%s').style.display = 'block'; document.getElementById('p_%s').innerHTML = 'Hide'; } else { document.getElementById('%s').style.display = 'none';; document.getElementById('p_%s').innerHTML = 'Show'; }\"><b><p id=\"p_%s\">Show</p></b></a>\n" id id id id id id;

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

106
107
108
109
110
111
112
113
        List.iter 
          (fun (mod_name,rules) -> 
            fprintf html_ch "<p><b><font color=\"red\">%s: </font></b><font color=\"green\">%s</font></p>\n" 
              mod_name
              (List_.to_string (fun x -> x) ", " rules);
            stats := (mod_name,rules)::(!stats)
          )
          rules_list;
bguillaum's avatar
bguillaum committed
114
115
116
        fprintf html_ch " </div>\n"

        
pj2m's avatar
pj2m committed
117
118
119
120
      ) nf_files;
    Html.leave html_ch;
    close_out html_ch;

121
122
    List.rev !stats
      
pj2m's avatar
pj2m committed
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
end




module Modul = struct
  type t = {
      name: string;
      local_labels: (string * string option) array;
      bad_labels: Label.t list;
      rules: Rule.t list;
      confluent: bool;
    }


138
139
140
141
142
143
144
145
146
147
  let build ?domain ast_module =
    let locals = Array.of_list ast_module.Ast.local_labels in
    Array.sort compare locals;
    {
     name = ast_module.Ast.module_id;
     local_labels = locals; 
     bad_labels = List.map Label.from_string ast_module.Ast.bad_labels;
     rules = List.map (Rule.build ?domain ~locals) ast_module.Ast.rules;
     confluent = ast_module.Ast.confluent;
   }
pj2m's avatar
pj2m committed
148
149
150
151
end

module Grs = struct
  type sequence = string * string list (* (name of the seq, list of modules) *)
152
        
pj2m's avatar
pj2m committed
153
154
155
156
157
  type t = {
      labels: Label.t list;    (* the list of global edge labels *)
      modules: Modul.t list;          (* the ordered list of modules used from rewriting *)
      sequences: sequence list;
    }
158
        
pj2m's avatar
pj2m committed
159
  let sequences t = t.sequences
160
      
pj2m's avatar
pj2m committed
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
  let empty = {labels=[]; modules=[]; sequences=[];}

  let build ast_grs =
    Label.init ast_grs.Ast.labels; 
    {
     labels = List.map (fun (l,_) -> Label.from_string l) ast_grs.Ast.labels;
     modules = List.map (Modul.build ~domain:ast_grs.Ast.domain) ast_grs.Ast.modules;
     sequences = List.map (fun s -> (s.Ast.seq_name, s.Ast.seq_mod)) ast_grs.Ast.sequences;
   }

  let rewrite grs sequence instance = 
    let module_names_to_apply = 
      try List.assoc sequence grs.sequences 
      with Not_found -> [sequence] in
    
    let modules_to_apply = 
      List.map 
178
179
180
181
182
        (fun name -> 
          try List.find (fun m -> m.Modul.name=name) grs.modules 
          with Not_found -> Log.fcritical "No sequence or module named '%s'" name
        )
        module_names_to_apply in
pj2m's avatar
pj2m committed
183
184
185
    
    let rec loop instance = function
      | [] -> (* no more modules to apply *) 
186
          {Rewrite_history.instance = instance; module_name = ""; good_nf = []; bad_nf = []; }
pj2m's avatar
pj2m committed
187
      | next::tail -> 
188
189
190
191
192
193
194
195
196
197
198
199
200
201
          let (good_set, bad_set) = 
            Rule.normalize
              ~confluent: next.Modul.confluent
              next.Modul.rules 
              (fun x -> true)  (* FIXME *)
              (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;
         }
pj2m's avatar
pj2m committed
202
203
204
205
206
207
208
209
210
    in loop instance modules_to_apply

  let build_rew_display grs sequence instance = 
    let module_names_to_apply = 
      try List.assoc sequence grs.sequences 
      with Not_found -> [sequence] in
    
    let modules_to_apply = 
      List.map 
211
212
213
214
215
        (fun name -> 
          try List.find (fun m -> m.Modul.name=name) grs.modules 
          with Not_found -> Log.fcritical "No sequence or module named '%s'" name
        )
        module_names_to_apply in
pj2m's avatar
pj2m committed
216
217
218
219
    
    let rec loop instance = function
      | [] -> Grew_types.Leaf instance.Instance.graph
      | next :: tail -> 
220
221
222
223
224
225
226
227
          let (good_set, bad_set) = 
            Rule.normalize
              ~confluent: next.Modul.confluent
              next.Modul.rules 
              (fun x -> true)  (* FIXME: filtering in module outputs *)
              (Instance.clear instance) in
          let inst_list = Instance_set.elements good_set 
              (* and bad_list = Instance_set.elements bad_set *) in
pj2m's avatar
pj2m committed
228

229
230
231
232
233
234
235
236
237
238
239
240
241
242
          match inst_list with
          | [{Instance.big_step = None}] -> 
              Grew_types.Local_normal_form (instance.Instance.graph, next.Modul.name, loop instance tail)
          | _ -> Grew_types.Node 
                (
                 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
243
244
245
    in loop instance modules_to_apply
end