grew_rule.ml 71.5 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

bguillaum's avatar
bguillaum committed
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;
bguillaum's avatar
bguillaum committed
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
bguillaum's avatar
bguillaum committed
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

bguillaum's avatar
bguillaum committed
54
  let to_gr ?domain t = G_graph.to_gr ?domain t.graph
55

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

bguillaum's avatar
bguillaum committed
58 59
  let save_dot_png ?domain ?filter ?main_feat base t =
    ignore (Dot.to_png_file (G_graph.to_dot ?domain ?main_feat t.graph) (base^".png"))
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

bguillaum's avatar
bguillaum committed
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
Bruno Guillaume's avatar
Bruno Guillaume committed
82
    (* *)
83
    | Feature_eq_cst of Pid.t * string * string
bguillaum's avatar
bguillaum committed
84
    | Feature_diff_cst of Pid.t * string * string
Bruno Guillaume's avatar
Bruno Guillaume committed
85
    (* *)
86
    | Feature_eq_float of Pid.t * string * float
bguillaum's avatar
bguillaum committed
87
    | Feature_diff_float of Pid.t * string * float
Bruno Guillaume's avatar
Bruno Guillaume committed
88
    (* *)
89
    | Feature_eq_regexp of Pid.t * string * string
Bruno Guillaume's avatar
Bruno Guillaume committed
90
    (* *)
91
    | Features_ineq of Ast.ineq * Pid.t * string * Pid.t * string
92
    | Feature_ineq_cst of Ast.ineq * Pid.t * string * float
Bruno Guillaume's avatar
Bruno Guillaume committed
93
    (* *)
bguillaum's avatar
bguillaum committed
94
    | Filter of Pid.t * P_fs.t (* used when a without impose a fs on a node defined by the match basic *)
Bruno Guillaume's avatar
Bruno Guillaume committed
95
    (* *)
96 97
    | Immediate_prec of Pid.t * Pid.t
    | Large_prec of Pid.t * Pid.t
bguillaum's avatar
bguillaum committed
98

Bruno Guillaume's avatar
Bruno Guillaume committed
99 100 101
  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]
102
  | Features_eq (pid1,fn1,pid2,fn2) ->
Bruno Guillaume's avatar
Bruno Guillaume committed
103 104 105 106 107 108 109 110
    `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);
      ]
    ]
111
  | Features_diseq (pid1,fn1,pid2,fn2) ->
Bruno Guillaume's avatar
Bruno Guillaume committed
112 113 114 115 116 117 118 119
    `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);
      ]
    ]
120
  | Feature_eq_cst (pid,fn,value) ->
Bruno Guillaume's avatar
Bruno Guillaume committed
121 122 123 124 125 126 127 128
    `Assoc ["feature_eq_cst",
      `Assoc [
        ("id", `String (Pid.to_string pid));
        ("feature_name_", `String fn);
        ("value", `String value);
      ]
    ]
  | Feature_diff_cst (pid,fn,value) ->
129
    `Assoc ["feature_diff_cst",
Bruno Guillaume's avatar
Bruno Guillaume committed
130 131 132 133 134 135
      `Assoc [
        ("id", `String (Pid.to_string pid));
        ("feature_name_", `String fn);
        ("value", `String value);
      ]
    ]
136
  | Feature_eq_float (pid,fn,value) ->
Bruno Guillaume's avatar
Bruno Guillaume committed
137 138 139 140 141 142 143 144 145 146 147 148 149 150 151
    `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));
      ]
    ]
152
  | Feature_eq_regexp (pid,fn,regexp) ->
Bruno Guillaume's avatar
Bruno Guillaume committed
153 154 155 156 157 158 159
    `Assoc ["feature_eq_regexp",
      `Assoc [
        ("id", `String (Pid.to_string pid));
        ("feature_name", `String fn);
        ("regexp", `String regexp);
      ]
    ]
160
  | Features_ineq (ineq,pid1,fn1,pid2,fn2) ->
Bruno Guillaume's avatar
Bruno Guillaume committed
161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185
    `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);
      ]
    ]
186
  | Immediate_prec (pid1, pid2) ->
Bruno Guillaume's avatar
Bruno Guillaume committed
187 188 189 190 191 192
    `Assoc ["immediate_prec",
      `Assoc [
        ("id1", `String (Pid.to_string pid1));
        ("id2", `String (Pid.to_string pid2));
      ]
    ]
193
  | Large_prec (pid1, pid2) ->
Bruno Guillaume's avatar
Bruno Guillaume committed
194 195 196 197 198 199 200
    `Assoc ["large_prec",
      `Assoc [
        ("id1", `String (Pid.to_string pid1));
        ("id2", `String (Pid.to_string pid2));
      ]
    ]

bguillaum's avatar
bguillaum committed
201
  let build_pos_constraint ?domain pos_table const =
bguillaum's avatar
bguillaum committed
202 203
    let pid_of_name loc node_name = Pid.Pos (Id.build ~loc node_name pos_table) in
    match const with
204
      | (Ast.Cst_out (id,label_cst), loc) ->
bguillaum's avatar
bguillaum committed
205
        Cst_out (pid_of_name loc id, Label_cst.build ~loc ?domain label_cst)
206
      | (Ast.Cst_in (id,label_cst), loc) ->
bguillaum's avatar
bguillaum committed
207
        Cst_in (pid_of_name loc id, Label_cst.build ~loc ?domain label_cst)
208

209
      | (Ast.Features_eq ((node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
bguillaum's avatar
bguillaum committed
210 211
        Domain.check_feature_name ?domain ~loc feat_name1;
        Domain.check_feature_name ?domain ~loc feat_name2;
212
        Features_eq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
213

214
      | (Ast.Features_diseq ((node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
bguillaum's avatar
bguillaum committed
215 216
        Domain.check_feature_name ?domain ~loc feat_name1;
        Domain.check_feature_name ?domain ~loc feat_name2;
217
        Features_diseq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
218

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

224
      | (Ast.Feature_ineq_cst (ineq, (node_name1, feat_name1), constant), loc) ->
bguillaum's avatar
bguillaum committed
225
        Domain.check_feature_name ?domain ~loc feat_name1;
226 227
        Feature_ineq_cst (ineq, pid_of_name loc node_name1, feat_name1, constant)

228
      | (Ast.Feature_eq_regexp ((node_name, feat_name), regexp), loc) ->
bguillaum's avatar
bguillaum committed
229
        Domain.check_feature_name ?domain ~loc feat_name;
230
        Feature_eq_regexp (pid_of_name loc node_name, feat_name, regexp)
bguillaum's avatar
bguillaum committed
231

232
      | (Ast.Feature_eq_cst ((node_name, feat_name), string), loc) ->
bguillaum's avatar
bguillaum committed
233
        Domain.check_feature_name ?domain ~loc feat_name;
234
        Feature_eq_cst (pid_of_name loc node_name, feat_name, string)
bguillaum's avatar
bguillaum committed
235 236 237 238
      | (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)

239
      | (Ast.Feature_eq_float ((node_name, feat_name), float), loc) ->
bguillaum's avatar
bguillaum committed
240
        Domain.check_feature_name ?domain ~loc feat_name;
241
        Feature_eq_float (pid_of_name loc node_name, feat_name, float)
bguillaum's avatar
bguillaum committed
242 243 244 245
      | (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)

246 247
      | (Ast.Immediate_prec (id1, id2), loc) ->
        Immediate_prec (pid_of_name loc id1, pid_of_name loc id2)
bguillaum's avatar
bguillaum committed
248

249 250
      | (Ast.Large_prec (id1, id2), loc) ->
        Large_prec (pid_of_name loc id1, pid_of_name loc id2)
bguillaum's avatar
bguillaum committed
251

bguillaum's avatar
bguillaum committed
252
  type basic = {
253 254 255
    graph: P_graph.t;
    constraints: const list;
  }
pj2m's avatar
pj2m committed
256

Bruno Guillaume's avatar
Bruno Guillaume committed
257 258 259 260 261 262
  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
263
  let build_pos_basic ?domain ?pat_vars basic_ast =
264
    let (graph, pos_table) =
bguillaum's avatar
bguillaum committed
265
      P_graph.build ?domain ?pat_vars basic_ast.Ast.pat_nodes basic_ast.Ast.pat_edges in
pj2m's avatar
pj2m committed
266
    (
bguillaum's avatar
bguillaum committed
267 268
      {
        graph = graph;
bguillaum's avatar
bguillaum committed
269
        constraints = List.map (build_pos_constraint ?domain pos_table) basic_ast.Ast.pat_const
bguillaum's avatar
bguillaum committed
270 271
      },
      pos_table
pj2m's avatar
pj2m committed
272 273
    )

bguillaum's avatar
bguillaum committed
274
  (* the neg part *)
bguillaum's avatar
bguillaum committed
275
  let build_neg_constraint ?domain pos_table neg_table const =
bguillaum's avatar
bguillaum committed
276 277 278 279
    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
280
    match const with
281
      | (Ast.Cst_out (id,label_cst), loc) ->
bguillaum's avatar
bguillaum committed
282
        Cst_out (pid_of_name loc id, Label_cst.build ~loc ?domain label_cst)
283
      | (Ast.Cst_in (id,label_cst), loc) ->
bguillaum's avatar
bguillaum committed
284
        Cst_in (pid_of_name loc id, Label_cst.build ~loc ?domain label_cst)
285

286
      | (Ast.Features_eq (feat_id1, feat_id2), loc) ->
287 288
        let (node_name1, feat_name1) = feat_id1
        and (node_name2, feat_name2) = feat_id2 in
bguillaum's avatar
bguillaum committed
289 290
        Domain.check_feature_name ?domain ~loc feat_name1;
        Domain.check_feature_name ?domain ~loc feat_name2;
291
        Features_eq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
292

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

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

307 308
      | (Ast.Feature_ineq_cst (ineq, feat_id1, constant), loc) ->
        let (node_name1, feat_name1) = feat_id1 in
bguillaum's avatar
bguillaum committed
309
        Domain.check_feature_name ?domain ~loc feat_name1;
310
        Feature_ineq_cst (ineq, pid_of_name loc node_name1, feat_name1, constant)
pj2m's avatar
pj2m committed
311

312
      | (Ast.Feature_eq_regexp (feat_id, regexp), loc) ->
bguillaum's avatar
bguillaum committed
313
        let (node_name, feat_name) = feat_id in
bguillaum's avatar
bguillaum committed
314
        Domain.check_feature_name ?domain ~loc feat_name;
315
        Feature_eq_regexp (pid_of_name loc node_name, feat_name, regexp)
bguillaum's avatar
bguillaum committed
316

317
      | (Ast.Feature_eq_cst ((node_name, feat_name), string), loc) ->
bguillaum's avatar
bguillaum committed
318
        Domain.check_feature_name ?domain ~loc feat_name;
319
        Feature_eq_cst (pid_of_name loc node_name, feat_name, string)
bguillaum's avatar
bguillaum committed
320 321 322 323
      | (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)

324
      | (Ast.Feature_eq_float ((node_name, feat_name), float), loc) ->
bguillaum's avatar
bguillaum committed
325
        Domain.check_feature_name ?domain ~loc feat_name;
326
        Feature_eq_float (pid_of_name loc node_name, feat_name, float)
bguillaum's avatar
bguillaum committed
327 328 329 330 331
      | (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)


332 333
      | (Ast.Immediate_prec (id1, id2), loc) ->
        Immediate_prec (pid_of_name loc id1, pid_of_name loc id2)
bguillaum's avatar
bguillaum committed
334

335 336
      | (Ast.Large_prec (id1, id2), loc) ->
        Large_prec (pid_of_name loc id1, pid_of_name loc id2)
bguillaum's avatar
bguillaum committed
337

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

343
    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
344
    {
bguillaum's avatar
bguillaum committed
345
      graph = extension.P_graph.ext_map;
bguillaum's avatar
bguillaum committed
346
      constraints = filters @ List.map (build_neg_constraint ?domain pos_table neg_table) basic_ast.Ast.pat_const ;
bguillaum's avatar
bguillaum committed
347
    }
pj2m's avatar
pj2m committed
348

bguillaum's avatar
bguillaum committed
349
  let get_edge_ids basic =
350
    Pid_map.fold
bguillaum's avatar
bguillaum committed
351 352
      (fun _ node acc ->
        Massoc_pid.fold
353
          (fun acc2 _ edge -> (P_edge.get_id edge)::acc2)
354
          acc (P_node.get_next node)
bguillaum's avatar
bguillaum committed
355
      ) basic.graph []
bguillaum's avatar
bguillaum committed
356

357 358 359
  (* a [pattern] is described by the positive basic and a list of negative basics. *)
  type pattern = basic * basic list

360
  let pid_name_list (pos,_) = P_graph.pid_name_list pos.graph
361

pj2m's avatar
pj2m committed
362 363
  type t = {
      name: string;
364
      pattern: pattern;
pj2m's avatar
pj2m committed
365
      commands: Command.t list;
366
      param: Lex_par.t option;
bguillaum's avatar
bguillaum committed
367
      param_names: (string list * string list);
bguillaum's avatar
bguillaum committed
368
      loc: Loc.t;
pj2m's avatar
pj2m committed
369 370
    }

bguillaum's avatar
bguillaum committed
371 372
  let get_name t = t.name

373
  let get_loc t = t.loc
pj2m's avatar
pj2m committed
374

Bruno Guillaume's avatar
Bruno Guillaume committed
375
  let to_json ?domain t =
376 377 378 379 380 381 382 383 384
    let param_json = match t.param with
    | None -> []
    | Some lex_par -> [
      ("pattern_param", `List (List.map (fun x -> `String x) (fst t.param_names)));
      ("command_param", `List (List.map (fun x -> `String x) (snd t.param_names)));
      ("lex_par", Lex_par.to_json lex_par);
    ] in
    `Assoc
    ([
Bruno Guillaume's avatar
Bruno Guillaume committed
385 386 387
      ("rule_name", `String t.name);
      ("match", basic_to_json ?domain (fst t.pattern));
      ("without", `List (List.map (basic_to_json ?domain) (snd t.pattern)));
388
      ("commands", `List (List.map (Command.to_json ?domain) t.commands))
389 390
    ] @ param_json
    )
Bruno Guillaume's avatar
Bruno Guillaume committed
391

392
  (* ====================================================================== *)
bguillaum's avatar
bguillaum committed
393
  let to_dep ?domain t =
394
    let pos_basic = fst t.pattern in
bguillaum's avatar
bguillaum committed
395 396 397
    let buff = Buffer.create 32 in
    bprintf buff "[GRAPH] { scale = 200; }\n";

bguillaum's avatar
bguillaum committed
398 399
    let nodes =
      Pid_map.fold
bguillaum's avatar
bguillaum committed
400
        (fun id node acc ->
bguillaum's avatar
bguillaum committed
401 402
          (node, sprintf "  N_%s { word=\"%s\"; subword=\"%s\"}"
            (Pid.to_id id) (P_node.get_name node) (P_fs.to_dep t.param_names (P_node.get_fs node))
bguillaum's avatar
bguillaum committed
403
          )
bguillaum's avatar
bguillaum committed
404
          :: acc
405
        ) pos_basic.graph [] in
bguillaum's avatar
bguillaum committed
406

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

bguillaum's avatar
bguillaum committed
410 411 412 413 414
    bprintf buff "[WORDS] {\n";
    List.iter
      (fun (_, dep_line) -> bprintf buff "%s\n" dep_line
      ) sorted_nodes;

415
    List.iteri
bguillaum's avatar
bguillaum committed
416 417
      (fun i cst ->
        match cst with
bguillaum's avatar
bguillaum committed
418
          | Cst_out _ | Cst_in _ -> bprintf buff "  C_%d { word=\"*\"}\n" i
bguillaum's avatar
bguillaum committed
419
          | _ -> ()
420
      ) pos_basic.constraints;
bguillaum's avatar
bguillaum committed
421
    bprintf buff "}\n";
bguillaum's avatar
bguillaum committed
422

bguillaum's avatar
bguillaum committed
423
    bprintf buff "[EDGES] {\n";
bguillaum's avatar
bguillaum committed
424

bguillaum's avatar
bguillaum committed
425 426
    Pid_map.iter
      (fun id_src node ->
bguillaum's avatar
bguillaum committed
427
        Massoc_pid.iter
bguillaum's avatar
bguillaum committed
428
          (fun id_tar edge ->
bguillaum's avatar
bguillaum committed
429 430 431
            bprintf buff "  N_%s -> N_%s { label=\"%s\"}\n"
              (Pid.to_id id_src)
              (Pid.to_id id_tar)
bguillaum's avatar
bguillaum committed
432
              (P_edge.to_string ?domain edge)
bguillaum's avatar
bguillaum committed
433 434
          )
          (P_node.get_next node)
435
      ) pos_basic.graph;
bguillaum's avatar
bguillaum committed
436

437
    List.iteri
bguillaum's avatar
bguillaum committed
438 439
      (fun i cst ->
        match cst with
bguillaum's avatar
bguillaum committed
440
          | Cst_out (pid, label_cst) ->
bguillaum's avatar
bguillaum committed
441
            bprintf buff "  N_%s -> C_%d {label = \"%s\"; style=dot; bottom; color=green;}\n"
bguillaum's avatar
bguillaum committed
442
              (Pid.to_id pid) i (Label_cst.to_string ?domain label_cst)
bguillaum's avatar
bguillaum committed
443
          | Cst_in (pid, label_cst) ->
bguillaum's avatar
bguillaum committed
444
            bprintf buff "  C_%d -> N_%s {label = \"%s\"; style=dot; bottom; color=green;}\n"
bguillaum's avatar
bguillaum committed
445
              i (Pid.to_id pid) (Label_cst.to_string ?domain label_cst)
bguillaum's avatar
bguillaum committed
446
          | _ -> ()
447
      ) pos_basic.constraints;
bguillaum's avatar
bguillaum committed
448 449
    bprintf buff "}\n";
    Buffer.contents buff
bguillaum's avatar
bguillaum committed
450

451
  (* ====================================================================== *)
Bruno Guillaume's avatar
Bruno Guillaume committed
452
  let build_commands ?domain ?param pos pos_table ast_commands =
Bruno Guillaume's avatar
Bruno Guillaume committed
453
    let known_node_ids = Array.to_list pos_table in
454
    let known_edge_ids = get_edge_ids pos in
455

Bruno Guillaume's avatar
Bruno Guillaume committed
456
    let rec loop (kni,kei) = function
457 458
      | [] -> []
      | ast_command :: tail ->
Bruno Guillaume's avatar
Bruno Guillaume committed
459
          let (command, (new_kni, new_kei)) =
460
            Command.build
bguillaum's avatar
bguillaum committed
461
              ?domain
462
              ?param
Bruno Guillaume's avatar
Bruno Guillaume committed
463
              (kni,kei)
464 465
              pos_table
              ast_command in
Bruno Guillaume's avatar
Bruno Guillaume committed
466 467
          command :: (loop (new_kni,new_kei) tail) in
    loop (known_node_ids, known_edge_ids) ast_commands
468 469

  (* ====================================================================== *)
bguillaum's avatar
bguillaum committed
470 471 472 473 474 475 476 477 478 479 480 481
  let parse_vars loc vars =
    let rec parse_cmd_vars = function
      | [] -> []
      | x::t when x.[0] = '@' -> x :: parse_cmd_vars t
      | x::t -> Error.bug ~loc "Illegal feature definition '%s' in the lexical rule" x in
    let rec parse_pat_vars = function
      | [] -> ([],[])
      | x::t when x.[0] = '@' -> ([],parse_cmd_vars (x::t))
      | x::t when x.[0] = '$' -> let (pv,cv) = parse_pat_vars t in (x::pv, cv)
      | x::t -> Error.bug ~loc "Illegal feature definition '%s' in the lexical rule" x in
    parse_pat_vars vars

482
  (* ====================================================================== *)
483 484 485 486 487
  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
488 489

    let (param, pat_vars, cmd_vars) =
bguillaum's avatar
bguillaum committed
490 491
      match rule_ast.Ast.param with
      | None -> (None,[],[])
492
      | Some (files,vars) ->
bguillaum's avatar
bguillaum committed
493 494 495
          let (pat_vars, cmd_vars) = parse_vars rule_ast.Ast.rule_loc vars in
          let nb_pv = List.length pat_vars in
          let nb_cv = List.length cmd_vars in
bguillaum's avatar
bguillaum committed
496

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

502
          (* second: load lexical parameters given in external files *)
bguillaum's avatar
bguillaum committed
503
          let full_param = List.fold_left
504
            (fun acc file ->
bguillaum's avatar
bguillaum committed
505 506 507 508 509 510
              match acc with
              | None -> Some (Lex_par.load ~loc:rule_ast.Ast.rule_loc dir nb_pv nb_cv file)
              | Some lp -> Some (Lex_par.append (Lex_par.load ~loc:rule_ast.Ast.rule_loc dir nb_pv nb_cv file) lp)
            ) local_param files in

          (full_param, pat_vars, cmd_vars) in
511

512
    (match (param, pat_vars) with
513
      | (None, _::_) -> Error.build ~loc:rule_ast.Ast.rule_loc "[Rule.build] Missing lexical parameters in rule \"%s\"" rule_ast.Ast.rule_id
514 515 516
      | _ -> ()
    );

517
    let pattern = Ast.normalize_pattern rule_ast.Ast.pattern in
518
    let (pos, pos_table) =
519
      try build_pos_basic ?domain ~pat_vars pattern.Ast.pat_pos
520 521 522 523
      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
524 525 526
    let (negs,_) =
      List.fold_left
      (fun (acc,pos) basic_ast ->
bguillaum's avatar
bguillaum committed
527
        try ((build_neg_basic ?domain ~pat_vars pos_table basic_ast) :: acc, pos+1)
bguillaum's avatar
bguillaum committed
528 529 530 531
        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)
532
      ) ([],1) pattern.Ast.pat_negs in
pj2m's avatar
pj2m committed
533
    {
bguillaum's avatar
bguillaum committed
534
      name = rule_ast.Ast.rule_id;
535
      pattern = (pos, negs);
bguillaum's avatar
bguillaum committed
536
      commands = build_commands ?domain ~param:(pat_vars,cmd_vars) pos pos_table rule_ast.Ast.commands;
bguillaum's avatar
bguillaum committed
537 538 539 540 541
      loc = rule_ast.Ast.rule_loc;
      param = param;
      param_names = (pat_vars,cmd_vars)
    }

bguillaum's avatar
bguillaum committed
542
  let build_pattern ?domain pattern_ast =
543
    let n_pattern = Ast.normalize_pattern pattern_ast in
544
    let (pos, pos_table) =
545
      try build_pos_basic ?domain n_pattern.Ast.pat_pos
546 547 548 549
      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
550
        (fun basic_ast -> build_neg_basic ?domain pos_table basic_ast)
551
        n_pattern.Ast.pat_negs in
bguillaum's avatar
bguillaum committed
552 553
    (pos, negs)

554
  (* ====================================================================== *)
pj2m's avatar
pj2m committed
555
  type matching = {
556
      n_match: Gid.t Pid_map.t;                     (* partial fct: pattern nodes |--> graph nodes *)
557
      e_match: (string*(Gid.t*Label.t*Gid.t)) list; (* edge matching: edge ident  |--> (src,label,tar) *)
558
      m_param: Lex_par.t option;
pj2m's avatar
pj2m committed
559
    }
560

561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576
  let to_python pattern graph m =

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

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

    List.iter
      (fun (id, (src,lab,tar)) ->
577
        bprintf buff "\"%s\":\"%s/%s/%s\", " id (node_name src) (Label.to_string lab) (node_name tar)
578 579 580 581 582
      ) m.e_match;

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

583 584 585 586 587
  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
588
        (P_node.get_name pnode, G_node.get_float gnode) :: acc
589 590
      ) n_match []

591
  let empty_matching param = { n_match = Pid_map.empty; e_match = []; m_param = param;}
592

pj2m's avatar
pj2m committed
593 594
  let e_comp (e1,_) (e2,_) = compare e1 e2

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

600
  let match_deco pattern matching =
601 602 603
    { G_deco.nodes =
        Pid_map.fold
          (fun pid gid acc ->
604
            let pnode = P_graph.find pid (fst pattern).graph in
605 606
            (gid, (P_node.get_name pnode, P_fs.feat_list (P_node.get_fs pnode))) ::acc
          ) matching.n_match [];
607
      G_deco.edges = List.fold_left (fun acc (_,edge) -> edge::acc) [] matching.e_match;
pj2m's avatar
pj2m committed
608 609
    }

bguillaum's avatar
bguillaum committed
610
  let find cnode ?loc (matching, created_nodes) =
pj2m's avatar
pj2m committed
611
    match cnode with
612
    | Command.Pat pid ->
613
        (try Pid_map.find pid matching.n_match
bguillaum's avatar
bguillaum committed
614 615
        with Not_found -> Error.bug ?loc "Inconsistent matching pid '%s' not found" (Pid.to_string pid))
    | Command.New name ->
bguillaum's avatar
bguillaum committed
616 617
        (try List.assoc name created_nodes
        with Not_found -> Error.run ?loc "Identifier '%s' not found" name)
pj2m's avatar
pj2m committed
618 619

  let down_deco (matching,created_nodes) commands =
620 621 622 623 624 625 626 627 628 629
    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
630
    {
631
     G_deco.nodes = List.map (fun (gid,feat_list) -> (gid, ("",feat_list))) (Gid_map.bindings feat_to_highlight);
632
     G_deco.edges = List.fold_left
bguillaum's avatar
bguillaum committed
633 634
       (fun acc -> function
         | (Command.ADD_EDGE (src_cn,tar_cn,edge),loc) ->
635
             (find src_cn (matching, created_nodes), edge, find tar_cn (matching, created_nodes)) :: acc
636
         | _ -> acc
pj2m's avatar
pj2m committed
637 638 639 640 641
       ) [] commands
   }

  exception Fail
  type partial = {
bguillaum's avatar
bguillaum committed
642
      sub: matching;
643 644 645
      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
646
      check: const list (* constraints to verify at the end of the matching *)
bguillaum's avatar
bguillaum committed
647 648 649
    }

        (* PREREQUISITES:
bguillaum's avatar
bguillaum committed
650 651
           - all partial matching have the same ?domain
           - the ?domain of the pattern P is the disjoint union of ?domain([sub]) and [unmatched_nodes]
652
         *)
bguillaum's avatar
bguillaum committed
653
  (*  ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
654 655
  let init param basic =
    let roots = P_graph.roots basic.graph in
pj2m's avatar
pj2m committed
656

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

    (* put all roots in the front of the list to speed up the algo *)
bguillaum's avatar
bguillaum committed
660
    let sorted_node_list =
pj2m's avatar
pj2m committed
661
      List.sort
662 663 664 665
        (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
666

bguillaum's avatar
bguillaum committed
667
    { sub = empty_matching param;
pj2m's avatar
pj2m committed
668 669 670
      unmatched_nodes = sorted_node_list;
      unmatched_edges = [];
      already_matched_gids = [];
bguillaum's avatar
bguillaum committed
671
      check = basic.constraints;
pj2m's avatar
pj2m committed
672 673
    }

bguillaum's avatar
bguillaum committed
674
  (*  ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
675
  let apply_cst ?domain graph matching cst =
bguillaum's avatar
bguillaum committed
676
    let get_node pid = G_graph.find (Pid_map.find pid matching.n_match) graph in
677
    let get_string_feat pid = function
678 679 680 681 682 683
      | "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
684 685
      | feat_name -> G_fs.get_string_atom feat_name (G_node.get_fs (get_node pid)) in
    let get_float_feat pid = function
686 687 688 689 690 691
      | "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
692
      | feat_name -> G_fs.get_float_feat feat_name (G_node.get_fs (get_node pid)) in
bguillaum's avatar
bguillaum committed
693 694

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