grew_rule.ml 71.9 KB
Newer Older
bguillaum's avatar
bguillaum committed
1 2 3
(**********************************************************************************)
(*    Libcaml-grew - a Graph Rewriting library dedicated to NLP applications      *)
(*                                                                                *)
Bruno Guillaume's avatar
Bruno Guillaume committed
4
(*    Copyright 2011-2018 Inria, Université de Lorraine                           *)
bguillaum's avatar
bguillaum committed
5
(*                                                                                *)
Bruno Guillaume's avatar
Bruno Guillaume committed
6
(*    Webpage: http://grew.fr                                                     *)
bguillaum's avatar
bguillaum committed
7 8 9 10
(*    License: CeCILL (see LICENSE folder or "http://www.cecill.info")            *)
(*    Authors: see AUTHORS file                                                   *)
(**********************************************************************************)

pj2m's avatar
pj2m committed
11
open Log
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


25
(* ================================================================================ *)
26
module Rule = struct
27

28 29 30 31 32 33 34 35 36 37
  (* the number of rewriting steps is bounded to stop rewriting when the system is not terminating *)
  let max_rules = ref 10000
  let current_rules = ref 0

  let set_max_rules n = max_rules := n
  let reset_rules () = current_rules := 0
  let incr_rules () =
    incr current_rules;
    if !current_rules > !max_rules
    then Error.run "More than %d rewriting steps: ckeck for loops or increase max_rules value" !max_rules
38

39
  type const =
40 41
    | Cst_out of Pid.t * Label_cst.t
    | Cst_in of Pid.t * Label_cst.t
42 43
    | Features_eq of Pid.t * string * Pid.t * string
    | Features_diseq of Pid.t * string * Pid.t * string
44
    (* *)
45
    | Feature_eq_cst of Pid.t * string * string
46
    | Feature_diff_cst of Pid.t * string * string
47
    (* *)
48 49 50
    | Feature_eq_lex of Pid.t * string * (string * string)
    | Feature_diff_lex of Pid.t * string * (string * string)
    (* *)
51
    | Feature_eq_float of Pid.t * string * float
52
    | Feature_diff_float of Pid.t * string * float
53
    (* *)
54
    | Feature_eq_regexp of Pid.t * string * string
55
    (* *)
56
    | Features_ineq of Ast.ineq * Pid.t * string * Pid.t * string
57
    | Feature_ineq_cst of Ast.ineq * Pid.t * string * float
58
    (* *)
bguillaum's avatar
bguillaum committed
59
    | Filter of Pid.t * P_fs.t (* used when a without impose a fs on a node defined by the match basic *)
60
    (* *)
61 62
    | Immediate_prec of Pid.t * Pid.t
    | Large_prec of Pid.t * Pid.t
63 64
    (* *)
    | Id_prec of Pid.t * Pid.t
65 66 67 68 69
    (* *)
    | Label_equal of string * string
    | Label_disequal of string * string


70

71 72 73
  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]
74
  | Features_eq (pid1,fn1,pid2,fn2) ->
75 76 77 78 79 80 81 82
    `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);
      ]
    ]
83
  | Features_diseq (pid1,fn1,pid2,fn2) ->
84 85 86 87 88 89 90 91
    `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);
      ]
    ]
92
  | Feature_eq_cst (pid,fn,value) ->
93 94 95 96 97 98 99 100
    `Assoc ["feature_eq_cst",
      `Assoc [
        ("id", `String (Pid.to_string pid));
        ("feature_name_", `String fn);
        ("value", `String value);
      ]
    ]
  | Feature_diff_cst (pid,fn,value) ->
101
    `Assoc ["feature_diff_cst",
102 103 104 105 106 107
      `Assoc [
        ("id", `String (Pid.to_string pid));
        ("feature_name_", `String fn);
        ("value", `String value);
      ]
    ]
108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127
  | 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);
      ]
    ]


128
  | Feature_eq_float (pid,fn,value) ->
129 130 131 132 133 134 135 136 137 138 139 140 141 142 143
    `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));
      ]
    ]
144
  | Feature_eq_regexp (pid,fn,regexp) ->
145 146 147 148 149 150 151
    `Assoc ["feature_eq_regexp",
      `Assoc [
        ("id", `String (Pid.to_string pid));
        ("feature_name", `String fn);
        ("regexp", `String regexp);
      ]
    ]
152
  | Features_ineq (ineq,pid1,fn1,pid2,fn2) ->
153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177
    `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);
      ]
    ]
178
  | Immediate_prec (pid1, pid2) ->
179 180 181 182 183 184
    `Assoc ["immediate_prec",
      `Assoc [
        ("id1", `String (Pid.to_string pid1));
        ("id2", `String (Pid.to_string pid2));
      ]
    ]
185
  | Large_prec (pid1, pid2) ->
186 187 188 189 190 191
    `Assoc ["large_prec",
      `Assoc [
        ("id1", `String (Pid.to_string pid1));
        ("id2", `String (Pid.to_string pid2));
      ]
    ]
192 193 194 195 196 197 198
  | Id_prec (pid1, pid2) ->
    `Assoc ["id_prec",
      `Assoc [
        ("id1", `String (Pid.to_string pid1));
        ("id2", `String (Pid.to_string pid2));
      ]
    ]
199 200 201 202 203 204 205 206 207 208 209 210 211 212
  | Label_equal (eid1, eid2) ->
    `Assoc ["label_equal",
      `Assoc [
        ("id1", `String eid1);
        ("id2", `String eid2);
      ]
    ]
  | Label_disequal (eid1, eid2) ->
    `Assoc ["label_disequal",
      `Assoc [
        ("id1", `String eid1);
        ("id2", `String eid2);
      ]
    ]
213

Bruno Guillaume's avatar
Bruno Guillaume committed
214
  let build_pos_constraint ?domain lexicons pos_table const =
215 216
    let pid_of_name loc node_name = Pid.Pos (Id.build ~loc node_name pos_table) in
    match const with
217
      | (Ast.Cst_out (id,label_cst), loc) ->
bguillaum's avatar
bguillaum committed
218
        Cst_out (pid_of_name loc id, Label_cst.build ~loc ?domain label_cst)
219
      | (Ast.Cst_in (id,label_cst), loc) ->
bguillaum's avatar
bguillaum committed
220
        Cst_in (pid_of_name loc id, Label_cst.build ~loc ?domain label_cst)
221

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

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

232
      | (Ast.Features_ineq (ineq, (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_ineq (ineq, pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
236

237
      | (Ast.Feature_ineq_cst (ineq, (node_name1, feat_name1), constant), loc) ->
bguillaum's avatar
bguillaum committed
238
        Domain.check_feature_name ?domain ~loc feat_name1;
239 240
        Feature_ineq_cst (ineq, pid_of_name loc node_name1, feat_name1, constant)

241
      | (Ast.Feature_eq_regexp ((node_name, feat_name), regexp), loc) ->
bguillaum's avatar
bguillaum committed
242
        Domain.check_feature_name ?domain ~loc feat_name;
243
        Feature_eq_regexp (pid_of_name loc node_name, feat_name, regexp)
244

245
      | (Ast.Feature_eq_cst ((node_name, feat_name), string), loc) ->
246
        Domain.check_feature_name ?domain ~loc feat_name;
247
        Feature_eq_cst (pid_of_name loc node_name, feat_name, string)
248 249 250 251
      | (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)

252 253 254 255 256 257 258
      | (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)

259
      | (Ast.Feature_eq_float ((node_name, feat_name), float), loc) ->
260
        Domain.check_feature_name ?domain ~loc feat_name;
261
        Feature_eq_float (pid_of_name loc node_name, feat_name, float)
262 263 264 265
      | (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)

266 267
      | (Ast.Immediate_prec (id1, id2), loc) ->
        Immediate_prec (pid_of_name loc id1, pid_of_name loc id2)
268

269 270
      | (Ast.Large_prec (id1, id2), loc) ->
        Large_prec (pid_of_name loc id1, pid_of_name loc id2)
271

272 273 274 275 276 277
      | (Ast.Label_equal (eid1, eid2), loc) ->
        Label_equal (eid1, eid2)

      | (Ast.Label_disequal (eid1, eid2), loc) ->
        Label_disequal (eid1, eid2)

Bruno Guillaume's avatar
Bruno Guillaume committed
278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293
      | (Ast.Feature_eq_lex_or_fs ((node_name, feat_name),(node_or_lex, fn_or_field)), loc) ->
          begin
            match Id.build_opt node_or_lex pos_table with
            | None ->
              Lexicons.check ~loc node_or_lex fn_or_field lexicons;
              Feature_eq_lex (pid_of_name loc node_name, feat_name, (node_or_lex, fn_or_field))
            | _ ->  Features_eq (pid_of_name loc node_name, feat_name, pid_of_name loc node_or_lex, fn_or_field)
          end
      | (Ast.Feature_diff_lex_or_fs ((node_name, feat_name),(node_or_lex, fn_or_field)), loc) ->
          begin
            match Id.build_opt node_or_lex pos_table with
            | None ->
              Lexicons.check ~loc node_or_lex fn_or_field lexicons;
              Feature_diff_lex (pid_of_name loc node_name, feat_name, (node_or_lex, fn_or_field))
            | _ ->  Features_diseq (pid_of_name loc node_name, feat_name, pid_of_name loc node_or_lex, fn_or_field)
          end
294 295 296
      | (Ast.Id_prec (id1, id2), loc) ->
        Id_prec (pid_of_name loc id1, pid_of_name loc id2)

297 298


bguillaum's avatar
bguillaum committed
299
  type basic = {
300 301 302
    graph: P_graph.t;
    constraints: const list;
  }
pj2m's avatar
pj2m committed
303

304 305 306 307 308 309
  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));
    ]

310
  let build_pos_basic ?domain lexicons pivot basic_ast =
311
    let (graph, pos_table) =
312
      P_graph.build ?domain lexicons pivot basic_ast in
pj2m's avatar
pj2m committed
313
    (
314 315
      {
        graph = graph;
Bruno Guillaume's avatar
Bruno Guillaume committed
316
        constraints = List.map (build_pos_constraint ?domain lexicons pos_table) basic_ast.Ast.pat_const
317 318
      },
      pos_table
pj2m's avatar
pj2m committed
319 320
    )

321
  (* the neg part *)
Bruno Guillaume's avatar
Bruno Guillaume committed
322
  let build_neg_constraint ?domain lexicons pos_table neg_table const =
323 324 325 326
    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
327
    match const with
328
      | (Ast.Cst_out (id,label_cst), loc) ->
bguillaum's avatar
bguillaum committed
329
        Cst_out (pid_of_name loc id, Label_cst.build ~loc ?domain label_cst)
330
      | (Ast.Cst_in (id,label_cst), loc) ->
bguillaum's avatar
bguillaum committed
331
        Cst_in (pid_of_name loc id, Label_cst.build ~loc ?domain label_cst)
332

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

340
      | (Ast.Features_diseq (feat_id1, feat_id2), loc) ->
341 342
        let (node_name1, feat_name1) = feat_id1
        and (node_name2, feat_name2) = feat_id2 in
bguillaum's avatar
bguillaum committed
343 344
        Domain.check_feature_name ?domain ~loc feat_name1;
        Domain.check_feature_name ?domain ~loc feat_name2;
345
        Features_diseq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
346

347
      | (Ast.Features_ineq (ineq, feat_id1, feat_id2), loc) ->
348 349
        let (node_name1, feat_name1) = feat_id1
        and (node_name2, feat_name2) = feat_id2 in
bguillaum's avatar
bguillaum committed
350 351
        Domain.check_feature_name ?domain ~loc feat_name1;
        Domain.check_feature_name ?domain ~loc feat_name2;
352
        Features_ineq (ineq, pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
353

354 355
      | (Ast.Feature_ineq_cst (ineq, feat_id1, constant), loc) ->
        let (node_name1, feat_name1) = feat_id1 in
bguillaum's avatar
bguillaum committed
356
        Domain.check_feature_name ?domain ~loc feat_name1;
357
        Feature_ineq_cst (ineq, pid_of_name loc node_name1, feat_name1, constant)
pj2m's avatar
pj2m committed
358

359
      | (Ast.Feature_eq_regexp (feat_id, regexp), loc) ->
360
        let (node_name, feat_name) = feat_id in
bguillaum's avatar
bguillaum committed
361
        Domain.check_feature_name ?domain ~loc feat_name;
362
        Feature_eq_regexp (pid_of_name loc node_name, feat_name, regexp)
363

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

371 372 373 374 375 376 377
      | (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)

378
      | (Ast.Feature_eq_float ((node_name, feat_name), float), loc) ->
379
        Domain.check_feature_name ?domain ~loc feat_name;
380
        Feature_eq_float (pid_of_name loc node_name, feat_name, float)
381 382 383 384
      | (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)

385 386
      | (Ast.Immediate_prec (id1, id2), loc) ->
        Immediate_prec (pid_of_name loc id1, pid_of_name loc id2)
387

388 389
      | (Ast.Large_prec (id1, id2), loc) ->
        Large_prec (pid_of_name loc id1, pid_of_name loc id2)
390

391 392 393 394 395 396
      | (Ast.Label_equal (eid1, eid2), loc) ->
        Label_equal (eid1, eid2)

      | (Ast.Label_disequal (eid1, eid2), loc) ->
        Label_disequal (eid1, eid2)

Bruno Guillaume's avatar
Bruno Guillaume committed
397 398 399 400 401 402 403 404 405 406 407 408 409 410 411
      | (Ast.Feature_eq_lex_or_fs ((node_name, feat_name),(node_or_lex, fn_or_field)), loc) ->
          begin
            match (Id.build_opt node_or_lex pos_table, Id.build_opt node_or_lex neg_table) with
            | (None, None) ->
              Lexicons.check ~loc node_or_lex fn_or_field lexicons;
              Feature_eq_lex (pid_of_name loc node_name, feat_name, (node_or_lex, fn_or_field))
            | _ ->  Features_eq (pid_of_name loc node_name, feat_name, pid_of_name loc node_or_lex, fn_or_field)
          end
      | (Ast.Feature_diff_lex_or_fs ((node_name, feat_name),(node_or_lex, fn_or_field)), loc) ->
          begin
            match (Id.build_opt node_or_lex pos_table, Id.build_opt node_or_lex neg_table) with
            | (None, None) -> Feature_diff_lex (pid_of_name loc node_name, feat_name, (node_or_lex, fn_or_field))
            | _ ->  Features_diseq (pid_of_name loc node_name, feat_name, pid_of_name loc node_or_lex, fn_or_field)
          end

412 413 414
      | (Ast.Id_prec (id1, id2), loc) ->
        Id_prec (pid_of_name loc id1, pid_of_name loc id2)

415 416


bguillaum's avatar
bguillaum committed
417
  (* It may raise [P_fs.Fail_unif] in case of contradiction on constraints *)
418
  let build_neg_basic ?domain lexicons pos_table basic_ast =
pj2m's avatar
pj2m committed
419
    let (extension, neg_table) =
420
      P_graph.build_extension ?domain lexicons pos_table basic_ast.Ast.pat_nodes basic_ast.Ast.pat_edges in
bguillaum's avatar
bguillaum committed
421

422
    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
423
    {
424
      graph = {P_graph.map = extension.P_graph.ext_map; pivot = None };
Bruno Guillaume's avatar
Bruno Guillaume committed
425
      constraints = filters @ List.map (build_neg_constraint ?domain lexicons pos_table neg_table) basic_ast.Ast.pat_const ;
426
    }
pj2m's avatar
pj2m committed
427

bguillaum's avatar
bguillaum committed
428
  let get_edge_ids basic =
429
    Pid_map.fold
430 431
      (fun _ node acc ->
        Massoc_pid.fold
432
          (fun acc2 _ edge -> (P_edge.get_id edge)::acc2)
433
          acc (P_node.get_next node)
434
      ) basic.graph.P_graph.map []
435

436
  (* a [pattern] is described by the positive basic and a list of negative basics. *)
437
  type pattern = {
438
    global: string list;
439 440 441
    pos: basic;
    negs: basic list;
  }
442

443
  let pid_name_list pattern = P_graph.pid_name_list pattern.pos.graph
444

pj2m's avatar
pj2m committed
445 446
  type t = {
      name: string;
447
      pattern: pattern;
pj2m's avatar
pj2m committed
448
      commands: Command.t list;
Bruno Guillaume's avatar
Bruno Guillaume committed
449
      lexicons: Lexicons.t;
bguillaum's avatar
bguillaum committed
450
      loc: Loc.t;
451
      path: string;
pj2m's avatar
pj2m committed
452 453
    }

454 455
  let get_name t = t.name

456 457
  let get_long_name t = t.path ^ t.name

458
  let get_loc t = t.loc
pj2m's avatar
pj2m committed
459

460
  let to_json ?domain t =
461 462
    `Assoc
    ([
463
      ("rule_name", `String t.name);
464 465
      ("pattern", basic_to_json ?domain t.pattern.pos);
      ("without", `List (List.map (basic_to_json ?domain) t.pattern.negs));
466
      ("commands", `List (List.map (Command.to_json ?domain) t.commands))
467
    ]
468
    )
469

470
  (* ====================================================================== *)
bguillaum's avatar
bguillaum committed
471
  let to_dep ?domain t =
472
    let pos_basic = t.pattern.pos in
473 474 475
    let buff = Buffer.create 32 in
    bprintf buff "[GRAPH] { scale = 200; }\n";

476 477
    let nodes =
      Pid_map.fold
478
        (fun id node acc ->
479
          (node, sprintf "  N_%s { word=\"%s\"; subword=\"%s\"}"
480
            (Pid.to_id id) (P_node.get_name node) (P_fs.to_dep (P_node.get_fs node))
481
          )
482
          :: acc
483
        ) pos_basic.graph.P_graph.map [] in
484

485
    (* nodes are sorted to appear in the same order in dep picture and in input file *)
486
    let sorted_nodes = List.sort (fun (n1,_) (n2,_) -> P_node.compare_pos n1 n2) nodes in
487

488 489 490 491 492
    bprintf buff "[WORDS] {\n";
    List.iter
      (fun (_, dep_line) -> bprintf buff "%s\n" dep_line
      ) sorted_nodes;

493
    List.iteri
494 495
      (fun i cst ->
        match cst with
496
          | Cst_out _ | Cst_in _ -> bprintf buff "  C_%d { word=\"*\"}\n" i
497
          | _ -> ()
498
      ) pos_basic.constraints;
499
    bprintf buff "}\n";
500

501
    bprintf buff "[EDGES] {\n";
502

503 504
    Pid_map.iter
      (fun id_src node ->
505
        Massoc_pid.iter
506
          (fun id_tar edge ->
507 508 509
            bprintf buff "  N_%s -> N_%s { label=\"%s\"}\n"
              (Pid.to_id id_src)
              (Pid.to_id id_tar)
bguillaum's avatar
bguillaum committed
510
              (P_edge.to_string ?domain edge)
511 512
          )
          (P_node.get_next node)
513
      ) pos_basic.graph.P_graph.map;
514

515
    List.iteri
516 517
      (fun i cst ->
        match cst with
518
          | Cst_out (pid, label_cst) ->
519
            bprintf buff "  N_%s -> C_%d {label = \"%s\"; style=dot; bottom; color=green;}\n"
bguillaum's avatar
bguillaum committed
520
              (Pid.to_id pid) i (Label_cst.to_string ?domain label_cst)
521
          | Cst_in (pid, label_cst) ->
522
            bprintf buff "  C_%d -> N_%s {label = \"%s\"; style=dot; bottom; color=green;}\n"
bguillaum's avatar
bguillaum committed
523
              i (Pid.to_id pid) (Label_cst.to_string ?domain label_cst)
524
          | _ -> ()
525
      ) pos_basic.constraints;
526 527
    bprintf buff "}\n";
    Buffer.contents buff
bguillaum's avatar
bguillaum committed
528

529
  (* ====================================================================== *)
530
  let build_commands ?domain lexicons pos pos_table ast_commands =
Bruno Guillaume's avatar
Bruno Guillaume committed
531
    let known_node_ids = Array.to_list pos_table in
532
    let known_edge_ids = get_edge_ids pos in
533

Bruno Guillaume's avatar
Bruno Guillaume committed
534
    let rec loop (kni,kei) = function
535 536
      | [] -> []
      | ast_command :: tail ->
Bruno Guillaume's avatar
Bruno Guillaume committed
537
          let (command, (new_kni, new_kei)) =
538
            Command.build
bguillaum's avatar
bguillaum committed
539
              ?domain
Bruno Guillaume's avatar
Bruno Guillaume committed
540
              lexicons
Bruno Guillaume's avatar
Bruno Guillaume committed
541
              (kni,kei)
542 543
              pos_table
              ast_command in
Bruno Guillaume's avatar
Bruno Guillaume committed
544
          command :: (loop (new_kni,new_kei) tail) in
545
    loop (known_node_ids, known_edge_ids) ast_commands
546

Bruno Guillaume's avatar
Bruno Guillaume committed
547
  let build_lex loc = function
Bruno Guillaume's avatar
Bruno Guillaume committed
548 549
  | Ast.File filename ->
      if Filename.is_relative filename
550 551
      then Lexicon.load loc (Filename.concat (Global.get_dir ()) filename)
      else Lexicon.load loc filename
Bruno Guillaume's avatar
Bruno Guillaume committed
552
  | Ast.Final (line_list) -> Lexicon.build loc line_list
553 554


555
  (* ====================================================================== *)
Bruno Guillaume's avatar
Bruno Guillaume committed
556
  let build ?domain rule_ast =
Bruno Guillaume's avatar
Bruno Guillaume committed
557 558
    let lexicons =
      List.fold_left (fun acc (name,lex) ->
559 560
        try
          let prev = List.assoc name acc in
Bruno Guillaume's avatar
Bruno Guillaume committed
561
          (name, (Lexicon.union prev (build_lex rule_ast.Ast.rule_loc lex))) :: (List.remove_assoc name acc)
Bruno Guillaume's avatar
Bruno Guillaume committed
562 563
        with Not_found -> (name, build_lex rule_ast.Ast.rule_loc lex) :: acc
    ) [] rule_ast.Ast.lexicon_info in
564

565
    let pattern = Ast.normalize_pattern rule_ast.Ast.pattern in
566
    let (pos, pos_table) =
567
      try build_pos_basic ?domain lexicons pattern.Ast.pivot pattern.Ast.pat_pos
568 569 570 571
      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
572 573 574
    let (negs,_) =
      List.fold_left
      (fun (acc,pos) basic_ast ->
575
        try ((build_neg_basic ?domain lexicons pos_table basic_ast) :: acc, pos+1)
bguillaum's avatar
bguillaum committed
576
        with P_fs.Fail_unif ->
577 578
          Error.warning ~loc:rule_ast.Ast.rule_loc "In rule \"%s\", the wihtout number %d cannot be satisfied, it is skipped"
            rule_ast.Ast.rule_id pos;
bguillaum's avatar
bguillaum committed
579
          (acc, pos+1)
580
      ) ([],1) pattern.Ast.pat_negs in
pj2m's avatar
pj2m committed
581
    {
582
      name = rule_ast.Ast.rule_id;
583
      pattern = { pos; negs; global=pattern.Ast.pat_glob; };
584
      commands = build_commands ?domain lexicons pos pos_table rule_ast.Ast.commands;
585
      loc = rule_ast.Ast.rule_loc;
586
      lexicons;
587
      path = rule_ast.Ast.rule_path;
588 589
    }

Bruno Guillaume's avatar
Bruno Guillaume committed
590
  let build_pattern ?domain ?(lexicons=[]) pattern_ast =
591
    let n_pattern = Ast.normalize_pattern pattern_ast in
592
    let (pos, pos_table) =
593
      try build_pos_basic ?domain lexicons n_pattern.Ast.pivot n_pattern.Ast.pat_pos
594 595 596 597
      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 *)
Bruno Guillaume's avatar
Bruno Guillaume committed
598
        (fun basic_ast -> build_neg_basic ?domain lexicons pos_table basic_ast)
599
        n_pattern.Ast.pat_negs in
600
    { pos; negs; global=pattern_ast.pat_glob; }
bguillaum's avatar
bguillaum committed
601

602
  (* ====================================================================== *)
pj2m's avatar
pj2m committed
603
  type matching = {
604
    n_match: Gid.t Pid_map.t;                      (* partial fct: pattern nodes |--> graph nodes *)
605
    e_match: (Gid.t*G_edge.t*Gid.t) String_map.t;  (* edge matching: edge ident  |--> (src,label,tar) *)
606
    l_param: Lexicons.t;                           (* *)
Bruno Guillaume's avatar
Bruno Guillaume committed
607
  }
608

Bruno Guillaume's avatar
Bruno Guillaume committed
609 610 611
  let intern s = String_.re_match (Str.regexp "__.*__") s

  let matching_to_json ?(all_edges=false) pattern graph m =
612 613
    let node_name gid = G_node.get_name gid (G_graph.find gid graph) in
    let nodes = Pid_map.fold (fun pid gid acc ->
614
      let pnode = P_graph.find pid pattern.pos.graph in
615 616
        (P_node.get_name pnode, `String (node_name gid))::acc
      ) m.n_match [] in
617
    let edges = String_map.fold (fun id (src,lab,tar) acc ->
Bruno Guillaume's avatar
Bruno Guillaume committed
618
      if all_edges || not (intern id)
619
      then (id, `Assoc [
Bruno Guillaume's avatar
Bruno Guillaume committed
620 621 622
          ("source", `String (node_name src));
          ("label", `String (G_edge.to_string lab));
          ("target", `String (node_name tar));
623 624 625
        ]) :: acc
      else acc
      ) m.e_match [] in
Bruno Guillaume's avatar
Bruno Guillaume committed
626 627 628 629
    `Assoc [
      ("nodes", `Assoc nodes);
      ("edges", `Assoc edges)
    ]
630

631 632 633
  let node_matching pattern graph { n_match } =
    Pid_map.fold
      (fun pid gid acc ->
634
        let pnode = P_graph.find pid pattern.pos.graph in
635
        let gnode = G_graph.find gid graph in
636
        (P_node.get_name pnode, G_node.get_name gid gnode) :: acc
637 638
      ) n_match []

639
  let empty_matching ?(lexicons=[]) () = { n_match = Pid_map.empty; e_match = String_map.empty; l_param = lexicons;}
640

641 642
  let e_match_add ?pos edge_id new_edge matching =
    if String_map.mem edge_id matching.e_match
Bruno Guillaume's avatar
Bruno Guillaume committed
643
    then Error.run "The edge identifier '%s' is binded twice in the same pattern" edge_id
644
    else { matching with e_match = String_map.add edge_id new_edge matching.e_match }
645

646
  let match_deco pattern matching =
647 648 649
    { G_deco.nodes =
        Pid_map.fold
          (fun pid gid acc ->
650
            let pnode = P_graph.find pid pattern.pos.graph in
651
            let pattern_feat_list = P_fs.feat_list (P_node.get_fs pnode) in
652
            (gid, (P_node.get_name pnode, pattern_feat_list)) :: acc
653
          ) matching.n_match [];
654
      G_deco.edges = String_map.fold (fun _ edge acc -> edge::acc) matching.e_match [];
655 656 657
      G_deco.pivot = match pattern.pos.graph.pivot with
        | None -> None
        | Some pid -> try Some (Pid_map.find pid matching.n_match) with Not_found -> None
pj2m's avatar
pj2m committed
658 659
    }

bguillaum's avatar
bguillaum committed
660
  let find cnode ?loc (matching, created_nodes) =
pj2m's avatar
pj2m committed
661
    match cnode with
662
    | Command.Pat pid ->
663
        (try Pid_map.find pid matching.n_match
664 665
        with Not_found -> Error.bug ?loc "Inconsistent matching pid '%s' not found" (Pid.to_string pid))
    | Command.New name ->
bguillaum's avatar
bguillaum committed
666 667
        (try List.assoc name created_nodes
        with Not_found -> Error.run ?loc "Identifier '%s' not found" name)
pj2m's avatar
pj2m committed
668 669

  let down_deco (matching,created_nodes) commands =
670 671 672 673 674 675 676 677 678 679
    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
680
    {
681 682 683 684 685 686 687 688
      G_deco.nodes = List.map (fun (gid,feat_list) ->
        (gid, ("", (List.map (fun x -> (x,None)) feat_list)))
      ) (Gid_map.bindings feat_to_highlight);
      G_deco.edges = List.fold_left (fun acc -> function
        | (Command.ADD_EDGE (src_cn,tar_cn,edge),loc) ->
            (find src_cn (matching, created_nodes), edge, find tar_cn (matching, created_nodes)) :: acc
        | _ -> acc
      ) [] commands;
689
      pivot=None;
690
    }
pj2m's avatar
pj2m committed
691 692 693

  exception Fail
  type partial = {
694
      sub: matching;
695 696 697
      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
698
      check: const list (* constraints to verify at the end of the matching *)
699 700 701
    }

        (* PREREQUISITES:
bguillaum's avatar
bguillaum committed
702 703
           - all partial matching have the same ?domain
           - the ?domain of the pattern P is the disjoint union of ?domain([sub]) and [unmatched_nodes]
704
         *)
bguillaum's avatar
bguillaum committed
705
  (*  ---------------------------------------------------------------------- *)
706
  let init ?lexicons basic =
bguillaum's avatar
bguillaum committed
707
    let roots = P_graph.roots basic.graph in
pj2m's avatar
pj2m committed
708

709
    let node_list = Pid_map.fold (fun pid _ acc -> pid::acc) basic.graph.P_graph.map [] in
pj2m's avatar
pj2m committed
710 711

    (* put all roots in the front of the list to speed up the algo *)
712
    let sorted_node_list =
pj2m's avatar
pj2m committed
713
      List.sort
714 715 716 717
        (fun n1 n2 -> match (List.mem n1 roots, List.mem n2 roots) with
        | true, false -> -1
        | false, true -> 1
        | _ -> 0) node_list in
Bruno Guillaume's avatar
Bruno Guillaume committed
718 719
    {
      sub = empty_matching ?lexicons ();
pj2m's avatar
pj2m committed
720 721 722
      unmatched_nodes = sorted_node_list;
      unmatched_edges = [];
      already_matched_gids = [];
bguillaum's avatar
bguillaum committed
723
      check = basic.constraints;
pj2m's avatar
pj2m committed
724 725
    }

bguillaum's avatar
bguillaum committed
726
  (*  ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
727
  let apply_cst ?domain graph matching cst =
bguillaum's avatar
bguillaum committed
728
    let get_node pid = G_graph.find (Pid_map.find pid matching.n_match) graph in
729
    let get_string_feat pid = function
730 731 732
      | "position" ->
        begin
          match G_node.get_position (get_node pid) with
733 734
          | Some f -> Some (sprintf "%g" f)
          | None -> Error.run "Cannot read position of an unordered node"
735
        end
736 737
      | feat_name -> G_fs.get_string_atom feat_name (G_node.get_fs (get_node pid)) in
    let get_float_feat pid = function
738 739 740
      | "position" ->
        begin
          match G_node.get_position (get_node pid) with
741 742
          | Some f -> Some f
          | None -> Error.run "Cannot read position of an unordered node"
743
        end
744
      | feat_name -> G_fs.get_float_feat feat_name (G_node.get_fs (get_node pid)) in
bguillaum's avatar
bguillaum committed
745 746

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

      | Id_prec (pid1, pid2) ->
          let gid1 = Pid_map.find pid1 matching.n_match in
          let gid2 = Pid_map.find pid2 matching.n_match in
          if gid1 < gid2
          then matching
          else raise Fail

852 853
      | Label_equal (eid1, eid2) ->
        begin
854
          match (String_map.find_opt eid1 matching.e_match, String_map.find_opt eid2 matching.e_match) with
855 856 857 858 859 860 861 862 863
          | (Some (_,e1,_), Some (_,e2,_)) when e1 = e2 -> matching
          | (Some (_,e1,_), Some (_,e2,_)) -> raise Fail
          | (None, Some _) -> Error.build "Edge identifier '%s' not found" eid1;
          | (Some _, None) -> Error.build "Edge identifier '%s' not found" eid2;
          | (None, None) -> Error.build "Edge identifiers '%s' and '%s' not found" eid1 eid2;
        end

      | Label_disequal (eid1, eid2) ->
        begin
864
          match (String_map.find_opt eid1 matching.e_match, String_map.find_opt eid2 matching.e_match) with
865 866 867 868 869 870 871
          | (Some (_,e1,_), Some (_,e2,_)) when e1 <> e2 -> matching
          | (Some (_,e1,_), Some (_,e2,_)) -> raise Fail
          | (None, Some _) -> Error.build "Edge identifier '%s' not found" eid1;
          | (Some _, None) -> Error.build "Edge identifier '%s' not found" eid2;
          | (None, None) -> Error.build "Edge identifiers '%s' and '%s' not found" eid1 eid2;
        end

872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892
      | Feature_eq_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.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
893

pj2m's avatar
pj2m committed
894

bguillaum's avatar
bguillaum committed
895
  (*  ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
896
  (* returns all extension of the partial input matching *)
bguillaum's avatar
bguillaum committed
897
  let rec extend_matching ?domain (positive,neg) (graph:G_graph.t) (partial:partial) =
pj2m's avatar
pj2m committed
898
    match (partial.unmatched_edges, partial.unmatched_nodes) with
899
    | [], [] ->
900 901 902 903 904
      begin
        try
          let new_matching =
            List.fold_left
              (fun acc const ->
bguillaum's avatar
bguillaum committed
905
                apply_cst ?domain graph acc const
906 907 908 909
              ) partial.sub partial.check in
          [new_matching, partial.already_matched_gids]
        with Fail -> []
      end
pj2m's avatar
pj2m committed
910
    | (src_pid, p_edge, tar_pid)::tail_ue, _ ->
911 912
        begin
          try (* is the tar already found in the matching ? *)
913
            let new_partials =
914 915 916
              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
917
              let g_edges = Massoc_gid.assoc tar_gid (G_node.get_next src_gnode) in
918

bguillaum's avatar
bguillaum committed
919
              match P_edge.match_list ?domain p_edge g_edges with
920
              | P_edge.Fail -> (* no good edge in graph for this pattern edge -> stop here *)
921
                  []
922
              | 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) *)
923
                  List.map
924
                    (fun label ->
925
                      {partial with sub = e_match_add id (src_gid,label,tar_gid) partial.sub; unmatched_edges = tail_ue }
926
                    ) labels
bguillaum's avatar
bguillaum committed
927
            in List_.flat_map (extend_matching ?domain (positive,neg) graph) new_partials
928 929
          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 *)
930
              let (src_gid : Gid.t) = Pid_map.find src_pid partial.sub.n_match in
931
              let src_gnode = G_graph.find src_gid graph in
932
              Massoc_gid.fold
933
                (fun acc gid_next g_edge ->
bguillaum's avatar
bguillaum committed
934
                  match P_edge.match_ ?domain p_edge g_edge with
935
                  | P_edge.Fail -> (* g_edge does not fit, no new candidate *)
936
                      acc
937
                  | P_edge.Binds (id,[label]) -> (* g_edge fits with an extended matching *)
938
                      (gid_next, e_match_add id (src_gid, label, gid_next) partial.sub) :: acc
939 940
                  | _ -> Error.bug "P_edge.match_ must return exactly one label"
                ) [] (G_node.get_next src_gnode) in
941
            List_.flat_map
942
              (fun (gid_next, matching) ->
bguillaum's avatar
bguillaum committed
943
                extend_matching_from ?domain (positive,neg) graph tar_pid gid_next
944 945 946
                  {partial with sub=matching; unmatched_edges = tail_ue}
              ) candidates
        end
947
    | [], pid :: _ ->
948 949
        G_graph.fold_gid
          (fun gid acc ->
bguillaum's avatar
bguillaum committed
950
            (extend_matching_from ?domain (positive,neg) graph pid gid partial) @ acc
951
          ) graph []
952

bguillaum's avatar
bguillaum committed
953
  (*  ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
954
  and extend_matching_from ?domain (positive,neg) (graph:G_graph.t) pid (gid : Gid.t) partial =
pj2m's avatar
pj2m committed
955 956 957
    if List.mem gid partial.already_matched_gids
    then [] (* the required association pid -> gid is not injective *)
    else
958 959 960 961 962 963 964 965 966 967
      let p_node =
        try P_graph.find pid positive
        with Not_found ->
          try P_graph.find pid neg
          with Not_found -> Error.bug "[Grew_rule.extend_matching_from] cannot find node" in

      (* let p_node =  *)
      (*   if pid >= 0  *)
      (*   then try P_graph.find pid positive with Not_found -> failwith "POS" *)
      (*   else try P_graph.find pid neg with Not_found -> failwith "NEG" in *)
968
      let g_node = try G_graph.find gid graph with Not_found -> Error.bug "[extend_matching_from] cannot find gid in graph" in
969

bguillaum's avatar
bguillaum committed
970
      try
971
        let new_lex_set = P_node.match_ ~lexicons:partial.sub.l_param p_node g_node in
972
        (* add all out-edges from pid in pattern *)
973 974
        let new_unmatched_edges =
          Massoc_pid.fold
975
            (fun acc pid_next p_edge -> (pid, p_edge, pid_next) :: acc
976
            ) partial.unmatched_edges (P_node.get_next p_node) in
977 978

        let new_partial =
bguillaum's avatar
bguillaum committed
979
          { partial with
980
            unmatched_nodes = (try List_.rm pid partial.unmatched_nodes with Not_found -> Error.bug "[extend_matching_from] cannot find pid in unmatched_nodes");
bguillaum's avatar
bguillaum committed
981 982
            unmatched_edges = new_unmatched_edges;
            already_matched_gids = gid :: partial.already_matched_gids;
983
            sub = {partial.sub with n_match = Pid_map.add pid gid partial.sub.n_match; l_param = new_lex_set};
bguillaum's avatar
bguillaum committed
984
          } in
bguillaum's avatar
bguillaum committed
985
        extend_matching ?domain (positive,neg) graph new_partial
986
      with P_fs.Fail -> []
pj2m's avatar
pj2m committed
987

988 989
  (*  [test_locality matching created_nodes gid] checks if [gid] is a "local" node:
      either it belongs to the codomain of [matching] or it is one of the [created_nodes] *)
990 991 992
  let test_locality matching created_nodes gid =
    (Pid_map.exists (fun _ id -> id=gid) matching.n_match) || (List.exists (fun (_,id) -> id=gid) created_nodes)

pj2m's avatar
pj2m committed
993

bguillaum's avatar
bguillaum committed
994
  (*  ---------------------------------------------------------------------- *)
995
  let update_partial pos_graph without (sub, already_matched_gids) =
996
    let neg_graph = without.graph in
997 998 999
    let unmatched_nodes =
      Pid_map.fold
        (fun pid _ acc -> match pid with Pid.Neg _ -> pid::acc | _ -> acc)
1000
        neg_graph.P_graph.map [] in
1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016
    let unmatched_edges =
      Pid_map.fold
        (fun pid node acc ->
          match pid with
            | Pid.Neg _ -> acc
            | Pid.Pos i ->
          (* if pid < 0  *)
          (* then acc *)
          (* else  *)
              Massoc_pid.fold
                (fun acc2 pid_next p_edge -> (pid, p_edge, pid_next) :: acc2)
                acc (P_node.get_next node)

            (* Massoc.fold_left  *)
            (*   (fun acc2 pid_next p_edge -> (pid, p_edge, pid_next) :: acc2) *)
            (*   acc (P_node.get_next node) *)