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

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

14 15
open Dep2pict

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

bguillaum's avatar
bguillaum committed
409 410
    let nodes =
      Pid_map.fold
bguillaum's avatar
bguillaum committed
411
        (fun id node acc ->
bguillaum's avatar
bguillaum committed
412 413
          (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
414
          )
bguillaum's avatar
bguillaum committed
415
          :: acc
416
        ) pos_basic.graph [] in
bguillaum's avatar
bguillaum committed
417

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

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

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

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

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

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

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

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

  (* ====================================================================== *)
bguillaum's avatar
bguillaum committed
482 483 484 485 486 487 488 489 490 491 492 493
  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

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

    let (param, pat_vars, cmd_vars) =
bguillaum's avatar
bguillaum committed
498 499
      match rule_ast.Ast.param with
      | None -> (None,[],[])
500
      | Some (files,vars) ->
bguillaum's avatar
bguillaum committed
501 502 503
          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
504

505
          (* first: load lexical parameters given in the same file at the end of the rule definition *)
bguillaum's avatar
bguillaum committed
506 507 508 509
          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

510
          (* second: load lexical parameters given in external files *)
bguillaum's avatar
bguillaum committed
511
          let full_param = List.fold_left
512
            (fun acc file ->
bguillaum's avatar
bguillaum committed
513 514 515 516 517 518
              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
519

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

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

bguillaum's avatar
bguillaum committed
550
  let build_pattern ?domain pattern_ast =
551
    let n_pattern = Ast.normalize_pattern pattern_ast in
552
    let (pos, pos_table) =
553
      try build_pos_basic ?domain n_pattern.Ast.pat_pos
554 555 556 557
      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
558
        (fun basic_ast -> build_neg_basic ?domain pos_table basic_ast)
559
        n_pattern.Ast.pat_negs in
bguillaum's avatar
bguillaum committed
560 561
    (pos, negs)

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

569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584
  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)) ->
585
        bprintf buff "\"%s\":\"%s/%s/%s\", " id (node_name src) (Label.to_string lab) (node_name tar)
586 587 588 589 590
      ) m.e_match;

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

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

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

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

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

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

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

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

  exception Fail
  type partial = {
bguillaum's avatar
bguillaum committed
650
      sub: matching;
651 652 653
      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
654
      check: const list (* constraints to verify at the end of the matching *)
bguillaum's avatar
bguillaum committed
655 656 657
    }

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

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

    (* put all roots in the front of the list to speed up the algo *)
bguillaum's avatar
bguillaum committed
668
    let sorted_node_list =
pj2m's avatar
pj2m committed
669
      List.sort
670 671 672 673
        (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
674

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

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

    match cst with
bguillaum's avatar
bguillaum committed
693
      | Cst_out (pid,label_cst) ->
694
        let gid = Pid_map.find pid matching.n_match in
bguillaum's avatar
bguillaum committed
695
        if G_graph.edge_out ?domain graph gid label_cst
bguillaum's avatar
bguillaum committed
696 697
        then matching
        else raise Fail
bguillaum's avatar
bguillaum committed
698
      | Cst_in (pid,label_cst) ->
699
        let gid = Pid_map.find pid matching.n_match in
bguillaum's avatar
bguillaum committed
700
        if G_graph.node_exists
701
          (fun node ->
bguillaum's avatar
bguillaum committed
702
            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
703
          ) graph
bguillaum's avatar
bguillaum committed
704 705
        then matching
        else raise Fail
bguillaum's avatar
bguillaum committed
706
      | Filter (pid, fs) ->
bguillaum's avatar
bguillaum committed
707 708 709 710 711 712 713 714
        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
715
      | Features_eq (pid1, feat_name1, pid2, feat_name2) ->
bguillaum's avatar
bguillaum committed
716 717
        begin
          match (get_string_feat pid1 feat_name1, get_string_feat pid2 feat_name2) with
bguillaum's avatar
bguillaum committed
718 719
            | Some fv1, Some fv2 when fv1 = fv2 -> matching
            | _ -> raise Fail
bguillaum's avatar
bguillaum committed
720
        end
721
      | Feature_eq_cst (pid1, feat_name1, value) ->
bguillaum's avatar
bguillaum committed
722 723 724 725 726 727 728 729 730 731 732
        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
733
      | Feature_eq_float (pid1, feat_name1, float) ->
bguillaum's avatar
bguillaum committed
734 735 736 737 738 739 740 741 742 743 744
        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
745
      | Features_diseq (pid1, feat_name1, pid2, feat_name2) ->
bguillaum's avatar
bguillaum committed
746 747
        begin
          match (get_string_feat pid1 feat_name1, get_string_feat pid2 feat_name2) with
bguillaum's avatar
bguillaum committed
748 749
            | Some fv1, Some fv2 when fv1 <> fv2 -> matching
            | _ -> raise Fail
bguillaum's avatar
bguillaum committed
750
        end
751
      | Features_ineq (ineq, pid1, feat_name1, pid2, feat_name2) ->
752 753
        begin
          match (ineq, get_float_feat pid1 feat_name1, get_float_feat pid2