grew_rule.ml 48.2 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
    | Feature_eq of Pid.t * string * Pid.t * string
90
    | Feature_diseq of Pid.t * string * Pid.t * string
bguillaum's avatar
bguillaum committed
91

bguillaum's avatar
bguillaum committed
92 93 94 95 96 97
    | Feature_cst of Pid.t * string * string
    | Feature_diff_cst of Pid.t * string * string

    | Feature_float of Pid.t * string * float
    | Feature_diff_float of Pid.t * string * float

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

bguillaum's avatar
bguillaum committed
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) ->
bguillaum's avatar
bguillaum committed
112
        Cst_out (pid_of_name loc id, Label_cst.build ~loc ?domain label_cst)
113
      | (Ast.Cst_in (id,label_cst), loc) ->
bguillaum's avatar
bguillaum committed
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) ->
bguillaum's avatar
bguillaum committed
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) ->
bguillaum's avatar
bguillaum committed
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) ->
bguillaum's avatar
bguillaum committed
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) ->
bguillaum's avatar
bguillaum committed
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
      | (Ast.Feature_re ((node_name, feat_name), regexp), loc) ->
bguillaum's avatar
bguillaum committed
136
        Domain.check_feature_name ?domain ~loc feat_name;
bguillaum's avatar
bguillaum committed
137
        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 145 146 147 148 149 150 151 152
      | (Ast.Feature_cst ((node_name, feat_name), string), loc) ->
        Domain.check_feature_name ?domain ~loc feat_name;
        Feature_cst (pid_of_name loc node_name, feat_name, string)
      | (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)

      | (Ast.Feature_float ((node_name, feat_name), float), loc) ->
        Domain.check_feature_name ?domain ~loc feat_name;
        Feature_float (pid_of_name loc node_name, feat_name, float)
      | (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)

bguillaum's avatar
bguillaum committed
153 154 155 156 157 158
      | (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
159
  type basic = {
160 161 162
    graph: P_graph.t;
    constraints: const list;
  }
pj2m's avatar
pj2m committed
163

bguillaum's avatar
bguillaum committed
164
  let build_pos_basic ?domain ?pat_vars ?(locals=[||]) basic_ast =
165
    let (graph, pos_table) =
bguillaum's avatar
bguillaum committed
166
      P_graph.build ?domain ?pat_vars basic_ast.Ast.pat_nodes basic_ast.Ast.pat_edges in
pj2m's avatar
pj2m committed
167
    (
bguillaum's avatar
bguillaum committed
168 169
      {
        graph = graph;
bguillaum's avatar
bguillaum committed
170
        constraints = List.map (build_pos_constraint ?domain pos_table) basic_ast.Ast.pat_const
bguillaum's avatar
bguillaum committed
171 172
      },
      pos_table
pj2m's avatar
pj2m committed
173 174
    )

bguillaum's avatar
bguillaum committed
175
  (* the neg part *)
bguillaum's avatar
bguillaum committed
176
  let build_neg_constraint ?domain pos_table neg_table const =
bguillaum's avatar
bguillaum committed
177 178 179 180
    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
181
    match const with
182
      | (Ast.Cst_out (id,label_cst), loc) ->
bguillaum's avatar
bguillaum committed
183
        Cst_out (pid_of_name loc id, Label_cst.build ~loc ?domain label_cst)
184
      | (Ast.Cst_in (id,label_cst), loc) ->
bguillaum's avatar
bguillaum committed
185
        Cst_in (pid_of_name loc id, Label_cst.build ~loc ?domain label_cst)
186

187 188 189
      | (Ast.Feature_eq (feat_id1, feat_id2), loc) ->
        let (node_name1, feat_name1) = feat_id1
        and (node_name2, feat_name2) = feat_id2 in
bguillaum's avatar
bguillaum committed
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_eq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
193

194 195 196
      | (Ast.Feature_diseq (feat_id1, feat_id2), loc) ->
        let (node_name1, feat_name1) = feat_id1
        and (node_name2, feat_name2) = feat_id2 in
bguillaum's avatar
bguillaum committed
197 198
        Domain.check_feature_name ?domain ~loc feat_name1;
        Domain.check_feature_name ?domain ~loc feat_name2;
bguillaum's avatar
bguillaum committed
199
        Feature_diseq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
200

201 202 203
      | (Ast.Feature_ineq (ineq, feat_id1, feat_id2), loc) ->
        let (node_name1, feat_name1) = feat_id1
        and (node_name2, feat_name2) = feat_id2 in
bguillaum's avatar
bguillaum committed
204 205
        Domain.check_feature_name ?domain ~loc feat_name1;
        Domain.check_feature_name ?domain ~loc feat_name2;
bguillaum's avatar
bguillaum committed
206
        Feature_ineq (ineq, pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
207

208 209
      | (Ast.Feature_ineq_cst (ineq, feat_id1, constant), loc) ->
        let (node_name1, feat_name1) = feat_id1 in
bguillaum's avatar
bguillaum committed
210
        Domain.check_feature_name ?domain ~loc feat_name1;
211
        Feature_ineq_cst (ineq, pid_of_name loc node_name1, feat_name1, constant)
pj2m's avatar
pj2m committed
212

bguillaum's avatar
bguillaum committed
213 214
      | (Ast.Feature_re (feat_id, regexp), loc) ->
        let (node_name, feat_name) = feat_id in
bguillaum's avatar
bguillaum committed
215
        Domain.check_feature_name ?domain ~loc feat_name;
bguillaum's avatar
bguillaum committed
216 217
        Feature_re (pid_of_name loc node_name, feat_name, regexp)

bguillaum's avatar
bguillaum committed
218 219 220 221 222 223 224 225 226 227 228 229 230 231 232
      | (Ast.Feature_cst ((node_name, feat_name), string), loc) ->
        Domain.check_feature_name ?domain ~loc feat_name;
        Feature_cst (pid_of_name loc node_name, feat_name, string)
      | (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)

      | (Ast.Feature_float ((node_name, feat_name), float), loc) ->
        Domain.check_feature_name ?domain ~loc feat_name;
        Feature_float (pid_of_name loc node_name, feat_name, float)
      | (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)


bguillaum's avatar
bguillaum committed
233 234 235 236 237 238
      | (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
239
  (* It may raise [P_fs.Fail_unif] in case of contradiction on constraints *)
bguillaum's avatar
bguillaum committed
240
  let build_neg_basic ?domain ?pat_vars ?(locals=[||]) pos_table basic_ast =
pj2m's avatar
pj2m committed
241
    let (extension, neg_table) =
bguillaum's avatar
bguillaum committed
242
      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
243

244
    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
245
    {
bguillaum's avatar
bguillaum committed
246
      graph = extension.P_graph.ext_map;
bguillaum's avatar
bguillaum committed
247
      constraints = filters @ List.map (build_neg_constraint ?domain pos_table neg_table) basic_ast.Ast.pat_const ;
bguillaum's avatar
bguillaum committed
248
    }
pj2m's avatar
pj2m committed
249

bguillaum's avatar
bguillaum committed
250
  let get_edge_ids basic =
251
    Pid_map.fold
bguillaum's avatar
bguillaum committed
252 253
      (fun _ node acc ->
        Massoc_pid.fold
254
          (fun acc2 _ edge -> (P_edge.get_id edge)::acc2)
255
          acc (P_node.get_next node)
bguillaum's avatar
bguillaum committed
256
      ) basic.graph []
bguillaum's avatar
bguillaum committed
257

258 259 260
  (* a [pattern] is described by the positive basic and a list of negative basics. *)
  type pattern = basic * basic list

261
  let pid_name_list (pos,_) = P_graph.pid_name_list pos.graph
262

pj2m's avatar
pj2m committed
263 264
  type t = {
      name: string;
265
      pattern: pattern;
pj2m's avatar
pj2m committed
266
      commands: Command.t list;
267
      param: Lex_par.t option;
bguillaum's avatar
bguillaum committed
268
      param_names: (string list * string list);
bguillaum's avatar
bguillaum committed
269
      loc: Loc.t;
pj2m's avatar
pj2m committed
270 271
    }

bguillaum's avatar
bguillaum committed
272 273
  let get_name t = t.name

274
  let get_loc t = t.loc
pj2m's avatar
pj2m committed
275

276 277 278
  let is_filter t = t.commands = []

  (* ====================================================================== *)
bguillaum's avatar
bguillaum committed
279
  let to_dep ?domain t =
280
    let pos_basic = fst t.pattern in
bguillaum's avatar
bguillaum committed
281 282 283
    let buff = Buffer.create 32 in
    bprintf buff "[GRAPH] { scale = 200; }\n";

bguillaum's avatar
bguillaum committed
284 285
    let nodes =
      Pid_map.fold
bguillaum's avatar
bguillaum committed
286
        (fun id node acc ->
bguillaum's avatar
bguillaum committed
287 288
          (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
289
          )
bguillaum's avatar
bguillaum committed
290
          :: acc
291
        ) pos_basic.graph [] in
bguillaum's avatar
bguillaum committed
292

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

bguillaum's avatar
bguillaum committed
296 297 298 299 300
    bprintf buff "[WORDS] {\n";
    List.iter
      (fun (_, dep_line) -> bprintf buff "%s\n" dep_line
      ) sorted_nodes;

301
    List.iteri
bguillaum's avatar
bguillaum committed
302 303
      (fun i cst ->
        match cst with
bguillaum's avatar
bguillaum committed
304
          | Cst_out _ | Cst_in _ -> bprintf buff "  C_%d { word=\"*\"}\n" i
bguillaum's avatar
bguillaum committed
305
          | _ -> ()
306
      ) pos_basic.constraints;
bguillaum's avatar
bguillaum committed
307
    bprintf buff "}\n";
bguillaum's avatar
bguillaum committed
308

bguillaum's avatar
bguillaum committed
309
    bprintf buff "[EDGES] {\n";
bguillaum's avatar
bguillaum committed
310

bguillaum's avatar
bguillaum committed
311 312
    Pid_map.iter
      (fun id_src node ->
bguillaum's avatar
bguillaum committed
313
        Massoc_pid.iter
bguillaum's avatar
bguillaum committed
314
          (fun id_tar edge ->
bguillaum's avatar
bguillaum committed
315 316 317
            bprintf buff "  N_%s -> N_%s { label=\"%s\"}\n"
              (Pid.to_id id_src)
              (Pid.to_id id_tar)
bguillaum's avatar
bguillaum committed
318
              (P_edge.to_string ?domain edge)
bguillaum's avatar
bguillaum committed
319 320
          )
          (P_node.get_next node)
321
      ) pos_basic.graph;
bguillaum's avatar
bguillaum committed
322

323
    List.iteri
bguillaum's avatar
bguillaum committed
324 325
      (fun i cst ->
        match cst with
bguillaum's avatar
bguillaum committed
326
          | Cst_out (pid, label_cst) ->
bguillaum's avatar
bguillaum committed
327
            bprintf buff "  N_%s -> C_%d {label = \"%s\"; style=dot; bottom; color=green;}\n"
bguillaum's avatar
bguillaum committed
328
              (Pid.to_id pid) i (Label_cst.to_string ?domain label_cst)
bguillaum's avatar
bguillaum committed
329
          | Cst_in (pid, label_cst) ->
bguillaum's avatar
bguillaum committed
330
            bprintf buff "  C_%d -> N_%s {label = \"%s\"; style=dot; bottom; color=green;}\n"
bguillaum's avatar
bguillaum committed
331
              i (Pid.to_id pid) (Label_cst.to_string ?domain label_cst)
bguillaum's avatar
bguillaum committed
332
          | _ -> ()
333
      ) pos_basic.constraints;
bguillaum's avatar
bguillaum committed
334 335
    bprintf buff "}\n";
    Buffer.contents buff
bguillaum's avatar
bguillaum committed
336

337
  (* ====================================================================== *)
bguillaum's avatar
bguillaum committed
338
  let build_commands ?domain ?param ?(locals=[||]) pos pos_table ast_commands =
bguillaum's avatar
bguillaum committed
339
    let known_act_ids = Array.to_list pos_table in
340
    let known_edge_ids = get_edge_ids pos in
341

342
    let rec loop (kai,kei) = function
343 344
      | [] -> []
      | ast_command :: tail ->
345
          let (command, (new_kai, new_kei)) =
346
            Command.build
bguillaum's avatar
bguillaum committed
347
              ?domain
348
              ?param
349
              (kai,kei)
350 351 352
              pos_table
              locals
              ast_command in
353 354
          command :: (loop (new_kai,new_kei) tail) in
    loop (known_act_ids, known_edge_ids) ast_commands
355 356

  (* ====================================================================== *)
bguillaum's avatar
bguillaum committed
357 358 359 360 361 362 363 364 365 366 367 368
  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

369
  (* ====================================================================== *)
bguillaum's avatar
bguillaum committed
370
  let build ?domain ?(locals=[||]) dir rule_ast =
bguillaum's avatar
bguillaum committed
371 372

    let (param, pat_vars, cmd_vars) =
bguillaum's avatar
bguillaum committed
373 374
      match rule_ast.Ast.param with
      | None -> (None,[],[])
375
      | Some (files,vars) ->
bguillaum's avatar
bguillaum committed
376 377 378
          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
379

380
          (* first: load lexical parameters given in the same file at the end of the rule definition *)
bguillaum's avatar
bguillaum committed
381 382 383 384
          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

385
          (* second: load lexical parameters given in external files *)
bguillaum's avatar
bguillaum committed
386
          let full_param = List.fold_left
387
            (fun acc file ->
bguillaum's avatar
bguillaum committed
388 389 390 391 392 393
              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
394

395
    (match (param, pat_vars) with
396
      | (None, _::_) -> Error.build ~loc:rule_ast.Ast.rule_loc "[Rule.build] Missing lexical parameters in rule \"%s\"" rule_ast.Ast.rule_id
397 398 399
      | _ -> ()
    );

400
    let pattern = Ast.normalize_pattern rule_ast.Ast.pattern in
401
    let (pos, pos_table) =
402
      try build_pos_basic ?domain ~pat_vars pattern.Ast.pat_pos
403 404 405 406
      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
407 408 409
    let (negs,_) =
      List.fold_left
      (fun (acc,pos) basic_ast ->
bguillaum's avatar
bguillaum committed
410
        try ((build_neg_basic ?domain ~pat_vars pos_table basic_ast) :: acc, pos+1)
bguillaum's avatar
bguillaum committed
411 412 413 414
        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)
415
      ) ([],1) pattern.Ast.pat_negs in
pj2m's avatar
pj2m committed
416
    {
bguillaum's avatar
bguillaum committed
417
      name = rule_ast.Ast.rule_id;
418
      pattern = (pos, negs);
bguillaum's avatar
bguillaum committed
419
      commands = build_commands ?domain ~param:(pat_vars,cmd_vars) pos pos_table rule_ast.Ast.commands;
bguillaum's avatar
bguillaum committed
420 421 422 423 424
      loc = rule_ast.Ast.rule_loc;
      param = param;
      param_names = (pat_vars,cmd_vars)
    }

bguillaum's avatar
bguillaum committed
425
  let build_pattern ?domain pattern_ast =
426
    let n_pattern = Ast.normalize_pattern pattern_ast in
427
    let (pos, pos_table) =
428
      try build_pos_basic ?domain n_pattern.Ast.pat_pos
429 430 431 432
      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
433
        (fun basic_ast -> build_neg_basic ?domain pos_table basic_ast)
434
        n_pattern.Ast.pat_negs in
bguillaum's avatar
bguillaum committed
435 436
    (pos, negs)

437
  (* ====================================================================== *)
pj2m's avatar
pj2m committed
438
  type matching = {
439
      n_match: Gid.t Pid_map.t;                     (* partial fct: pattern nodes |--> graph nodes *)
440
      e_match: (string*(Gid.t*Label.t*Gid.t)) list; (* edge matching: edge ident  |--> (src,label,tar) *)
441
      m_param: Lex_par.t option;
pj2m's avatar
pj2m committed
442
    }
443

444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459
  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)) ->
460
        bprintf buff "\"%s\":\"%s/%s/%s\", " id (node_name src) (Label.to_string lab) (node_name tar)
461 462 463 464 465
      ) m.e_match;

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

466 467 468 469 470 471 472 473
  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 []

474
  let empty_matching param = { n_match = Pid_map.empty; e_match = []; m_param = param;}
475

pj2m's avatar
pj2m committed
476 477
  let e_comp (e1,_) (e2,_) = compare e1 e2

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

483
  let match_deco pattern matching =
484 485 486
    { G_deco.nodes =
        Pid_map.fold
          (fun pid gid acc ->
487
            let pnode = P_graph.find pid (fst pattern).graph in
488 489
            (gid, (P_node.get_name pnode, P_fs.feat_list (P_node.get_fs pnode))) ::acc
          ) matching.n_match [];
490
      G_deco.edges = List.fold_left (fun acc (_,edge) -> edge::acc) [] matching.e_match;
pj2m's avatar
pj2m committed
491 492
    }

bguillaum's avatar
bguillaum committed
493
  let find cnode ?loc (matching, created_nodes) =
pj2m's avatar
pj2m committed
494
    match cnode with
495
    | Command.Pat pid ->
496
        (try Pid_map.find pid matching.n_match
bguillaum's avatar
bguillaum committed
497 498
        with Not_found -> Error.bug ?loc "Inconsistent matching pid '%s' not found" (Pid.to_string pid))
    | Command.New name ->
bguillaum's avatar
bguillaum committed
499 500
        (try List.assoc name created_nodes
        with Not_found -> Error.run ?loc "Identifier '%s' not found" name)
pj2m's avatar
pj2m committed
501 502

  let down_deco (matching,created_nodes) commands =
503 504 505 506 507 508 509 510 511 512
    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
513
    {
514
     G_deco.nodes = List.map (fun (gid,feat_list) -> (gid, ("",feat_list))) (Gid_map.bindings feat_to_highlight);
515
     G_deco.edges = List.fold_left
bguillaum's avatar
bguillaum committed
516 517
       (fun acc -> function
         | (Command.ADD_EDGE (src_cn,tar_cn,edge),loc) ->
518
             (find src_cn (matching, created_nodes), edge, find tar_cn (matching, created_nodes)) :: acc
519
         | _ -> acc
pj2m's avatar
pj2m committed
520 521 522 523 524
       ) [] commands
   }

  exception Fail
  type partial = {
bguillaum's avatar
bguillaum committed
525
      sub: matching;
526 527 528
      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
529
      check: const list (* constraints to verify at the end of the matching *)
bguillaum's avatar
bguillaum committed
530 531 532
    }

        (* PREREQUISITES:
bguillaum's avatar
bguillaum committed
533 534
           - all partial matching have the same ?domain
           - the ?domain of the pattern P is the disjoint union of ?domain([sub]) and [unmatched_nodes]
535
         *)
bguillaum's avatar
bguillaum committed
536
  (*  ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
537 538
  let init param basic =
    let roots = P_graph.roots basic.graph in
pj2m's avatar
pj2m committed
539

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

    (* put all roots in the front of the list to speed up the algo *)
bguillaum's avatar
bguillaum committed
543
    let sorted_node_list =
pj2m's avatar
pj2m committed
544
      List.sort
545 546 547 548
        (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
549

bguillaum's avatar
bguillaum committed
550
    { sub = empty_matching param;
pj2m's avatar
pj2m committed
551 552 553
      unmatched_nodes = sorted_node_list;
      unmatched_edges = [];
      already_matched_gids = [];
bguillaum's avatar
bguillaum committed
554
      check = basic.constraints;
pj2m's avatar
pj2m committed
555 556
    }

bguillaum's avatar
bguillaum committed
557
  (*  ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
558
  let apply_cst ?domain graph matching cst =
bguillaum's avatar
bguillaum committed
559
    let get_node pid = G_graph.find (Pid_map.find pid matching.n_match) graph in
560 561 562 563 564 565
    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
566 567

    match cst with
bguillaum's avatar
bguillaum committed
568
      | Cst_out (pid,label_cst) ->
569
        let gid = Pid_map.find pid matching.n_match in
bguillaum's avatar
bguillaum committed
570
        if G_graph.edge_out ?domain graph gid label_cst
bguillaum's avatar
bguillaum committed
571 572
        then matching
        else raise Fail
bguillaum's avatar
bguillaum committed
573
      | Cst_in (pid,label_cst) ->
574
        let gid = Pid_map.find pid matching.n_match in
bguillaum's avatar
bguillaum committed
575
        if G_graph.node_exists
576
          (fun node ->
bguillaum's avatar
bguillaum committed
577
            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
578
          ) graph
bguillaum's avatar
bguillaum committed
579 580
        then matching
        else raise Fail
bguillaum's avatar
bguillaum committed
581
      | Filter (pid, fs) ->
bguillaum's avatar
bguillaum committed
582 583 584 585 586 587 588 589
        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
590 591 592
      | 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
593 594
            | Some fv1, Some fv2 when fv1 = fv2 -> matching
            | _ -> raise Fail
bguillaum's avatar
bguillaum committed
595
        end
bguillaum's avatar
bguillaum committed
596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619
      | Feature_cst (pid1, feat_name1, value) ->
        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
      | Feature_float (pid1, feat_name1, float) ->
        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
bguillaum's avatar
bguillaum committed
620 621 622
      | 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
623 624
            | Some fv1, Some fv2 when fv1 <> fv2 -> matching
            | _ -> raise Fail
bguillaum's avatar
bguillaum committed
625 626
        end
      | Feature_ineq (ineq, pid1, feat_name1, pid2, feat_name2) ->
627 628
        begin
          match (ineq, get_float_feat pid1 feat_name1, get_float_feat pid2 feat_name2) with
bguillaum's avatar
bguillaum committed
629 630 631 632 633
            | (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
634 635 636 637 638 639 640 641 642 643
          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
644 645 646 647 648 649
      | 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
650
            if String_.re_match re string_feat then matching else raise Fail
bguillaum's avatar
bguillaum committed
651
        end
bguillaum's avatar
bguillaum committed
652 653 654
      | Prec (pid1, pid2) ->
          let gid1 = Pid_map.find pid1 matching.n_match in
          let gid2 = Pid_map.find pid2 matching.n_match in
655
          let gnode1 = G_graph.find gid1 graph in
656
          if G_node.get_succ gnode1 = Some gid2
657 658
          then matching
          else  raise Fail
bguillaum's avatar
bguillaum committed
659
      | Lprec (pid1, pid2) ->
660 661 662 663 664
          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
665

bguillaum's avatar
bguillaum committed
666
  (*  ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
667
  (* returns all extension of the partial input matching *)
bguillaum's avatar
bguillaum committed
668
  let rec extend_matching ?domain (positive,neg) (graph:G_graph.t) (partial:partial) =
pj2m's avatar
pj2m committed
669
    match (partial.unmatched_edges, partial.unmatched_nodes) with
bguillaum's avatar
bguillaum committed
670
    | [], [] ->
bguillaum's avatar
bguillaum committed
671 672 673 674 675
      begin
        try
          let new_matching =
            List.fold_left
              (fun acc const ->
bguillaum's avatar
bguillaum committed
676
                apply_cst ?domain graph acc const
bguillaum's avatar
bguillaum committed
677 678 679 680
              ) partial.sub partial.check in
          [new_matching, partial.already_matched_gids]
        with Fail -> []
      end
pj2m's avatar
pj2m committed
681
    | (src_pid, p_edge, tar_pid)::tail_ue, _ ->
682 683
        begin
          try (* is the tar already found in the matching ? *)
bguillaum's avatar
bguillaum committed
684
            let new_partials =
685 686 687
              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
688
              let g_edges = Massoc_gid.assoc tar_gid (G_node.get_next src_gnode) in
bguillaum's avatar
bguillaum committed
689

bguillaum's avatar
bguillaum committed
690
              match P_edge.match_list ?domain p_edge g_edges with
691
              | P_edge.Fail -> (* no good edge in graph for this pattern edge -> stop here *)
692
                  []
693
              | 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
694
                  List.map
695 696
                    (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
697
                    ) labels
bguillaum's avatar
bguillaum committed
698
            in List_.flat_map (extend_matching ?domain (positive,neg) graph) new_partials
699 700
          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
701
              let (src_gid : Gid.t) = Pid_map.find src_pid partial.sub.n_match in
702
              let src_gnode = G_graph.find src_gid graph in
703
              Massoc_gid.fold
704
                (fun acc gid_next g_edge ->
bguillaum's avatar
bguillaum committed
705
                  match P_edge.match_ ?domain p_edge g_edge with
706
                  | P_edge.Fail -> (* g_edge does not fit, no new candidate *)
707
                      acc
708
                  | P_edge.Binds (id,[label]) -> (* g_edge fits with an extended matching *)
709
                      (gid_next, e_match_add (id, (src_gid, label, gid_next)) partial.sub) :: acc
710 711
                  | _ -> Error.bug "P_edge.match_ must return exactly one label"
                ) [] (G_node.get_next src_gnode) in
712
            List_.flat_map
bguillaum's avatar
bguillaum committed
713
              (fun (gid_next, matching) ->
bguillaum's avatar
bguillaum committed
714
                extend_matching_from ?domain (positive,neg) graph tar_pid gid_next
715 716 717
                  {partial with sub=matching; unmatched_edges = tail_ue}
              ) candidates
        end
bguillaum's avatar
bguillaum committed
718
    | [], pid :: _ ->
719 720
        G_graph.fold_gid
          (fun gid acc ->
bguillaum's avatar
bguillaum committed
721
            (extend_matching_from ?domain (positive,neg) graph pid gid partial) @ acc
bguillaum's avatar
bguillaum committed
722
          ) graph []
bguillaum's avatar
bguillaum committed
723

bguillaum's avatar
bguillaum committed
724
  (*  ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
725
  and extend_matching_from ?domain (positive,neg) (graph:G_graph.t) pid (gid : Gid.t) partial =
pj2m's avatar
pj2m committed
726 727 728
    if List.mem gid partial.already_matched_gids
    then [] (* the required association pid -> gid is not injective *)
    else
bguillaum's avatar
bguillaum committed
729 730 731 732 733 734 735 736 737 738
      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 *)
739
      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
740

bguillaum's avatar
bguillaum committed
741
      try
742
        let new_param = P_node.match_ ?param: partial.sub.m_param p_node g_node in
743
        (* add all out-edges from pid in pattern *)
bguillaum's avatar
bguillaum committed
744 745
        let new_unmatched_edges =
          Massoc_pid.fold
746
            (fun acc pid_next p_edge -> (pid, p_edge, pid_next) :: acc
747
            ) partial.unmatched_edges (P_node.get_next p_node) in
bguillaum's avatar
bguillaum committed
748 749

        let new_partial =
bguillaum's avatar
bguillaum committed
750
          { partial with
751
            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
752 753 754 755
            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
bguillaum's avatar
bguillaum committed
756
        extend_matching ?domain (positive,neg) graph new_partial
757
      with P_fs.Fail -> []
pj2m's avatar
pj2m committed
758

bguillaum's avatar
bguillaum committed
759 760
  (*  ---------------------------------------------------------------------- *)
  (* the exception below is added to handle unification failure in merge!! *)
761
  exception Command_execution_fail
pj2m's avatar
pj2m committed
762

bguillaum's avatar
bguillaum committed
763 764
  (*  ---------------------------------------------------------------------- *)
  (** [apply_command instance matching created_nodes command] returns [(new_instance, new_created_nodes)] *)
bguillaum's avatar
bguillaum committed
765
  let apply_command ?domain (command,loc) instance matching created_nodes =
bguillaum's avatar
bguillaum committed
766
    let node_find cnode = find ~loc cnode (matching, created_nodes) in
767 768

    match command with
bguillaum's avatar
bguillaum committed
769
    | Command.ADD_EDGE (src_cn,tar_cn,edge) ->
770 771 772
        let src_gid = node_find src_cn in
        let tar_gid = node_find tar_cn in
        begin
773
          match G_graph.add_edge instance.Instance.graph src_gid edge tar_gid with
bguillaum's avatar
bguillaum committed
774
          | Some new_graph ->
775
              (
bguillaum's avatar
bguillaum committed
776 777
               {instance with
                Instance.graph = new_graph;
778
                history = List_.sort_insert (Command.H_ADD_EDGE (src_gid,tar_gid,edge)) instance.Instance.history
779
              },
bguillaum's avatar
bguillaum committed
780
               created_nodes
781
              )
bguillaum's avatar
bguillaum committed
782
          | None ->
bguillaum's avatar
bguillaum committed
783
              Error.run "ADD_EDGE: the edge '%s' already exists %s" (G_edge.to_string ?domain edge) (Loc.to_string loc)
784 785
        end

bguillaum's avatar
bguillaum committed
786
    | Command.DEL_EDGE_EXPL (src_cn,tar_cn,edge) ->
787 788 789
        let src_gid = node_find src_cn in
        let tar_gid = node_find tar_cn in
        (
bguillaum's avatar
bguillaum committed
790
         {instance with
bguillaum's avatar
bguillaum committed
791
          Instance.graph = G_graph.del_edge ?domain loc instance.Instance.graph src_gid edge tar_gid;
792
           history = List_.sort_insert (Command.H_DEL_EDGE_EXPL (src_gid,tar_gid,edge)) instance.Instance.history
793
        },
bguillaum's avatar
bguillaum committed
794
         created_nodes
795 796 797
        )

    | Command.DEL_EDGE_NAME edge_ident ->
bguillaum's avatar
bguillaum committed
798 799
        let (src_gid,edge,tar_gid) =
          try List.assoc edge_ident matching.e_match
800 801
          with Not_found -> Error.bug "The edge identifier '%s' is undefined %s" edge_ident (Loc.to_string loc) in
        (
bguillaum's avatar
bguillaum committed
802
         {instance with
bguillaum's avatar
bguillaum committed
803
          Instance.graph = G_graph.del_edge ?domain ~edge_ident loc instance.Instance.graph src_gid edge tar_gid;
804
          history = List_.sort_insert (Command.H_DEL_EDGE_EXPL (src_gid,tar_gid,edge)) instance.Instance.history
805
        },
bguillaum's avatar
bguillaum committed
806
         created_nodes
bguillaum's avatar
bguillaum committed
807
        )
808

bguillaum's avatar
bguillaum committed
809
    | Command.DEL_NODE node_cn ->
810 811
        let node_gid = node_find node_cn in
        (
bguillaum's avatar
bguillaum committed
812
         {instance with
813
          Instance.graph = G_graph.del_node instance.Instance.graph node_gid;
814
          history = List_.sort_insert (Command.H_DEL_NODE node_gid) instance.Instance.history
815
        },
bguillaum's avatar
bguillaum committed
816
         created_nodes
817 818 819 820 821
        )

    | Command.MERGE_NODE (src_cn, tar_cn) ->
        let src_gid = node_find src_cn in
        let tar_gid = node_find tar_cn in
bguillaum's avatar
bguillaum committed
822
        (match G_graph.merge_node loc ?domain instance.Instance.graph src_gid tar_gid with
bguillaum's avatar
bguillaum committed
823
        | Some new_graph ->
824
            (
bguillaum's avatar
bguillaum committed
825
             {instance with
826
              Instance.graph = new_graph;
827
              history = List_.sort_insert (Command.H_MERGE_NODE (src_gid,tar_gid)) instance.Instance.history