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
15 16
open Grew_types

bguillaum's avatar
bguillaum committed
17
open Grew_ast
pj2m's avatar
pj2m committed
18
open Grew_edge
bguillaum's avatar
bguillaum committed
19
open Grew_fs
pj2m's avatar
pj2m committed
20
open Grew_node
bguillaum's avatar
bguillaum committed
21 22
open Grew_command
open Grew_graph
pj2m's avatar
pj2m committed
23

24

25
(* ================================================================================ *)
pj2m's avatar
pj2m committed
26 27
module Instance = struct
  type t = {
28 29 30
    graph: G_graph.t;
    history: Command.h list;
    rules: string list;
31
    big_step: Libgrew_types.big_step option;
32 33 34 35 36 37 38 39 40
    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;
41
      free_index = (G_graph.max_binding graph) + 1;
pj2m's avatar
pj2m committed
42 43
    }

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

50 51 52 53 54 55 56 57 58 59
  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
60

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

65 66
  let to_gr t = G_graph.to_gr t.graph

bguillaum's avatar
bguillaum committed
67 68
  let to_conll t = G_graph.to_conll t.graph

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

pj2m's avatar
pj2m committed
72
IFDEF DEP2PICT THEN
73
  let save_dep_png ?filter ?main_feat base t =
74 75 76 77 78 79 80 81 82 83 84
    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

85
ELSE
86 87
  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
88
ENDIF
89
end (* module Instance *)
pj2m's avatar
pj2m committed
90

91
(* ================================================================================ *)
92
module Instance_set = Set.Make (Instance)
pj2m's avatar
pj2m committed
93

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

99
  type const =
100 101 102
    | 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
103
    | Feature_diseq of Pid.t * string * Pid.t * string
bguillaum's avatar
bguillaum committed
104

105 106
    | 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
107

bguillaum's avatar
bguillaum committed
108 109 110
  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
111 112 113 114 115 116 117 118 119 120
      | (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
121
        Feature_eq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
122
      | (Ast.Feature_diseq ((node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
bguillaum's avatar
bguillaum committed
123
        Feature_diseq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
124
      | (Ast.Feature_ineq (ineq, (node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
bguillaum's avatar
bguillaum committed
125
        Feature_ineq (ineq, pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
bguillaum's avatar
bguillaum committed
126

bguillaum's avatar
bguillaum committed
127
  type pattern = {
128 129 130
    graph: P_graph.t;
    constraints: const list;
  }
pj2m's avatar
pj2m committed
131

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

bguillaum's avatar
bguillaum committed
143
  (* the neg part *)
pj2m's avatar
pj2m committed
144
  let build_neg_constraint ?locals pos_table neg_table const =
bguillaum's avatar
bguillaum committed
145 146 147 148
    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
149
    match const with
150 151 152 153 154 155 156 157 158 159 160 161 162
      | (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
163
        Feature_eq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
164 165 166
      | (Ast.Feature_diseq (qfn1, qfn2), loc) ->
        let (node_name1, feat_name1) = qfn1
        and (node_name2, feat_name2) = qfn2 in
bguillaum's avatar
bguillaum committed
167
        Feature_diseq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
168 169 170
      | (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
171
        Feature_ineq (ineq, pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
pj2m's avatar
pj2m committed
172

173
  let build_neg_pattern ?(locals=[||]) pos_table pattern_ast =
pj2m's avatar
pj2m committed
174
    let (extension, neg_table) =
175
      P_graph.build_extension ~locals pos_table pattern_ast.Ast.pat_nodes pattern_ast.Ast.pat_edges in
176
    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
177
    {
bguillaum's avatar
bguillaum committed
178 179 180
      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
181

182
  let get_edge_ids pattern =
183
    Pid_map.fold
bguillaum's avatar
bguillaum committed
184 185
      (fun _ node acc ->
        Massoc_pid.fold
186 187 188
          (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
189

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

bguillaum's avatar
bguillaum committed
200 201
  let get_name t = t.name

202
  let get_loc t = t.loc
pj2m's avatar
pj2m committed
203

204 205 206
  let is_filter t = t.commands = []

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

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

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

223 224 225 226 227 228 229 230
    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
231
          | Cst_out _ | Cst_in _ -> bprintf buff "  C_%d { word=\"*\"}\n" i
232 233 234
          | _ -> ()
      ) t.pos.constraints;
    bprintf buff "}\n";
bguillaum's avatar
bguillaum committed
235

236
    bprintf buff "[EDGES] {\n";
bguillaum's avatar
bguillaum committed
237

238 239
    Pid_map.iter
      (fun id_src node ->
bguillaum's avatar
bguillaum committed
240
        Massoc_pid.iter
241
          (fun id_tar edge ->
bguillaum's avatar
bguillaum committed
242 243 244
            bprintf buff "  N_%s -> N_%s { label=\"%s\"}\n"
              (Pid.to_id id_src)
              (Pid.to_id id_tar)
245 246 247 248 249 250 251 252 253
              (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
254 255 256 257 258
            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)
259 260 261 262
          | _ -> ()
      ) t.pos.constraints;
    bprintf buff "}\n";
    Buffer.contents buff
bguillaum's avatar
bguillaum committed
263

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

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

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

296
  (* ====================================================================== *)
297
  let build ?(locals=[||]) suffixes dir rule_ast =
bguillaum's avatar
bguillaum committed
298 299

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

bguillaum's avatar
bguillaum committed
319
    let (pos, pos_table) = build_pos_pattern ~pat_vars ~locals rule_ast.Ast.pos_pattern in
pj2m's avatar
pj2m committed
320
    {
bguillaum's avatar
bguillaum committed
321 322 323
      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;
324
      commands = build_commands ~param:(pat_vars,cmd_vars) ~locals suffixes pos pos_table rule_ast.Ast.commands;
bguillaum's avatar
bguillaum committed
325 326 327 328 329
      loc = rule_ast.Ast.rule_loc;
      param = param;
      param_names = (pat_vars,cmd_vars)
    }

330
  (* ====================================================================== *)
pj2m's avatar
pj2m committed
331
  type matching = {
332
      n_match: Gid.t Pid_map.t;                     (* partial fct: pattern nodes |--> graph nodes *)
333 334
      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 *)
335
      m_param: Lex_par.t option;
pj2m's avatar
pj2m committed
336
    }
337

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

pj2m's avatar
pj2m committed
340 341
  let e_comp (e1,_) (e2,_) = compare e1 e2

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

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

349 350 351 352 353 354 355
  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 [];
356
      G_deco.edges = List.fold_left (fun acc (_,edge) -> edge::acc) matching.a_match matching.e_match;
pj2m's avatar
pj2m committed
357 358
    }

bguillaum's avatar
bguillaum committed
359
  let find cnode ?loc (matching, (created_nodes,activated_nodes)) =
pj2m's avatar
pj2m committed
360
    match cnode with
361
    | Command.Pat pid ->
362
        (try Pid_map.find pid matching.n_match
bguillaum's avatar
bguillaum committed
363 364
        with Not_found -> Error.bug ?loc "Inconsistent matching pid '%s' not found" (Pid.to_string pid))
    | Command.New name ->
bguillaum's avatar
bguillaum committed
365 366
        (try List.assoc name created_nodes
        with Not_found -> Error.run ?loc "Identifier '%s' not found" name)
bguillaum's avatar
bguillaum committed
367 368 369 370
    | 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
371

pj2m's avatar
pj2m committed
372 373

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

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

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

bguillaum's avatar
bguillaum committed
409
  let init param pattern =
410
    let roots = P_graph.roots pattern.graph in
pj2m's avatar
pj2m committed
411

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

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

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

429 430 431 432 433 434 435 436
(* (\* 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! *\) *)
437 438


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

    match cst with
      | Cst_out (pid,edge) ->
450 451
        let gid = Pid_map.find pid matching.n_match in
        G_graph.edge_out graph gid edge
bguillaum's avatar
bguillaum committed
452
      | Cst_in (pid,edge) ->
453
        let gid = Pid_map.find pid matching.n_match in
454 455
        G_graph.node_exists
          (fun node ->
456
            List.exists (fun e -> P_edge.compatible edge e) (Massoc_gid.assoc gid (G_node.get_next node))
457
          ) graph
bguillaum's avatar
bguillaum committed
458
      | Filter (pid, fs) ->
459
        let gid = Pid_map.find pid matching.n_match in
460
        let gnode = G_graph.find gid graph in
461
        P_fs.filter fs (G_node.get_fs gnode)
bguillaum's avatar
bguillaum committed
462 463 464 465 466 467 468 469 470 471 472 473 474
      | 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
475
        match (ineq, get_float_feat pid1 feat_name1, get_float_feat pid2 feat_name2) with
bguillaum's avatar
bguillaum committed
476 477 478 479 480
            | (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
481

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

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

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

bguillaum's avatar
bguillaum committed
552
      try
553 554 555

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

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

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

(* the exception below is added to handle unification failure in merge!! *)
573
  exception Command_execution_fail
pj2m's avatar
pj2m committed
574 575

(** [apply_command instance matching created_nodes command] returns [(new_instance, new_created_nodes)] *)
bguillaum's avatar
bguillaum committed
576 577
  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
578 579

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

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

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

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

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

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

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

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

    | Command.NEW_NEIGHBOUR (created_name,edge,base_pid) ->
682 683
        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
684
        (
bguillaum's avatar
bguillaum committed
685
         {instance with
686
          Instance.graph = new_graph;
687 688
          history = List_.sort_insert (Command.H_NEW_NEIGHBOUR (created_name,edge,new_gid)) instance.Instance.history;
          activated_node = new_gid :: instance.Instance.activated_node;
689
        },
bguillaum's avatar
bguillaum committed
690 691 692 693 694 695 696 697 698 699 700 701
         ((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)
702
        )
703
    | Command.ACT_NODE _ -> Error.bug "Try to activate a node without suffix" (Loc.to_string loc)
704

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

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

bguillaum's avatar
bguillaum committed
727
    | Command.SHIFT_EDGE (src_cn,tar_cn) ->
728 729 730
        let src_gid = node_find src_cn in
        let tar_gid = node_find tar_cn in
        (
731 732 733 734
          {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
735
          (created_nodes, activated_nodes)
736
        )
pj2m's avatar
pj2m committed
737

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

bguillaum's avatar
bguillaum committed
743 744 745
    (* Timeout check *)
    (try Timeout.check () with Timeout.Stop -> Error.run "Time out");

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

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

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

bguillaum's avatar
bguillaum committed
766
    {new_instance with
767 768
      Instance.rules = rule.name :: new_instance.Instance.rules;
      big_step = match new_instance.Instance.big_step with
769 770
        | 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 }
771
    }
pj2m's avatar
pj2m committed
772 773 774

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

bguillaum's avatar
bguillaum committed
775
  let update_partial pos_graph without (sub, already_matched_gids) =
776
    let neg_graph = without.graph in
bguillaum's avatar
bguillaum committed
777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796
    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) *)
797
        ) neg_graph [] in
798 799 800 801 802 803 804
    {
     sub = sub;
     unmatched_nodes = unmatched_nodes;
     unmatched_edges = unmatched_edges;
     already_matched_gids = already_matched_gids;
     check = without.constraints;
   }
bguillaum's avatar
bguillaum committed
805

pj2m's avatar
pj2m committed
806

807 808 809
  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
810
    | x -> false
pj2m's avatar
pj2m committed
811 812


bguillaum's avatar
bguillaum committed
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 843 844 845
(* ================================================================================ *)
(* ================================================================================ *)
(* ================================================================================ *)
(* ================================================================================ *)
  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 *)
846
  let one_step instance rules =
bguillaum's avatar
bguillaum committed
847 848
    List.fold_left
      (fun acc rule ->
bguillaum's avatar
bguillaum committed
849
        let matching_list = match_in_graph rule instance.Instance.graph in
bguillaum's avatar
bguillaum committed
850 851

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

(** [conf_one_step instance rules] computes one Some (one-step reduct) with rules, None if no rule apply *)
859 860 861 862 863 864
  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
865 866 867 868
        let matching_list =
          extend_matching
            (pos_graph,P_graph.empty)
            instance.Instance.graph
bguillaum's avatar
bguillaum committed
869
            (init rule.param rule.pos) in
bguillaum's avatar
bguillaum committed
870 871

        try
872 873 874
          let (first_matching_where_all_witout_are_fulfilled,_) =
            List.find
              (fun (sub, already_matched_gids) ->
bguillaum's avatar
bguillaum committed
875 876
                List.for_all
                  (fun without ->
877 878 879 880 881 882 883
                    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
884 885 886


(** filter nfs being equal *)
887
  let rec filter_equal_nfs nfs =
bguillaum's avatar
bguillaum committed
888
    Instance_set.fold
889 890 891 892 893
      (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
894

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

900
  (* type: Instance.t -> t list -> Instance_set.t *)
901
  let normalize_instance modul_name instance rules =
902 903 904
    let rec loop to_do_set nf_set =
      if to_do_set = Instance_set.empty
      then nf_set
905
      else
906
        let (new_to_do_set,new_nf_set) =
bguillaum's avatar
bguillaum committed
907
          Instance_set.fold
908 909 910 911
            (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)