grew_rule.ml 77.2 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
open Grew_base
15
open Grew_types
bguillaum's avatar
bguillaum committed
16
open Grew_ast
17
open Grew_domain
pj2m's avatar
pj2m committed
18
open Grew_edge
bguillaum's avatar
bguillaum committed
19
open Grew_fs
pj2m's avatar
pj2m committed
20
open Grew_node
bguillaum's avatar
bguillaum committed
21 22
open Grew_command
open Grew_graph
pj2m's avatar
pj2m committed
23

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

Bruno Guillaume's avatar
Bruno Guillaume committed
33 34 35 36 37
  let swap t =
    match t.big_step with
    | None -> t
    | Some bs -> {t with big_step = Some (Libgrew_types.swap bs) }

38
  let empty = {graph = G_graph.empty; rules=[]; history=[]; big_step=None; }
39

40
  let from_graph graph = {empty with graph}
pj2m's avatar
pj2m committed
41

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

48 49
  let refresh t = { empty with graph=t.graph }

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

54
  let to_gr t = G_graph.to_gr t.graph
55

56
  let to_conll_string t = G_graph.to_conll_string t.graph
bguillaum's avatar
bguillaum committed
57

58 59
  let save_dot_png ?filter ?main_feat base t =
    ignore (Dot.to_png_file (G_graph.to_dot ?main_feat t.graph) (base^".png"))
60
end (* module Instance *)
pj2m's avatar
pj2m committed
61

62
(* ================================================================================ *)
63
module Instance_set = Set.Make (Instance)
pj2m's avatar
pj2m committed
64

65
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
66
module Rule = struct
67

bguillaum's avatar
bguillaum committed
68
  (* the rewriting depth is bounded to stop rewriting when the system is not terminating *)
bguillaum's avatar
bguillaum committed
69 70
  let max_depth_det = ref 2000
  let max_depth_non_det = ref 100
bguillaum's avatar
bguillaum committed
71
  let debug_loop = ref false
72 73 74

  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
75
  let set_debug_loop () = debug_loop := true
pj2m's avatar
pj2m committed
76

77
  type const =
bguillaum's avatar
bguillaum committed
78 79
    | Cst_out of Pid.t * Label_cst.t
    | Cst_in of Pid.t * Label_cst.t
80 81
    | Features_eq of Pid.t * string * Pid.t * string
    | Features_diseq of Pid.t * string * Pid.t * string
82
    (* *)
83
    | Feature_eq_cst of Pid.t * string * string
84
    | Feature_diff_cst of Pid.t * string * string
85
    (* *)
86 87 88
    | Feature_eq_lex of Pid.t * string * (string * string)
    | Feature_diff_lex of Pid.t * string * (string * string)
    (* *)
89
    | Feature_eq_float of Pid.t * string * float
90
    | Feature_diff_float of Pid.t * string * float
91
    (* *)
92
    | Feature_eq_regexp of Pid.t * string * string
93
    (* *)
94
    | Features_ineq of Ast.ineq * Pid.t * string * Pid.t * string
95
    | Feature_ineq_cst of Ast.ineq * Pid.t * string * float
96
    (* *)
bguillaum's avatar
bguillaum committed
97
    | Filter of Pid.t * P_fs.t (* used when a without impose a fs on a node defined by the match basic *)
98
    (* *)
99 100
    | Immediate_prec of Pid.t * Pid.t
    | Large_prec of Pid.t * Pid.t
bguillaum's avatar
bguillaum committed
101

102 103 104
  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]
105
  | Features_eq (pid1,fn1,pid2,fn2) ->
106 107 108 109 110 111 112 113
    `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);
      ]
    ]
114
  | Features_diseq (pid1,fn1,pid2,fn2) ->
115 116 117 118 119 120 121 122
    `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);
      ]
    ]
123
  | Feature_eq_cst (pid,fn,value) ->
124 125 126 127 128 129 130 131
    `Assoc ["feature_eq_cst",
      `Assoc [
        ("id", `String (Pid.to_string pid));
        ("feature_name_", `String fn);
        ("value", `String value);
      ]
    ]
  | Feature_diff_cst (pid,fn,value) ->
132
    `Assoc ["feature_diff_cst",
133 134 135 136 137 138
      `Assoc [
        ("id", `String (Pid.to_string pid));
        ("feature_name_", `String fn);
        ("value", `String value);
      ]
    ]
139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158
  | Feature_eq_lex (pid,fn,(lex,field)) ->
    `Assoc ["feature_eq_lex",
      `Assoc [
        ("id", `String (Pid.to_string pid));
        ("feature_name_", `String fn);
        ("lexicon", `String lex);
        ("field", `String field);
      ]
    ]
  | Feature_diff_lex (pid,fn,(lex,field)) ->
    `Assoc ["feature_diff_lex",
      `Assoc [
        ("id", `String (Pid.to_string pid));
        ("feature_name_", `String fn);
        ("lexicon", `String lex);
        ("field", `String field);
      ]
    ]


159
  | Feature_eq_float (pid,fn,value) ->
160 161 162 163 164 165 166 167 168 169 170 171 172 173 174
    `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));
      ]
    ]
175
  | Feature_eq_regexp (pid,fn,regexp) ->
176 177 178 179 180 181 182
    `Assoc ["feature_eq_regexp",
      `Assoc [
        ("id", `String (Pid.to_string pid));
        ("feature_name", `String fn);
        ("regexp", `String regexp);
      ]
    ]
183
  | Features_ineq (ineq,pid1,fn1,pid2,fn2) ->
184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208
    `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);
      ]
    ]
209
  | Immediate_prec (pid1, pid2) ->
210 211 212 213 214 215
    `Assoc ["immediate_prec",
      `Assoc [
        ("id1", `String (Pid.to_string pid1));
        ("id2", `String (Pid.to_string pid2));
      ]
    ]
216
  | Large_prec (pid1, pid2) ->
217 218 219 220 221 222 223
    `Assoc ["large_prec",
      `Assoc [
        ("id1", `String (Pid.to_string pid1));
        ("id2", `String (Pid.to_string pid2));
      ]
    ]

Bruno Guillaume's avatar
Bruno Guillaume committed
224
  let build_pos_constraint ?domain ?lexicons pos_table const =
bguillaum's avatar
bguillaum committed
225 226
    let pid_of_name loc node_name = Pid.Pos (Id.build ~loc node_name pos_table) in
    match const with
227
      | (Ast.Cst_out (id,label_cst), loc) ->
bguillaum's avatar
bguillaum committed
228
        Cst_out (pid_of_name loc id, Label_cst.build ~loc ?domain label_cst)
229
      | (Ast.Cst_in (id,label_cst), loc) ->
bguillaum's avatar
bguillaum committed
230
        Cst_in (pid_of_name loc id, Label_cst.build ~loc ?domain label_cst)
231

232
      | (Ast.Features_eq ((node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
bguillaum's avatar
bguillaum committed
233 234
        Domain.check_feature_name ?domain ~loc feat_name1;
        Domain.check_feature_name ?domain ~loc feat_name2;
235
        Features_eq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
236

237
      | (Ast.Features_diseq ((node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
bguillaum's avatar
bguillaum committed
238 239
        Domain.check_feature_name ?domain ~loc feat_name1;
        Domain.check_feature_name ?domain ~loc feat_name2;
240
        Features_diseq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
241

242
      | (Ast.Features_ineq (ineq, (node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
bguillaum's avatar
bguillaum committed
243 244
        Domain.check_feature_name ?domain ~loc feat_name1;
        Domain.check_feature_name ?domain ~loc feat_name2;
245
        Features_ineq (ineq, pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
246

247
      | (Ast.Feature_ineq_cst (ineq, (node_name1, feat_name1), constant), loc) ->
bguillaum's avatar
bguillaum committed
248
        Domain.check_feature_name ?domain ~loc feat_name1;
249 250
        Feature_ineq_cst (ineq, pid_of_name loc node_name1, feat_name1, constant)

251
      | (Ast.Feature_eq_regexp ((node_name, feat_name), regexp), loc) ->
bguillaum's avatar
bguillaum committed
252
        Domain.check_feature_name ?domain ~loc feat_name;
253
        Feature_eq_regexp (pid_of_name loc node_name, feat_name, regexp)
bguillaum's avatar
bguillaum committed
254

255
      | (Ast.Feature_eq_cst ((node_name, feat_name), string), loc) ->
256
        Domain.check_feature_name ?domain ~loc feat_name;
257
        Feature_eq_cst (pid_of_name loc node_name, feat_name, string)
258 259 260 261
      | (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)

262 263 264 265 266 267 268
      | (Ast.Feature_eq_lex ((node_name, feat_name), lf), loc) ->
        Domain.check_feature_name ?domain ~loc feat_name;
        Feature_eq_lex (pid_of_name loc node_name, feat_name, lf)
      | (Ast.Feature_diff_lex ((node_name, feat_name), lf), loc) ->
        Domain.check_feature_name ?domain ~loc feat_name;
        Feature_diff_lex (pid_of_name loc node_name, feat_name, lf)

269
      | (Ast.Feature_eq_float ((node_name, feat_name), float), loc) ->
270
        Domain.check_feature_name ?domain ~loc feat_name;
271
        Feature_eq_float (pid_of_name loc node_name, feat_name, float)
272 273 274 275
      | (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)

276 277
      | (Ast.Immediate_prec (id1, id2), loc) ->
        Immediate_prec (pid_of_name loc id1, pid_of_name loc id2)
bguillaum's avatar
bguillaum committed
278

279 280
      | (Ast.Large_prec (id1, id2), loc) ->
        Large_prec (pid_of_name loc id1, pid_of_name loc id2)
bguillaum's avatar
bguillaum committed
281

282 283 284 285
      | (Ast.Feature_eq_lex_or_fs (s1,s2), loc) -> failwith "TODO"
      | (Ast.Feature_diff_lex_or_fs (s1,s2), loc) -> failwith "TODO"


bguillaum's avatar
bguillaum committed
286
  type basic = {
287 288 289
    graph: P_graph.t;
    constraints: const list;
  }
pj2m's avatar
pj2m committed
290

291 292 293 294 295 296
  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));
    ]

Bruno Guillaume's avatar
Bruno Guillaume committed
297
  let build_pos_basic ?domain ?lexicons ?pat_vars basic_ast =
298
    let (graph, pos_table) =
bguillaum's avatar
bguillaum committed
299
      P_graph.build ?domain ?pat_vars basic_ast.Ast.pat_nodes basic_ast.Ast.pat_edges in
pj2m's avatar
pj2m committed
300
    (
bguillaum's avatar
bguillaum committed
301 302
      {
        graph = graph;
Bruno Guillaume's avatar
Bruno Guillaume committed
303
        constraints = List.map (build_pos_constraint ?domain ?lexicons pos_table) basic_ast.Ast.pat_const
bguillaum's avatar
bguillaum committed
304 305
      },
      pos_table
pj2m's avatar
pj2m committed
306 307
    )

bguillaum's avatar
bguillaum committed
308
  (* the neg part *)
bguillaum's avatar
bguillaum committed
309
  let build_neg_constraint ?domain pos_table neg_table const =
bguillaum's avatar
bguillaum committed
310 311 312 313
    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
314
    match const with
315
      | (Ast.Cst_out (id,label_cst), loc) ->
bguillaum's avatar
bguillaum committed
316
        Cst_out (pid_of_name loc id, Label_cst.build ~loc ?domain label_cst)
317
      | (Ast.Cst_in (id,label_cst), loc) ->
bguillaum's avatar
bguillaum committed
318
        Cst_in (pid_of_name loc id, Label_cst.build ~loc ?domain label_cst)
319

320
      | (Ast.Features_eq (feat_id1, feat_id2), loc) ->
321 322
        let (node_name1, feat_name1) = feat_id1
        and (node_name2, feat_name2) = feat_id2 in
bguillaum's avatar
bguillaum committed
323 324
        Domain.check_feature_name ?domain ~loc feat_name1;
        Domain.check_feature_name ?domain ~loc feat_name2;
325
        Features_eq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
326

327
      | (Ast.Features_diseq (feat_id1, feat_id2), loc) ->
328 329
        let (node_name1, feat_name1) = feat_id1
        and (node_name2, feat_name2) = feat_id2 in
bguillaum's avatar
bguillaum committed
330 331
        Domain.check_feature_name ?domain ~loc feat_name1;
        Domain.check_feature_name ?domain ~loc feat_name2;
332
        Features_diseq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
333

334
      | (Ast.Features_ineq (ineq, feat_id1, feat_id2), loc) ->
335 336
        let (node_name1, feat_name1) = feat_id1
        and (node_name2, feat_name2) = feat_id2 in
bguillaum's avatar
bguillaum committed
337 338
        Domain.check_feature_name ?domain ~loc feat_name1;
        Domain.check_feature_name ?domain ~loc feat_name2;
339
        Features_ineq (ineq, pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
340

341 342
      | (Ast.Feature_ineq_cst (ineq, feat_id1, constant), loc) ->
        let (node_name1, feat_name1) = feat_id1 in
bguillaum's avatar
bguillaum committed
343
        Domain.check_feature_name ?domain ~loc feat_name1;
344
        Feature_ineq_cst (ineq, pid_of_name loc node_name1, feat_name1, constant)
pj2m's avatar
pj2m committed
345

346
      | (Ast.Feature_eq_regexp (feat_id, regexp), loc) ->
bguillaum's avatar
bguillaum committed
347
        let (node_name, feat_name) = feat_id in
bguillaum's avatar
bguillaum committed
348
        Domain.check_feature_name ?domain ~loc feat_name;
349
        Feature_eq_regexp (pid_of_name loc node_name, feat_name, regexp)
bguillaum's avatar
bguillaum committed
350

351
      | (Ast.Feature_eq_cst ((node_name, feat_name), string), loc) ->
352
        Domain.check_feature_name ?domain ~loc feat_name;
353
        Feature_eq_cst (pid_of_name loc node_name, feat_name, string)
354 355 356 357
      | (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)

358 359 360 361 362 363 364
      | (Ast.Feature_eq_lex ((node_name, feat_name), lf), loc) ->
        Domain.check_feature_name ?domain ~loc feat_name;
        Feature_eq_lex (pid_of_name loc node_name, feat_name, lf)
      | (Ast.Feature_diff_lex ((node_name, feat_name), lf), loc) ->
        Domain.check_feature_name ?domain ~loc feat_name;
        Feature_diff_lex (pid_of_name loc node_name, feat_name, lf)

365
      | (Ast.Feature_eq_float ((node_name, feat_name), float), loc) ->
366
        Domain.check_feature_name ?domain ~loc feat_name;
367
        Feature_eq_float (pid_of_name loc node_name, feat_name, float)
368 369 370 371
      | (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)

372 373
      | (Ast.Immediate_prec (id1, id2), loc) ->
        Immediate_prec (pid_of_name loc id1, pid_of_name loc id2)
bguillaum's avatar
bguillaum committed
374

375 376
      | (Ast.Large_prec (id1, id2), loc) ->
        Large_prec (pid_of_name loc id1, pid_of_name loc id2)
bguillaum's avatar
bguillaum committed
377

378 379 380 381
      | (Ast.Feature_eq_lex_or_fs (s1,s2), loc) -> failwith "TODO"
      | (Ast.Feature_diff_lex_or_fs (s1,s2), loc) -> failwith "TODO"


bguillaum's avatar
bguillaum committed
382
  (* It may raise [P_fs.Fail_unif] in case of contradiction on constraints *)
Bruno Guillaume's avatar
Bruno Guillaume committed
383
  let build_neg_basic ?domain ?pat_vars pos_table basic_ast =
pj2m's avatar
pj2m committed
384
    let (extension, neg_table) =
bguillaum's avatar
bguillaum committed
385
      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
386

387
    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
388
    {
bguillaum's avatar
bguillaum committed
389
      graph = extension.P_graph.ext_map;
bguillaum's avatar
bguillaum committed
390
      constraints = filters @ List.map (build_neg_constraint ?domain pos_table neg_table) basic_ast.Ast.pat_const ;
bguillaum's avatar
bguillaum committed
391
    }
pj2m's avatar
pj2m committed
392

bguillaum's avatar
bguillaum committed
393
  let get_edge_ids basic =
394
    Pid_map.fold
bguillaum's avatar
bguillaum committed
395 396
      (fun _ node acc ->
        Massoc_pid.fold
397
          (fun acc2 _ edge -> (P_edge.get_id edge)::acc2)
398
          acc (P_node.get_next node)
bguillaum's avatar
bguillaum committed
399
      ) basic.graph []
bguillaum's avatar
bguillaum committed
400

401 402 403
  (* a [pattern] is described by the positive basic and a list of negative basics. *)
  type pattern = basic * basic list

404
  let pid_name_list (pos,_) = P_graph.pid_name_list pos.graph
405

pj2m's avatar
pj2m committed
406 407
  type t = {
      name: string;
408
      pattern: pattern;
pj2m's avatar
pj2m committed
409
      commands: Command.t list;
Bruno Guillaume's avatar
Bruno Guillaume committed
410
      param: Lex_par.t * string list; (* ([],[]) if None *)
Bruno Guillaume's avatar
Bruno Guillaume committed
411
      lexicons: Lexicons.t;
bguillaum's avatar
bguillaum committed
412
      loc: Loc.t;
pj2m's avatar
pj2m committed
413 414
    }

bguillaum's avatar
bguillaum committed
415 416
  let get_name t = t.name

417
  let get_loc t = t.loc
pj2m's avatar
pj2m committed
418

419
  let to_json ?domain t =
420
    let param_json = match t.param with
Bruno Guillaume's avatar
Bruno Guillaume committed
421 422 423
    | ([],[]) -> []
    | (lex_par, param_names) -> [
      ("pattern_param", `List (List.map (fun x -> `String x) (param_names)));
424 425 426 427
      ("lex_par", Lex_par.to_json lex_par);
    ] in
    `Assoc
    ([
428 429 430
      ("rule_name", `String t.name);
      ("match", basic_to_json ?domain (fst t.pattern));
      ("without", `List (List.map (basic_to_json ?domain) (snd t.pattern)));
431
      ("commands", `List (List.map (Command.to_json ?domain) t.commands))
432 433
    ] @ param_json
    )
434

435
  (* ====================================================================== *)
bguillaum's avatar
bguillaum committed
436
  let to_dep ?domain t =
437
    let pos_basic = fst t.pattern in
438 439 440
    let buff = Buffer.create 32 in
    bprintf buff "[GRAPH] { scale = 200; }\n";

bguillaum's avatar
bguillaum committed
441 442
    let nodes =
      Pid_map.fold
443
        (fun id node acc ->
bguillaum's avatar
bguillaum committed
444
          (node, sprintf "  N_%s { word=\"%s\"; subword=\"%s\"}"
Bruno Guillaume's avatar
Bruno Guillaume committed
445
            (Pid.to_id id) (P_node.get_name node) (P_fs.to_dep (snd t.param) (P_node.get_fs node))
446
          )
447
          :: acc
448
        ) pos_basic.graph [] in
449

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

453 454 455 456 457
    bprintf buff "[WORDS] {\n";
    List.iter
      (fun (_, dep_line) -> bprintf buff "%s\n" dep_line
      ) sorted_nodes;

458
    List.iteri
459 460
      (fun i cst ->
        match cst with
bguillaum's avatar
bguillaum committed
461
          | Cst_out _ | Cst_in _ -> bprintf buff "  C_%d { word=\"*\"}\n" i
462
          | _ -> ()
463
      ) pos_basic.constraints;
464
    bprintf buff "}\n";
bguillaum's avatar
bguillaum committed
465

466
    bprintf buff "[EDGES] {\n";
bguillaum's avatar
bguillaum committed
467

468 469
    Pid_map.iter
      (fun id_src node ->
bguillaum's avatar
bguillaum committed
470
        Massoc_pid.iter
471
          (fun id_tar edge ->
bguillaum's avatar
bguillaum committed
472 473 474
            bprintf buff "  N_%s -> N_%s { label=\"%s\"}\n"
              (Pid.to_id id_src)
              (Pid.to_id id_tar)
bguillaum's avatar
bguillaum committed
475
              (P_edge.to_string ?domain edge)
476 477
          )
          (P_node.get_next node)
478
      ) pos_basic.graph;
479

480
    List.iteri
481 482
      (fun i cst ->
        match cst with
bguillaum's avatar
bguillaum committed
483
          | Cst_out (pid, label_cst) ->
bguillaum's avatar
bguillaum committed
484
            bprintf buff "  N_%s -> C_%d {label = \"%s\"; style=dot; bottom; color=green;}\n"
bguillaum's avatar
bguillaum committed
485
              (Pid.to_id pid) i (Label_cst.to_string ?domain label_cst)
bguillaum's avatar
bguillaum committed
486
          | Cst_in (pid, label_cst) ->
bguillaum's avatar
bguillaum committed
487
            bprintf buff "  C_%d -> N_%s {label = \"%s\"; style=dot; bottom; color=green;}\n"
bguillaum's avatar
bguillaum committed
488
              i (Pid.to_id pid) (Label_cst.to_string ?domain label_cst)
489
          | _ -> ()
490
      ) pos_basic.constraints;
491 492
    bprintf buff "}\n";
    Buffer.contents buff
bguillaum's avatar
bguillaum committed
493

494
  (* ====================================================================== *)
495
  let build_commands ?domain ?param lexicon_names pos pos_table ast_commands =
Bruno Guillaume's avatar
Bruno Guillaume committed
496
    let known_node_ids = Array.to_list pos_table in
497
    let known_edge_ids = get_edge_ids pos in
498

Bruno Guillaume's avatar
Bruno Guillaume committed
499
    let rec loop (kni,kei) = function
500 501
      | [] -> []
      | ast_command :: tail ->
Bruno Guillaume's avatar
Bruno Guillaume committed
502
          let (command, (new_kni, new_kei)) =
503
            Command.build
bguillaum's avatar
bguillaum committed
504
              ?domain
505
              ?param
506
              lexicon_names
Bruno Guillaume's avatar
Bruno Guillaume committed
507
              (kni,kei)
508 509
              pos_table
              ast_command in
Bruno Guillaume's avatar
Bruno Guillaume committed
510 511
          command :: (loop (new_kni,new_kei) tail) in
    loop (known_node_ids, known_edge_ids) ast_commands
512

Bruno Guillaume's avatar
Bruno Guillaume committed
513
  let build_lex loc = function
514
  | Ast.File filename -> Lexicon.load filename
Bruno Guillaume's avatar
Bruno Guillaume committed
515
  | Ast.Final (line_list) -> Lexicon.build loc line_list
516 517


518
  (* ====================================================================== *)
519 520 521 522 523
  let build ?domain deprecated_dir rule_ast =

    let dir = match rule_ast.Ast.rule_dir with
    | Some d -> d
    | None -> deprecated_dir in
bguillaum's avatar
bguillaum committed
524

Bruno Guillaume's avatar
Bruno Guillaume committed
525
    let lexicons = List.fold_left (fun acc (name,lex) ->
Bruno Guillaume's avatar
Bruno Guillaume committed
526 527
        try
          let prev = List.assoc name acc in
Bruno Guillaume's avatar
Bruno Guillaume committed
528
          (name, (Lexicon.union prev (build_lex rule_ast.Ast.rule_loc lex))) :: (List.remove_assoc name acc)
Bruno Guillaume's avatar
Bruno Guillaume committed
529
        with
Bruno Guillaume's avatar
Bruno Guillaume committed
530
          Not_found -> (name, build_lex rule_ast.Ast.rule_loc lex) :: acc
Bruno Guillaume's avatar
Bruno Guillaume committed
531
      ) [] rule_ast.Ast.lexicon_info in
532 533 534

    let lexicon_names = List.map fst lexicons in

535
    let (param, pat_vars) =
bguillaum's avatar
bguillaum committed
536
      match rule_ast.Ast.param with
Bruno Guillaume's avatar
Bruno Guillaume committed
537
      | None -> ([],[])
538
      | Some (files,vars) ->
539
          let nb_var = List.length vars in
bguillaum's avatar
bguillaum committed
540

541
          (* first: load lexical parameters given in the same file at the end of the rule definition *)
bguillaum's avatar
bguillaum committed
542
          let local_param = match rule_ast.Ast.lex_par with
Bruno Guillaume's avatar
Bruno Guillaume committed
543 544
          | None -> []
          | Some lines -> Lex_par.from_lines ~loc:rule_ast.Ast.rule_loc nb_var lines in
bguillaum's avatar
bguillaum committed
545

546
          (* second: load lexical parameters given in external files *)
bguillaum's avatar
bguillaum committed
547
          let full_param = List.fold_left
548
            (fun acc file ->
bguillaum's avatar
bguillaum committed
549
              match acc with
Bruno Guillaume's avatar
Bruno Guillaume committed
550 551
              | [] -> Lex_par.load ~loc:rule_ast.Ast.rule_loc dir nb_var file
              | lp -> Lex_par.append (Lex_par.load ~loc:rule_ast.Ast.rule_loc dir nb_var file) lp
bguillaum's avatar
bguillaum committed
552 553
            ) local_param files in

554
          (full_param, vars) in
555

556
    (match (param, pat_vars) with
Bruno Guillaume's avatar
Bruno Guillaume committed
557
      | ([], _::_) -> Error.build ~loc:rule_ast.Ast.rule_loc "[Rule.build] Missing lexical parameters in rule \"%s\"" rule_ast.Ast.rule_id
558 559 560
      | _ -> ()
    );

561
    let pattern = Ast.normalize_pattern rule_ast.Ast.pattern in
562
    let (pos, pos_table) =
Bruno Guillaume's avatar
Bruno Guillaume committed
563
      try build_pos_basic ?domain ~lexicons:lexicons ~pat_vars pattern.Ast.pat_pos
564 565 566 567
      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
568 569 570
    let (negs,_) =
      List.fold_left
      (fun (acc,pos) basic_ast ->
bguillaum's avatar
bguillaum committed
571
        try ((build_neg_basic ?domain ~pat_vars pos_table basic_ast) :: acc, pos+1)
bguillaum's avatar
bguillaum committed
572 573 574 575
        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)
576
      ) ([],1) pattern.Ast.pat_negs in
pj2m's avatar
pj2m committed
577
    {
bguillaum's avatar
bguillaum committed
578
      name = rule_ast.Ast.rule_id;
579
      pattern = (pos, negs);
580
      commands = build_commands ?domain ~param:pat_vars lexicon_names pos pos_table rule_ast.Ast.commands;
bguillaum's avatar
bguillaum committed
581
      loc = rule_ast.Ast.rule_loc;
582
      lexicons;
Bruno Guillaume's avatar
Bruno Guillaume committed
583
      param = (param, pat_vars);
bguillaum's avatar
bguillaum committed
584 585
    }

Bruno Guillaume's avatar
Bruno Guillaume committed
586
  let build_pattern ?domain ?lexicons pattern_ast =
587
    let n_pattern = Ast.normalize_pattern pattern_ast in
588
    let (pos, pos_table) =
Bruno Guillaume's avatar
Bruno Guillaume committed
589
      try build_pos_basic ?domain ?lexicons n_pattern.Ast.pat_pos
590 591 592 593
      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
594
        (fun basic_ast -> build_neg_basic ?domain pos_table basic_ast)
595
        n_pattern.Ast.pat_negs in
bguillaum's avatar
bguillaum committed
596 597
    (pos, negs)

598
  (* ====================================================================== *)
pj2m's avatar
pj2m committed
599
  type matching = {
600
      n_match: Gid.t Pid_map.t;                     (* partial fct: pattern nodes |--> graph nodes *)
601
      e_match: (string*(Gid.t*Label.t*Gid.t)) list; (* edge matching: edge ident  |--> (src,label,tar) *)
602
      m_param: Lex_par.t option;
Bruno Guillaume's avatar
Bruno Guillaume committed
603
      l_param: Lexicons.t;
604

pj2m's avatar
pj2m committed
605
    }
606

607
  let to_python pattern graph m =
Bruno Guillaume's avatar
Bruno Guillaume committed
608 609 610 611 612 613 614 615 616
    let node_name gid = G_node.get_name gid (G_graph.find gid graph) in
    let nodes = Pid_map.fold (fun pid gid acc ->
      let pnode = P_graph.find pid (fst pattern).graph in
        (P_node.get_name pnode, `String (node_name gid))::acc
      ) m.n_match [] in
    let edges = List.map (fun (id, (src,lab,tar)) ->
      (id, `String (sprintf "%s/%s/%s" (node_name src) (Label.to_string lab) (node_name tar)))
      ) m.e_match in
    `Assoc ( nodes @ edges)
617

618 619 620 621 622
  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
623
        (P_node.get_name pnode, G_node.get_float gnode) :: acc
624 625
      ) n_match []

Bruno Guillaume's avatar
Bruno Guillaume committed
626
  let empty_matching ?(lexicons=[]) param = { n_match = Pid_map.empty; e_match = []; m_param = param; l_param = lexicons;}
627

pj2m's avatar
pj2m committed
628 629
  let e_comp (e1,_) (e2,_) = compare e1 e2

bguillaum's avatar
bguillaum committed
630
  let e_match_add ?pos edge_id matching =
pj2m's avatar
pj2m committed
631 632
    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
633
    | None -> Error.bug "The edge identifier '%s' is binded twice in the same pattern" (fst edge_id)
bguillaum's avatar
bguillaum committed
634

635
  let match_deco pattern matching =
636 637 638
    { G_deco.nodes =
        Pid_map.fold
          (fun pid gid acc ->
639
            let pnode = P_graph.find pid (fst pattern).graph in
640 641
            (gid, (P_node.get_name pnode, P_fs.feat_list (P_node.get_fs pnode))) ::acc
          ) matching.n_match [];
642
      G_deco.edges = List.fold_left (fun acc (_,edge) -> edge::acc) [] matching.e_match;
pj2m's avatar
pj2m committed
643 644
    }

bguillaum's avatar
bguillaum committed
645
  let find cnode ?loc (matching, created_nodes) =
pj2m's avatar
pj2m committed
646
    match cnode with
647
    | Command.Pat pid ->
648
        (try Pid_map.find pid matching.n_match
bguillaum's avatar
bguillaum committed
649 650
        with Not_found -> Error.bug ?loc "Inconsistent matching pid '%s' not found" (Pid.to_string pid))
    | Command.New name ->
bguillaum's avatar
bguillaum committed
651 652
        (try List.assoc name created_nodes
        with Not_found -> Error.run ?loc "Identifier '%s' not found" name)
pj2m's avatar
pj2m committed
653 654

  let down_deco (matching,created_nodes) commands =
655 656 657 658 659 660 661 662 663 664
    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
665
    {
666
     G_deco.nodes = List.map (fun (gid,feat_list) -> (gid, ("",feat_list))) (Gid_map.bindings feat_to_highlight);
667
     G_deco.edges = List.fold_left
bguillaum's avatar
bguillaum committed
668 669
       (fun acc -> function
         | (Command.ADD_EDGE (src_cn,tar_cn,edge),loc) ->
670
             (find src_cn (matching, created_nodes), edge, find tar_cn (matching, created_nodes)) :: acc
671
         | _ -> acc
pj2m's avatar
pj2m committed
672 673 674 675 676
       ) [] commands
   }

  exception Fail
  type partial = {
bguillaum's avatar
bguillaum committed
677
      sub: matching;
678 679 680
      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
681
      check: const list (* constraints to verify at the end of the matching *)
bguillaum's avatar
bguillaum committed
682 683 684
    }

        (* PREREQUISITES:
bguillaum's avatar
bguillaum committed
685 686
           - all partial matching have the same ?domain
           - the ?domain of the pattern P is the disjoint union of ?domain([sub]) and [unmatched_nodes]
687
         *)
bguillaum's avatar
bguillaum committed
688
  (*  ---------------------------------------------------------------------- *)
Bruno Guillaume's avatar
Bruno Guillaume committed
689
  let init ?lexicons param basic =
bguillaum's avatar
bguillaum committed
690
    let roots = P_graph.roots basic.graph in
pj2m's avatar
pj2m committed
691

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

    (* put all roots in the front of the list to speed up the algo *)
bguillaum's avatar
bguillaum committed
695
    let sorted_node_list =
pj2m's avatar
pj2m committed
696
      List.sort
697 698 699 700
        (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
701

Bruno Guillaume's avatar
Bruno Guillaume committed
702
    { sub = empty_matching ?lexicons param;
pj2m's avatar
pj2m committed
703 704 705
      unmatched_nodes = sorted_node_list;
      unmatched_edges = [];
      already_matched_gids = [];
bguillaum's avatar
bguillaum committed
706
      check = basic.constraints;
pj2m's avatar
pj2m committed
707 708
    }

bguillaum's avatar
bguillaum committed
709
  (*  ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
710
  let apply_cst ?domain graph matching cst =
bguillaum's avatar
bguillaum committed
711
    let get_node pid = G_graph.find (Pid_map.find pid matching.n_match) graph in
712
    let get_string_feat pid = function
713 714 715 716 717 718
      | "position" ->
        begin
          match G_node.get_position (get_node pid) with
          | G_node.Ordered f -> Some (sprintf "%g" f)
          | _ -> Error.run "Cannot read position of an unordered node"
        end
719 720
      | feat_name -> G_fs.get_string_atom feat_name (G_node.get_fs (get_node pid)) in
    let get_float_feat pid = function
721 722 723 724 725 726
      | "position" ->
        begin
          match G_node.get_position (get_node pid) with
          | G_node.Ordered f -> Some f
          | _ -> Error.run "Cannot read position of an unordered node"
        end
727
      | feat_name -> G_fs.get_float_feat feat_name (G_node.get_fs (get_node pid)) in
bguillaum's avatar
bguillaum committed
728 729

    match cst with
bguillaum's avatar
bguillaum committed
730
      | Cst_out (pid,label_cst) ->
731
        let gid = Pid_map.find pid matching.n_match in
732
        if G_graph.edge_out graph gid label_cst
bguillaum's avatar
bguillaum committed
733 734
        then matching
        else raise Fail
bguillaum's avatar
bguillaum committed
735
      | Cst_in (pid,label_cst) ->
736
        let gid = Pid_map.find pid matching.n_match in
bguillaum's avatar
bguillaum committed
737
        if G_graph.node_exists
738
          (fun node ->
bguillaum's avatar
bguillaum committed
739
            List.exists (fun e -> Label_cst.match_ ?domain label_cst e) (Massoc_gid.assoc gid (G_node.get_next node))
740
          ) graph
bguillaum's avatar
bguillaum committed
741 742
        then matching
        else raise Fail
bguillaum's avatar
bguillaum committed
743
      | Filter (pid, fs) ->
bguillaum's avatar
bguillaum committed
744 745 746 747
        begin
          try
            let gid = Pid_map.find pid matching.n_match in
            let gnode = G_graph.find gid graph in
748 749
            let new_param = P_fs.match_ ~lexicons:(matching.l_param) fs (G_node.get_fs gnode) in
            {matching with l_param = new_param }
bguillaum's avatar
bguillaum committed
750 751
          with P_fs.Fail -> raise Fail
        end
752
      | Features_eq (pid1, feat_name1, pid2, feat_name2) ->
bguillaum's avatar
bguillaum committed
753 754
        begin
          match (get_string_feat pid1 feat_name1, get_string_feat pid2 feat_name2) with
bguillaum's avatar
bguillaum committed
755 756
            | Some fv1, Some fv2 when fv1 = fv2 -> matching
            | _ -> raise Fail
bguillaum's avatar
bguillaum committed
757
        end
758
      | Feature_eq_cst (pid1, feat_name1, value) ->
759 760 761 762 763 764 765 766 767 768 769
        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
770
      | Feature_eq_float (pid1, feat_name1, float) ->
771 772 773 774 775 776 777 778 779 780 781
        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
782
      | Features_diseq (pid1, feat_name1, pid2, feat_name2) ->
bguillaum's avatar
bguillaum committed
783 784
        begin
          match (get_string_feat pid1 feat_name1, get_string_feat pid2 feat_name2) with
bguillaum's avatar
bguillaum committed
785 786
            | Some fv1, Some fv2 when fv1 <> fv2 -> matching
            | _ -> raise Fail
bguillaum's avatar
bguillaum committed
787
        end
788
      | Features_ineq (ineq, pid1, feat_name1, pid2, feat_name2) ->
789 790
        begin
          match (ineq, get_float_feat pid1 feat_name1, get_float_feat pid2 feat_name2) with
bguillaum's avatar
bguillaum committed
791 792 793 794 795
            | (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
796 797 798 799 800 801 802 803 804 805
          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
806
      | Feature_eq_regexp (pid, feat_name, regexp) ->
bguillaum's avatar
bguillaum committed
807 808 809 810 811
        begin
          match get_string_feat pid feat_name with
          | None -> raise Fail
          | Some string_feat ->
            let re = Str.regexp regexp in
812
            if String_.re_match re string_feat then matching else raise Fail
bguillaum's avatar
bguillaum committed
813
        end
814
      | Immediate_prec (pid1, pid2) ->
bguillaum's avatar
bguillaum committed
815 816
          let gid1 = Pid_map.find pid1 matching.n_match in
          let gid2 = Pid_map.find pid2 matching.n_match in
817
          let gnode1 = G_graph.find gid1 graph in
818
          if G_node.get_succ gnode1 = Some gid2
819 820
          then matching
          else  raise Fail
821
      | Large_prec (pid1, pid2) ->
822 823 824 825 826
          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
827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848
      | Feature_eq_lex (pid, feature_name, (lexicon,field)) ->
        begin
          Printf.printf "### Feature_eq_lex\n%!";
          match get_string_feat pid feature_name with
          | None -> raise Fail
          | Some v ->
              let old_lex = List.assoc lexicon matching.l_param in
              match Lexicon.select field v old_lex with
              | None -> raise Fail
              | Some new_lex -> {matching with l_param = (lexicon, new_lex) :: (List.remove_assoc lexicon matching.l_param) }
        end

      | Feature_diff_lex (pid, feature_name, (lexicon,field)) ->
        begin
          match get_string_feat pid feature_name with
          | None -> raise Fail
          | Some v ->
              let old_lex = List.assoc lexicon matching.l_param in
              match Lexicon.unselect field v old_lex with
              | None -> raise Fail
              | Some new_lex -> {matching with l_param = (lexicon, new_lex) :: (List.remove_assoc lexicon matching.l_param) }
        end
849

pj2m's avatar
pj2m committed
850

bguillaum's avatar
bguillaum committed
851
  (*  ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
852
  (* returns all extension of the partial input matching *)
bguillaum's avatar
bguillaum committed
853
  let rec extend_matching ?domain (positive,neg) (graph:G_graph.t) (partial:partial) =
pj2m's avatar
pj2m committed
854
    match (partial.unmatched_edges, partial.unmatched_nodes) with
bguillaum's avatar
bguillaum committed
855
    | [], [] ->
bguillaum's avatar
bguillaum committed
856 857 858 859 860
      begin
        try
          let new_matching =
            List.fold_left
              (fun acc const ->