grew_rule.ml 38.8 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
open Grew_base
bguillaum's avatar
bguillaum committed
15
open Grew_ast
pj2m's avatar
pj2m committed
16
open Grew_edge
bguillaum's avatar
bguillaum committed
17
open Grew_fs
pj2m's avatar
pj2m committed
18
open Grew_node
bguillaum's avatar
bguillaum committed
19 20
open Grew_command
open Grew_graph
pj2m's avatar
pj2m committed
21

22
(* ================================================================================ *)
pj2m's avatar
pj2m committed
23 24
module Instance = struct
  type t = {
25 26 27
    graph: G_graph.t;
    history: Command.h list;
    rules: string list;
28
    big_step: Libgrew_types.big_step option;
29 30 31 32 33 34 35 36 37
    free_index: int;
    activated_node: Gid.t list;
  }

  let empty = {graph = G_graph.empty; rules=[]; history=[]; big_step=None; free_index=0; activated_node=[];}

  let from_graph graph =
    {empty with
      graph = graph;
38
      free_index = (G_graph.max_binding graph) + 1;
pj2m's avatar
pj2m committed
39 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 49 50 51 52 53 54 55 56
  let flatten t =
    (* [mapping] is list of couple (node_id, node_id) used to flatten the graph *)
    let (mapping, new_free) = List.fold_left
      (fun (acc_map, next_free) node_id ->
        (
          (node_id, Gid.Old next_free) :: acc_map,
          next_free + 1
        )
      ) ([], t.free_index) t.activated_node in
    { empty with graph = G_graph.rename mapping t.graph; free_index = new_free }
pj2m's avatar
pj2m committed
57

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

62 63
  let to_gr t = G_graph.to_gr t.graph

bguillaum's avatar
bguillaum committed
64 65
  let to_conll t = G_graph.to_conll t.graph

66
  let save_dot_png ?filter ?main_feat base t =
bguillaum's avatar
bguillaum committed
67
    ignore (Dot.to_png_file (G_graph.to_dot ?main_feat t.graph) (base^".png"))
68

pj2m's avatar
pj2m committed
69
IFDEF DEP2PICT THEN
70
  let save_dep_png ?filter ?main_feat base t =
71 72 73 74 75 76 77 78 79 80 81
    let (_,_,highlight_position) =
      Dep2pict.Dep2pict.fromDepStringToPng_with_pos
        (G_graph.to_dep ?filter ?main_feat t.graph) (base^".png") in
    highlight_position

  let save_dep_svg ?filter ?main_feat base t =
    let (_,_,highlight_position) =
      Dep2pict.Dep2pict.fromDepStringToSvgFile_with_pos
        (G_graph.to_dep ?filter ?main_feat t.graph) (base^".svg") in
    highlight_position

82
ELSE
83 84
  let save_dep_png ?filter ?main_feat base t = None
  let save_dep_svg ?filter ?main_feat base t = None
pj2m's avatar
pj2m committed
85
ENDIF
86
end (* module Instance *)
pj2m's avatar
pj2m committed
87

88
(* ================================================================================ *)
89
module Instance_set = Set.Make (Instance)
pj2m's avatar
pj2m committed
90

91
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
92 93
module Rule = struct
  (* the rewriting depth is bounded to stop rewriting when the system is not terminating *)
94
  let max_depth = ref 500
pj2m's avatar
pj2m committed
95

96
  type const =
97 98 99
    | Cst_out of Pid.t * P_edge.t
    | Cst_in of Pid.t * P_edge.t
    | Feature_eq of Pid.t * string * Pid.t * string
100
    | Feature_diseq of Pid.t * string * Pid.t * string
bguillaum's avatar
bguillaum committed
101

102 103
    | Feature_ineq of Ast.ineq * Pid.t * string * Pid.t * string
    | Filter of Pid.t * P_fs.t (* used when a without impose a fs on a node defined by the match pattern *)
pj2m's avatar
pj2m committed
104

bguillaum's avatar
bguillaum committed
105 106 107
  let build_pos_constraint ?locals pos_table const =
    let pid_of_name loc node_name = Pid.Pos (Id.build ~loc node_name pos_table) in
    match const with
108 109 110 111 112 113 114 115 116 117
      | (Ast.Start (id, labels), loc) ->
        Cst_out (pid_of_name loc id, P_edge.make ~loc ?locals labels)
      | (Ast.Cst_out id, loc) ->
        Cst_out (pid_of_name loc id, P_edge.all)
      | (Ast.End (id, labels),loc) ->
        Cst_in (pid_of_name loc id, P_edge.make ~loc ?locals labels)
      | (Ast.Cst_in id, loc) ->
        Cst_in (pid_of_name loc id, P_edge.all)

      | (Ast.Feature_eq ((node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
bguillaum's avatar
bguillaum committed
118
        Feature_eq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
119
      | (Ast.Feature_diseq ((node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
bguillaum's avatar
bguillaum committed
120
        Feature_diseq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
121
      | (Ast.Feature_ineq (ineq, (node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
bguillaum's avatar
bguillaum committed
122
        Feature_ineq (ineq, pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
bguillaum's avatar
bguillaum committed
123

bguillaum's avatar
bguillaum committed
124
  type pattern = {
125 126 127
    graph: P_graph.t;
    constraints: const list;
  }
pj2m's avatar
pj2m committed
128

129
  let build_pos_pattern ?pat_vars ?(locals=[||]) pattern_ast =
130
    let (graph, pos_table) =
bguillaum's avatar
bguillaum committed
131
      P_graph.build ?pat_vars ~locals pattern_ast.Ast.pat_nodes pattern_ast.Ast.pat_edges in
pj2m's avatar
pj2m committed
132
    (
bguillaum's avatar
bguillaum committed
133 134
      {
        graph = graph;
135
        constraints = List.map (build_pos_constraint ~locals pos_table) pattern_ast.Ast.pat_const
bguillaum's avatar
bguillaum committed
136 137
      },
      pos_table
pj2m's avatar
pj2m committed
138 139
    )

bguillaum's avatar
bguillaum committed
140
  (* the neg part *)
pj2m's avatar
pj2m committed
141
  let build_neg_constraint ?locals pos_table neg_table const =
bguillaum's avatar
bguillaum committed
142 143 144 145
    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
146
    match const with
147 148 149 150 151 152 153 154 155 156 157 158 159
      | (Ast.Start (id, labels),loc) ->
        Cst_out (pid_of_name loc id, P_edge.make ~loc ?locals labels)
      | (Ast.Cst_out id, loc) ->
        Cst_out (pid_of_name loc id, P_edge.all)
      | (Ast.End (id, labels),loc) ->
        Cst_in (pid_of_name loc id, P_edge.make ~loc ?locals labels)
      | (Ast.Cst_in id, loc) ->
        Cst_in (pid_of_name loc id, P_edge.all)

      | (Ast.Feature_eq (qfn1, qfn2), loc) ->
        let (node_name1, feat_name1) = qfn1
        and (node_name2, feat_name2) = qfn2 in

bguillaum's avatar
bguillaum committed
160
        Feature_eq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
161 162 163
      | (Ast.Feature_diseq (qfn1, qfn2), loc) ->
        let (node_name1, feat_name1) = qfn1
        and (node_name2, feat_name2) = qfn2 in
bguillaum's avatar
bguillaum committed
164
        Feature_diseq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
165 166 167
      | (Ast.Feature_ineq (ineq, qfn1, qfn2), loc) ->
        let (node_name1, feat_name1) = qfn1
        and (node_name2, feat_name2) = qfn2 in
bguillaum's avatar
bguillaum committed
168
        Feature_ineq (ineq, pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
pj2m's avatar
pj2m committed
169

170
  let build_neg_pattern ?(locals=[||]) pos_table pattern_ast =
pj2m's avatar
pj2m committed
171
    let (extension, neg_table) =
172
      P_graph.build_extension ~locals pos_table pattern_ast.Ast.pat_nodes pattern_ast.Ast.pat_edges in
173
    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
174
    {
bguillaum's avatar
bguillaum committed
175 176 177
      graph = extension.P_graph.ext_map;
      constraints = filters @ List.map (build_neg_constraint ~locals pos_table neg_table) pattern_ast.Ast.pat_const ;
    }
pj2m's avatar
pj2m committed
178

179
  let get_edge_ids pattern =
180
    Pid_map.fold
bguillaum's avatar
bguillaum committed
181 182
      (fun _ node acc ->
        Massoc_pid.fold
183 184 185
          (fun acc2 _ edge -> match P_edge.get_id edge with None -> acc2 | Some id -> id::acc2)
          acc (P_node.get_next node)
      ) pattern.graph []
bguillaum's avatar
bguillaum committed
186

pj2m's avatar
pj2m committed
187 188 189 190 191
  type t = {
      name: string;
      pos: pattern;
      neg: pattern list;
      commands: Command.t list;
192
      param: Lex_par.t option;
193
      param_names: (string list * string list);
bguillaum's avatar
bguillaum committed
194
      loc: Loc.t;
pj2m's avatar
pj2m committed
195 196
    }

bguillaum's avatar
bguillaum committed
197 198
  let get_name t = t.name

199
  let get_loc t = t.loc
pj2m's avatar
pj2m committed
200

201 202 203
  let is_filter t = t.commands = []

  (* ====================================================================== *)
204 205 206 207
  let to_dep t =
    let buff = Buffer.create 32 in
    bprintf buff "[GRAPH] { scale = 200; }\n";

bguillaum's avatar
bguillaum committed
208 209
    let nodes =
      Pid_map.fold
210
        (fun id node acc ->
bguillaum's avatar
bguillaum committed
211 212
          (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))
213
          )
214 215 216
          :: acc
        ) t.pos.graph [] in

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

220 221 222 223 224 225 226 227
    bprintf buff "[WORDS] {\n";
    List.iter
      (fun (_, dep_line) -> bprintf buff "%s\n" dep_line
      ) sorted_nodes;

    List_.iteri
      (fun i cst ->
        match cst with
bguillaum's avatar
bguillaum committed
228
          | Cst_out _ | Cst_in _ -> bprintf buff "  C_%d { word=\"*\"}\n" i
229 230 231
          | _ -> ()
      ) t.pos.constraints;
    bprintf buff "}\n";
bguillaum's avatar
bguillaum committed
232

233
    bprintf buff "[EDGES] {\n";
bguillaum's avatar
bguillaum committed
234

235 236
    Pid_map.iter
      (fun id_src node ->
bguillaum's avatar
bguillaum committed
237
        Massoc_pid.iter
238
          (fun id_tar edge ->
bguillaum's avatar
bguillaum committed
239 240 241
            bprintf buff "  N_%s -> N_%s { label=\"%s\"}\n"
              (Pid.to_id id_src)
              (Pid.to_id id_tar)
242 243 244 245 246 247 248 249 250
              (P_edge.to_string edge)
          )
          (P_node.get_next node)
      ) t.pos.graph;

    List_.iteri
      (fun i cst ->
        match cst with
          | Cst_out (pid, edge) ->
bguillaum's avatar
bguillaum committed
251 252 253 254 255
            bprintf buff "  N_%s -> C_%d {label = \"%s\"; style=dot; bottom; color=green;}\n"
              (Pid.to_id pid) i (P_edge.to_string edge)
          | Cst_in (pid, edge) ->
            bprintf buff "  C_%d -> N_%s {label = \"%s\"; style=dot; bottom; color=green;}\n"
              i (Pid.to_id pid) (P_edge.to_string edge)
256 257 258 259
          | _ -> ()
      ) t.pos.constraints;
    bprintf buff "}\n";
    Buffer.contents buff
bguillaum's avatar
bguillaum committed
260

261
  (* ====================================================================== *)
262
  let build_commands ?param ?(locals=[||]) suffixes pos pos_table ast_commands =
263
    let known_act_ids = List.map (fun x -> (x,None)) (Array.to_list pos_table) in
264
    let known_edge_ids = get_edge_ids pos in
265

266
    let rec loop (kai,kei) = function
267 268
      | [] -> []
      | ast_command :: tail ->
269
          let (command, (new_kai, new_kei)) =
270 271
            Command.build
              ?param
272
              (kai,kei)
273 274
              pos_table
              locals
275
              suffixes
276
              ast_command in
277 278
          command :: (loop (new_kai,new_kei) tail) in
    loop (known_act_ids, known_edge_ids) ast_commands
279 280

  (* ====================================================================== *)
bguillaum's avatar
bguillaum committed
281 282 283 284 285 286 287 288 289 290 291 292
  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

293
  (* ====================================================================== *)
294
  let build ?(locals=[||]) suffixes dir rule_ast =
bguillaum's avatar
bguillaum committed
295 296

    let (param, pat_vars, cmd_vars) =
bguillaum's avatar
bguillaum committed
297 298
      match rule_ast.Ast.param with
      | None -> (None,[],[])
299
      | Some (files,vars) ->
bguillaum's avatar
bguillaum committed
300 301 302
          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
303 304 305 306 307 308
          let param = List.fold_left
            (fun acc file ->
              Lex_par.append
                (Lex_par.load ~loc:rule_ast.Ast.rule_loc dir nb_pv nb_cv file)
                acc
            )
bguillaum's avatar
bguillaum committed
309 310
            (match rule_ast.Ast.lp with
              | None -> Lex_par.empty
311 312 313
              | Some lines -> Lex_par.from_lines ~loc:rule_ast.Ast.rule_loc nb_pv nb_cv lines
            )
            files in
314
          (Some param, pat_vars, cmd_vars) in
315

bguillaum's avatar
bguillaum committed
316
    let (pos, pos_table) = build_pos_pattern ~pat_vars ~locals rule_ast.Ast.pos_pattern in
pj2m's avatar
pj2m committed
317
    {
bguillaum's avatar
bguillaum committed
318 319 320
      name = rule_ast.Ast.rule_id;
      pos = pos;
      neg = List.map (fun pattern_ast -> build_neg_pattern ~locals pos_table pattern_ast) rule_ast.Ast.neg_patterns;
321
      commands = build_commands ~param:(pat_vars,cmd_vars) ~locals suffixes pos pos_table rule_ast.Ast.commands;
bguillaum's avatar
bguillaum committed
322 323 324 325 326
      loc = rule_ast.Ast.rule_loc;
      param = param;
      param_names = (pat_vars,cmd_vars)
    }

327
  (* ====================================================================== *)
pj2m's avatar
pj2m committed
328
  type matching = {
329
      n_match: Gid.t Pid_map.t;                     (* partial fct: pattern nodes |--> graph nodes *)
330 331
      e_match: (string*(Gid.t*Label.t*Gid.t)) list; (* edge matching: edge ident  |--> (src,label,tar) *)
      a_match: (Gid.t*Label.t*Gid.t) list;          (* anonymous edge mached *)
332
      m_param: Lex_par.t option;
pj2m's avatar
pj2m committed
333
    }
334

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

pj2m's avatar
pj2m committed
337 338
  let e_comp (e1,_) (e2,_) = compare e1 e2

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

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

346 347 348 349 350 351 352
  let up_deco rule matching =
    { G_deco.nodes =
        Pid_map.fold
          (fun pid gid acc ->
            let pnode = P_graph.find pid rule.pos.graph in
            (gid, (P_node.get_name pnode, P_fs.feat_list (P_node.get_fs pnode))) ::acc
          ) matching.n_match [];
353
      G_deco.edges = List.fold_left (fun acc (_,edge) -> edge::acc) matching.a_match matching.e_match;
pj2m's avatar
pj2m committed
354 355
    }

bguillaum's avatar
bguillaum committed
356
  let find cnode ?loc (matching, (created_nodes,activated_nodes)) =
pj2m's avatar
pj2m committed
357
    match cnode with
358
    | Command.Pat pid ->
359
        (try Pid_map.find pid matching.n_match
bguillaum's avatar
bguillaum committed
360 361
        with Not_found -> Error.bug ?loc "Inconsistent matching pid '%s' not found" (Pid.to_string pid))
    | Command.New name ->
bguillaum's avatar
bguillaum committed
362 363
        (try List.assoc name created_nodes
        with Not_found -> Error.run ?loc "Identifier '%s' not found" name)
bguillaum's avatar
bguillaum committed
364 365 366 367
    | Command.Act (pid, new_name) ->
        (try List.assoc (pid, new_name) activated_nodes
        with Not_found -> Error.run ?loc "Activated identifier with suffix '%s' not found" new_name)

bguillaum's avatar
bguillaum committed
368

pj2m's avatar
pj2m committed
369 370

  let down_deco (matching,created_nodes) commands =
371 372 373 374 375 376 377 378 379 380
    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
381
    {
382
     G_deco.nodes = List.map (fun (gid,feat_list) -> (gid, ("",feat_list))) (Gid_map.bindings feat_to_highlight);
383
     G_deco.edges = List.fold_left
bguillaum's avatar
bguillaum committed
384 385
       (fun acc -> function
         | (Command.ADD_EDGE (src_cn,tar_cn,edge),loc) ->
386
             (find src_cn (matching, created_nodes), edge, find tar_cn (matching, created_nodes)) :: acc
387
         | _ -> acc
pj2m's avatar
pj2m committed
388 389 390 391 392 393
       ) [] commands
   }

  exception Fail
(* ================================================================================ *)
  type partial = {
bguillaum's avatar
bguillaum committed
394
      sub: matching;
395 396 397
      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
398
      check: const list (* constraints to verify at the end of the matching *)
bguillaum's avatar
bguillaum committed
399 400 401 402
    }

        (* PREREQUISITES:
           - all partial matching have the same domain
403 404
           - the domain of the pattern P is the disjoint union of domain([sub]) and [unmatched_nodes]
         *)
pj2m's avatar
pj2m committed
405

bguillaum's avatar
bguillaum committed
406
  let init param pattern =
407
    let roots = P_graph.roots pattern.graph in
pj2m's avatar
pj2m committed
408

409
    let node_list = Pid_map.fold (fun pid _ acc -> pid::acc) pattern.graph [] in
pj2m's avatar
pj2m committed
410 411

    (* put all roots in the front of the list to speed up the algo *)
bguillaum's avatar
bguillaum committed
412
    let sorted_node_list =
pj2m's avatar
pj2m committed
413
      List.sort
414 415 416 417
        (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
418

bguillaum's avatar
bguillaum committed
419
    { sub = empty_matching param;
pj2m's avatar
pj2m committed
420 421 422 423 424 425
      unmatched_nodes = sorted_node_list;
      unmatched_edges = [];
      already_matched_gids = [];
      check = pattern.constraints;
    }

426 427 428 429 430 431 432 433
(* (\* Ocaml < 3.12 doesn't have exists function for maps! *\) *)
(*   exception True *)
(*   let gid_map_exists fct map = *)
(*     try *)
(*       Gid_map.iter (fun k v -> if fct k v then raise True) map; *)
(*       false *)
(*     with True -> true *)
(* (\* Ocaml < 3.12 doesn't have exists function for maps! *\) *)
434 435


bguillaum's avatar
bguillaum committed
436 437
  let fullfill graph matching cst =
    let get_node pid = G_graph.find (Pid_map.find pid matching.n_match) graph in
438 439 440 441 442 443
    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
444 445 446

    match cst with
      | Cst_out (pid,edge) ->
447 448
        let gid = Pid_map.find pid matching.n_match in
        G_graph.edge_out graph gid edge
bguillaum's avatar
bguillaum committed
449
      | Cst_in (pid,edge) ->
450
        let gid = Pid_map.find pid matching.n_match in
451 452
        G_graph.node_exists
          (fun node ->
453
            List.exists (fun e -> P_edge.compatible edge e) (Massoc_gid.assoc gid (G_node.get_next node))
454
          ) graph
bguillaum's avatar
bguillaum committed
455
      | Filter (pid, fs) ->
456
        let gid = Pid_map.find pid matching.n_match in
457
        let gnode = G_graph.find gid graph in
458
        P_fs.filter fs (G_node.get_fs gnode)
bguillaum's avatar
bguillaum committed
459 460 461 462 463 464 465 466 467 468 469 470 471
      | Feature_eq (pid1, feat_name1, pid2, feat_name2) ->
        begin
          match (get_string_feat pid1 feat_name1, get_string_feat pid2 feat_name2) with
            | Some fv1, Some fv2 when fv1 = fv2 -> true
            | _ -> false
        end
      | Feature_diseq (pid1, feat_name1, pid2, feat_name2) ->
        begin
          match (get_string_feat pid1 feat_name1, get_string_feat pid2 feat_name2) with
            | Some fv1, Some fv2 when fv1 <> fv2 -> true
            | _ -> false
        end
      | Feature_ineq (ineq, pid1, feat_name1, pid2, feat_name2) ->
bguillaum's avatar
bguillaum committed
472
        match (ineq, get_float_feat pid1 feat_name1, get_float_feat pid2 feat_name2) with
bguillaum's avatar
bguillaum committed
473 474 475 476 477
            | (Ast.Lt, Some fv1, Some fv2) when fv1 < fv2 -> true
            | (Ast.Gt, Some fv1, Some fv2) when fv1 > fv2 -> true
            | (Ast.Le, Some fv1, Some fv2) when fv1 <= fv2 -> true
            | (Ast.Ge, Some fv1, Some fv2) when fv1 >= fv2 -> true
            | _ -> false
pj2m's avatar
pj2m committed
478

bguillaum's avatar
bguillaum committed
479
  (* returns all extension of the partial input matching *)
480
  let rec extend_matching (positive,neg) (graph:G_graph.t) (partial:partial) =
pj2m's avatar
pj2m committed
481
    match (partial.unmatched_edges, partial.unmatched_nodes) with
bguillaum's avatar
bguillaum committed
482 483
    | [], [] ->
        if List.for_all (fun const -> fullfill graph partial.sub const) partial.check
484 485
        then [partial.sub, partial.already_matched_gids]
        else []
pj2m's avatar
pj2m committed
486
    | (src_pid, p_edge, tar_pid)::tail_ue, _ ->
487 488
        begin
          try (* is the tar already found in the matching ? *)
bguillaum's avatar
bguillaum committed
489
            let new_partials =
490 491 492
              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
493
              let g_edges = Massoc_gid.assoc tar_gid (G_node.get_next src_gnode) in
bguillaum's avatar
bguillaum committed
494

495 496
              match P_edge.match_list p_edge g_edges with
              | P_edge.Fail -> (* no good edge in graph for this pattern edge -> stop here *)
497
                  []
498
              | P_edge.Ok label -> (* at least an edge in the graph fits the p_edge "constraint" -> go on *)
bguillaum's avatar
bguillaum committed
499
                  [ {partial with unmatched_edges = tail_ue; sub = a_match_add (src_gid,label,tar_gid) partial.sub} ]
500
              | 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
501
                  List.map
502 503
                    (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
504
                    ) labels
505 506 507
            in List_.flat_map (extend_matching (positive,neg) graph) new_partials
          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
508
              let (src_gid : Gid.t) = Pid_map.find src_pid partial.sub.n_match in
509
              let src_gnode = G_graph.find src_gid graph in
510
              Massoc_gid.fold
511
                (fun acc gid_next g_edge ->
512 513
                  match P_edge.match_ p_edge g_edge with
                  | P_edge.Fail -> (* g_edge does not fit, no new candidate *)
514
                      acc
515
                  | P_edge.Ok label -> (* g_edge fits with the same matching *)
bguillaum's avatar
bguillaum committed
516
                      (gid_next, a_match_add (src_gid, label, gid_next) partial.sub) :: acc
517
                  | P_edge.Binds (id,[label]) -> (* g_edge fits with an extended matching *)
518
                      (gid_next, e_match_add (id, (src_gid, label, gid_next)) partial.sub) :: acc
519 520
                  | _ -> Error.bug "P_edge.match_ must return exactly one label"
                ) [] (G_node.get_next src_gnode) in
521
            List_.flat_map
bguillaum's avatar
bguillaum committed
522
              (fun (gid_next, matching) ->
523 524 525 526
                extend_matching_from (positive,neg) graph tar_pid gid_next
                  {partial with sub=matching; unmatched_edges = tail_ue}
              ) candidates
        end
bguillaum's avatar
bguillaum committed
527
    | [], pid :: _ ->
528 529
        G_graph.fold_gid
          (fun gid acc ->
530
            (extend_matching_from (positive,neg) graph pid gid partial) @ acc
531
          ) graph []
bguillaum's avatar
bguillaum committed
532 533

  and extend_matching_from (positive,neg) (graph:G_graph.t) pid (gid : Gid.t) partial =
pj2m's avatar
pj2m committed
534 535 536
    if List.mem gid partial.already_matched_gids
    then [] (* the required association pid -> gid is not injective *)
    else
bguillaum's avatar
bguillaum committed
537 538 539 540 541 542 543 544 545 546
      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 *)
547
      let g_node = try G_graph.find gid graph with Not_found -> failwith "INS" in
bguillaum's avatar
bguillaum committed
548

bguillaum's avatar
bguillaum committed
549
      try
550 551 552

        let new_param = P_node.match_ ?param: partial.sub.m_param p_node g_node in

553
        (* add all out-edges from pid in pattern *)
bguillaum's avatar
bguillaum committed
554 555
        let new_unmatched_edges =
          Massoc_pid.fold
556
            (fun acc pid_next p_edge -> (pid, p_edge, pid_next) :: acc
557
            ) partial.unmatched_edges (P_node.get_next p_node) in
bguillaum's avatar
bguillaum committed
558 559

        let new_partial =
bguillaum's avatar
bguillaum committed
560
          { partial with
bguillaum's avatar
bguillaum committed
561
            unmatched_nodes = (try List_.rm pid partial.unmatched_nodes with Not_found -> failwith "List_.rm");
bguillaum's avatar
bguillaum committed
562 563 564 565
            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
566
        extend_matching (positive,neg) graph new_partial
567
      with P_fs.Fail -> []
pj2m's avatar
pj2m committed
568 569

(* the exception below is added to handle unification failure in merge!! *)
570
  exception Command_execution_fail
pj2m's avatar
pj2m committed
571 572

(** [apply_command instance matching created_nodes command] returns [(new_instance, new_created_nodes)] *)
bguillaum's avatar
bguillaum committed
573 574
  let apply_command (command,loc) instance matching (created_nodes, (activated_nodes:((Pid.t * string) * Gid.t) list)) =
    let node_find cnode = find ~loc cnode (matching, (created_nodes, activated_nodes)) in
575 576

    match command with
bguillaum's avatar
bguillaum committed
577
    | Command.ADD_EDGE (src_cn,tar_cn,edge) ->
578 579 580
        let src_gid = node_find src_cn in
        let tar_gid = node_find tar_cn in
        begin
581
          match G_graph.add_edge instance.Instance.graph src_gid edge tar_gid with
bguillaum's avatar
bguillaum committed
582
          | Some new_graph ->
583
              (
bguillaum's avatar
bguillaum committed
584 585
               {instance with
                Instance.graph = new_graph;
586
                history = List_.sort_insert (Command.H_ADD_EDGE (src_gid,tar_gid,edge)) instance.Instance.history
587
              },
bguillaum's avatar
bguillaum committed
588
               (created_nodes, activated_nodes)
589
              )
bguillaum's avatar
bguillaum committed
590
          | None ->
591
              Error.run "ADD_EDGE: the edge '%s' already exists %s" (G_edge.to_string edge) (Loc.to_string loc)
592 593
        end

bguillaum's avatar
bguillaum committed
594
    | Command.DEL_EDGE_EXPL (src_cn,tar_cn,edge) ->
595 596 597
        let src_gid = node_find src_cn in
        let tar_gid = node_find tar_cn in
        (
bguillaum's avatar
bguillaum committed
598 599
         {instance with
          Instance.graph = G_graph.del_edge loc instance.Instance.graph src_gid edge tar_gid;
600
           history = List_.sort_insert (Command.H_DEL_EDGE_EXPL (src_gid,tar_gid,edge)) instance.Instance.history
601
        },
bguillaum's avatar
bguillaum committed
602
         (created_nodes, activated_nodes)
603 604 605
        )

    | Command.DEL_EDGE_NAME edge_ident ->
bguillaum's avatar
bguillaum committed
606 607
        let (src_gid,edge,tar_gid) =
          try List.assoc edge_ident matching.e_match
608 609
          with Not_found -> Error.bug "The edge identifier '%s' is undefined %s" edge_ident (Loc.to_string loc) in
        (
bguillaum's avatar
bguillaum committed
610 611
         {instance with
          Instance.graph = G_graph.del_edge ~edge_ident loc instance.Instance.graph src_gid edge tar_gid;
612
          history = List_.sort_insert (Command.H_DEL_EDGE_EXPL (src_gid,tar_gid,edge)) instance.Instance.history
613
        },
bguillaum's avatar
bguillaum committed
614
         (created_nodes, activated_nodes)
bguillaum's avatar
bguillaum committed
615
        )
616

bguillaum's avatar
bguillaum committed
617
    | Command.DEL_NODE node_cn ->
618 619
        let node_gid = node_find node_cn in
        (
bguillaum's avatar
bguillaum committed
620
         {instance with
621
          Instance.graph = G_graph.del_node instance.Instance.graph node_gid;
622
          history = List_.sort_insert (Command.H_DEL_NODE node_gid) instance.Instance.history
623
        },
bguillaum's avatar
bguillaum committed
624
         (created_nodes, activated_nodes)
625 626 627 628 629
        )

    | Command.MERGE_NODE (src_cn, tar_cn) ->
        let src_gid = node_find src_cn in
        let tar_gid = node_find tar_cn in
630
        (match G_graph.merge_node loc instance.Instance.graph src_gid tar_gid with
bguillaum's avatar
bguillaum committed
631
        | Some new_graph ->
632
            (
bguillaum's avatar
bguillaum committed
633
             {instance with
634
              Instance.graph = new_graph;
635
              history = List_.sort_insert (Command.H_MERGE_NODE (src_gid,tar_gid)) instance.Instance.history
636
            },
bguillaum's avatar
bguillaum committed
637
             (created_nodes, activated_nodes)
638 639 640
            )
        | None -> raise Command_execution_fail
        )
bguillaum's avatar
bguillaum committed
641

642
    | Command.UPDATE_FEAT (tar_cn,tar_feat_name, item_list) ->
bguillaum's avatar
bguillaum committed
643
        let tar_gid = node_find tar_cn in
644 645
        let rule_items = List.map
            (function
bguillaum's avatar
bguillaum committed
646 647
              | 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
648
              | Command.Param_out index ->
bguillaum's avatar
bguillaum committed
649 650
                  (match matching.m_param with
                  | None -> Error.bug "Cannot apply a UPDATE_FEAT command without parameter"
bguillaum's avatar
bguillaum committed
651
                  | Some param -> Concat_item.String (Lex_par.get_command_value index param))
bguillaum's avatar
bguillaum committed
652
              | Command.Param_in index ->
bguillaum's avatar
bguillaum committed
653
                  (match matching.m_param with
654
                  | None -> Error.bug "Cannot apply a UPDATE_FEAT command without parameter"
bguillaum's avatar
bguillaum committed
655
                  | Some param -> Concat_item.String (Lex_par.get_param_value index param))
656
            ) item_list in
657

bguillaum's avatar
bguillaum committed
658
        let (new_graph, new_feature_value) =
659
          G_graph.update_feat ~loc instance.Instance.graph tar_gid tar_feat_name rule_items in
bguillaum's avatar
bguillaum committed
660
        (
661 662
         {instance with
          Instance.graph = new_graph;
663
          history = List_.sort_insert (Command.H_UPDATE_FEAT (tar_gid,tar_feat_name,new_feature_value)) instance.Instance.history
bguillaum's avatar
bguillaum committed
664
        },
bguillaum's avatar
bguillaum committed
665
         (created_nodes, activated_nodes)
666
        )
667 668 669 670

    | Command.DEL_FEAT (tar_cn,feat_name) ->
        let tar_gid = node_find tar_cn in
        (
bguillaum's avatar
bguillaum committed
671
         {instance with
672
          Instance.graph = G_graph.del_feat instance.Instance.graph tar_gid feat_name;
673
          history = List_.sort_insert (Command.H_DEL_FEAT (tar_gid,feat_name)) instance.Instance.history
674
        },
bguillaum's avatar
bguillaum committed
675
         (created_nodes, activated_nodes)
bguillaum's avatar
bguillaum committed
676
        )
677 678

    | Command.NEW_NEIGHBOUR (created_name,edge,base_pid) ->
679 680
        let base_gid = Pid_map.find base_pid matching.n_match in
        let (new_gid,new_graph) = G_graph.add_neighbour loc instance.Instance.graph base_gid edge in
681
        (
bguillaum's avatar
bguillaum committed
682
         {instance with
683
          Instance.graph = new_graph;
684 685
          history = List_.sort_insert (Command.H_NEW_NEIGHBOUR (created_name,edge,new_gid)) instance.Instance.history;
          activated_node = new_gid :: instance.Instance.activated_node;
686
        },
bguillaum's avatar
bguillaum committed
687 688 689 690 691 692 693 694 695 696 697 698
         ((created_name,new_gid) :: created_nodes, activated_nodes)
        )

    | Command.ACT_NODE (Command.Act (pid, new_name)) ->
        let node_gid = node_find (Command.Pat(pid)) in
        let (new_gid, new_graph) = G_graph.activate loc node_gid new_name instance.Instance.graph in
        (
         {instance with
          Instance.graph = new_graph;
          history = List_.sort_insert (Command.H_ACT_NODE (node_gid,new_name)) instance.Instance.history
        },
         (created_nodes, ((pid, new_name), new_gid) :: activated_nodes)
699
        )
700
    | Command.ACT_NODE _ -> Error.bug "Try to activate a node without suffix" (Loc.to_string loc)
701

702 703 704 705
    | Command.SHIFT_IN (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
706 707
         {instance with
          Instance.graph = G_graph.shift_in loc instance.Instance.graph src_gid tar_gid;
708
          history = List_.sort_insert (Command.H_SHIFT_IN (src_gid,tar_gid)) instance.Instance.history
709
        },
bguillaum's avatar
bguillaum committed
710
         (created_nodes, activated_nodes)
711 712 713 714 715 716
        )

    | Command.SHIFT_OUT (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
717 718
         {instance with
          Instance.graph = G_graph.shift_out loc instance.Instance.graph src_gid tar_gid;
719
          history = List_.sort_insert (Command.H_SHIFT_OUT (src_gid,tar_gid)) instance.Instance.history
720
        },
bguillaum's avatar
bguillaum committed
721
         (created_nodes, activated_nodes)
722 723
        )

bguillaum's avatar
bguillaum committed
724
    | Command.SHIFT_EDGE (src_cn,tar_cn) ->
725 726 727
        let src_gid = node_find src_cn in
        let tar_gid = node_find tar_cn in
        (
728 729 730 731
          {instance with
            Instance.graph = G_graph.shift_edges loc instance.Instance.graph src_gid tar_gid;
            history = List_.sort_insert (Command.H_SHIFT_EDGE (src_gid,tar_gid)) instance.Instance.history
          },
bguillaum's avatar
bguillaum committed
732
          (created_nodes, activated_nodes)
733
        )
pj2m's avatar
pj2m committed
734

bguillaum's avatar
bguillaum committed
735
(** [apply_rule instance matching rule] returns a new instance after the application of the rule
pj2m's avatar
pj2m committed
736 737
    [Command_execution_fail] is raised if some merge unification fails
 *)
bguillaum's avatar
bguillaum committed
738
  let apply_rule instance matching rule =
pj2m's avatar
pj2m committed
739

bguillaum's avatar
bguillaum committed
740 741 742
    (* Timeout check *)
    (try Timeout.check () with Timeout.Stop -> Error.run "Time out");

743 744
    (* limit the rewriting depth to avoid looping rewriting *)
    begin
bguillaum's avatar
bguillaum committed
745
      if List.length instance.Instance.rules >= !max_depth
746 747
      then Error.run "Bound reached (when applying rule %s)" rule.name
    end;
bguillaum's avatar
bguillaum committed
748

749
    let (new_instance, created_nodes) =
bguillaum's avatar
bguillaum committed
750
      List.fold_left
751 752
        (fun (instance, created_nodes) command ->
          apply_command command instance matching created_nodes
bguillaum's avatar
bguillaum committed
753
        )
bguillaum's avatar
bguillaum committed
754
        (instance, ([],[]))
755 756
        rule.commands in

757
    let rule_app = {
758
      Libgrew_types.rule_name = rule.name;
759
      up = up_deco rule matching;
760 761
      down = down_deco (matching,created_nodes) rule.commands
    } in
pj2m's avatar
pj2m committed
762

bguillaum's avatar
bguillaum committed
763
    {new_instance with
764 765
      Instance.rules = rule.name :: new_instance.Instance.rules;
      big_step = match new_instance.Instance.big_step with
766 767
        | None -> Some { Libgrew_types.first = rule_app; small_step = [] }
        | Some bs -> Some { bs with Libgrew_types.small_step = (instance.Instance.graph, rule_app) :: bs.Libgrew_types.small_step }
768
    }
pj2m's avatar
pj2m committed
769 770 771

(*-----------------------------*)

bguillaum's avatar
bguillaum committed
772
  let update_partial pos_graph without (sub, already_matched_gids) =
773
    let neg_graph = without.graph in
bguillaum's avatar
bguillaum committed
774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793
    let unmatched_nodes =
      Pid_map.fold
        (fun pid _ acc -> match pid with Pid.Neg _ -> pid::acc | _ -> acc)
        neg_graph [] in
    let unmatched_edges =
      Pid_map.fold
        (fun pid node acc ->
          match pid with
            | Pid.Neg _ -> acc
            | Pid.Pos i ->
          (* if pid < 0  *)
          (* then acc *)
          (* else  *)
              Massoc_pid.fold
                (fun acc2 pid_next p_edge -> (pid, p_edge, pid_next) :: acc2)
                acc (P_node.get_next node)

            (* Massoc.fold_left  *)
            (*   (fun acc2 pid_next p_edge -> (pid, p_edge, pid_next) :: acc2) *)
            (*   acc (P_node.get_next node) *)
794
        ) neg_graph [] in
795 796 797 798 799 800 801
    {
     sub = sub;
     unmatched_nodes = unmatched_nodes;
     unmatched_edges = unmatched_edges;
     already_matched_gids = already_matched_gids;
     check = without.constraints;
   }
bguillaum's avatar
bguillaum committed
802

pj2m's avatar
pj2m committed
803

804 805 806
  let fulfill (pos_graph,neg_graph) graph new_partial_matching  =
    match extend_matching (pos_graph, neg_graph) graph new_partial_matching with
    | [] -> true (* the without pattern in not found -> OK *)
bguillaum's avatar
bguillaum committed
807
    | x -> false
pj2m's avatar
pj2m committed
808 809


bguillaum's avatar
bguillaum committed
810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842
(* ================================================================================ *)
(* ================================================================================ *)
(* ================================================================================ *)
(* ================================================================================ *)
  let match_in_graph rule graph =
    let pos_graph = rule.pos.graph in

    (* get the list of partial matching for positive part of the pattern *)
    let matching_list =
      extend_matching
        (pos_graph,P_graph.empty)
        graph
        (init rule.param rule.pos) in

    let filtered_matching_list =
      List.filter
        (fun (sub, already_matched_gids) ->
          List.for_all
            (fun without ->
              let neg_graph = without.graph in
              let new_partial_matching = update_partial pos_graph without (sub, already_matched_gids) in
              fulfill (pos_graph,neg_graph) graph new_partial_matching
            ) rule.neg
        ) matching_list in

    List.map fst filtered_matching_list
(* ================================================================================ *)
(* ================================================================================ *)
(* ================================================================================ *)
(* ================================================================================ *)


  (** [one_step instance rules] computes the list of one-step reduct with rules *)
843
  let one_step instance rules =
bguillaum's avatar
bguillaum committed
844 845
    List.fold_left
      (fun acc rule ->
bguillaum's avatar
bguillaum committed
846
        let matching_list = match_in_graph rule instance.Instance.graph in
bguillaum's avatar
bguillaum committed
847 848

        List.fold_left
bguillaum's avatar
bguillaum committed
849
          (fun acc1 matching ->
bguillaum's avatar
bguillaum committed
850
            try (apply_rule instance matching rule) :: acc1
bguillaum's avatar
bguillaum committed
851 852
            with Command_execution_fail -> acc1
          ) acc matching_list
bguillaum's avatar
bguillaum committed
853
      ) [] rules
pj2m's avatar
pj2m committed
854 855

(** [conf_one_step instance rules] computes one Some (one-step reduct) with rules, None if no rule apply *)
856 857 858 859 860 861
  let rec conf_one_step (instance : Instance.t) = function
    | [] -> None
    | rule::rule_tail ->
        let pos_graph = rule.pos.graph in

        (* get the list of partial matching for positive part of the pattern *)
bguillaum's avatar
bguillaum committed
862 863 864 865
        let matching_list =
          extend_matching
            (pos_graph,P_graph.empty)
            instance.Instance.graph
bguillaum's avatar
bguillaum committed
866
            (init rule.param rule.pos) in
bguillaum's avatar
bguillaum committed
867 868

        try
869 870 871
          let (first_matching_where_all_witout_are_fulfilled,_) =
            List.find
              (fun (sub, already_matched_gids) ->
bguillaum's avatar
bguillaum committed
872 873
                List.for_all
                  (fun without ->
874 875 876 877 878 879 880
                    let neg_graph = without.graph in
                    let new_partial_matching = update_partial pos_graph without (sub, already_matched_gids) in
                    fulfill (pos_graph,neg_graph) instance.Instance.graph new_partial_matching
                  ) rule.neg
              ) matching_list in
          Some (apply_rule instance first_matching_where_all_witout_are_fulfilled rule)
        with Not_found -> (* try another rule *) conf_one_step instance rule_tail
pj2m's avatar
pj2m committed
881 882 883


(** filter nfs being equal *)
884
  let rec filter_equal_nfs nfs =
bguillaum's avatar
bguillaum committed
885
    Instance_set.fold
886 887 888 889 890
      (fun nf acc ->
        if Instance_set.exists (fun e -> G_graph.equals e.Instance.graph nf.Instance.graph) acc
        then acc
        else Instance_set.add nf acc
      ) nfs Instance_set.empty
bguillaum's avatar
bguillaum committed
891

pj2m's avatar
pj2m committed
892 893
(** normalize [t] according to the [rules]
 * [t] is a raw graph
894
 * Info about the commands applied on [t] are kept
pj2m's avatar
pj2m committed
895 896
 *)

897
  (* type: Instance.t -> t list -> Instance_set.t *)
898
  let normalize_instance modul_name instance rules =
899 900 901
    let rec loop to_do_set nf_set =
      if to_do_set = Instance_set.empty
      then nf_set
902
      else
903
        let (new_to_do_set,new_nf_set) =
bguillaum's avatar
bguillaum committed
904
          Instance_set.fold
905 906 907 908
            (fun v (to_do_set_acc,nf_set_acc) ->
              match one_step v rules with
                | [] -> (to_do_set_acc,Instance_set.add (Instance.rev_steps v) nf_set_acc)
                | step_of_v -> (List.fold_left (fun acc v1 -> Instance_set.add v1 acc) to_do_set_acc step_of_v, nf_set_acc)
909
            )
910 911
            to_do_set (Instance_set.empty,nf_set) in
        loop new_to_do_set new_nf_set in