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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

bguillaum's avatar
bguillaum committed
172
  let build_neg_basic ?pat_vars ?(locals=[||]) pos_table basic_ast =
pj2m's avatar
pj2m committed
173
    let (extension, neg_table) =
bguillaum's avatar
bguillaum committed
174
      P_graph.build_extension ?pat_vars ~locals pos_table basic_ast.Ast.pat_nodes basic_ast.Ast.pat_edges in
bguillaum's avatar
bguillaum committed
175

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
      graph = extension.P_graph.ext_map;
bguillaum's avatar
bguillaum committed
179
      constraints = filters @ List.map (build_neg_constraint ~locals pos_table neg_table) basic_ast.Ast.pat_const ;
bguillaum's avatar
bguillaum committed
180
    }
pj2m's avatar
pj2m committed
181

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

190 191 192
  (* a [pattern] is described by the positive basic and a list of negative basics. *)
  type pattern = basic * basic list

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

bguillaum's avatar
bguillaum committed
202 203
  let get_name t = t.name

204
  let get_loc t = t.loc
pj2m's avatar
pj2m committed
205

206 207 208
  let is_filter t = t.commands = []

  (* ====================================================================== *)
209
  let to_dep t =
210
    let pos_basic = fst t.pattern in
211 212 213
    let buff = Buffer.create 32 in
    bprintf buff "[GRAPH] { scale = 200; }\n";

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

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

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

239
    bprintf buff "[EDGES] {\n";
bguillaum's avatar
bguillaum committed
240

241 242
    Pid_map.iter
      (fun id_src node ->
bguillaum's avatar
bguillaum committed
243
        Massoc_pid.iter
244
          (fun id_tar edge ->
bguillaum's avatar
bguillaum committed
245 246 247
            bprintf buff "  N_%s -> N_%s { label=\"%s\"}\n"
              (Pid.to_id id_src)
              (Pid.to_id id_tar)
248 249 250
              (P_edge.to_string edge)
          )
          (P_node.get_next node)
251
      ) pos_basic.graph;
252 253 254 255 256

    List_.iteri
      (fun i cst ->
        match cst with
          | Cst_out (pid, edge) ->
bguillaum's avatar
bguillaum committed
257 258 259 260 261
            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)
262
          | _ -> ()
263
      ) pos_basic.constraints;
264 265
    bprintf buff "}\n";
    Buffer.contents buff
bguillaum's avatar
bguillaum committed
266

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

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

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

299
  (* ====================================================================== *)
300
  let build ?(locals=[||]) suffixes dir rule_ast =
bguillaum's avatar
bguillaum committed
301 302

    let (param, pat_vars, cmd_vars) =
bguillaum's avatar
bguillaum committed
303 304
      match rule_ast.Ast.param with
      | None -> (None,[],[])
305
      | Some (files,vars) ->
bguillaum's avatar
bguillaum committed
306 307 308
          let (pat_vars, cmd_vars) = parse_vars rule_ast.Ast.rule_loc vars in
          let nb_pv = List.length pat_vars in
          let nb_cv = List.length cmd_vars in
bguillaum's avatar
bguillaum committed
309 310 311 312 313 314

          let local_param = match rule_ast.Ast.lex_par with
          | None -> None
          | Some lines -> Some (Lex_par.from_lines ~loc:rule_ast.Ast.rule_loc nb_pv nb_cv lines) in

          let full_param = List.fold_left
315
            (fun acc file ->
bguillaum's avatar
bguillaum committed
316 317 318 319 320 321
              match acc with
              | None -> Some (Lex_par.load ~loc:rule_ast.Ast.rule_loc dir nb_pv nb_cv file)
              | Some lp -> Some (Lex_par.append (Lex_par.load ~loc:rule_ast.Ast.rule_loc dir nb_pv nb_cv file) lp)
            ) local_param files in

          (full_param, pat_vars, cmd_vars) in
322

bguillaum's avatar
bguillaum committed
323
    let (pos, pos_table) = build_pos_basic ~pat_vars ~locals rule_ast.Ast.pos_basic in
bguillaum's avatar
bguillaum committed
324
    let negs = List.map (fun basic_ast -> build_neg_basic ~pat_vars ~locals pos_table basic_ast) rule_ast.Ast.neg_basics in
pj2m's avatar
pj2m committed
325
    {
bguillaum's avatar
bguillaum committed
326
      name = rule_ast.Ast.rule_id;
327
      pattern = (pos, negs);
328
      commands = build_commands ~param:(pat_vars,cmd_vars) ~locals suffixes pos pos_table rule_ast.Ast.commands;
bguillaum's avatar
bguillaum committed
329 330 331 332 333
      loc = rule_ast.Ast.rule_loc;
      param = param;
      param_names = (pat_vars,cmd_vars)
    }

334 335 336
  let build_pattern pattern_ast =
    let (pos, pos_table) = build_pos_basic pattern_ast.Ast.pat_pos in
    let negs = List.map (fun basic_ast -> build_neg_basic pos_table basic_ast) pattern_ast.Ast.pat_negs in
bguillaum's avatar
bguillaum committed
337 338
    (pos, negs)

339
  (* ====================================================================== *)
pj2m's avatar
pj2m committed
340
  type matching = {
341
      n_match: Gid.t Pid_map.t;                     (* partial fct: pattern nodes |--> graph nodes *)
342
      e_match: (string*(Gid.t*Label.t*Gid.t)) list; (* edge matching: edge ident  |--> (src,label,tar) *)
bguillaum's avatar
bguillaum committed
343
      a_match: (Gid.t*Label.t*Gid.t) list;          (* anonymous edge matched *)
344
      m_param: Lex_par.t option;
pj2m's avatar
pj2m committed
345
    }
346

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

pj2m's avatar
pj2m committed
349 350
  let e_comp (e1,_) (e2,_) = compare e1 e2

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

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

358
  let match_deco pattern matching =
359 360 361
    { G_deco.nodes =
        Pid_map.fold
          (fun pid gid acc ->
362
            let pnode = P_graph.find pid (fst pattern).graph in
363 364
            (gid, (P_node.get_name pnode, P_fs.feat_list (P_node.get_fs pnode))) ::acc
          ) matching.n_match [];
365
      G_deco.edges = List.fold_left (fun acc (_,edge) -> edge::acc) matching.a_match matching.e_match;
pj2m's avatar
pj2m committed
366 367
    }

bguillaum's avatar
bguillaum committed
368
  let find cnode ?loc (matching, (created_nodes,activated_nodes)) =
pj2m's avatar
pj2m committed
369
    match cnode with
370
    | Command.Pat pid ->
371
        (try Pid_map.find pid matching.n_match
bguillaum's avatar
bguillaum committed
372 373
        with Not_found -> Error.bug ?loc "Inconsistent matching pid '%s' not found" (Pid.to_string pid))
    | Command.New name ->
bguillaum's avatar
bguillaum committed
374 375
        (try List.assoc name created_nodes
        with Not_found -> Error.run ?loc "Identifier '%s' not found" name)
bguillaum's avatar
bguillaum committed
376 377 378 379
    | 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
380

pj2m's avatar
pj2m committed
381 382

  let down_deco (matching,created_nodes) commands =
383 384 385 386 387 388 389 390 391 392
    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
393
    {
394
     G_deco.nodes = List.map (fun (gid,feat_list) -> (gid, ("",feat_list))) (Gid_map.bindings feat_to_highlight);
395
     G_deco.edges = List.fold_left
bguillaum's avatar
bguillaum committed
396 397
       (fun acc -> function
         | (Command.ADD_EDGE (src_cn,tar_cn,edge),loc) ->
398
             (find src_cn (matching, created_nodes), edge, find tar_cn (matching, created_nodes)) :: acc
399
         | _ -> acc
pj2m's avatar
pj2m committed
400 401 402 403 404
       ) [] commands
   }

  exception Fail
  type partial = {
bguillaum's avatar
bguillaum committed
405
      sub: matching;
406 407 408
      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
409
      check: const list (* constraints to verify at the end of the matching *)
bguillaum's avatar
bguillaum committed
410 411 412 413
    }

        (* PREREQUISITES:
           - all partial matching have the same domain
414 415
           - the domain of the pattern P is the disjoint union of domain([sub]) and [unmatched_nodes]
         *)
bguillaum's avatar
bguillaum committed
416
  (*  ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
417 418
  let init param basic =
    let roots = P_graph.roots basic.graph in
pj2m's avatar
pj2m committed
419

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

    (* put all roots in the front of the list to speed up the algo *)
bguillaum's avatar
bguillaum committed
423
    let sorted_node_list =
pj2m's avatar
pj2m committed
424
      List.sort
425 426 427 428
        (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
429

bguillaum's avatar
bguillaum committed
430
    { sub = empty_matching param;
pj2m's avatar
pj2m committed
431 432 433
      unmatched_nodes = sorted_node_list;
      unmatched_edges = [];
      already_matched_gids = [];
bguillaum's avatar
bguillaum committed
434
      check = basic.constraints;
pj2m's avatar
pj2m committed
435 436
    }

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

    match cst with
      | Cst_out (pid,edge) ->
449
        let gid = Pid_map.find pid matching.n_match in
bguillaum's avatar
bguillaum committed
450 451 452
        if G_graph.edge_out graph gid edge
        then matching
        else raise Fail
bguillaum's avatar
bguillaum committed
453
      | Cst_in (pid,edge) ->
454
        let gid = Pid_map.find pid matching.n_match in
bguillaum's avatar
bguillaum committed
455
        if G_graph.node_exists
456
          (fun node ->
457
            List.exists (fun e -> P_edge.compatible edge e) (Massoc_gid.assoc gid (G_node.get_next node))
458
          ) graph
bguillaum's avatar
bguillaum committed
459 460
        then matching
        else raise Fail
bguillaum's avatar
bguillaum committed
461
      | Filter (pid, fs) ->
bguillaum's avatar
bguillaum committed
462 463 464 465 466 467 468 469
        begin
          try
            let gid = Pid_map.find pid matching.n_match in
            let gnode = G_graph.find gid graph in
            let new_param = P_fs.match_ ?param:matching.m_param fs (G_node.get_fs gnode) in
            {matching with m_param = new_param }
          with P_fs.Fail -> raise Fail
        end
bguillaum's avatar
bguillaum committed
470 471 472
      | Feature_eq (pid1, feat_name1, pid2, feat_name2) ->
        begin
          match (get_string_feat pid1 feat_name1, get_string_feat pid2 feat_name2) with
bguillaum's avatar
bguillaum committed
473 474
            | Some fv1, Some fv2 when fv1 = fv2 -> matching
            | _ -> raise Fail
bguillaum's avatar
bguillaum committed
475 476 477 478
        end
      | Feature_diseq (pid1, feat_name1, pid2, feat_name2) ->
        begin
          match (get_string_feat pid1 feat_name1, get_string_feat pid2 feat_name2) with
bguillaum's avatar
bguillaum committed
479 480
            | Some fv1, Some fv2 when fv1 <> fv2 -> matching
            | _ -> raise Fail
bguillaum's avatar
bguillaum committed
481 482
        end
      | Feature_ineq (ineq, pid1, feat_name1, pid2, feat_name2) ->
bguillaum's avatar
bguillaum committed
483
        match (ineq, get_float_feat pid1 feat_name1, get_float_feat pid2 feat_name2) with
bguillaum's avatar
bguillaum committed
484 485 486 487 488
            | (Ast.Lt, Some fv1, Some fv2) when fv1 < fv2 -> matching
            | (Ast.Gt, Some fv1, Some fv2) when fv1 > fv2 -> matching
            | (Ast.Le, Some fv1, Some fv2) when fv1 <= fv2 -> matching
            | (Ast.Ge, Some fv1, Some fv2) when fv1 >= fv2 -> matching
            | _ -> raise Fail
pj2m's avatar
pj2m committed
489

bguillaum's avatar
bguillaum committed
490
  (*  ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
491
  (* returns all extension of the partial input matching *)
492
  let rec extend_matching (positive,neg) (graph:G_graph.t) (partial:partial) =
pj2m's avatar
pj2m committed
493
    match (partial.unmatched_edges, partial.unmatched_nodes) with
bguillaum's avatar
bguillaum committed
494
    | [], [] ->
bguillaum's avatar
bguillaum committed
495 496 497 498 499 500 501 502 503 504
      begin
        try
          let new_matching =
            List.fold_left
              (fun acc const ->
                apply_cst graph acc const
              ) partial.sub partial.check in
          [new_matching, partial.already_matched_gids]
        with Fail -> []
      end
pj2m's avatar
pj2m committed
505
    | (src_pid, p_edge, tar_pid)::tail_ue, _ ->
506 507
        begin
          try (* is the tar already found in the matching ? *)
bguillaum's avatar
bguillaum committed
508
            let new_partials =
509 510 511
              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
512
              let g_edges = Massoc_gid.assoc tar_gid (G_node.get_next src_gnode) in
bguillaum's avatar
bguillaum committed
513

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

bguillaum's avatar
bguillaum committed
552
  (*  ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
553
  and extend_matching_from (positive,neg) (graph:G_graph.t) pid (gid : Gid.t) partial =
pj2m's avatar
pj2m committed
554 555 556
    if List.mem gid partial.already_matched_gids
    then [] (* the required association pid -> gid is not injective *)
    else
bguillaum's avatar
bguillaum committed
557 558 559 560 561 562 563 564 565 566
      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 *)
567
      let g_node = try G_graph.find gid graph with Not_found -> failwith "INS" in
bguillaum's avatar
bguillaum committed
568

bguillaum's avatar
bguillaum committed
569
      try
570
        let new_param = P_node.match_ ?param: partial.sub.m_param p_node g_node in
571
        (* add all out-edges from pid in pattern *)
bguillaum's avatar
bguillaum committed
572 573
        let new_unmatched_edges =
          Massoc_pid.fold
574
            (fun acc pid_next p_edge -> (pid, p_edge, pid_next) :: acc
575
            ) partial.unmatched_edges (P_node.get_next p_node) in
bguillaum's avatar
bguillaum committed
576 577

        let new_partial =
bguillaum's avatar
bguillaum committed
578
          { partial with
bguillaum's avatar
bguillaum committed
579
            unmatched_nodes = (try List_.rm pid partial.unmatched_nodes with Not_found -> failwith "List_.rm");
bguillaum's avatar
bguillaum committed
580 581 582 583
            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
584
        extend_matching (positive,neg) graph new_partial
585
      with P_fs.Fail -> []
pj2m's avatar
pj2m committed
586

bguillaum's avatar
bguillaum committed
587 588
  (*  ---------------------------------------------------------------------- *)
  (* the exception below is added to handle unification failure in merge!! *)
589
  exception Command_execution_fail
pj2m's avatar
pj2m committed
590

bguillaum's avatar
bguillaum committed
591 592
  (*  ---------------------------------------------------------------------- *)
  (** [apply_command instance matching created_nodes command] returns [(new_instance, new_created_nodes)] *)
bguillaum's avatar
bguillaum committed
593 594
  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
595 596

    match command with
bguillaum's avatar
bguillaum committed
597
    | Command.ADD_EDGE (src_cn,tar_cn,edge) ->
598 599 600
        let src_gid = node_find src_cn in
        let tar_gid = node_find tar_cn in
        begin
601
          match G_graph.add_edge instance.Instance.graph src_gid edge tar_gid with
bguillaum's avatar
bguillaum committed
602
          | Some new_graph ->
603
              (
bguillaum's avatar
bguillaum committed
604 605
               {instance with
                Instance.graph = new_graph;
606
                history = List_.sort_insert (Command.H_ADD_EDGE (src_gid,tar_gid,edge)) instance.Instance.history
607
              },
bguillaum's avatar
bguillaum committed
608
               (created_nodes, activated_nodes)
609
              )
bguillaum's avatar
bguillaum committed
610
          | None ->
611
              Error.run "ADD_EDGE: the edge '%s' already exists %s" (G_edge.to_string edge) (Loc.to_string loc)
612 613
        end

bguillaum's avatar
bguillaum committed
614
    | Command.DEL_EDGE_EXPL (src_cn,tar_cn,edge) ->
615 616 617
        let src_gid = node_find src_cn in
        let tar_gid = node_find tar_cn in
        (
bguillaum's avatar
bguillaum committed
618 619
         {instance with
          Instance.graph = G_graph.del_edge loc instance.Instance.graph src_gid edge tar_gid;
620
           history = List_.sort_insert (Command.H_DEL_EDGE_EXPL (src_gid,tar_gid,edge)) instance.Instance.history
621
        },
bguillaum's avatar
bguillaum committed
622
         (created_nodes, activated_nodes)
623 624 625
        )

    | Command.DEL_EDGE_NAME edge_ident ->
bguillaum's avatar
bguillaum committed
626 627
        let (src_gid,edge,tar_gid) =
          try List.assoc edge_ident matching.e_match
628 629
          with Not_found -> Error.bug "The edge identifier '%s' is undefined %s" edge_ident (Loc.to_string loc) in
        (
bguillaum's avatar
bguillaum committed
630 631
         {instance with
          Instance.graph = G_graph.del_edge ~edge_ident loc instance.Instance.graph src_gid edge tar_gid;
632
          history = List_.sort_insert (Command.H_DEL_EDGE_EXPL (src_gid,tar_gid,edge)) instance.Instance.history
633
        },
bguillaum's avatar
bguillaum committed
634
         (created_nodes, activated_nodes)
bguillaum's avatar
bguillaum committed
635
        )
636

bguillaum's avatar
bguillaum committed
637
    | Command.DEL_NODE node_cn ->
638 639
        let node_gid = node_find node_cn in
        (
bguillaum's avatar
bguillaum committed
640
         {instance with
641
          Instance.graph = G_graph.del_node instance.Instance.graph node_gid;
642
          history = List_.sort_insert (Command.H_DEL_NODE node_gid) instance.Instance.history
643
        },
bguillaum's avatar
bguillaum committed
644
         (created_nodes, activated_nodes)
645 646 647 648 649
        )

    | Command.MERGE_NODE (src_cn, tar_cn) ->
        let src_gid = node_find src_cn in
        let tar_gid = node_find tar_cn in
650
        (match G_graph.merge_node loc instance.Instance.graph src_gid tar_gid with
bguillaum's avatar
bguillaum committed
651
        | Some new_graph ->
652
            (
bguillaum's avatar
bguillaum committed
653
             {instance with
654
              Instance.graph = new_graph;
655
              history = List_.sort_insert (Command.H_MERGE_NODE (src_gid,tar_gid)) instance.Instance.history
656
            },
bguillaum's avatar
bguillaum committed
657
             (created_nodes, activated_nodes)
658 659 660
            )
        | None -> raise Command_execution_fail
        )
bguillaum's avatar
bguillaum committed
661

662
    | Command.UPDATE_FEAT (tar_cn,tar_feat_name, item_list) ->
bguillaum's avatar
bguillaum committed
663
        let tar_gid = node_find tar_cn in
664 665
        let rule_items = List.map
            (function
bguillaum's avatar
bguillaum committed
666 667
              | 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
668
              | Command.Param_out index ->
bguillaum's avatar
bguillaum committed
669 670
                  (match matching.m_param with
                  | None -> Error.bug "Cannot apply a UPDATE_FEAT command without parameter"
bguillaum's avatar
bguillaum committed
671
                  | Some param -> Concat_item.String (Lex_par.get_command_value index param))
bguillaum's avatar
bguillaum committed
672
              | Command.Param_in index ->
bguillaum's avatar
bguillaum committed
673
                  (match matching.m_param with
674
                  | None -> Error.bug "Cannot apply a UPDATE_FEAT command without parameter"
bguillaum's avatar
bguillaum committed
675
                  | Some param -> Concat_item.String (Lex_par.get_param_value index param))
676
            ) item_list in
677

bguillaum's avatar
bguillaum committed
678
        let (new_graph, new_feature_value) =
679
          G_graph.update_feat ~loc instance.Instance.graph tar_gid tar_feat_name rule_items in
bguillaum's avatar
bguillaum committed
680
        (
681 682
         {instance with
          Instance.graph = new_graph;
683
          history = List_.sort_insert (Command.H_UPDATE_FEAT (tar_gid,tar_feat_name,new_feature_value)) instance.Instance.history
bguillaum's avatar
bguillaum committed
684
        },
bguillaum's avatar
bguillaum committed
685
         (created_nodes, activated_nodes)
686
        )
687 688 689 690

    | Command.DEL_FEAT (tar_cn,feat_name) ->
        let tar_gid = node_find tar_cn in
        (
bguillaum's avatar
bguillaum committed
691
         {instance with
692
          Instance.graph = G_graph.del_feat instance.Instance.graph tar_gid feat_name;
693
          history = List_.sort_insert (Command.H_DEL_FEAT (tar_gid,feat_name)) instance.Instance.history
694
        },
bguillaum's avatar
bguillaum committed
695
         (created_nodes, activated_nodes)
bguillaum's avatar
bguillaum committed
696
        )
697 698

    | Command.NEW_NEIGHBOUR (created_name,edge,base_pid) ->
699 700
        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
701
        (
bguillaum's avatar
bguillaum committed
702
         {instance with
703
          Instance.graph = new_graph;
704 705
          history = List_.sort_insert (Command.H_NEW_NEIGHBOUR (created_name,edge,new_gid)) instance.Instance.history;
          activated_node = new_gid :: instance.Instance.activated_node;
706
        },
bguillaum's avatar
bguillaum committed
707 708 709 710 711 712 713 714 715 716 717 718
         ((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)
719
        )
720
    | Command.ACT_NODE _ -> Error.bug "Try to activate a node without suffix" (Loc.to_string loc)
721

722 723 724 725
    | 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
726 727
         {instance with
          Instance.graph = G_graph.shift_in loc instance.Instance.graph src_gid tar_gid;
728
          history = List_.sort_insert (Command.H_SHIFT_IN (src_gid,tar_gid)) instance.Instance.history
729
        },
bguillaum's avatar
bguillaum committed
730
         (created_nodes, activated_nodes)
731 732 733 734 735 736
        )

    | 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
737 738
         {instance with
          Instance.graph = G_graph.shift_out loc instance.Instance.graph src_gid tar_gid;
739
          history = List_.sort_insert (Command.H_SHIFT_OUT (src_gid,tar_gid)) instance.Instance.history
740
        },
bguillaum's avatar
bguillaum committed
741
         (created_nodes, activated_nodes)
742 743
        )

bguillaum's avatar
bguillaum committed
744
    | Command.SHIFT_EDGE (src_cn,tar_cn) ->
745 746 747
        let src_gid = node_find src_cn in
        let tar_gid = node_find tar_cn in
        (
748 749 750 751
          {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
752
          (created_nodes, activated_nodes)
753
        )
pj2m's avatar
pj2m committed
754

bguillaum's avatar
bguillaum committed
755 756 757
  (*  ---------------------------------------------------------------------- *)
  (** [apply_rule instance matching rule] returns a new instance after the application of the rule
      [Command_execution_fail] is raised if some merge unification fails *)
bguillaum's avatar
bguillaum committed
758
  let apply_rule instance matching rule =
pj2m's avatar
pj2m committed
759

bguillaum's avatar
bguillaum committed
760 761 762
    (* Timeout check *)
    (try Timeout.check () with Timeout.Stop -> Error.run "Time out");

763 764
    (* limit the rewriting depth to avoid looping rewriting *)
    begin
bguillaum's avatar
bguillaum committed
765
      if List.length instance.Instance.rules >= !max_depth
766 767
      then Error.run "Bound reached (when applying rule %s)" rule.name
    end;
bguillaum's avatar
bguillaum committed
768

769
    let (new_instance, created_nodes) =
bguillaum's avatar
bguillaum committed
770
      List.fold_left
771 772
        (fun (instance, created_nodes) command ->
          apply_command command instance matching created_nodes
bguillaum's avatar
bguillaum committed
773
        )
bguillaum's avatar
bguillaum committed
774
        (instance, ([],[]))
775 776
        rule.commands in

777
    let rule_app = {
778
      Libgrew_types.rule_name = rule.name;
779
      up = match_deco rule.pattern matching;
780 781
      down = down_deco (matching,created_nodes) rule.commands
    } in
pj2m's avatar
pj2m committed
782

bguillaum's avatar
bguillaum committed
783
    {new_instance with
784 785
      Instance.rules = rule.name :: new_instance.Instance.rules;
      big_step = match new_instance.Instance.big_step with
786 787
        | 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 }
788
    }
pj2m's avatar
pj2m committed
789

bguillaum's avatar
bguillaum committed
790
  (*  ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
791
  let update_partial pos_graph without (sub, already_matched_gids) =
792
    let neg_graph = without.graph in
bguillaum's avatar
bguillaum committed
793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812
    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) *)
813
        ) neg_graph [] in
814 815 816 817 818 819 820
    {
     sub = sub;
     unmatched_nodes = unmatched_nodes;
     unmatched_edges = unmatched_edges;
     already_matched_gids = already_matched_gids;
     check = without.constraints;
   }
bguillaum's avatar
bguillaum committed
821

pj2m's avatar
pj2m committed
822

bguillaum's avatar
bguillaum committed
823
  (*  ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
824
  let fulfill (pos_graph,neg_graph) graph new_partial_matching =
825
    match extend_matching (pos_graph, neg_graph) graph new_partial_matching with
bguillaum's avatar
bguillaum committed
826 827
    | [] -> true (* the without pattern in not found -> OK *)
    | _ -> false
pj2m's avatar
pj2m committed
828

bguillaum's avatar
bguillaum committed
829
  (*  ---------------------------------------------------------------------- *)
830 831
  let match_in_graph ?param (pos, negs) graph =
    let pos_graph = pos.graph in
bguillaum's avatar
bguillaum committed
832 833 834 835 836 837

    (* get the list of partial matching for positive part of the pattern *)
    let matching_list =
      extend_matching
        (pos_graph,P_graph.empty)
        graph
838
        (init param pos) in
bguillaum's avatar
bguillaum committed
839 840 841 842 843 844 845 846 847

    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
848
            ) negs
bguillaum's avatar
bguillaum committed
849 850 851 852
        ) matching_list in

    List.map fst filtered_matching_list

bguillaum's avatar
bguillaum committed
853
  (*  ---------------------------------------------------------------------- *)
</