grew_rule.ml 44 KB
Newer Older
bguillaum's avatar
bguillaum committed
1 2 3 4 5 6 7 8 9 10
(**********************************************************************************)
(*    Libcaml-grew - a Graph Rewriting library dedicated to NLP applications      *)
(*                                                                                *)
(*    Copyright 2011-2013 Inria, Université de Lorraine                           *)
(*                                                                                *)
(*    Webpage: http://grew.loria.fr                                               *)
(*    License: CeCILL (see LICENSE folder or "http://www.cecill.info")            *)
(*    Authors: see AUTHORS file                                                   *)
(**********************************************************************************)

pj2m's avatar
pj2m committed
11
open Log
bguillaum's avatar
bguillaum committed
12
open Printf
pj2m's avatar
pj2m committed
13

14 15 16 17
IFDEF DEP2PICT THEN
open Dep2pict
ENDIF

18
open Grew_base
19 20
open Grew_types

bguillaum's avatar
bguillaum committed
21
open Grew_ast
pj2m's avatar
pj2m committed
22
open Grew_edge
bguillaum's avatar
bguillaum committed
23
open Grew_fs
pj2m's avatar
pj2m committed
24
open Grew_node
bguillaum's avatar
bguillaum committed
25 26
open Grew_command
open Grew_graph
pj2m's avatar
pj2m committed
27

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

bguillaum's avatar
bguillaum committed
38
  let empty = {graph = G_graph.empty; rules=[]; history=[]; big_step=None; free_index=0; }
39 40 41 42

  let from_graph graph =
    {empty with
      graph = graph;
43
      free_index = (G_graph.max_binding graph) + 1;
pj2m's avatar
pj2m committed
44 45
    }

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

bguillaum's avatar
bguillaum committed
52 53
  let flatten t = t (* TODO remove *)
(*
54 55 56 57 58 59 60 61
  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
        )
bguillaum's avatar
bguillaum committed
62
      ) ([], t.free_index) t.actiiivated_node in
63
    { empty with graph = G_graph.rename mapping t.graph; free_index = new_free }
bguillaum's avatar
bguillaum committed
64
*)
pj2m's avatar
pj2m committed
65

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

70
  let to_gr domain t = G_graph.to_gr domain t.graph
71

72
  let to_conll_string domain t = G_graph.to_conll_string domain t.graph
bguillaum's avatar
bguillaum committed
73

74 75
  let save_dot_png domain ?filter ?main_feat base t =
    ignore (Dot.to_png_file (G_graph.to_dot domain ?main_feat t.graph) (base^".png"))
76

bguillaum's avatar
bguillaum committed
77
  IFDEF DEP2PICT THEN
78 79
  let save_dep_png domain ?filter ?main_feat base t =
    let dep = G_graph.to_dep domain ?filter ?main_feat t.graph in
80 81 82
    let d2p = Dep2pict.from_dep ~dep in
    let _ = Dep2pict.save_png ~filename: (base^".png") d2p in
    Dep2pict.highlight_shift ()
83

84 85
  let save_dep_svg domain ?filter ?main_feat base t =
    let dep = G_graph.to_dep domain ?filter ?main_feat t.graph in
86 87 88 89
    let d2p = Dep2pict.from_dep ~dep in
    let _ = Dep2pict.save_svg ~filename: (base^".png") d2p in
    Dep2pict.highlight_shift ()
 
bguillaum's avatar
bguillaum committed
90
  ELSE
bguillaum's avatar
bguillaum committed
91 92
  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
93
  ENDIF
94
end (* module Instance *)
pj2m's avatar
pj2m committed
95

96
(* ================================================================================ *)
97
module Instance_set = Set.Make (Instance)
pj2m's avatar
pj2m committed
98

99
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
100 101
module Rule = struct
  (* the rewriting depth is bounded to stop rewriting when the system is not terminating *)
102
  let max_depth = ref 500
pj2m's avatar
pj2m committed
103

104
  type const =
bguillaum's avatar
bguillaum committed
105 106
    | Cst_out of Pid.t * Label_cst.t
    | Cst_in of Pid.t * Label_cst.t
107
    | Feature_eq of Pid.t * string * Pid.t * string
108
    | Feature_diseq of Pid.t * string * Pid.t * string
bguillaum's avatar
bguillaum committed
109

bguillaum's avatar
bguillaum committed
110 111
    | Feature_re of Pid.t * string * string

112
    | Feature_ineq of Ast.ineq * Pid.t * string * Pid.t * string
113 114
    | Feature_ineq_cst of Ast.ineq * Pid.t * string * float

bguillaum's avatar
bguillaum committed
115
    | 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
116

bguillaum's avatar
bguillaum committed
117 118 119
    | Prec of Pid.t * Pid.t
    | Lprec of Pid.t * Pid.t

120
  let build_pos_constraint domain ?locals pos_table const =
bguillaum's avatar
bguillaum committed
121 122
    let pid_of_name loc node_name = Pid.Pos (Id.build ~loc node_name pos_table) in
    match const with
123
      | (Ast.Cst_out (id,label_cst), loc) ->
124
        Cst_out (pid_of_name loc id, Label_cst.build ~loc domain ?locals label_cst)
125
      | (Ast.Cst_in (id,label_cst), loc) ->
126
        Cst_in (pid_of_name loc id, Label_cst.build ~loc domain ?locals label_cst)
127 128

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

133
      | (Ast.Feature_diseq ((node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
134 135
        Domain.check_feature_name domain ~loc feat_name1;
        Domain.check_feature_name domain ~loc feat_name2;
bguillaum's avatar
bguillaum committed
136
        Feature_diseq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
137

138
      | (Ast.Feature_ineq (ineq, (node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
139 140
        Domain.check_feature_name domain ~loc feat_name1;
        Domain.check_feature_name domain ~loc feat_name2;
bguillaum's avatar
bguillaum committed
141
        Feature_ineq (ineq, pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
142

143
      | (Ast.Feature_ineq_cst (ineq, (node_name1, feat_name1), constant), loc) ->
144
        Domain.check_feature_name domain ~loc feat_name1;
145 146
        Feature_ineq_cst (ineq, pid_of_name loc node_name1, feat_name1, constant)

bguillaum's avatar
bguillaum committed
147 148 149
      | (Ast.Feature_re ((node_name, feat_name), regexp), loc) ->
        Domain.check_feature_name domain ~loc feat_name;
        Feature_re (pid_of_name loc node_name, feat_name, regexp)
bguillaum's avatar
bguillaum committed
150

bguillaum's avatar
bguillaum committed
151 152 153 154 155 156
      | (Ast.Prec (id1, id2), loc) ->
        Prec (pid_of_name loc id1, pid_of_name loc id2)

      | (Ast.Lprec (id1, id2), loc) ->
        Lprec (pid_of_name loc id1, pid_of_name loc id2)

bguillaum's avatar
bguillaum committed
157
  type basic = {
158 159 160
    graph: P_graph.t;
    constraints: const list;
  }
pj2m's avatar
pj2m committed
161

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

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

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

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

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

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

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

bguillaum's avatar
bguillaum committed
216 217 218 219 220 221
      | (Ast.Prec (id1, id2), loc) ->
        Prec (pid_of_name loc id1, pid_of_name loc id2)

      | (Ast.Lprec (id1, id2), loc) ->
        Lprec (pid_of_name loc id1, pid_of_name loc id2)

bguillaum's avatar
bguillaum committed
222
  (* It may raise [P_fs.Fail_unif] in case of contradiction on constraints *)
223
  let build_neg_basic domain ?pat_vars ?(locals=[||]) pos_table basic_ast =
pj2m's avatar
pj2m committed
224
    let (extension, neg_table) =
225
      P_graph.build_extension domain ?pat_vars ~locals pos_table basic_ast.Ast.pat_nodes basic_ast.Ast.pat_edges in
bguillaum's avatar
bguillaum committed
226

227
    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
228
    {
bguillaum's avatar
bguillaum committed
229
      graph = extension.P_graph.ext_map;
230
      constraints = filters @ List.map (build_neg_constraint domain ~locals pos_table neg_table) basic_ast.Ast.pat_const ;
bguillaum's avatar
bguillaum committed
231
    }
pj2m's avatar
pj2m committed
232

bguillaum's avatar
bguillaum committed
233
  let get_edge_ids basic =
234
    Pid_map.fold
bguillaum's avatar
bguillaum committed
235 236
      (fun _ node acc ->
        Massoc_pid.fold
237 238
          (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
239
      ) basic.graph []
bguillaum's avatar
bguillaum committed
240

241 242 243
  (* a [pattern] is described by the positive basic and a list of negative basics. *)
  type pattern = basic * basic list

pj2m's avatar
pj2m committed
244 245
  type t = {
      name: string;
246
      pattern: pattern;
pj2m's avatar
pj2m committed
247
      commands: Command.t list;
248
      param: Lex_par.t option;
249
      param_names: (string list * string list);
bguillaum's avatar
bguillaum committed
250
      loc: Loc.t;
pj2m's avatar
pj2m committed
251 252
    }

bguillaum's avatar
bguillaum committed
253 254
  let get_name t = t.name

255
  let get_loc t = t.loc
pj2m's avatar
pj2m committed
256

257 258 259
  let is_filter t = t.commands = []

  (* ====================================================================== *)
260
  let to_dep domain t =
261
    let pos_basic = fst t.pattern in
262 263 264
    let buff = Buffer.create 32 in
    bprintf buff "[GRAPH] { scale = 200; }\n";

bguillaum's avatar
bguillaum committed
265 266
    let nodes =
      Pid_map.fold
267
        (fun id node acc ->
bguillaum's avatar
bguillaum committed
268 269
          (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))
270
          )
271
          :: acc
272
        ) pos_basic.graph [] in
273

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

277 278 279 280 281
    bprintf buff "[WORDS] {\n";
    List.iter
      (fun (_, dep_line) -> bprintf buff "%s\n" dep_line
      ) sorted_nodes;

282
    List.iteri
283 284
      (fun i cst ->
        match cst with
bguillaum's avatar
bguillaum committed
285
          | Cst_out _ | Cst_in _ -> bprintf buff "  C_%d { word=\"*\"}\n" i
286
          | _ -> ()
287
      ) pos_basic.constraints;
288
    bprintf buff "}\n";
bguillaum's avatar
bguillaum committed
289

290
    bprintf buff "[EDGES] {\n";
bguillaum's avatar
bguillaum committed
291

292 293
    Pid_map.iter
      (fun id_src node ->
bguillaum's avatar
bguillaum committed
294
        Massoc_pid.iter
295
          (fun id_tar edge ->
bguillaum's avatar
bguillaum committed
296 297 298
            bprintf buff "  N_%s -> N_%s { label=\"%s\"}\n"
              (Pid.to_id id_src)
              (Pid.to_id id_tar)
299
              (P_edge.to_string domain edge)
300 301
          )
          (P_node.get_next node)
302
      ) pos_basic.graph;
303

304
    List.iteri
305 306
      (fun i cst ->
        match cst with
bguillaum's avatar
bguillaum committed
307
          | Cst_out (pid, label_cst) ->
bguillaum's avatar
bguillaum committed
308
            bprintf buff "  N_%s -> C_%d {label = \"%s\"; style=dot; bottom; color=green;}\n"
309
              (Pid.to_id pid) i (Label_cst.to_string domain label_cst)
bguillaum's avatar
bguillaum committed
310
          | Cst_in (pid, label_cst) ->
bguillaum's avatar
bguillaum committed
311
            bprintf buff "  C_%d -> N_%s {label = \"%s\"; style=dot; bottom; color=green;}\n"
312
              i (Pid.to_id pid) (Label_cst.to_string domain label_cst)
313
          | _ -> ()
314
      ) pos_basic.constraints;
315 316
    bprintf buff "}\n";
    Buffer.contents buff
bguillaum's avatar
bguillaum committed
317

318
  (* ====================================================================== *)
bguillaum's avatar
bguillaum committed
319 320
  let build_commands domain ?param ?(locals=[||]) pos pos_table ast_commands =
    let known_act_ids = Array.to_list pos_table in
321
    let known_edge_ids = get_edge_ids pos in
322

323
    let rec loop (kai,kei) = function
324 325
      | [] -> []
      | ast_command :: tail ->
326
          let (command, (new_kai, new_kei)) =
327
            Command.build
328
              domain
329
              domain
330
              ?param
331
              (kai,kei)
332 333 334
              pos_table
              locals
              ast_command in
335 336
          command :: (loop (new_kai,new_kei) tail) in
    loop (known_act_ids, known_edge_ids) ast_commands
337 338

  (* ====================================================================== *)
bguillaum's avatar
bguillaum committed
339 340 341 342 343 344 345 346 347 348 349 350
  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

351
  (* ====================================================================== *)
bguillaum's avatar
bguillaum committed
352
  let build domain ?(locals=[||]) dir rule_ast =
bguillaum's avatar
bguillaum committed
353 354

    let (param, pat_vars, cmd_vars) =
bguillaum's avatar
bguillaum committed
355 356
      match rule_ast.Ast.param with
      | None -> (None,[],[])
357
      | Some (files,vars) ->
bguillaum's avatar
bguillaum committed
358 359 360
          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
361

362
          (* first: load lexical parameters given in the same file at the end of the rule definition *)
bguillaum's avatar
bguillaum committed
363 364 365 366
          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

367
          (* second: load lexical parameters given in external files *)
bguillaum's avatar
bguillaum committed
368
          let full_param = List.fold_left
369
            (fun acc file ->
bguillaum's avatar
bguillaum committed
370 371 372 373 374 375
              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
376

377 378 379 380 381
    (match (param, pat_vars) with
      | (None, _::_) -> Error.build ~loc:rule_ast.Ast.rule_loc "Missing lexical parameters in rule \"%s\"" rule_ast.Ast.rule_id
      | _ -> ()
    );

382
    let (pos, pos_table) = build_pos_basic domain ~pat_vars ~locals rule_ast.Ast.pattern.Ast.pat_pos in
bguillaum's avatar
bguillaum committed
383 384 385
    let (negs,_) =
      List.fold_left
      (fun (acc,pos) basic_ast ->
386
        try ((build_neg_basic domain ~pat_vars ~locals pos_table basic_ast) :: acc, pos+1)
bguillaum's avatar
bguillaum committed
387 388 389 390
        with P_fs.Fail_unif ->
          Log.fwarning "In rule \"%s\" [%s], the wihtout number %d cannot be satisfied, it is skipped"
            rule_ast.Ast.rule_id (Loc.to_string rule_ast.Ast.rule_loc) pos;
          (acc, pos+1)
391
      ) ([],1) rule_ast.Ast.pattern.Ast.pat_negs in
pj2m's avatar
pj2m committed
392
    {
bguillaum's avatar
bguillaum committed
393
      name = rule_ast.Ast.rule_id;
394
      pattern = (pos, negs);
bguillaum's avatar
bguillaum committed
395
      commands = build_commands domain ~param:(pat_vars,cmd_vars) ~locals pos pos_table rule_ast.Ast.commands;
bguillaum's avatar
bguillaum committed
396 397 398 399 400
      loc = rule_ast.Ast.rule_loc;
      param = param;
      param_names = (pat_vars,cmd_vars)
    }

401 402 403
  let build_pattern domain pattern_ast =
    let (pos, pos_table) = build_pos_basic domain pattern_ast.Ast.pat_pos in
    let negs = List_.try_map P_fs.Fail_unif (fun basic_ast -> build_neg_basic domain pos_table basic_ast) pattern_ast.Ast.pat_negs in
bguillaum's avatar
bguillaum committed
404 405
    (pos, negs)

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

414 415 416 417 418 419 420 421
  let node_matching pattern graph { n_match } =
    Pid_map.fold
      (fun pid gid acc ->
        let pnode = P_graph.find pid (fst pattern).graph in
        let gnode = G_graph.find gid graph in
        (P_node.get_name pnode, int_of_float (G_node.get_position gnode)) :: acc
      ) n_match []

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

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

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

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

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

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

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

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

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

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

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

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

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

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

          let gnode1 = G_graph.find gid1 graph in
          let edges_1_to_2 = Massoc_gid.assoc gid2 (G_node.get_next gnode1) in
          if List.exists (fun l -> Label.is_succ l) edges_1_to_2
          then matching
          else  raise Fail
bguillaum's avatar
bguillaum committed
592
      | Lprec (pid1, pid2) ->
593 594 595 596 597
          let gnode1 = G_graph.find (Pid_map.find pid1 matching.n_match) graph in
          let gnode2 = G_graph.find (Pid_map.find pid2 matching.n_match) graph in
          if G_node.get_position gnode1 < G_node.get_position gnode2
          then matching
          else raise Fail
pj2m's avatar
pj2m committed
598

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

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

bguillaum's avatar
bguillaum committed
661
  (*  ---------------------------------------------------------------------- *)
662
  and extend_matching_from domain (positive,neg) (graph:G_graph.t) pid (gid : Gid.t) partial =
pj2m's avatar
pj2m committed
663 664 665
    if List.mem gid partial.already_matched_gids
    then [] (* the required association pid -> gid is not injective *)
    else
bguillaum's avatar
bguillaum committed
666 667 668 669 670 671 672 673 674 675
      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 *)
676
      let g_node = try G_graph.find gid graph with Not_found -> failwith "INS" in
bguillaum's avatar
bguillaum committed
677

bguillaum's avatar
bguillaum committed
678
      try
679
        let new_param = P_node.match_ ?param: partial.sub.m_param p_node g_node in
680
        (* add all out-edges from pid in pattern *)
bguillaum's avatar
bguillaum committed
681 682
        let new_unmatched_edges =
          Massoc_pid.fold
683
            (fun acc pid_next p_edge -> (pid, p_edge, pid_next) :: acc
684
            ) partial.unmatched_edges (P_node.get_next p_node) in
bguillaum's avatar
bguillaum committed
685 686

        let new_partial =
bguillaum's avatar
bguillaum committed
687
          { partial with
bguillaum's avatar
bguillaum committed
688
            unmatched_nodes = (try List_.rm pid partial.unmatched_nodes with Not_found -> failwith "List_.rm");
bguillaum's avatar
bguillaum committed
689 690 691 692
            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
693
        extend_matching domain (positive,neg) graph new_partial
694
      with P_fs.Fail -> []
pj2m's avatar
pj2m committed
695

bguillaum's avatar
bguillaum committed
696 697
  (*  ---------------------------------------------------------------------- *)
  (* the exception below is added to handle unification failure in merge!! *)
698
  exception Command_execution_fail
pj2m's avatar
pj2m committed
699

bguillaum's avatar
bguillaum committed
700 701
  (*  ---------------------------------------------------------------------- *)
  (** [apply_command instance matching created_nodes command] returns [(new_instance, new_created_nodes)] *)
bguillaum's avatar
bguillaum committed
702 703
  let apply_command domain (command,loc) instance matching created_nodes =
    let node_find cnode = find ~loc cnode (matching, created_nodes) in
704 705

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

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

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

bguillaum's avatar
bguillaum committed
746
    | Command.DEL_NODE node_cn ->
747 748
        let node_gid = node_find node_cn in
        (
bguillaum's avatar
bguillaum committed
749
         {instance with
750
          Instance.graph = G_graph.del_node instance.Instance.graph node_gid;
751
          history = List_.sort_insert (Command.H_DEL_NODE node_gid) instance.Instance.history
752
        },
bguillaum's avatar
bguillaum committed
753
         created_nodes
754 755 756 757 758
        )

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

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

bguillaum's avatar
bguillaum committed
787
        let (new_graph, new_feature_value) =
788
          G_graph.update_feat ~loc domain instance.Instance.graph tar_gid tar_feat_name rule_items in
bguillaum's avatar
bguillaum committed
789
        (
790 791
         {instance with
          Instance.graph = new_graph;
792
          history = List_.sort_insert (Command.H_UPDATE_FEAT (tar_gid,tar_feat_name,new_feature_value)) instance.Instance.history
bguillaum's avatar
bguillaum committed
793
        },
bguillaum's avatar
bguillaum committed
794
         created_nodes
795
        )
796 797 798 799

    | Command.DEL_FEAT (tar_cn,feat_name) ->
        let tar_gid = node_find tar_cn in
        (
bguillaum's avatar
bguillaum committed
800
         {instance with
801
          Instance.graph = G_graph.del_feat instance.Instance.graph tar_gid feat_name;
802
          history = List_.sort_insert (Command.H_DEL_FEAT (tar_gid,feat_name)) instance.Instance.history
803
        },