grew_rule.ml 52.1 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                                                   *)
(**********************************************************************************)

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

14 15
open Dep2pict

16
open Grew_base
17
open Grew_types
bguillaum's avatar
bguillaum committed
18
open Grew_ast
19
open Grew_domain
pj2m's avatar
pj2m committed
20
open Grew_edge
bguillaum's avatar
bguillaum committed
21
open Grew_fs
pj2m's avatar
pj2m committed
22
open Grew_node
bguillaum's avatar
bguillaum committed
23 24
open Grew_command
open Grew_graph
pj2m's avatar
pj2m committed
25

26
(* ================================================================================ *)
pj2m's avatar
pj2m committed
27 28
module Instance = struct
  type t = {
29 30 31
    graph: G_graph.t;
    history: Command.h list;
    rules: string list;
32
    big_step: Libgrew_types.big_step option;
33 34
  }

35
  let empty = {graph = G_graph.empty; rules=[]; history=[]; big_step=None; }
36

37
  let from_graph graph = {empty with graph}
pj2m's avatar
pj2m committed
38

bguillaum's avatar
bguillaum committed
39
  let rev_steps t =
pj2m's avatar
pj2m committed
40
    { t with big_step = match t.big_step with
41
      | None -> None
42
      | Some bs -> Some {bs with Libgrew_types.small_step = List.rev bs.Libgrew_types.small_step }
pj2m's avatar
pj2m committed
43 44
    }

45 46
  let refresh t = { empty with graph=t.graph }

47
  (* comparison is done on the list of commands *)
bguillaum's avatar
bguillaum committed
48
  (* only graph rewritten from the same init graph can be "compared" *)
49
  let compare t1 t2 = Pervasives.compare t1.history t2.history
pj2m's avatar
pj2m committed
50

bguillaum's avatar
bguillaum committed
51
  let to_gr ?domain t = G_graph.to_gr ?domain t.graph
52

bguillaum's avatar
bguillaum committed
53
  let to_conll_string ?domain t = G_graph.to_conll_string ?domain t.graph
bguillaum's avatar
bguillaum committed
54

bguillaum's avatar
bguillaum committed
55 56
  let save_dot_png ?domain ?filter ?main_feat base t =
    ignore (Dot.to_png_file (G_graph.to_dot ?domain ?main_feat t.graph) (base^".png"))
57

bguillaum's avatar
bguillaum committed
58 59
  let save_dep_png ?domain ?filter ?main_feat base t =
    let dep = G_graph.to_dep ?domain ?filter ?main_feat t.graph in
60 61 62
    let d2p = Dep2pict.from_dep ~dep in
    let _ = Dep2pict.save_png ~filename: (base^".png") d2p in
    Dep2pict.highlight_shift ()
63

bguillaum's avatar
bguillaum committed
64 65
  let save_dep_svg ?domain ?filter ?main_feat base t =
    let dep = G_graph.to_dep ?domain ?filter ?main_feat t.graph in
66 67 68
    let d2p = Dep2pict.from_dep ~dep in
    let _ = Dep2pict.save_svg ~filename: (base^".png") d2p in
    Dep2pict.highlight_shift ()
69
end (* module Instance *)
pj2m's avatar
pj2m committed
70

71
(* ================================================================================ *)
72
module Instance_set = Set.Make (Instance)
pj2m's avatar
pj2m committed
73

74
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
75
module Rule = struct
76

bguillaum's avatar
bguillaum committed
77
  (* the rewriting depth is bounded to stop rewriting when the system is not terminating *)
bguillaum's avatar
bguillaum committed
78 79
  let max_depth_det = ref 2000
  let max_depth_non_det = ref 100
bguillaum's avatar
bguillaum committed
80
  let debug_loop = ref false
81 82 83

  let set_max_depth_det value = max_depth_det := value
  let set_max_depth_non_det value = max_depth_non_det := value
bguillaum's avatar
bguillaum committed
84
  let set_debug_loop () = debug_loop := true
pj2m's avatar
pj2m committed
85

86
  type const =
bguillaum's avatar
bguillaum committed
87 88
    | Cst_out of Pid.t * Label_cst.t
    | Cst_in of Pid.t * Label_cst.t
89 90
    | Features_eq of Pid.t * string * Pid.t * string
    | Features_diseq of Pid.t * string * Pid.t * string
91
    (* *)
92
    | Feature_eq_cst of Pid.t * string * string
93
    | Feature_diff_cst of Pid.t * string * string
94
    (* *)
95
    | Feature_eq_float of Pid.t * string * float
96
    | Feature_diff_float of Pid.t * string * float
97
    (* *)
98
    | Feature_eq_regexp of Pid.t * string * string
99
    (* *)
100
    | Features_ineq of Ast.ineq * Pid.t * string * Pid.t * string
101
    | Feature_ineq_cst of Ast.ineq * Pid.t * string * float
102
    (* *)
bguillaum's avatar
bguillaum committed
103
    | Filter of Pid.t * P_fs.t (* used when a without impose a fs on a node defined by the match basic *)
104
    (* *)
105 106
    | Immediate_prec of Pid.t * Pid.t
    | Large_prec of Pid.t * Pid.t
bguillaum's avatar
bguillaum committed
107

108 109 110
  let const_to_json ?domain = function
  | Cst_out (pid, label_cst) -> `Assoc ["cst_out", Label_cst.to_json ?domain label_cst]
  | Cst_in (pid, label_cst) -> `Assoc ["cst_in", Label_cst.to_json ?domain label_cst]
111
  | Features_eq (pid1,fn1,pid2,fn2) ->
112 113 114 115 116 117 118 119
    `Assoc ["features_eq",
      `Assoc [
        ("id1", `String (Pid.to_string pid1));
        ("feature_name_1", `String fn1);
        ("id2", `String (Pid.to_string pid2));
        ("feature_name_2", `String fn2);
      ]
    ]
120
  | Features_diseq (pid1,fn1,pid2,fn2) ->
121 122 123 124 125 126 127 128
    `Assoc ["features_diseq",
      `Assoc [
        ("id1", `String (Pid.to_string pid1));
        ("feature_name_1", `String fn1);
        ("id2", `String (Pid.to_string pid2));
        ("feature_name_2", `String fn2);
      ]
    ]
129
  | Feature_eq_cst (pid,fn,value) ->
130 131 132 133 134 135 136 137
    `Assoc ["feature_eq_cst",
      `Assoc [
        ("id", `String (Pid.to_string pid));
        ("feature_name_", `String fn);
        ("value", `String value);
      ]
    ]
  | Feature_diff_cst (pid,fn,value) ->
138
    `Assoc ["feature_diff_cst",
139 140 141 142 143 144
      `Assoc [
        ("id", `String (Pid.to_string pid));
        ("feature_name_", `String fn);
        ("value", `String value);
      ]
    ]
145
  | Feature_eq_float (pid,fn,value) ->
146 147 148 149 150 151 152 153 154 155 156 157 158 159 160
    `Assoc ["feature_eq_float",
      `Assoc [
        ("id", `String (Pid.to_string pid));
        ("feature_name_", `String fn);
        ("value", `String (string_of_float value));
        ]
    ]
  | Feature_diff_float (pid,fn,value) ->
    `Assoc ["feature_diff_float",
      `Assoc [
        ("id", `String (Pid.to_string pid));
        ("feature_name", `String fn);
        ("value", `String (string_of_float value));
      ]
    ]
161
  | Feature_eq_regexp (pid,fn,regexp) ->
162 163 164 165 166 167 168
    `Assoc ["feature_eq_regexp",
      `Assoc [
        ("id", `String (Pid.to_string pid));
        ("feature_name", `String fn);
        ("regexp", `String regexp);
      ]
    ]
169
  | Features_ineq (ineq,pid1,fn1,pid2,fn2) ->
170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194
    `Assoc ["features_ineq",
      `Assoc [
        ("ineq", `String (Ast.string_of_ineq ineq));
        ("id1", `String (Pid.to_string pid1));
        ("feature_name_1", `String fn1);
        ("id2", `String (Pid.to_string pid2));
        ("feature_name_2", `String fn2);
      ]
    ]
  | Feature_ineq_cst (ineq,pid,fn,value) ->
    `Assoc ["feature_ineq_cst",
      `Assoc [
        ("ineq", `String (Ast.string_of_ineq ineq));
        ("id", `String (Pid.to_string pid));
        ("feature_name", `String fn);
        ("value", `String (string_of_float value));
      ]
    ]
  | Filter (pid, p_fs) ->
    `Assoc ["filter",
      `Assoc [
        ("id", `String (Pid.to_string pid));
        ("fs", P_fs.to_json ?domain p_fs);
      ]
    ]
195
  | Immediate_prec (pid1, pid2) ->
196 197 198 199 200 201
    `Assoc ["immediate_prec",
      `Assoc [
        ("id1", `String (Pid.to_string pid1));
        ("id2", `String (Pid.to_string pid2));
      ]
    ]
202
  | Large_prec (pid1, pid2) ->
203 204 205 206 207 208 209
    `Assoc ["large_prec",
      `Assoc [
        ("id1", `String (Pid.to_string pid1));
        ("id2", `String (Pid.to_string pid2));
      ]
    ]

bguillaum's avatar
bguillaum committed
210
  let build_pos_constraint ?domain pos_table const =
bguillaum's avatar
bguillaum committed
211 212
    let pid_of_name loc node_name = Pid.Pos (Id.build ~loc node_name pos_table) in
    match const with
213
      | (Ast.Cst_out (id,label_cst), loc) ->
bguillaum's avatar
bguillaum committed
214
        Cst_out (pid_of_name loc id, Label_cst.build ~loc ?domain label_cst)
215
      | (Ast.Cst_in (id,label_cst), loc) ->
bguillaum's avatar
bguillaum committed
216
        Cst_in (pid_of_name loc id, Label_cst.build ~loc ?domain label_cst)
217

218
      | (Ast.Features_eq ((node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
bguillaum's avatar
bguillaum committed
219 220
        Domain.check_feature_name ?domain ~loc feat_name1;
        Domain.check_feature_name ?domain ~loc feat_name2;
221
        Features_eq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
222

223
      | (Ast.Features_diseq ((node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
bguillaum's avatar
bguillaum committed
224 225
        Domain.check_feature_name ?domain ~loc feat_name1;
        Domain.check_feature_name ?domain ~loc feat_name2;
226
        Features_diseq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
227

228
      | (Ast.Features_ineq (ineq, (node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
bguillaum's avatar
bguillaum committed
229 230
        Domain.check_feature_name ?domain ~loc feat_name1;
        Domain.check_feature_name ?domain ~loc feat_name2;
231
        Features_ineq (ineq, pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
232

233
      | (Ast.Feature_ineq_cst (ineq, (node_name1, feat_name1), constant), loc) ->
bguillaum's avatar
bguillaum committed
234
        Domain.check_feature_name ?domain ~loc feat_name1;
235 236
        Feature_ineq_cst (ineq, pid_of_name loc node_name1, feat_name1, constant)

237
      | (Ast.Feature_eq_regexp ((node_name, feat_name), regexp), loc) ->
bguillaum's avatar
bguillaum committed
238
        Domain.check_feature_name ?domain ~loc feat_name;
239
        Feature_eq_regexp (pid_of_name loc node_name, feat_name, regexp)
bguillaum's avatar
bguillaum committed
240

241
      | (Ast.Feature_eq_cst ((node_name, feat_name), string), loc) ->
242
        Domain.check_feature_name ?domain ~loc feat_name;
243
        Feature_eq_cst (pid_of_name loc node_name, feat_name, string)
244 245 246 247
      | (Ast.Feature_diff_cst ((node_name, feat_name), string), loc) ->
        Domain.check_feature_name ?domain ~loc feat_name;
        Feature_diff_cst (pid_of_name loc node_name, feat_name, string)

248
      | (Ast.Feature_eq_float ((node_name, feat_name), float), loc) ->
249
        Domain.check_feature_name ?domain ~loc feat_name;
250
        Feature_eq_float (pid_of_name loc node_name, feat_name, float)
251 252 253 254
      | (Ast.Feature_diff_float ((node_name, feat_name), float), loc) ->
        Domain.check_feature_name ?domain ~loc feat_name;
        Feature_diff_float (pid_of_name loc node_name, feat_name, float)

255 256
      | (Ast.Immediate_prec (id1, id2), loc) ->
        Immediate_prec (pid_of_name loc id1, pid_of_name loc id2)
bguillaum's avatar
bguillaum committed
257

258 259
      | (Ast.Large_prec (id1, id2), loc) ->
        Large_prec (pid_of_name loc id1, pid_of_name loc id2)
bguillaum's avatar
bguillaum committed
260

bguillaum's avatar
bguillaum committed
261
  type basic = {
262 263 264
    graph: P_graph.t;
    constraints: const list;
  }
pj2m's avatar
pj2m committed
265

266 267 268 269 270 271
  let basic_to_json ?domain basic =
    `Assoc [
      ("graph", P_graph.to_json ?domain basic.graph);
      ("constraints", `List (List.map (const_to_json ?domain) basic.constraints));
    ]

bguillaum's avatar
bguillaum committed
272
  let build_pos_basic ?domain ?pat_vars ?(locals=[||]) basic_ast =
273
    let (graph, pos_table) =
bguillaum's avatar
bguillaum committed
274
      P_graph.build ?domain ?pat_vars basic_ast.Ast.pat_nodes basic_ast.Ast.pat_edges in
pj2m's avatar
pj2m committed
275
    (
bguillaum's avatar
bguillaum committed
276 277
      {
        graph = graph;
bguillaum's avatar
bguillaum committed
278
        constraints = List.map (build_pos_constraint ?domain pos_table) basic_ast.Ast.pat_const
bguillaum's avatar
bguillaum committed
279 280
      },
      pos_table
pj2m's avatar
pj2m committed
281 282
    )

bguillaum's avatar
bguillaum committed
283
  (* the neg part *)
bguillaum's avatar
bguillaum committed
284
  let build_neg_constraint ?domain pos_table neg_table const =
bguillaum's avatar
bguillaum committed
285 286 287 288
    let pid_of_name loc node_name =
      match Id.build_opt node_name pos_table with
        | Some i -> Pid.Pos i
        | None -> Pid.Neg (Id.build ~loc node_name neg_table) in
pj2m's avatar
pj2m committed
289
    match const with
290
      | (Ast.Cst_out (id,label_cst), loc) ->
bguillaum's avatar
bguillaum committed
291
        Cst_out (pid_of_name loc id, Label_cst.build ~loc ?domain label_cst)
292
      | (Ast.Cst_in (id,label_cst), loc) ->
bguillaum's avatar
bguillaum committed
293
        Cst_in (pid_of_name loc id, Label_cst.build ~loc ?domain label_cst)
294

295
      | (Ast.Features_eq (feat_id1, feat_id2), loc) ->
296 297
        let (node_name1, feat_name1) = feat_id1
        and (node_name2, feat_name2) = feat_id2 in
bguillaum's avatar
bguillaum committed
298 299
        Domain.check_feature_name ?domain ~loc feat_name1;
        Domain.check_feature_name ?domain ~loc feat_name2;
300
        Features_eq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
301

302
      | (Ast.Features_diseq (feat_id1, feat_id2), loc) ->
303 304
        let (node_name1, feat_name1) = feat_id1
        and (node_name2, feat_name2) = feat_id2 in
bguillaum's avatar
bguillaum committed
305 306
        Domain.check_feature_name ?domain ~loc feat_name1;
        Domain.check_feature_name ?domain ~loc feat_name2;
307
        Features_diseq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
308

309
      | (Ast.Features_ineq (ineq, feat_id1, feat_id2), loc) ->
310 311
        let (node_name1, feat_name1) = feat_id1
        and (node_name2, feat_name2) = feat_id2 in
bguillaum's avatar
bguillaum committed
312 313
        Domain.check_feature_name ?domain ~loc feat_name1;
        Domain.check_feature_name ?domain ~loc feat_name2;
314
        Features_ineq (ineq, pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
315

316 317
      | (Ast.Feature_ineq_cst (ineq, feat_id1, constant), loc) ->
        let (node_name1, feat_name1) = feat_id1 in
bguillaum's avatar
bguillaum committed
318
        Domain.check_feature_name ?domain ~loc feat_name1;
319
        Feature_ineq_cst (ineq, pid_of_name loc node_name1, feat_name1, constant)
pj2m's avatar
pj2m committed
320

321
      | (Ast.Feature_eq_regexp (feat_id, regexp), loc) ->
bguillaum's avatar
bguillaum committed
322
        let (node_name, feat_name) = feat_id in
bguillaum's avatar
bguillaum committed
323
        Domain.check_feature_name ?domain ~loc feat_name;
324
        Feature_eq_regexp (pid_of_name loc node_name, feat_name, regexp)
bguillaum's avatar
bguillaum committed
325

326
      | (Ast.Feature_eq_cst ((node_name, feat_name), string), loc) ->
327
        Domain.check_feature_name ?domain ~loc feat_name;
328
        Feature_eq_cst (pid_of_name loc node_name, feat_name, string)
329 330 331 332
      | (Ast.Feature_diff_cst ((node_name, feat_name), string), loc) ->
        Domain.check_feature_name ?domain ~loc feat_name;
        Feature_diff_cst (pid_of_name loc node_name, feat_name, string)

333
      | (Ast.Feature_eq_float ((node_name, feat_name), float), loc) ->
334
        Domain.check_feature_name ?domain ~loc feat_name;
335
        Feature_eq_float (pid_of_name loc node_name, feat_name, float)
336 337 338 339 340
      | (Ast.Feature_diff_float ((node_name, feat_name), float), loc) ->
        Domain.check_feature_name ?domain ~loc feat_name;
        Feature_diff_float (pid_of_name loc node_name, feat_name, float)


341 342
      | (Ast.Immediate_prec (id1, id2), loc) ->
        Immediate_prec (pid_of_name loc id1, pid_of_name loc id2)
bguillaum's avatar
bguillaum committed
343

344 345
      | (Ast.Large_prec (id1, id2), loc) ->
        Large_prec (pid_of_name loc id1, pid_of_name loc id2)
bguillaum's avatar
bguillaum committed
346

bguillaum's avatar
bguillaum committed
347
  (* It may raise [P_fs.Fail_unif] in case of contradiction on constraints *)
bguillaum's avatar
bguillaum committed
348
  let build_neg_basic ?domain ?pat_vars ?(locals=[||]) pos_table basic_ast =
pj2m's avatar
pj2m committed
349
    let (extension, neg_table) =
bguillaum's avatar
bguillaum committed
350
      P_graph.build_extension ?domain ?pat_vars pos_table basic_ast.Ast.pat_nodes basic_ast.Ast.pat_edges in
bguillaum's avatar
bguillaum committed
351

352
    let filters = Pid_map.fold (fun id node acc -> Filter (id, P_node.get_fs node) :: acc) extension.P_graph.old_map [] in
pj2m's avatar
pj2m committed
353
    {
bguillaum's avatar
bguillaum committed
354
      graph = extension.P_graph.ext_map;
bguillaum's avatar
bguillaum committed
355
      constraints = filters @ List.map (build_neg_constraint ?domain pos_table neg_table) basic_ast.Ast.pat_const ;
bguillaum's avatar
bguillaum committed
356
    }
pj2m's avatar
pj2m committed
357

bguillaum's avatar
bguillaum committed
358
  let get_edge_ids basic =
359
    Pid_map.fold
bguillaum's avatar
bguillaum committed
360 361
      (fun _ node acc ->
        Massoc_pid.fold
362
          (fun acc2 _ edge -> (P_edge.get_id edge)::acc2)
363
          acc (P_node.get_next node)
bguillaum's avatar
bguillaum committed
364
      ) basic.graph []
bguillaum's avatar
bguillaum committed
365

366 367 368
  (* a [pattern] is described by the positive basic and a list of negative basics. *)
  type pattern = basic * basic list

369
  let pid_name_list (pos,_) = P_graph.pid_name_list pos.graph
370

pj2m's avatar
pj2m committed
371 372
  type t = {
      name: string;
373
      pattern: pattern;
pj2m's avatar
pj2m committed
374
      commands: Command.t list;
375
      param: Lex_par.t option;
376
      param_names: (string list * string list);
bguillaum's avatar
bguillaum committed
377
      loc: Loc.t;
pj2m's avatar
pj2m committed
378 379
    }

bguillaum's avatar
bguillaum committed
380 381
  let get_name t = t.name

382
  let get_loc t = t.loc
pj2m's avatar
pj2m committed
383

384 385
  let is_filter t = t.commands = []

386
  let to_json ?domain t =
387 388 389 390 391 392 393 394 395
    let param_json = match t.param with
    | None -> []
    | Some lex_par -> [
      ("pattern_param", `List (List.map (fun x -> `String x) (fst t.param_names)));
      ("command_param", `List (List.map (fun x -> `String x) (snd t.param_names)));
      ("lex_par", Lex_par.to_json lex_par);
    ] in
    `Assoc
    ([
396 397 398
      ("rule_name", `String t.name);
      ("match", basic_to_json ?domain (fst t.pattern));
      ("without", `List (List.map (basic_to_json ?domain) (snd t.pattern)));
399 400
    ] @ param_json
    )
401

402
  (* ====================================================================== *)
bguillaum's avatar
bguillaum committed
403
  let to_dep ?domain t =
404
    let pos_basic = fst t.pattern in
405 406 407
    let buff = Buffer.create 32 in
    bprintf buff "[GRAPH] { scale = 200; }\n";

bguillaum's avatar
bguillaum committed
408 409
    let nodes =
      Pid_map.fold
410
        (fun id node acc ->
bguillaum's avatar
bguillaum committed
411 412
          (node, sprintf "  N_%s { word=\"%s\"; subword=\"%s\"}"
            (Pid.to_id id) (P_node.get_name node) (P_fs.to_dep t.param_names (P_node.get_fs node))
413
          )
414
          :: acc
415
        ) pos_basic.graph [] in
416

417
    (* nodes are sorted to appear in the same order in dep picture and in input file *)
418
    let sorted_nodes = List.sort (fun (n1,_) (n2,_) -> P_node.compare_pos n1 n2) nodes in
bguillaum's avatar
bguillaum committed
419

420 421 422 423 424
    bprintf buff "[WORDS] {\n";
    List.iter
      (fun (_, dep_line) -> bprintf buff "%s\n" dep_line
      ) sorted_nodes;

425
    List.iteri
426 427
      (fun i cst ->
        match cst with
bguillaum's avatar
bguillaum committed
428
          | Cst_out _ | Cst_in _ -> bprintf buff "  C_%d { word=\"*\"}\n" i
429
          | _ -> ()
430
      ) pos_basic.constraints;
431
    bprintf buff "}\n";
bguillaum's avatar
bguillaum committed
432

433
    bprintf buff "[EDGES] {\n";
bguillaum's avatar
bguillaum committed
434

435 436
    Pid_map.iter
      (fun id_src node ->
bguillaum's avatar
bguillaum committed
437
        Massoc_pid.iter
438
          (fun id_tar edge ->
bguillaum's avatar
bguillaum committed
439 440 441
            bprintf buff "  N_%s -> N_%s { label=\"%s\"}\n"
              (Pid.to_id id_src)
              (Pid.to_id id_tar)
bguillaum's avatar
bguillaum committed
442
              (P_edge.to_string ?domain edge)
443 444
          )
          (P_node.get_next node)
445
      ) pos_basic.graph;
446

447
    List.iteri
448 449
      (fun i cst ->
        match cst with
bguillaum's avatar
bguillaum committed
450
          | Cst_out (pid, label_cst) ->
bguillaum's avatar
bguillaum committed
451
            bprintf buff "  N_%s -> C_%d {label = \"%s\"; style=dot; bottom; color=green;}\n"
bguillaum's avatar
bguillaum committed
452
              (Pid.to_id pid) i (Label_cst.to_string ?domain label_cst)
bguillaum's avatar
bguillaum committed
453
          | Cst_in (pid, label_cst) ->
bguillaum's avatar
bguillaum committed
454
            bprintf buff "  C_%d -> N_%s {label = \"%s\"; style=dot; bottom; color=green;}\n"
bguillaum's avatar
bguillaum committed
455
              i (Pid.to_id pid) (Label_cst.to_string ?domain label_cst)
456
          | _ -> ()
457
      ) pos_basic.constraints;
458 459
    bprintf buff "}\n";
    Buffer.contents buff
bguillaum's avatar
bguillaum committed
460

461
  (* ====================================================================== *)
bguillaum's avatar
bguillaum committed
462
  let build_commands ?domain ?param ?(locals=[||]) pos pos_table ast_commands =
bguillaum's avatar
bguillaum committed
463
    let known_act_ids = Array.to_list pos_table in
464
    let known_edge_ids = get_edge_ids pos in
465

466
    let rec loop (kai,kei) = function
467 468
      | [] -> []
      | ast_command :: tail ->
469
          let (command, (new_kai, new_kei)) =
470
            Command.build
bguillaum's avatar
bguillaum committed
471
              ?domain
472
              ?param
473
              (kai,kei)
474 475 476
              pos_table
              locals
              ast_command in
477 478
          command :: (loop (new_kai,new_kei) tail) in
    loop (known_act_ids, known_edge_ids) ast_commands
479 480

  (* ====================================================================== *)
bguillaum's avatar
bguillaum committed
481 482 483 484 485 486 487 488 489 490 491 492
  let parse_vars loc vars =
    let rec parse_cmd_vars = function
      | [] -> []
      | x::t when x.[0] = '@' -> x :: parse_cmd_vars t
      | x::t -> Error.bug ~loc "Illegal feature definition '%s' in the lexical rule" x in
    let rec parse_pat_vars = function
      | [] -> ([],[])
      | x::t when x.[0] = '@' -> ([],parse_cmd_vars (x::t))
      | x::t when x.[0] = '$' -> let (pv,cv) = parse_pat_vars t in (x::pv, cv)
      | x::t -> Error.bug ~loc "Illegal feature definition '%s' in the lexical rule" x in
    parse_pat_vars vars

493
  (* ====================================================================== *)
bguillaum's avatar
bguillaum committed
494
  let build ?domain ?(locals=[||]) dir rule_ast =
bguillaum's avatar
bguillaum committed
495 496

    let (param, pat_vars, cmd_vars) =
bguillaum's avatar
bguillaum committed
497 498
      match rule_ast.Ast.param with
      | None -> (None,[],[])
499
      | Some (files,vars) ->
bguillaum's avatar
bguillaum committed
500 501 502
          let (pat_vars, cmd_vars) = parse_vars rule_ast.Ast.rule_loc vars in
          let nb_pv = List.length pat_vars in
          let nb_cv = List.length cmd_vars in
bguillaum's avatar
bguillaum committed
503

504
          (* first: load lexical parameters given in the same file at the end of the rule definition *)
bguillaum's avatar
bguillaum committed
505 506 507 508
          let local_param = match rule_ast.Ast.lex_par with
          | None -> None
          | Some lines -> Some (Lex_par.from_lines ~loc:rule_ast.Ast.rule_loc nb_pv nb_cv lines) in

509
          (* second: load lexical parameters given in external files *)
bguillaum's avatar
bguillaum committed
510
          let full_param = List.fold_left
511
            (fun acc file ->
bguillaum's avatar
bguillaum committed
512 513 514 515 516 517
              match acc with
              | None -> Some (Lex_par.load ~loc:rule_ast.Ast.rule_loc dir nb_pv nb_cv file)
              | Some lp -> Some (Lex_par.append (Lex_par.load ~loc:rule_ast.Ast.rule_loc dir nb_pv nb_cv file) lp)
            ) local_param files in

          (full_param, pat_vars, cmd_vars) in
518

519
    (match (param, pat_vars) with
520
      | (None, _::_) -> Error.build ~loc:rule_ast.Ast.rule_loc "[Rule.build] Missing lexical parameters in rule \"%s\"" rule_ast.Ast.rule_id
521 522 523
      | _ -> ()
    );

524
    let pattern = Ast.normalize_pattern rule_ast.Ast.pattern in
525
    let (pos, pos_table) =
526
      try build_pos_basic ?domain ~pat_vars pattern.Ast.pat_pos
527 528 529 530
      with P_fs.Fail_unif ->
        Error.build ~loc:rule_ast.Ast.rule_loc
          "[Rule.build] in rule \"%s\": feature structures declared in the \"match\" clause are inconsistent"
          rule_ast.Ast.rule_id in
bguillaum's avatar
bguillaum committed
531 532 533
    let (negs,_) =
      List.fold_left
      (fun (acc,pos) basic_ast ->
bguillaum's avatar
bguillaum committed
534
        try ((build_neg_basic ?domain ~pat_vars pos_table basic_ast) :: acc, pos+1)
bguillaum's avatar
bguillaum committed
535 536 537 538
        with P_fs.Fail_unif ->
          Log.fwarning "In rule \"%s\" [%s], the wihtout number %d cannot be satisfied, it is skipped"
            rule_ast.Ast.rule_id (Loc.to_string rule_ast.Ast.rule_loc) pos;
          (acc, pos+1)
539
      ) ([],1) pattern.Ast.pat_negs in
pj2m's avatar
pj2m committed
540
    {
bguillaum's avatar
bguillaum committed
541
      name = rule_ast.Ast.rule_id;
542
      pattern = (pos, negs);
bguillaum's avatar
bguillaum committed
543
      commands = build_commands ?domain ~param:(pat_vars,cmd_vars) pos pos_table rule_ast.Ast.commands;
bguillaum's avatar
bguillaum committed
544 545 546 547 548
      loc = rule_ast.Ast.rule_loc;
      param = param;
      param_names = (pat_vars,cmd_vars)
    }

bguillaum's avatar
bguillaum committed
549
  let build_pattern ?domain pattern_ast =
550
    let n_pattern = Ast.normalize_pattern pattern_ast in
551
    let (pos, pos_table) =
552
      try build_pos_basic ?domain n_pattern.Ast.pat_pos
553 554 555 556
      with P_fs.Fail_unif -> Error.build "feature structures declared in the \"match\" clause are inconsistent " in
    let negs =
      List_.try_map
        P_fs.Fail_unif (* Skip the without parts that are incompatible with the match part *)
bguillaum's avatar
bguillaum committed
557
        (fun basic_ast -> build_neg_basic ?domain pos_table basic_ast)
558
        n_pattern.Ast.pat_negs in
bguillaum's avatar
bguillaum committed
559 560
    (pos, negs)

561
  (* ====================================================================== *)
pj2m's avatar
pj2m committed
562
  type matching = {
563
      n_match: Gid.t Pid_map.t;                     (* partial fct: pattern nodes |--> graph nodes *)
564
      e_match: (string*(Gid.t*Label.t*Gid.t)) list; (* edge matching: edge ident  |--> (src,label,tar) *)
565
      m_param: Lex_par.t option;
pj2m's avatar
pj2m committed
566
    }
567

568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583
  let to_python pattern graph m =

    let node_name gid =
      let gnode = G_graph.find gid graph in
      G_node.get_name gid gnode in
    let buff = Buffer.create 32 in
    bprintf buff "%s" "{ ";

    Pid_map.iter
      (fun pid gid ->
        let pnode = P_graph.find pid (fst pattern).graph in
        bprintf buff "\"%s\":\"%s\", " (P_node.get_name pnode) (node_name gid)
      ) m.n_match;

    List.iter
      (fun (id, (src,lab,tar)) ->
584
        bprintf buff "\"%s\":\"%s/%s/%s\", " id (node_name src) (Label.to_string lab) (node_name tar)
585 586 587 588 589
      ) m.e_match;

    bprintf buff "%s" "}";
    Buffer.contents buff

590 591 592 593 594 595 596 597
  let node_matching pattern graph { n_match } =
    Pid_map.fold
      (fun pid gid acc ->
        let pnode = P_graph.find pid (fst pattern).graph in
        let gnode = G_graph.find gid graph in
        (P_node.get_name pnode, int_of_float (G_node.get_position gnode)) :: acc
      ) n_match []

598
  let empty_matching param = { n_match = Pid_map.empty; e_match = []; m_param = param;}
599

pj2m's avatar
pj2m committed
600 601
  let e_comp (e1,_) (e2,_) = compare e1 e2

bguillaum's avatar
bguillaum committed
602
  let e_match_add ?pos edge_id matching =
pj2m's avatar
pj2m committed
603 604
    match List_.usort_insert ~compare:e_comp edge_id matching.e_match with
    | Some new_e_match -> { matching with e_match = new_e_match }
bguillaum's avatar
bguillaum committed
605
    | None -> Error.bug "The edge identifier '%s' is binded twice in the same pattern" (fst edge_id)
bguillaum's avatar
bguillaum committed
606

607
  let match_deco pattern matching =
608 609 610
    { G_deco.nodes =
        Pid_map.fold
          (fun pid gid acc ->
611
            let pnode = P_graph.find pid (fst pattern).graph in
612 613
            (gid, (P_node.get_name pnode, P_fs.feat_list (P_node.get_fs pnode))) ::acc
          ) matching.n_match [];
614
      G_deco.edges = List.fold_left (fun acc (_,edge) -> edge::acc) [] matching.e_match;
pj2m's avatar
pj2m committed
615 616
    }

bguillaum's avatar
bguillaum committed
617
  let find cnode ?loc (matching, created_nodes) =
pj2m's avatar
pj2m committed
618
    match cnode with
619
    | Command.Pat pid ->
620
        (try Pid_map.find pid matching.n_match
bguillaum's avatar
bguillaum committed
621 622
        with Not_found -> Error.bug ?loc "Inconsistent matching pid '%s' not found" (Pid.to_string pid))
    | Command.New name ->
bguillaum's avatar
bguillaum committed
623 624
        (try List.assoc name created_nodes
        with Not_found -> Error.run ?loc "Identifier '%s' not found" name)
pj2m's avatar
pj2m committed
625 626

  let down_deco (matching,created_nodes) commands =
627 628 629 630 631 632 633 634 635 636
    let feat_to_highlight = List.fold_left
      (fun acc -> function
        | (Command.UPDATE_FEAT (tar_cn,feat_name,_),loc) ->
          (* | (Command.SHIFT_EDGE (_,tar_cn),loc) *)
          let gid = find tar_cn (matching, created_nodes) in
          let old_feat_list = try Gid_map.find gid acc with Not_found -> [] in
          Gid_map.add gid (feat_name :: old_feat_list) acc
        | _ -> acc
      ) Gid_map.empty commands in

pj2m's avatar
pj2m committed
637
    {
638
     G_deco.nodes = List.map (fun (gid,feat_list) -> (gid, ("",feat_list))) (Gid_map.bindings feat_to_highlight);
639
     G_deco.edges = List.fold_left
bguillaum's avatar
bguillaum committed
640 641
       (fun acc -> function
         | (Command.ADD_EDGE (src_cn,tar_cn,edge),loc) ->
642
             (find src_cn (matching, created_nodes), edge, find tar_cn (matching, created_nodes)) :: acc
643
         | _ -> acc
pj2m's avatar
pj2m committed
644 645 646 647 648
       ) [] commands
   }

  exception Fail
  type partial = {
bguillaum's avatar
bguillaum committed
649
      sub: matching;
650 651 652
      unmatched_nodes: Pid.t list;
      unmatched_edges: (Pid.t * P_edge.t * Pid.t) list;
      already_matched_gids: Gid.t list; (* to ensure injectivity *)
pj2m's avatar
pj2m committed
653
      check: const list (* constraints to verify at the end of the matching *)
bguillaum's avatar
bguillaum committed
654 655 656
    }

        (* PREREQUISITES:
bguillaum's avatar
bguillaum committed
657 658
           - all partial matching have the same ?domain
           - the ?domain of the pattern P is the disjoint union of ?domain([sub]) and [unmatched_nodes]
659
         *)
bguillaum's avatar
bguillaum committed
660
  (*  ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
661 662
  let init param basic =
    let roots = P_graph.roots basic.graph in
pj2m's avatar
pj2m committed
663

bguillaum's avatar
bguillaum committed
664
    let node_list = Pid_map.fold (fun pid _ acc -> pid::acc) basic.graph [] in
pj2m's avatar
pj2m committed
665 666

    (* put all roots in the front of the list to speed up the algo *)
bguillaum's avatar
bguillaum committed
667
    let sorted_node_list =
pj2m's avatar
pj2m committed
668
      List.sort
669 670 671 672
        (fun n1 n2 -> match (List.mem n1 roots, List.mem n2 roots) with
        | true, false -> -1
        | false, true -> 1
        | _ -> 0) node_list in
bguillaum's avatar
bguillaum committed
673

bguillaum's avatar
bguillaum committed
674
    { sub = empty_matching param;
pj2m's avatar
pj2m committed
675 676 677
      unmatched_nodes = sorted_node_list;
      unmatched_edges = [];
      already_matched_gids = [];
bguillaum's avatar
bguillaum committed
678
      check = basic.constraints;
pj2m's avatar
pj2m committed
679 680
    }

bguillaum's avatar
bguillaum committed
681
  (*  ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
682
  let apply_cst ?domain graph matching cst =
bguillaum's avatar
bguillaum committed
683
    let get_node pid = G_graph.find (Pid_map.find pid matching.n_match) graph in
684 685 686 687 688 689
    let get_string_feat pid = function
      | "position" -> Some (sprintf "%g" (G_node.get_position (get_node pid)))
      | feat_name -> G_fs.get_string_atom feat_name (G_node.get_fs (get_node pid)) in
    let get_float_feat pid = function
      | "position" -> Some (G_node.get_position (get_node pid))
      | feat_name -> G_fs.get_float_feat feat_name (G_node.get_fs (get_node pid)) in
bguillaum's avatar
bguillaum committed
690 691

    match cst with
bguillaum's avatar
bguillaum committed
692
      | Cst_out (pid,label_cst) ->
693
        let gid = Pid_map.find pid matching.n_match in
bguillaum's avatar
bguillaum committed
694
        if G_graph.edge_out ?domain graph gid label_cst
bguillaum's avatar
bguillaum committed
695 696
        then matching
        else raise Fail
bguillaum's avatar
bguillaum committed
697
      | Cst_in (pid,label_cst) ->
698
        let gid = Pid_map.find pid matching.n_match in
bguillaum's avatar
bguillaum committed
699
        if G_graph.node_exists
700
          (fun node ->
bguillaum's avatar
bguillaum committed
701
            List.exists (fun e -> Label_cst.match_ ?domain label_cst e) (Massoc_gid.assoc gid (G_node.get_next node))
702
          ) graph
bguillaum's avatar
bguillaum committed
703 704
        then matching
        else raise Fail
bguillaum's avatar
bguillaum committed
705
      | Filter (pid, fs) ->
bguillaum's avatar
bguillaum committed
706 707 708 709 710 711 712 713
        begin
          try
            let gid = Pid_map.find pid matching.n_match in
            let gnode = G_graph.find gid graph in
            let new_param = P_fs.match_ ?param:matching.m_param fs (G_node.get_fs gnode) in
            {matching with m_param = new_param }
          with P_fs.Fail -> raise Fail
        end
714
      | Features_eq (pid1, feat_name1, pid2, feat_name2) ->
bguillaum's avatar
bguillaum committed
715 716
        begin
          match (get_string_feat pid1 feat_name1, get_string_feat pid2 feat_name2) with
bguillaum's avatar
bguillaum committed
717 718
            | Some fv1, Some fv2 when fv1 = fv2 -> matching
            | _ -> raise Fail
bguillaum's avatar
bguillaum committed
719
        end
720
      | Feature_eq_cst (pid1, feat_name1, value) ->
721 722 723 724 725 726 727 728 729 730 731
        begin
          match get_string_feat pid1 feat_name1 with
            | Some fv1 when fv1 = value -> matching
            | _ -> raise Fail
        end
      | Feature_diff_cst (pid1, feat_name1, value) ->
        begin
          match get_string_feat pid1 feat_name1 with
            | Some fv1 when fv1 <> value -> matching
            | _ -> raise Fail
        end
732
      | Feature_eq_float (pid1, feat_name1, float) ->
733 734 735 736 737 738 739 740 741 742 743
        begin
          match get_float_feat pid1 feat_name1 with
            | Some fv1 when fv1 = float -> matching
            | _ -> raise Fail
        end
      | Feature_diff_float (pid1, feat_name1, float) ->
        begin
          match get_float_feat pid1 feat_name1 with
            | Some fv1 when fv1 <> float -> matching
            | _ -> raise Fail
        end
744
      | Features_diseq (pid1, feat_name1, pid2, feat_name2) ->
bguillaum's avatar
bguillaum committed
745 746
        begin
          match (get_string_feat pid1 feat_name1, get_string_feat pid2 feat_name2) with
bguillaum's avatar
bguillaum committed
747 748
            | Some fv1, Some fv2 when fv1 <> fv2 -> matching
            | _ -> raise Fail
bguillaum's avatar
bguillaum committed
749
        end
750
      | Features_ineq (ineq, pid1, feat_name1, pid2, feat_name2) ->
751 752
        begin
          match (ineq, get_float_feat pid1 feat_name1, get_float_feat pid2 feat_name2) with
bguillaum's avatar
bguillaum committed
753 754 755 756 757
            | (Ast.Lt, Some fv1, Some fv2) when fv1 < fv2 -> matching
            | (Ast.Gt, Some fv1, Some fv2) when fv1 > fv2 -> matching
            | (Ast.Le, Some fv1, Some fv2) when fv1 <= fv2 -> matching
            | (Ast.Ge, Some fv1, Some fv2) when fv1 >= fv2 -> matching
            | _ -> raise Fail
758 759 760 761 762 763 764 765 766 767
          end
      | Feature_ineq_cst (ineq, pid1, feat_name1, constant) ->
        begin
          match (ineq, get_float_feat pid1 feat_name1) with
            | (Ast.Lt, Some fv1) when fv1 < constant -> matching
            | (Ast.Gt, Some fv1) when fv1 > constant -> matching
            | (Ast.Le, Some fv1) when fv1 <= constant -> matching
            | (Ast.Ge, Some fv1) when fv1 >= constant -> matching
            | _ -> raise Fail
          end
768
      | Feature_eq_regexp (pid, feat_name, regexp) ->
bguillaum's avatar
bguillaum committed
769 770 771 772 773
        begin
          match get_string_feat pid feat_name with
          | None -> raise Fail
          | Some string_feat ->
            let re = Str.regexp regexp in
774
            if String_.re_match re string_feat then matching else raise Fail
bguillaum's avatar
bguillaum committed
775
        end
776
      | Immediate_prec (pid1, pid2) ->
bguillaum's avatar
bguillaum committed
777 778
          let gid1 = Pid_map.find pid1 matching.n_match in
          let gid2 = Pid_map.find pid2 matching.n_match in
779
          let gnode1 = G_graph.find gid1 graph in
780
          if G_node.get_succ gnode1 = Some gid2
781 782
          then matching
          else  raise Fail
783
      | Large_prec (pid1, pid2) ->
784 785 786 787 788
          let gnode1 = G_graph.find (Pid_map.find pid1 matching.n_match) graph in
          let gnode2 = G_graph.find (Pid_map.find pid2 matching.n_match) graph in
          if G_node.get_position gnode1 < G_node.get_position gnode2
          then matching
          else raise Fail
pj2m's avatar
pj2m committed
789

bguillaum's avatar
bguillaum committed
790
  (*  ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
791
  (* returns all extension of the partial input matching *)
bguillaum's avatar
bguillaum committed
792
  let rec extend_matching ?domain (positive,neg) (graph:G_graph.t) (partial:partial) =
pj2m's avatar
pj2m committed
793
    match (partial.unmatched_edges, partial.unmatched_nodes) with
bguillaum's avatar
bguillaum committed
794
    | [], [] ->
bguillaum's avatar
bguillaum committed
795 796 797 798 799
      begin
        try
          let new_matching =
            List.fold_left
              (fun acc const ->
bguillaum's avatar
bguillaum committed
800
                apply_cst ?domain graph acc const
bguillaum's avatar
bguillaum committed
801 802 803 804
              ) partial.sub partial.check in
          [new_matching, partial.already_matched_gids]
        with Fail -> []
      end
pj2m's avatar
pj2m committed
805
    | (src_pid, p_edge, tar_pid)::tail_ue, _ ->
806 807
        begin
          try (* is the tar already found in the matching ? *)
bguillaum's avatar
bguillaum committed
808
            let new_partials =
809 810 811
              let src_gid = Pid_map.find src_pid partial.sub.n_match in
              let tar_gid = Pid_map.find tar_pid partial.sub.n_match in
              let src_gnode = G_graph.find src_gid graph in
812
              let g_edges = Massoc_gid.assoc tar_gid (G_node.get_next src_gnode) in
bguillaum's avatar
bguillaum committed
813

bguillaum's avatar
bguillaum committed
814
              match P_edge.match_list ?domain p_edge g_edges with
815
              | P_edge.Fail -> (* no good edge in graph for this pattern edge -> stop here *)
816
                  []
817
              | P_edge.Binds (id,labels) -> (* n edges in the graph match the identified p_edge -> make copies of the [k] matchings (and returns n*k matchings) *)
bguillaum's avatar
bguillaum committed
818
                  List.map
819 820
                    (fun label ->
                      {partial with sub = e_match_add (id,(src_gid,label,tar_gid)) partial.sub; unmatched_edges = tail_ue }
bguillaum's avatar
bguillaum committed
821
                    ) labels
bguillaum's avatar
bguillaum committed
822
            in List_.flat_map (extend_matching ?domain (positive,neg) graph) new_partials
823 824
          with Not_found -> (* p_edge goes to an unmatched node *)
            let candidates = (* candidates (of type (gid, matching)) for m(tar_pid) = gid) with new partial matching m *)
bguillaum's avatar
bguillaum committed
825
              let (src_gid : Gid.t) = Pid_map.find src_pid partial.sub.n_match in
826
              let src_gnode = G_graph.find src_gid graph in
827
              Massoc_gid.fold
828
                (fun acc gid_next g_edge ->
bguillaum's avatar
bguillaum committed
829
                  match P_edge.match_ ?domain p_edge g_edge with
830
                  | P_edge.Fail -> (* g_edge does not fit, no new candidate *)
831
                      acc
832
                  | P_edge.Binds (id,[label]) -> (* g_edge fits with an extended matching *)
833
                      (gid_next, e_match_add (id, (src_gid, label, gid_next)) partial.sub) :: acc
834 835
                  | _ -> Error.bug "P_edge.match_ must return exactly one label"
                ) [] (G_node.get_next src_gnode) in
836
            List_.flat_map
bguillaum's avatar
bguillaum committed
837
              (fun (gid_next, matching) ->
bguillaum's avatar
bguillaum committed
838
                extend_matching_from ?domain (positive,neg) graph tar_pid gid_next
839 840 841
                  {partial with sub=matching; unmatched_edges = tail_ue}
              ) candidates
        end
bguillaum's avatar
bguillaum committed
842
    | [], pid :: _ ->
843 844
        G_graph.fold_gid
          (fun gid acc ->
bguillaum's avatar
bguillaum committed
845
            (extend_matching_from ?domain (positive,neg) graph pid gid partial) @ acc
846
          ) graph []
bguillaum's avatar
bguillaum committed
847

bguillaum's avatar
bguillaum committed