grew_rule.ml 46 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
bguillaum's avatar
bguillaum committed
88
  let debug_loop = ref false
89 90 91

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

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

bguillaum's avatar
bguillaum committed
100 101
    | Feature_re of Pid.t * string * string

102
    | Feature_ineq of Ast.ineq * Pid.t * string * Pid.t * string
103 104
    | Feature_ineq_cst of Ast.ineq * Pid.t * string * float

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

bguillaum's avatar
bguillaum committed
107 108 109
    | Prec of Pid.t * Pid.t
    | Lprec of Pid.t * Pid.t

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

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

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

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

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

bguillaum's avatar
bguillaum committed
137 138 139
      | (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
140

bguillaum's avatar
bguillaum committed
141 142 143 144 145 146
      | (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
147
  type basic = {
148 149 150
    graph: P_graph.t;
    constraints: const list;
  }
pj2m's avatar
pj2m committed
151

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

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

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

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

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

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

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

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

bguillaum's avatar
bguillaum committed
223
  let get_edge_ids basic =
224
    Pid_map.fold
bguillaum's avatar
bguillaum committed
225 226
      (fun _ node acc ->
        Massoc_pid.fold
227 228
          (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
229
      ) basic.graph []
bguillaum's avatar
bguillaum committed
230

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

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

bguillaum's avatar
bguillaum committed
243 244
  let get_name t = t.name

245
  let get_loc t = t.loc
pj2m's avatar
pj2m committed
246

247 248 249
  let is_filter t = t.commands = []

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

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

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

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

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

280
    bprintf buff "[EDGES] {\n";
bguillaum's avatar
bguillaum committed
281

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

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

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

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

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

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

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

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

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

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

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

396
  let build_pattern domain pattern_ast =
397 398 399 400 401 402 403 404
    let (pos, pos_table) =
      try build_pos_basic domain pattern_ast.Ast.pat_pos
      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 *)
        (fun basic_ast -> build_neg_basic domain pos_table basic_ast)
        pattern_ast.Ast.pat_negs in
bguillaum's avatar
bguillaum committed
405 406
    (pos, negs)

407
  (* ====================================================================== *)
pj2m's avatar
pj2m committed
408
  type matching = {
409
      n_match: Gid.t Pid_map.t;                     (* partial fct: pattern nodes |--> graph nodes *)
410
      e_match: (string*(Gid.t*Label.t*Gid.t)) list; (* edge matching: edge ident  |--> (src,label,tar) *)
bguillaum's avatar
bguillaum committed
411
      a_match: (Gid.t*Label.t*Gid.t) list;          (* anonymous edge matched *)
412
      m_param: Lex_par.t option;
pj2m's avatar
pj2m committed
413
    }
414

415 416 417 418 419 420 421 422
  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
423
  let empty_matching param = { n_match = Pid_map.empty; e_match = []; a_match = []; m_param = param;}
424

pj2m's avatar
pj2m committed
425 426
  let e_comp (e1,_) (e2,_) = compare e1 e2

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

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

434
  let match_deco pattern matching =
435 436 437
    { G_deco.nodes =
        Pid_map.fold
          (fun pid gid acc ->
438
            let pnode = P_graph.find pid (fst pattern).graph in
439 440
            (gid, (P_node.get_name pnode, P_fs.feat_list (P_node.get_fs pnode))) ::acc
          ) matching.n_match [];
441
      G_deco.edges = List.fold_left (fun acc (_,edge) -> edge::acc) matching.a_match matching.e_match;
pj2m's avatar
pj2m committed
442 443
    }

bguillaum's avatar
bguillaum committed
444
  let find cnode ?loc (matching, created_nodes) =
pj2m's avatar
pj2m committed
445
    match cnode with
446
    | Command.Pat pid ->
447
        (try Pid_map.find pid matching.n_match
bguillaum's avatar
bguillaum committed
448 449
        with Not_found -> Error.bug ?loc "Inconsistent matching pid '%s' not found" (Pid.to_string pid))
    | Command.New name ->
bguillaum's avatar
bguillaum committed
450 451
        (try List.assoc name created_nodes
        with Not_found -> Error.run ?loc "Identifier '%s' not found" name)
pj2m's avatar
pj2m committed
452 453

  let down_deco (matching,created_nodes) commands =
454 455 456 457 458 459 460 461 462 463
    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
464
    {
465
     G_deco.nodes = List.map (fun (gid,feat_list) -> (gid, ("",feat_list))) (Gid_map.bindings feat_to_highlight);
466
     G_deco.edges = List.fold_left
bguillaum's avatar
bguillaum committed
467 468
       (fun acc -> function
         | (Command.ADD_EDGE (src_cn,tar_cn,edge),loc) ->
469
             (find src_cn (matching, created_nodes), edge, find tar_cn (matching, created_nodes)) :: acc
470
         | _ -> acc
pj2m's avatar
pj2m committed
471 472 473 474 475
       ) [] commands
   }

  exception Fail
  type partial = {
bguillaum's avatar
bguillaum committed
476
      sub: matching;
477 478 479
      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
480
      check: const list (* constraints to verify at the end of the matching *)
bguillaum's avatar
bguillaum committed
481 482 483 484
    }

        (* PREREQUISITES:
           - all partial matching have the same domain
485 486
           - the domain of the pattern P is the disjoint union of domain([sub]) and [unmatched_nodes]
         *)
bguillaum's avatar
bguillaum committed
487
  (*  ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
488 489
  let init param basic =
    let roots = P_graph.roots basic.graph in
pj2m's avatar
pj2m committed
490

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

    (* put all roots in the front of the list to speed up the algo *)
bguillaum's avatar
bguillaum committed
494
    let sorted_node_list =
pj2m's avatar
pj2m committed
495
      List.sort
496 497 498 499
        (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
500

bguillaum's avatar
bguillaum committed
501
    { sub = empty_matching param;
pj2m's avatar
pj2m committed
502 503 504
      unmatched_nodes = sorted_node_list;
      unmatched_edges = [];
      already_matched_gids = [];
bguillaum's avatar
bguillaum committed
505
      check = basic.constraints;
pj2m's avatar
pj2m committed
506 507
    }

bguillaum's avatar
bguillaum committed
508
  (*  ---------------------------------------------------------------------- *)
509
  let apply_cst domain graph matching cst =
bguillaum's avatar
bguillaum committed
510
    let get_node pid = G_graph.find (Pid_map.find pid matching.n_match) graph in
511 512 513 514 515 516
    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
517 518

    match cst with
bguillaum's avatar
bguillaum committed
519
      | Cst_out (pid,label_cst) ->
520
        let gid = Pid_map.find pid matching.n_match in
521
        if G_graph.edge_out domain graph gid label_cst
bguillaum's avatar
bguillaum committed
522 523
        then matching
        else raise Fail
bguillaum's avatar
bguillaum committed
524
      | Cst_in (pid,label_cst) ->
525
        let gid = Pid_map.find pid matching.n_match in
bguillaum's avatar
bguillaum committed
526
        if G_graph.node_exists
527
          (fun node ->
528
            List.exists (fun e -> Label_cst.match_ domain label_cst e) (Massoc_gid.assoc gid (G_node.get_next node))
529
          ) graph
bguillaum's avatar
bguillaum committed
530 531
        then matching
        else raise Fail
bguillaum's avatar
bguillaum committed
532
      | Filter (pid, fs) ->
bguillaum's avatar
bguillaum committed
533 534 535 536 537 538 539 540
        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
541 542 543
      | 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
544 545
            | Some fv1, Some fv2 when fv1 = fv2 -> matching
            | _ -> raise Fail
bguillaum's avatar
bguillaum committed
546 547 548 549
        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
550 551
            | Some fv1, Some fv2 when fv1 <> fv2 -> matching
            | _ -> raise Fail
bguillaum's avatar
bguillaum committed
552 553
        end
      | Feature_ineq (ineq, pid1, feat_name1, pid2, feat_name2) ->
554 555
        begin
          match (ineq, get_float_feat pid1 feat_name1, get_float_feat pid2 feat_name2) with
bguillaum's avatar
bguillaum committed
556 557 558 559 560
            | (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
561 562 563 564 565 566 567 568 569 570
          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
571 572 573 574 575 576
      | 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
577
            if String_.re_match re string_feat then matching else raise Fail
bguillaum's avatar
bguillaum committed
578
        end
bguillaum's avatar
bguillaum committed
579 580 581
      | Prec (pid1, pid2) ->
          let gid1 = Pid_map.find pid1 matching.n_match in
          let gid2 = Pid_map.find pid2 matching.n_match in
582
          let gnode1 = G_graph.find gid1 graph in
583
          if G_node.get_succ gnode1 = Some gid2
584 585
          then matching
          else  raise Fail
bguillaum's avatar
bguillaum committed
586
      | Lprec (pid1, pid2) ->
587 588 589 590 591
          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
592

bguillaum's avatar
bguillaum committed
593
  (*  ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
594
  (* returns all extension of the partial input matching *)
595
  let rec extend_matching domain (positive,neg) (graph:G_graph.t) (partial:partial) =
pj2m's avatar
pj2m committed
596
    match (partial.unmatched_edges, partial.unmatched_nodes) with
bguillaum's avatar
bguillaum committed
597
    | [], [] ->
bguillaum's avatar
bguillaum committed
598 599 600 601 602
      begin
        try
          let new_matching =
            List.fold_left
              (fun acc const ->
603
                apply_cst domain graph acc const
bguillaum's avatar
bguillaum committed
604 605 606 607
              ) partial.sub partial.check in
          [new_matching, partial.already_matched_gids]
        with Fail -> []
      end
pj2m's avatar
pj2m committed
608
    | (src_pid, p_edge, tar_pid)::tail_ue, _ ->
609 610
        begin
          try (* is the tar already found in the matching ? *)
bguillaum's avatar
bguillaum committed
611
            let new_partials =
612 613 614
              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
615
              let g_edges = Massoc_gid.assoc tar_gid (G_node.get_next src_gnode) in
bguillaum's avatar
bguillaum committed
616

617
              match P_edge.match_list domain p_edge g_edges with
618
              | P_edge.Fail -> (* no good edge in graph for this pattern edge -> stop here *)
619
                  []
620
              | P_edge.Ok label -> (* at least an edge in the graph fits the p_edge "constraint" -> go on *)
bguillaum's avatar
bguillaum committed
621
                  [ {partial with unmatched_edges = tail_ue; sub = a_match_add (src_gid,label,tar_gid) partial.sub} ]
622
              | 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
623
                  List.map
624 625
                    (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
626
                    ) labels
627
            in List_.flat_map (extend_matching domain (positive,neg) graph) new_partials
628 629
          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
630
              let (src_gid : Gid.t) = Pid_map.find src_pid partial.sub.n_match in
631
              let src_gnode = G_graph.find src_gid graph in
632
              Massoc_gid.fold
633
                (fun acc gid_next g_edge ->
634
                  match P_edge.match_ domain p_edge g_edge with
635
                  | P_edge.Fail -> (* g_edge does not fit, no new candidate *)
636
                      acc
637
                  | P_edge.Ok label -> (* g_edge fits with the same matching *)
bguillaum's avatar
bguillaum committed
638
                      (gid_next, a_match_add (src_gid, label, gid_next) partial.sub) :: acc
639
                  | P_edge.Binds (id,[label]) -> (* g_edge fits with an extended matching *)
640
                      (gid_next, e_match_add (id, (src_gid, label, gid_next)) partial.sub) :: acc
641 642
                  | _ -> Error.bug "P_edge.match_ must return exactly one label"
                ) [] (G_node.get_next src_gnode) in
643
            List_.flat_map
bguillaum's avatar
bguillaum committed
644
              (fun (gid_next, matching) ->
645
                extend_matching_from domain (positive,neg) graph tar_pid gid_next
646 647 648
                  {partial with sub=matching; unmatched_edges = tail_ue}
              ) candidates
        end
bguillaum's avatar
bguillaum committed
649
    | [], pid :: _ ->
650 651
        G_graph.fold_gid
          (fun gid acc ->
652
            (extend_matching_from domain (positive,neg) graph pid gid partial) @ acc
653
          ) graph []
bguillaum's avatar
bguillaum committed
654

bguillaum's avatar
bguillaum committed
655
  (*  ---------------------------------------------------------------------- *)
656
  and extend_matching_from domain (positive,neg) (graph:G_graph.t) pid (gid : Gid.t) partial =
pj2m's avatar
pj2m committed
657 658 659
    if List.mem gid partial.already_matched_gids
    then [] (* the required association pid -> gid is not injective *)
    else
bguillaum's avatar
bguillaum committed
660 661 662 663 664 665 666 667 668 669
      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 *)
670
      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
671

bguillaum's avatar
bguillaum committed
672
      try
673
        let new_param = P_node.match_ ?param: partial.sub.m_param p_node g_node in
674
        (* add all out-edges from pid in pattern *)
bguillaum's avatar
bguillaum committed
675 676
        let new_unmatched_edges =
          Massoc_pid.fold
677
            (fun acc pid_next p_edge -> (pid, p_edge, pid_next) :: acc
678
            ) partial.unmatched_edges (P_node.get_next p_node) in
bguillaum's avatar
bguillaum committed
679 680

        let new_partial =
bguillaum's avatar
bguillaum committed
681
          { partial with
682
            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
683 684 685 686
            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
687
        extend_matching domain (positive,neg) graph new_partial
688
      with P_fs.Fail -> []
pj2m's avatar
pj2m committed
689

bguillaum's avatar
bguillaum committed
690 691
  (*  ---------------------------------------------------------------------- *)
  (* the exception below is added to handle unification failure in merge!! *)
692
  exception Command_execution_fail
pj2m's avatar
pj2m committed
693

bguillaum's avatar
bguillaum committed
694 695
  (*  ---------------------------------------------------------------------- *)
  (** [apply_command instance matching created_nodes command] returns [(new_instance, new_created_nodes)] *)
bguillaum's avatar
bguillaum committed
696 697
  let apply_command domain (command,loc) instance matching created_nodes =
    let node_find cnode = find ~loc cnode (matching, created_nodes) in
698 699

    match command with
bguillaum's avatar
bguillaum committed
700
    | Command.ADD_EDGE (src_cn,tar_cn,edge) ->
701 702 703
        let src_gid = node_find src_cn in
        let tar_gid = node_find tar_cn in
        begin
704
          match G_graph.add_edge instance.Instance.graph src_gid edge tar_gid with
bguillaum's avatar
bguillaum committed
705
          | Some new_graph ->
706
              (
bguillaum's avatar
bguillaum committed
707 708
               {instance with
                Instance.graph = new_graph;
709
                history = List_.sort_insert (Command.H_ADD_EDGE (src_gid,tar_gid,edge)) instance.Instance.history
710
              },
bguillaum's avatar
bguillaum committed
711
               created_nodes
712
              )
bguillaum's avatar
bguillaum committed
713
          | None ->
714
              Error.run "ADD_EDGE: the edge '%s' already exists %s" (G_edge.to_string domain edge) (Loc.to_string loc)
715 716
        end

bguillaum's avatar
bguillaum committed
717
    | Command.DEL_EDGE_EXPL (src_cn,tar_cn,edge) ->
718 719 720
        let src_gid = node_find src_cn in
        let tar_gid = node_find tar_cn in
        (
bguillaum's avatar
bguillaum committed
721
         {instance with
722
          Instance.graph = G_graph.del_edge domain loc instance.Instance.graph src_gid edge tar_gid;
723
           history = List_.sort_insert (Command.H_DEL_EDGE_EXPL (src_gid,tar_gid,edge)) instance.Instance.history
724
        },
bguillaum's avatar
bguillaum committed
725
         created_nodes
726 727 728
        )

    | Command.DEL_EDGE_NAME edge_ident ->
bguillaum's avatar
bguillaum committed
729 730
        let (src_gid,edge,tar_gid) =
          try List.assoc edge_ident matching.e_match
731 732
          with Not_found -> Error.bug "The edge identifier '%s' is undefined %s" edge_ident (Loc.to_string loc) in
        (
bguillaum's avatar
bguillaum committed
733
         {instance with
734
          Instance.graph = G_graph.del_edge domain ~edge_ident loc instance.Instance.graph src_gid edge tar_gid;
735
          history = List_.sort_insert (Command.H_DEL_EDGE_EXPL (src_gid,tar_gid,edge)) instance.Instance.history
736
        },
bguillaum's avatar
bguillaum committed
737
         created_nodes
bguillaum's avatar
bguillaum committed
738
        )
739

bguillaum's avatar
bguillaum committed
740
    | Command.DEL_NODE node_cn ->
741 742
        let node_gid = node_find node_cn in
        (
bguillaum's avatar
bguillaum committed
743
         {instance with
744
          Instance.graph = G_graph.del_node instance.Instance.graph node_gid;
745
          history = List_.sort_insert (Command.H_DEL_NODE node_gid) instance.Instance.history
746
        },
bguillaum's avatar
bguillaum committed
747
         created_nodes
748 749 750 751 752
        )

    | Command.MERGE_NODE (src_cn, tar_cn) ->
        let src_gid = node_find src_cn in
        let tar_gid = node_find tar_cn in
753
        (match G_graph.merge_node loc domain instance.Instance.graph src_gid tar_gid with
bguillaum's avatar
bguillaum committed
754
        | Some new_graph ->
755
            (
bguillaum's avatar
bguillaum committed
756
             {instance with
757
              Instance.graph = new_graph;
758
              history = List_.sort_insert (Command.H_MERGE_NODE (src_gid,tar_gid)) instance.Instance.history
759
            },
bguillaum's avatar
bguillaum committed
760
             created_nodes
761 762 763
            )
        | None -> raise Command_execution_fail
        )
bguillaum's avatar
bguillaum committed
764

765
    | Command.UPDATE_FEAT (tar_cn,tar_feat_name, item_list) ->
bguillaum's avatar
bguillaum committed
766
        let tar_gid = node_find tar_cn in
767 768
        let rule_items = List.map
            (function
bguillaum's avatar
bguillaum committed
769 770
              | 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
771
              | Command.Param_out index ->
bguillaum's avatar
bguillaum committed
772 773
                  (match matching.m_param with
                  | None -> Error.bug "Cannot apply a UPDATE_FEAT command without parameter"
bguillaum's avatar
bguillaum committed
774
                  | Some param -> Concat_item.String (Lex_par.get_command_value index param))
bguillaum's avatar
bguillaum committed
775
              | Command.Param_in index ->
bguillaum's avatar
bguillaum committed
776
                  (match matching.m_param with
777
                  | None -> Error.bug "Cannot apply a UPDATE_FEAT command without parameter"
bguillaum's avatar
bguillaum committed
778
                  | Some param -> Concat_item.String (Lex_par.get_param_value index param))
779
            ) item_list in
780

bguillaum's avatar
bguillaum committed
781
        let (new_graph, new_feature_value) =
782
          G_graph.update_feat ~loc domain instance.Instance.graph tar_gid tar_feat_name rule_items in
bguillaum's avatar
bguillaum committed
783
        (
784 785
         {instance with
          Instance.graph = new_graph;
786
          history = List_.sort_insert (Command.H_UPDATE_FEAT (tar_gid,tar_feat_name,new_feature_value)) instance.Instance.history
bguillaum's avatar
bguillaum committed
787
        },
bguillaum's avatar
bguillaum committed
788
         created_nodes
789
        )