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

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

14 15 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 38 39 40 41 42 43
    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;
44
      free_index = (G_graph.max_binding graph) + 1;
pj2m's avatar
pj2m committed
45 46
    }

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

53 54 55 56 57 58 59 60 61 62
  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
63

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

68
  let to_gr domain t = G_graph.to_gr domain t.graph
69

70
  let to_conll_string domain t = G_graph.to_conll_string domain t.graph
bguillaum's avatar
bguillaum committed
71

72 73
  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"))
74

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

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

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

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

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

bguillaum's avatar
bguillaum committed
108 109
    | Feature_re of Pid.t * string * string

110
    | Feature_ineq of Ast.ineq * Pid.t * string * Pid.t * string
111 112
    | Feature_ineq_cst of Ast.ineq * Pid.t * string * float

bguillaum's avatar
bguillaum committed
113
    | 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
114

bguillaum's avatar
bguillaum committed
115 116 117
    | Prec of Pid.t * Pid.t
    | Lprec of Pid.t * Pid.t

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

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

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

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

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

bguillaum's avatar
bguillaum committed
145 146 147
      | (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
148

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

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

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

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

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

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

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

bguillaum's avatar
bguillaum committed
209 210 211 212 213
      | (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
214 215 216 217 218 219
      | (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
220
  (* It may raise [P_fs.Fail_unif] in case of contradiction on constraints *)
221
  let build_neg_basic domain ?pat_vars ?(locals=[||]) pos_table basic_ast =
pj2m's avatar
pj2m committed
222
    let (extension, neg_table) =
223
      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
224

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

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

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

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

bguillaum's avatar
bguillaum committed
251 252
  let get_name t = t.name

253
  let get_loc t = t.loc
pj2m's avatar
pj2m committed
254

255 256 257
  let is_filter t = t.commands = []

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

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

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

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

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

288
    bprintf buff "[EDGES] {\n";
bguillaum's avatar
bguillaum committed
289

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

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

316
  (* ====================================================================== *)
317
  let build_commands domain ?param ?(locals=[||]) suffixes pos pos_table ast_commands =
318
    let known_act_ids = List.map (fun x -> (Ast.No_sharp x)) (Array.to_list pos_table) in
319
    let known_edge_ids = get_edge_ids pos in
320

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

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

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

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

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

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

376 377 378 379 380
    (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
      | _ -> ()
    );

381
    let (pos, pos_table) = build_pos_basic domain ~pat_vars ~locals rule_ast.Ast.pattern.Ast.pat_pos in
bguillaum's avatar
bguillaum committed
382 383 384
    let (negs,_) =
      List.fold_left
      (fun (acc,pos) basic_ast ->
385
        try ((build_neg_basic domain ~pat_vars ~locals pos_table basic_ast) :: acc, pos+1)
bguillaum's avatar
bguillaum committed
386 387 388 389
        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)
390
      ) ([],1) rule_ast.Ast.pattern.Ast.pat_negs in
pj2m's avatar
pj2m committed
391
    {
bguillaum's avatar
bguillaum committed
392
      name = rule_ast.Ast.rule_id;
393
      pattern = (pos, negs);
394
      commands = build_commands domain ~param:(pat_vars,cmd_vars) ~locals suffixes pos pos_table rule_ast.Ast.commands;
bguillaum's avatar
bguillaum committed
395 396 397 398 399
      loc = rule_ast.Ast.rule_loc;
      param = param;
      param_names = (pat_vars,cmd_vars)
    }

400 401 402
  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
403 404
    (pos, negs)

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

413 414 415 416 417 418 419 420
  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
421
  let empty_matching param = { n_match = Pid_map.empty; e_match = []; a_match = []; m_param = param;}
422

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

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

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

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

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

pj2m's avatar
pj2m committed
455 456

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

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

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

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

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

bguillaum's avatar
bguillaum committed
504
    { sub = empty_matching param;
pj2m's avatar
pj2m committed
505 506 507
      unmatched_nodes = sorted_node_list;
      unmatched_edges = [];
      already_matched_gids = [];
bguillaum's avatar
bguillaum committed
508
      check = basic.constraints;
pj2m's avatar
pj2m committed
509 510
    }

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

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

          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
596
      | Lprec (pid1, pid2) ->
597 598 599 600 601
          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
602

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

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

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

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

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

bguillaum's avatar
bguillaum committed
700 701
  (*  ---------------------------------------------------------------------- *)
  (* the exception below is added to handle unification failure in merge!! *)
702
  exception Command_execution_fail
pj2m's avatar
pj2m committed
703

bguillaum's avatar
bguillaum committed
704 705
  (*  ---------------------------------------------------------------------- *)
  (** [apply_command instance matching created_nodes command] returns [(new_instance, new_created_nodes)] *)
706
  let apply_command domain (command,loc) instance matching (created_nodes, (activated_nodes:((Pid.t * string) * Gid.t) list)) =
bguillaum's avatar
bguillaum committed
707
    let node_find cnode = find ~loc cnode (matching, (created_nodes, activated_nodes)) in
708 709

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

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

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

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

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

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

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

    | Command.DEL_FEAT (tar_cn,feat_name) ->
        let tar_gid = node_find tar_cn in
        (
bguillaum's avatar
bguillaum committed
804
         {instance with
805
          Instance.graph = G_graph.del_feat instance.Instance