grew_rule.ml 45 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 16 17
IFDEF DEP2PICT THEN
open Dep2pict
ENDIF

18
open Grew_base
19 20
open Grew_types

bguillaum's avatar
bguillaum committed
21
open Grew_ast
pj2m's avatar
pj2m committed
22
open Grew_edge
bguillaum's avatar
bguillaum committed
23
open Grew_fs
pj2m's avatar
pj2m committed
24
open Grew_node
bguillaum's avatar
bguillaum committed
25 26
open Grew_command
open Grew_graph
pj2m's avatar
pj2m committed
27

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

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

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

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

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

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

53
  let to_gr domain t = G_graph.to_gr domain t.graph
54

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

57 58
  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"))
59

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

67 68
  let save_dep_svg domain ?filter ?main_feat base t =
    let dep = G_graph.to_dep domain ?filter ?main_feat t.graph in
69 70 71 72
    let d2p = Dep2pict.from_dep ~dep in
    let _ = Dep2pict.save_svg ~filename: (base^".png") d2p in
    Dep2pict.highlight_shift ()
 
bguillaum's avatar
bguillaum committed
73
  ELSE
bguillaum's avatar
bguillaum committed
74 75
  let save_dep_png _ ?filter ?main_feat base t = None
  let save_dep_svg _ ?filter ?main_feat base t = None
bguillaum's avatar
bguillaum committed
76
  ENDIF
77
end (* module Instance *)
pj2m's avatar
pj2m committed
78

79
(* ================================================================================ *)
80
module Instance_set = Set.Make (Instance)
pj2m's avatar
pj2m committed
81

82
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
83
module Rule = struct
84

bguillaum's avatar
bguillaum committed
85
  (* the rewriting depth is bounded to stop rewriting when the system is not terminating *)
bguillaum's avatar
bguillaum committed
86 87
  let max_depth_det = ref 2000
  let max_depth_non_det = ref 100
88 89 90

  let set_max_depth_det value = max_depth_det := value
  let set_max_depth_non_det value = max_depth_non_det := value
pj2m's avatar
pj2m committed
91

92
  type const =
bguillaum's avatar
bguillaum committed
93 94
    | Cst_out of Pid.t * Label_cst.t
    | Cst_in of Pid.t * Label_cst.t
95
    | Feature_eq of Pid.t * string * Pid.t * string
96
    | Feature_diseq of Pid.t * string * Pid.t * string
bguillaum's avatar
bguillaum committed
97

bguillaum's avatar
bguillaum committed
98 99
    | Feature_re of Pid.t * string * string

100
    | Feature_ineq of Ast.ineq * Pid.t * string * Pid.t * string
101 102
    | Feature_ineq_cst of Ast.ineq * Pid.t * string * float

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 *)
pj2m's avatar
pj2m committed
104

bguillaum's avatar
bguillaum committed
105 106 107
    | Prec of Pid.t * Pid.t
    | Lprec of Pid.t * Pid.t

108
  let build_pos_constraint domain pos_table const =
bguillaum's avatar
bguillaum committed
109 110
    let pid_of_name loc node_name = Pid.Pos (Id.build ~loc node_name pos_table) in
    match const with
111
      | (Ast.Cst_out (id,label_cst), loc) ->
112
        Cst_out (pid_of_name loc id, Label_cst.build ~loc domain label_cst)
113
      | (Ast.Cst_in (id,label_cst), loc) ->
114
        Cst_in (pid_of_name loc id, Label_cst.build ~loc domain label_cst)
115 116

      | (Ast.Feature_eq ((node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
117 118
        Domain.check_feature_name domain ~loc feat_name1;
        Domain.check_feature_name domain ~loc feat_name2;
bguillaum's avatar
bguillaum committed
119
        Feature_eq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
120

121
      | (Ast.Feature_diseq ((node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
122 123
        Domain.check_feature_name domain ~loc feat_name1;
        Domain.check_feature_name domain ~loc feat_name2;
bguillaum's avatar
bguillaum committed
124
        Feature_diseq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
125

126
      | (Ast.Feature_ineq (ineq, (node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
127 128
        Domain.check_feature_name domain ~loc feat_name1;
        Domain.check_feature_name domain ~loc feat_name2;
bguillaum's avatar
bguillaum committed
129
        Feature_ineq (ineq, pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
130

131
      | (Ast.Feature_ineq_cst (ineq, (node_name1, feat_name1), constant), loc) ->
132
        Domain.check_feature_name domain ~loc feat_name1;
133 134
        Feature_ineq_cst (ineq, pid_of_name loc node_name1, feat_name1, constant)

bguillaum's avatar
bguillaum committed
135 136 137
      | (Ast.Feature_re ((node_name, feat_name), regexp), loc) ->
        Domain.check_feature_name domain ~loc feat_name;
        Feature_re (pid_of_name loc node_name, feat_name, regexp)
bguillaum's avatar
bguillaum committed
138

bguillaum's avatar
bguillaum committed
139 140 141 142 143 144
      | (Ast.Prec (id1, id2), loc) ->
        Prec (pid_of_name loc id1, pid_of_name loc id2)

      | (Ast.Lprec (id1, id2), loc) ->
        Lprec (pid_of_name loc id1, pid_of_name loc id2)

bguillaum's avatar
bguillaum committed
145
  type basic = {
146 147 148
    graph: P_graph.t;
    constraints: const list;
  }
pj2m's avatar
pj2m committed
149

150
  let build_pos_basic domain ?pat_vars ?(locals=[||]) basic_ast =
151
    let (graph, pos_table) =
152
      P_graph.build domain ?pat_vars basic_ast.Ast.pat_nodes basic_ast.Ast.pat_edges in
pj2m's avatar
pj2m committed
153
    (
bguillaum's avatar
bguillaum committed
154 155
      {
        graph = graph;
156
        constraints = List.map (build_pos_constraint domain pos_table) basic_ast.Ast.pat_const
bguillaum's avatar
bguillaum committed
157 158
      },
      pos_table
pj2m's avatar
pj2m committed
159 160
    )

bguillaum's avatar
bguillaum committed
161
  (* the neg part *)
162
  let build_neg_constraint domain pos_table neg_table const =
bguillaum's avatar
bguillaum committed
163 164 165 166
    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
167
    match const with
168
      | (Ast.Cst_out (id,label_cst), loc) ->
169
        Cst_out (pid_of_name loc id, Label_cst.build ~loc domain label_cst)
170
      | (Ast.Cst_in (id,label_cst), loc) ->
171
        Cst_in (pid_of_name loc id, Label_cst.build ~loc domain label_cst)
172

173 174 175
      | (Ast.Feature_eq (feat_id1, feat_id2), loc) ->
        let (node_name1, feat_name1) = feat_id1
        and (node_name2, feat_name2) = feat_id2 in
176 177
        Domain.check_feature_name domain ~loc feat_name1;
        Domain.check_feature_name domain ~loc feat_name2;
bguillaum's avatar
bguillaum committed
178
        Feature_eq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
179

180 181 182
      | (Ast.Feature_diseq (feat_id1, feat_id2), loc) ->
        let (node_name1, feat_name1) = feat_id1
        and (node_name2, feat_name2) = feat_id2 in
183 184
        Domain.check_feature_name domain ~loc feat_name1;
        Domain.check_feature_name domain ~loc feat_name2;
bguillaum's avatar
bguillaum committed
185
        Feature_diseq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
186

187 188 189
      | (Ast.Feature_ineq (ineq, feat_id1, feat_id2), loc) ->
        let (node_name1, feat_name1) = feat_id1
        and (node_name2, feat_name2) = feat_id2 in
190 191
        Domain.check_feature_name domain ~loc feat_name1;
        Domain.check_feature_name domain ~loc feat_name2;
bguillaum's avatar
bguillaum committed
192
        Feature_ineq (ineq, pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
193

194 195
      | (Ast.Feature_ineq_cst (ineq, feat_id1, constant), loc) ->
        let (node_name1, feat_name1) = feat_id1 in
196
        Domain.check_feature_name domain ~loc feat_name1;
197
        Feature_ineq_cst (ineq, pid_of_name loc node_name1, feat_name1, constant)
pj2m's avatar
pj2m committed
198

bguillaum's avatar
bguillaum committed
199 200 201 202 203
      | (Ast.Feature_re (feat_id, regexp), loc) ->
        let (node_name, feat_name) = feat_id in
        Domain.check_feature_name domain ~loc feat_name;
        Feature_re (pid_of_name loc node_name, feat_name, regexp)

bguillaum's avatar
bguillaum committed
204 205 206 207 208 209
      | (Ast.Prec (id1, id2), loc) ->
        Prec (pid_of_name loc id1, pid_of_name loc id2)

      | (Ast.Lprec (id1, id2), loc) ->
        Lprec (pid_of_name loc id1, pid_of_name loc id2)

bguillaum's avatar
bguillaum committed
210
  (* It may raise [P_fs.Fail_unif] in case of contradiction on constraints *)
211
  let build_neg_basic domain ?pat_vars ?(locals=[||]) pos_table basic_ast =
pj2m's avatar
pj2m committed
212
    let (extension, neg_table) =
213
      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
214

215
    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
216
    {
bguillaum's avatar
bguillaum committed
217
      graph = extension.P_graph.ext_map;
218
      constraints = filters @ List.map (build_neg_constraint domain pos_table neg_table) basic_ast.Ast.pat_const ;
bguillaum's avatar
bguillaum committed
219
    }
pj2m's avatar
pj2m committed
220

bguillaum's avatar
bguillaum committed
221
  let get_edge_ids basic =
222
    Pid_map.fold
bguillaum's avatar
bguillaum committed
223 224
      (fun _ node acc ->
        Massoc_pid.fold
225 226
          (fun acc2 _ edge -> match P_edge.get_id edge with None -> acc2 | Some id -> id::acc2)
          acc (P_node.get_next node)
bguillaum's avatar
bguillaum committed
227
      ) basic.graph []
bguillaum's avatar
bguillaum committed
228

229 230 231
  (* a [pattern] is described by the positive basic and a list of negative basics. *)
  type pattern = basic * basic list

pj2m's avatar
pj2m committed
232 233
  type t = {
      name: string;
234
      pattern: pattern;
pj2m's avatar
pj2m committed
235
      commands: Command.t list;
236
      param: Lex_par.t option;
237
      param_names: (string list * string list);
bguillaum's avatar
bguillaum committed
238
      loc: Loc.t;
pj2m's avatar
pj2m committed
239 240
    }

bguillaum's avatar
bguillaum committed
241 242
  let get_name t = t.name

243
  let get_loc t = t.loc
pj2m's avatar
pj2m committed
244

245 246 247
  let is_filter t = t.commands = []

  (* ====================================================================== *)
248
  let to_dep domain t =
249
    let pos_basic = fst t.pattern in
250 251 252
    let buff = Buffer.create 32 in
    bprintf buff "[GRAPH] { scale = 200; }\n";

bguillaum's avatar
bguillaum committed
253 254
    let nodes =
      Pid_map.fold
255
        (fun id node acc ->
bguillaum's avatar
bguillaum committed
256 257
          (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))
258
          )
259
          :: acc
260
        ) pos_basic.graph [] in
261

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

265 266 267 268 269
    bprintf buff "[WORDS] {\n";
    List.iter
      (fun (_, dep_line) -> bprintf buff "%s\n" dep_line
      ) sorted_nodes;

270
    List.iteri
271 272
      (fun i cst ->
        match cst with
bguillaum's avatar
bguillaum committed
273
          | Cst_out _ | Cst_in _ -> bprintf buff "  C_%d { word=\"*\"}\n" i
274
          | _ -> ()
275
      ) pos_basic.constraints;
276
    bprintf buff "}\n";
bguillaum's avatar
bguillaum committed
277

278
    bprintf buff "[EDGES] {\n";
bguillaum's avatar
bguillaum committed
279

280 281
    Pid_map.iter
      (fun id_src node ->
bguillaum's avatar
bguillaum committed
282
        Massoc_pid.iter
283
          (fun id_tar edge ->
bguillaum's avatar
bguillaum committed
284 285 286
            bprintf buff "  N_%s -> N_%s { label=\"%s\"}\n"
              (Pid.to_id id_src)
              (Pid.to_id id_tar)
287
              (P_edge.to_string domain edge)
288 289
          )
          (P_node.get_next node)
290
      ) pos_basic.graph;
291

292
    List.iteri
293 294
      (fun i cst ->
        match cst with
bguillaum's avatar
bguillaum committed
295
          | Cst_out (pid, label_cst) ->
bguillaum's avatar
bguillaum committed
296
            bprintf buff "  N_%s -> C_%d {label = \"%s\"; style=dot; bottom; color=green;}\n"
297
              (Pid.to_id pid) i (Label_cst.to_string domain label_cst)
bguillaum's avatar
bguillaum committed
298
          | Cst_in (pid, label_cst) ->
bguillaum's avatar
bguillaum committed
299
            bprintf buff "  C_%d -> N_%s {label = \"%s\"; style=dot; bottom; color=green;}\n"
300
              i (Pid.to_id pid) (Label_cst.to_string domain label_cst)
301
          | _ -> ()
302
      ) pos_basic.constraints;
303 304
    bprintf buff "}\n";
    Buffer.contents buff
bguillaum's avatar
bguillaum committed
305

306
  (* ====================================================================== *)
bguillaum's avatar
bguillaum committed
307 308
  let build_commands domain ?param ?(locals=[||]) pos pos_table ast_commands =
    let known_act_ids = Array.to_list pos_table in
309
    let known_edge_ids = get_edge_ids pos in
310

311
    let rec loop (kai,kei) = function
312 313
      | [] -> []
      | ast_command :: tail ->
314
          let (command, (new_kai, new_kei)) =
315
            Command.build
316
              domain
317
              domain
318
              ?param
319
              (kai,kei)
320 321 322
              pos_table
              locals
              ast_command in
323 324
          command :: (loop (new_kai,new_kei) tail) in
    loop (known_act_ids, known_edge_ids) ast_commands
325 326

  (* ====================================================================== *)
bguillaum's avatar
bguillaum committed
327 328 329 330 331 332 333 334 335 336 337 338
  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

339
  (* ====================================================================== *)
bguillaum's avatar
bguillaum committed
340
  let build domain ?(locals=[||]) dir rule_ast =
bguillaum's avatar
bguillaum committed
341 342

    let (param, pat_vars, cmd_vars) =
bguillaum's avatar
bguillaum committed
343 344
      match rule_ast.Ast.param with
      | None -> (None,[],[])
345
      | Some (files,vars) ->
bguillaum's avatar
bguillaum committed
346 347 348
          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
349

350
          (* first: load lexical parameters given in the same file at the end of the rule definition *)
bguillaum's avatar
bguillaum committed
351 352 353 354
          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

355
          (* second: load lexical parameters given in external files *)
bguillaum's avatar
bguillaum committed
356
          let full_param = List.fold_left
357
            (fun acc file ->
bguillaum's avatar
bguillaum committed
358 359 360 361 362 363
              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
364

365 366 367 368 369
    (match (param, pat_vars) with
      | (None, _::_) -> Error.build ~loc:rule_ast.Ast.rule_loc "Missing lexical parameters in rule \"%s\"" rule_ast.Ast.rule_id
      | _ -> ()
    );

370
    let (pos, pos_table) = build_pos_basic domain ~pat_vars rule_ast.Ast.pattern.Ast.pat_pos in
bguillaum's avatar
bguillaum committed
371 372 373
    let (negs,_) =
      List.fold_left
      (fun (acc,pos) basic_ast ->
374
        try ((build_neg_basic domain ~pat_vars pos_table basic_ast) :: acc, pos+1)
bguillaum's avatar
bguillaum committed
375 376 377 378
        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)
379
      ) ([],1) rule_ast.Ast.pattern.Ast.pat_negs in
pj2m's avatar
pj2m committed
380
    {
bguillaum's avatar
bguillaum committed
381
      name = rule_ast.Ast.rule_id;
382
      pattern = (pos, negs);
383
      commands = build_commands domain ~param:(pat_vars,cmd_vars) pos pos_table rule_ast.Ast.commands;
bguillaum's avatar
bguillaum committed
384 385 386 387 388
      loc = rule_ast.Ast.rule_loc;
      param = param;
      param_names = (pat_vars,cmd_vars)
    }

389 390 391
  let build_pattern domain pattern_ast =
    let (pos, pos_table) = build_pos_basic domain pattern_ast.Ast.pat_pos in
    let negs = List_.try_map P_fs.Fail_unif (fun basic_ast -> build_neg_basic domain pos_table basic_ast) pattern_ast.Ast.pat_negs in
bguillaum's avatar
bguillaum committed
392 393
    (pos, negs)

394
  (* ====================================================================== *)
pj2m's avatar
pj2m committed
395
  type matching = {
396
      n_match: Gid.t Pid_map.t;                     (* partial fct: pattern nodes |--> graph nodes *)
397
      e_match: (string*(Gid.t*Label.t*Gid.t)) list; (* edge matching: edge ident  |--> (src,label,tar) *)
bguillaum's avatar
bguillaum committed
398
      a_match: (Gid.t*Label.t*Gid.t) list;          (* anonymous edge matched *)
399
      m_param: Lex_par.t option;
pj2m's avatar
pj2m committed
400
    }
401

402 403 404 405 406 407 408 409
  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 []

bguillaum's avatar
bguillaum committed
410
  let empty_matching param = { n_match = Pid_map.empty; e_match = []; a_match = []; m_param = param;}
411

pj2m's avatar
pj2m committed
412 413
  let e_comp (e1,_) (e2,_) = compare e1 e2

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

pj2m's avatar
pj2m committed
419 420
  let a_match_add edge matching = {matching with a_match = edge::matching.a_match }

421
  let match_deco pattern matching =
422 423 424
    { G_deco.nodes =
        Pid_map.fold
          (fun pid gid acc ->
425
            let pnode = P_graph.find pid (fst pattern).graph in
426 427
            (gid, (P_node.get_name pnode, P_fs.feat_list (P_node.get_fs pnode))) ::acc
          ) matching.n_match [];
428
      G_deco.edges = List.fold_left (fun acc (_,edge) -> edge::acc) matching.a_match matching.e_match;
pj2m's avatar
pj2m committed
429 430
    }

bguillaum's avatar
bguillaum committed
431
  let find cnode ?loc (matching, created_nodes) =
pj2m's avatar
pj2m committed
432
    match cnode with
433
    | Command.Pat pid ->
434
        (try Pid_map.find pid matching.n_match
bguillaum's avatar
bguillaum committed
435 436
        with Not_found -> Error.bug ?loc "Inconsistent matching pid '%s' not found" (Pid.to_string pid))
    | Command.New name ->
bguillaum's avatar
bguillaum committed
437 438
        (try List.assoc name created_nodes
        with Not_found -> Error.run ?loc "Identifier '%s' not found" name)
pj2m's avatar
pj2m committed
439 440

  let down_deco (matching,created_nodes) commands =
441 442 443 444 445 446 447 448 449 450
    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
451
    {
452
     G_deco.nodes = List.map (fun (gid,feat_list) -> (gid, ("",feat_list))) (Gid_map.bindings feat_to_highlight);
453
     G_deco.edges = List.fold_left
bguillaum's avatar
bguillaum committed
454 455
       (fun acc -> function
         | (Command.ADD_EDGE (src_cn,tar_cn,edge),loc) ->
456
             (find src_cn (matching, created_nodes), edge, find tar_cn (matching, created_nodes)) :: acc
457
         | _ -> acc
pj2m's avatar
pj2m committed
458 459 460 461 462
       ) [] commands
   }

  exception Fail
  type partial = {
bguillaum's avatar
bguillaum committed
463
      sub: matching;
464 465 466
      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
467
      check: const list (* constraints to verify at the end of the matching *)
bguillaum's avatar
bguillaum committed
468 469 470 471
    }

        (* PREREQUISITES:
           - all partial matching have the same domain
472 473
           - the domain of the pattern P is the disjoint union of domain([sub]) and [unmatched_nodes]
         *)
bguillaum's avatar
bguillaum committed
474
  (*  ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
475 476
  let init param basic =
    let roots = P_graph.roots basic.graph in
pj2m's avatar
pj2m committed
477

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

    (* put all roots in the front of the list to speed up the algo *)
bguillaum's avatar
bguillaum committed
481
    let sorted_node_list =
pj2m's avatar
pj2m committed
482
      List.sort
483 484 485 486
        (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
487

bguillaum's avatar
bguillaum committed
488
    { sub = empty_matching param;
pj2m's avatar
pj2m committed
489 490 491
      unmatched_nodes = sorted_node_list;
      unmatched_edges = [];
      already_matched_gids = [];
bguillaum's avatar
bguillaum committed
492
      check = basic.constraints;
pj2m's avatar
pj2m committed
493 494
    }

bguillaum's avatar
bguillaum committed
495
  (*  ---------------------------------------------------------------------- *)
496
  let apply_cst domain graph matching cst =
bguillaum's avatar
bguillaum committed
497
    let get_node pid = G_graph.find (Pid_map.find pid matching.n_match) graph in
498 499 500 501 502 503
    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
504 505

    match cst with
bguillaum's avatar
bguillaum committed
506
      | Cst_out (pid,label_cst) ->
507
        let gid = Pid_map.find pid matching.n_match in
508
        if G_graph.edge_out domain graph gid label_cst
bguillaum's avatar
bguillaum committed
509 510
        then matching
        else raise Fail
bguillaum's avatar
bguillaum committed
511
      | Cst_in (pid,label_cst) ->
512
        let gid = Pid_map.find pid matching.n_match in
bguillaum's avatar
bguillaum committed
513
        if G_graph.node_exists
514
          (fun node ->
515
            List.exists (fun e -> Label_cst.match_ domain label_cst e) (Massoc_gid.assoc gid (G_node.get_next node))
516
          ) graph
bguillaum's avatar
bguillaum committed
517 518
        then matching
        else raise Fail
bguillaum's avatar
bguillaum committed
519
      | Filter (pid, fs) ->
bguillaum's avatar
bguillaum committed
520 521 522 523 524 525 526 527
        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
bguillaum's avatar
bguillaum committed
528 529 530
      | Feature_eq (pid1, feat_name1, pid2, feat_name2) ->
        begin
          match (get_string_feat pid1 feat_name1, get_string_feat pid2 feat_name2) with
bguillaum's avatar
bguillaum committed
531 532
            | Some fv1, Some fv2 when fv1 = fv2 -> matching
            | _ -> raise Fail
bguillaum's avatar
bguillaum committed
533 534 535 536
        end
      | Feature_diseq (pid1, feat_name1, pid2, feat_name2) ->
        begin
          match (get_string_feat pid1 feat_name1, get_string_feat pid2 feat_name2) with
bguillaum's avatar
bguillaum committed
537 538
            | Some fv1, Some fv2 when fv1 <> fv2 -> matching
            | _ -> raise Fail
bguillaum's avatar
bguillaum committed
539 540
        end
      | Feature_ineq (ineq, pid1, feat_name1, pid2, feat_name2) ->
541 542
        begin
          match (ineq, get_float_feat pid1 feat_name1, get_float_feat pid2 feat_name2) with
bguillaum's avatar
bguillaum committed
543 544 545 546 547
            | (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
548 549 550 551 552 553 554 555 556 557
          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
bguillaum's avatar
bguillaum committed
558 559 560 561 562 563
      | Feature_re (pid, feat_name, regexp) ->
        begin
          match get_string_feat pid feat_name with
          | None -> raise Fail
          | Some string_feat ->
            let re = Str.regexp regexp in
564
            if String_.re_match re string_feat then matching else raise Fail
bguillaum's avatar
bguillaum committed
565
        end
bguillaum's avatar
bguillaum committed
566 567 568
      | Prec (pid1, pid2) ->
          let gid1 = Pid_map.find pid1 matching.n_match in
          let gid2 = Pid_map.find pid2 matching.n_match in
569
          let gnode1 = G_graph.find gid1 graph in
570
          if G_node.get_succ gnode1 = Some gid2
571 572
          then matching
          else  raise Fail
bguillaum's avatar
bguillaum committed
573
      | Lprec (pid1, pid2) ->
574 575 576 577 578
          let gnode1 = G_graph.find (Pid_map.find pid1 matching.n_match) graph in
          let gnode2 = G_graph.find (Pid_map.find pid2 matching.n_match) graph in
          if G_node.get_position gnode1 < G_node.get_position gnode2
          then matching
          else raise Fail
pj2m's avatar
pj2m committed
579

bguillaum's avatar
bguillaum committed
580
  (*  ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
581
  (* returns all extension of the partial input matching *)
582
  let rec extend_matching domain (positive,neg) (graph:G_graph.t) (partial:partial) =
pj2m's avatar
pj2m committed
583
    match (partial.unmatched_edges, partial.unmatched_nodes) with
bguillaum's avatar
bguillaum committed
584
    | [], [] ->
bguillaum's avatar
bguillaum committed
585 586 587 588 589
      begin
        try
          let new_matching =
            List.fold_left
              (fun acc const ->
590
                apply_cst domain graph acc const
bguillaum's avatar
bguillaum committed
591 592 593 594
              ) partial.sub partial.check in
          [new_matching, partial.already_matched_gids]
        with Fail -> []
      end
pj2m's avatar
pj2m committed
595
    | (src_pid, p_edge, tar_pid)::tail_ue, _ ->
596 597
        begin
          try (* is the tar already found in the matching ? *)
bguillaum's avatar
bguillaum committed
598
            let new_partials =
599 600 601
              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
602
              let g_edges = Massoc_gid.assoc tar_gid (G_node.get_next src_gnode) in
bguillaum's avatar
bguillaum committed
603

604
              match P_edge.match_list domain p_edge g_edges with
605
              | P_edge.Fail -> (* no good edge in graph for this pattern edge -> stop here *)
606
                  []
607
              | P_edge.Ok label -> (* at least an edge in the graph fits the p_edge "constraint" -> go on *)
bguillaum's avatar
bguillaum committed
608
                  [ {partial with unmatched_edges = tail_ue; sub = a_match_add (src_gid,label,tar_gid) partial.sub} ]
609
              | P_edge.Binds (id,labels) -> (* n edges in the graph match the identified p_edge -> make copies of the [k] matchings (and returns n*k matchings) *)
bguillaum's avatar
bguillaum committed
610
                  List.map
611 612
                    (fun label ->
                      {partial with sub = e_match_add (id,(src_gid,label,tar_gid)) partial.sub; unmatched_edges = tail_ue }
bguillaum's avatar
bguillaum committed
613
                    ) labels
614
            in List_.flat_map (extend_matching domain (positive,neg) graph) new_partials
615 616
          with Not_found -> (* p_edge goes to an unmatched node *)
            let candidates = (* candidates (of type (gid, matching)) for m(tar_pid) = gid) with new partial matching m *)
bguillaum's avatar
bguillaum committed
617
              let (src_gid : Gid.t) = Pid_map.find src_pid partial.sub.n_match in
618
              let src_gnode = G_graph.find src_gid graph in
619
              Massoc_gid.fold
620
                (fun acc gid_next g_edge ->
621
                  match P_edge.match_ domain p_edge g_edge with
622
                  | P_edge.Fail -> (* g_edge does not fit, no new candidate *)
623
                      acc
624
                  | P_edge.Ok label -> (* g_edge fits with the same matching *)
bguillaum's avatar
bguillaum committed
625
                      (gid_next, a_match_add (src_gid, label, gid_next) partial.sub) :: acc
626
                  | P_edge.Binds (id,[label]) -> (* g_edge fits with an extended matching *)
627
                      (gid_next, e_match_add (id, (src_gid, label, gid_next)) partial.sub) :: acc
628 629
                  | _ -> Error.bug "P_edge.match_ must return exactly one label"
                ) [] (G_node.get_next src_gnode) in
630
            List_.flat_map
bguillaum's avatar
bguillaum committed
631
              (fun (gid_next, matching) ->
632
                extend_matching_from domain (positive,neg) graph tar_pid gid_next
633 634 635
                  {partial with sub=matching; unmatched_edges = tail_ue}
              ) candidates
        end
bguillaum's avatar
bguillaum committed
636
    | [], pid :: _ ->
637 638
        G_graph.fold_gid
          (fun gid acc ->
639
            (extend_matching_from domain (positive,neg) graph pid gid partial) @ acc
640
          ) graph []
bguillaum's avatar
bguillaum committed
641

bguillaum's avatar
bguillaum committed
642
  (*  ---------------------------------------------------------------------- *)
643
  and extend_matching_from domain (positive,neg) (graph:G_graph.t) pid (gid : Gid.t) partial =
pj2m's avatar
pj2m committed
644 645 646
    if List.mem gid partial.already_matched_gids
    then [] (* the required association pid -> gid is not injective *)
    else
bguillaum's avatar
bguillaum committed
647 648 649 650 651 652 653 654 655 656
      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 *)
657
      let g_node = try G_graph.find gid graph with Not_found -> Error.bug "[extend_matching_from] cannot find gid in graph" in
bguillaum's avatar
bguillaum committed
658

bguillaum's avatar
bguillaum committed
659
      try
660
        let new_param = P_node.match_ ?param: partial.sub.m_param p_node g_node in
661
        (* add all out-edges from pid in pattern *)
bguillaum's avatar
bguillaum committed
662 663
        let new_unmatched_edges =
          Massoc_pid.fold
664
            (fun acc pid_next p_edge -> (pid, p_edge, pid_next) :: acc
665
            ) partial.unmatched_edges (P_node.get_next p_node) in
bguillaum's avatar
bguillaum committed
666 667

        let new_partial =
bguillaum's avatar
bguillaum committed
668
          { partial with
669
            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
670 671 672 673
            unmatched_edges = new_unmatched_edges;
            already_matched_gids = gid :: partial.already_matched_gids;
            sub = {partial.sub with n_match = Pid_map.add pid gid partial.sub.n_match; m_param = new_param};
          } in
674
        extend_matching domain (positive,neg) graph new_partial
675
      with P_fs.Fail -> []
pj2m's avatar
pj2m committed
676

bguillaum's avatar
bguillaum committed
677 678
  (*  ---------------------------------------------------------------------- *)
  (* the exception below is added to handle unification failure in merge!! *)
679
  exception Command_execution_fail
pj2m's avatar
pj2m committed
680

bguillaum's avatar
bguillaum committed
681 682
  (*  ---------------------------------------------------------------------- *)
  (** [apply_command instance matching created_nodes command] returns [(new_instance, new_created_nodes)] *)
bguillaum's avatar
bguillaum committed
683 684
  let apply_command domain (command,loc) instance matching created_nodes =
    let node_find cnode = find ~loc cnode (matching, created_nodes) in
685 686

    match command with
bguillaum's avatar
bguillaum committed
687
    | Command.ADD_EDGE (src_cn,tar_cn,edge) ->
688 689 690
        let src_gid = node_find src_cn in
        let tar_gid = node_find tar_cn in
        begin
691
          match G_graph.add_edge instance.Instance.graph src_gid edge tar_gid with
bguillaum's avatar
bguillaum committed
692
          | Some new_graph ->
693
              (
bguillaum's avatar
bguillaum committed
694 695
               {instance with
                Instance.graph = new_graph;
696
                history = List_.sort_insert (Command.H_ADD_EDGE (src_gid,tar_gid,edge)) instance.Instance.history
697
              },
bguillaum's avatar
bguillaum committed
698
               created_nodes
699
              )
bguillaum's avatar
bguillaum committed
700
          | None ->
701
              Error.run "ADD_EDGE: the edge '%s' already exists %s" (G_edge.to_string domain edge) (Loc.to_string loc)
702 703
        end

bguillaum's avatar
bguillaum committed
704
    | Command.DEL_EDGE_EXPL (src_cn,tar_cn,edge) ->
705 706 707
        let src_gid = node_find src_cn in
        let tar_gid = node_find tar_cn in
        (
bguillaum's avatar
bguillaum committed
708
         {instance with
709
          Instance.graph = G_graph.del_edge domain loc instance.Instance.graph src_gid edge tar_gid;
710
           history = List_.sort_insert (Command.H_DEL_EDGE_EXPL (src_gid,tar_gid,edge)) instance.Instance.history
711
        },
bguillaum's avatar
bguillaum committed
712
         created_nodes
713 714 715
        )

    | Command.DEL_EDGE_NAME edge_ident ->
bguillaum's avatar
bguillaum committed
716 717
        let (src_gid,edge,tar_gid) =
          try List.assoc edge_ident matching.e_match
718 719
          with Not_found -> Error.bug "The edge identifier '%s' is undefined %s" edge_ident (Loc.to_string loc) in
        (
bguillaum's avatar
bguillaum committed
720
         {instance with
721
          Instance.graph = G_graph.del_edge domain ~edge_ident loc instance.Instance.graph src_gid edge tar_gid;
722
          history = List_.sort_insert (Command.H_DEL_EDGE_EXPL (src_gid,tar_gid,edge)) instance.Instance.history
723
        },
bguillaum's avatar
bguillaum committed
724
         created_nodes
bguillaum's avatar
bguillaum committed
725
        )
726

bguillaum's avatar
bguillaum committed
727
    | Command.DEL_NODE node_cn ->
728 729
        let node_gid = node_find node_cn in
        (
bguillaum's avatar
bguillaum committed
730
         {instance with
731
          Instance.graph = G_graph.del_node instance.Instance.graph node_gid;
732
          history = List_.sort_insert (Command.H_DEL_NODE node_gid) instance.Instance.history
733
        },
bguillaum's avatar
bguillaum committed
734
         created_nodes
735 736 737 738 739
        )

    | Command.MERGE_NODE (src_cn, tar_cn) ->
        let src_gid = node_find src_cn in
        let tar_gid = node_find tar_cn in
740
        (match G_graph.merge_node loc domain instance.Instance.graph src_gid tar_gid with
bguillaum's avatar
bguillaum committed
741
        | Some new_graph ->
742
            (
bguillaum's avatar
bguillaum committed
743
             {instance with
744
              Instance.graph = new_graph;
745
              history = List_.sort_insert (Command.H_MERGE_NODE (src_gid,tar_gid)) instance.Instance.history
746
            },
bguillaum's avatar
bguillaum committed
747
             created_nodes
748 749 750
            )
        | None -> raise Command_execution_fail
        )
bguillaum's avatar
bguillaum committed
751

752
    | Command.UPDATE_FEAT (tar_cn,tar_feat_name, item_list) ->
bguillaum's avatar
bguillaum committed
753
        let tar_gid = node_find tar_cn in
754 755
        let rule_items = List.map
            (function
bguillaum's avatar
bguillaum committed
756 757
              | Command.Feat (cnode, feat_name) -> Concat_item.Feat (node_find cnode, feat_name)
              | Command.String s -> Concat_item.String s
bguillaum's avatar
bguillaum committed
758
              | Command.Param_out index ->
bguillaum's avatar
bguillaum committed
759 760
                  (match matching.m_param with
                  | None -> Error.bug "Cannot apply a UPDATE_FEAT command without parameter"
bguillaum's avatar
bguillaum committed
761
                  | Some param -> Concat_item.String (Lex_par.get_command_value index param))
bguillaum's avatar
bguillaum committed
762
              | Command.Param_in index ->
bguillaum's avatar
bguillaum committed
763
                  (match matching.m_param with
764
                  | None -> Error.bug "Cannot apply a UPDATE_FEAT command without parameter"
bguillaum's avatar
bguillaum committed
765
                  | Some param -> Concat_item.String (Lex_par.get_param_value index param))
766
            ) item_list in
767

bguillaum's avatar
bguillaum committed
768
        let (new_graph, new_feature_value) =
769
          G_graph.update_feat ~loc domain instance.Instance.graph tar_gid tar_feat_name rule_items in
bguillaum's avatar
bguillaum committed
770
        (
771 772
         {instance with
          Instance.graph = new_graph;
773
          history = List_.sort_insert (Command.H_UPDATE_FEAT (tar_gid,tar_feat_name,new_feature_value)) instance.Instance.history
bguillaum's avatar
bguillaum committed
774
        },
bguillaum's avatar
bguillaum committed
775
         created_nodes
776
        )
777 778 779 780

    | Command.DEL_FEAT (tar_cn,feat_name) ->
        let tar_gid = node_find tar_cn in
        (
bguillaum's avatar
bguillaum committed
781
         {instance with
782
          Instance.graph = G_graph.del_feat instance.Instance.graph tar_gid feat_name;
783
          history = List_.sort_insert (Command.H_DEL_FEAT (tar_gid,feat_name)) instance.Instance.history
784
        },
bguillaum's avatar
bguillaum committed
785
         created_nodes