grew_rule.ml 42.5 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 domain t = G_graph.to_conll 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
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

108
    | Feature_ineq of Ast.ineq * Pid.t * string * Pid.t * string
109 110
    | Feature_ineq_cst of Ast.ineq * Pid.t * string * float

bguillaum's avatar
bguillaum committed
111
    | 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
112

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

      | (Ast.Feature_eq ((node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
122 123
        Domain.check_feature_name domain ~loc feat_name1;
        Domain.check_feature_name domain ~loc feat_name2;
bguillaum's avatar
bguillaum committed
124
        Feature_eq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
125

126
      | (Ast.Feature_diseq ((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_diseq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
130

131
      | (Ast.Feature_ineq (ineq, (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_ineq (ineq, pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
135

136
      | (Ast.Feature_ineq_cst (ineq, (node_name1, feat_name1), constant), loc) ->
137
        Domain.check_feature_name domain ~loc feat_name1;
138 139
        Feature_ineq_cst (ineq, pid_of_name loc node_name1, feat_name1, constant)

bguillaum's avatar
bguillaum committed
140

bguillaum's avatar
bguillaum committed
141
  type basic = {
142 143 144
    graph: P_graph.t;
    constraints: const list;
  }
pj2m's avatar
pj2m committed
145

146
  let build_pos_basic domain ?pat_vars ?(locals=[||]) basic_ast =
147
    let (graph, pos_table) =
148
      P_graph.build domain ?pat_vars ~locals basic_ast.Ast.pat_nodes basic_ast.Ast.pat_edges in
pj2m's avatar
pj2m committed
149
    (
bguillaum's avatar
bguillaum committed
150 151
      {
        graph = graph;
152
        constraints = List.map (build_pos_constraint domain ~locals pos_table) basic_ast.Ast.pat_const
bguillaum's avatar
bguillaum committed
153 154
      },
      pos_table
pj2m's avatar
pj2m committed
155 156
    )

bguillaum's avatar
bguillaum committed
157
  (* the neg part *)
158
  let build_neg_constraint domain ?locals pos_table neg_table const =
bguillaum's avatar
bguillaum committed
159 160 161 162
    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
163
    match const with
164
      | (Ast.Cst_out (id,label_cst), loc) ->
165
        Cst_out (pid_of_name loc id, Label_cst.build ~loc domain ?locals label_cst)
166
      | (Ast.Cst_in (id,label_cst), loc) ->
167
        Cst_in (pid_of_name loc id, Label_cst.build ~loc domain ?locals label_cst)
168

169 170 171
      | (Ast.Feature_eq (feat_id1, feat_id2), loc) ->
        let (node_name1, feat_name1) = feat_id1
        and (node_name2, feat_name2) = feat_id2 in
172 173
        Domain.check_feature_name domain ~loc feat_name1;
        Domain.check_feature_name domain ~loc feat_name2;
bguillaum's avatar
bguillaum committed
174
        Feature_eq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
175

176 177 178
      | (Ast.Feature_diseq (feat_id1, feat_id2), loc) ->
        let (node_name1, feat_name1) = feat_id1
        and (node_name2, feat_name2) = feat_id2 in
179 180
        Domain.check_feature_name domain ~loc feat_name1;
        Domain.check_feature_name domain ~loc feat_name2;
bguillaum's avatar
bguillaum committed
181
        Feature_diseq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
182

183 184 185
      | (Ast.Feature_ineq (ineq, 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_ineq (ineq, pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
189

190 191
      | (Ast.Feature_ineq_cst (ineq, feat_id1, constant), loc) ->
        let (node_name1, feat_name1) = feat_id1 in
192
        Domain.check_feature_name domain ~loc feat_name1;
193
        Feature_ineq_cst (ineq, pid_of_name loc node_name1, feat_name1, constant)
pj2m's avatar
pj2m committed
194

bguillaum's avatar
bguillaum committed
195
  (* It may raise [P_fs.Fail_unif] in case of contradiction on constraints *)
196
  let build_neg_basic domain ?pat_vars ?(locals=[||]) pos_table basic_ast =
pj2m's avatar
pj2m committed
197
    let (extension, neg_table) =
198
      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
199

200
    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
201
    {
bguillaum's avatar
bguillaum committed
202
      graph = extension.P_graph.ext_map;
203
      constraints = filters @ List.map (build_neg_constraint domain ~locals pos_table neg_table) basic_ast.Ast.pat_const ;
bguillaum's avatar
bguillaum committed
204
    }
pj2m's avatar
pj2m committed
205

bguillaum's avatar
bguillaum committed
206
  let get_edge_ids basic =
207
    Pid_map.fold
bguillaum's avatar
bguillaum committed
208 209
      (fun _ node acc ->
        Massoc_pid.fold
210 211
          (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
212
      ) basic.graph []
bguillaum's avatar
bguillaum committed
213

214 215 216
  (* a [pattern] is described by the positive basic and a list of negative basics. *)
  type pattern = basic * basic list

pj2m's avatar
pj2m committed
217 218
  type t = {
      name: string;
219
      pattern: pattern;
pj2m's avatar
pj2m committed
220
      commands: Command.t list;
221
      param: Lex_par.t option;
222
      param_names: (string list * string list);
bguillaum's avatar
bguillaum committed
223
      loc: Loc.t;
pj2m's avatar
pj2m committed
224 225
    }

bguillaum's avatar
bguillaum committed
226 227
  let get_name t = t.name

228
  let get_loc t = t.loc
pj2m's avatar
pj2m committed
229

230 231 232
  let is_filter t = t.commands = []

  (* ====================================================================== *)
233
  let to_dep domain t =
234
    let pos_basic = fst t.pattern in
235 236 237
    let buff = Buffer.create 32 in
    bprintf buff "[GRAPH] { scale = 200; }\n";

bguillaum's avatar
bguillaum committed
238 239
    let nodes =
      Pid_map.fold
240
        (fun id node acc ->
bguillaum's avatar
bguillaum committed
241 242
          (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))
243
          )
244
          :: acc
245
        ) pos_basic.graph [] in
246

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

250 251 252 253 254
    bprintf buff "[WORDS] {\n";
    List.iter
      (fun (_, dep_line) -> bprintf buff "%s\n" dep_line
      ) sorted_nodes;

255
    List.iteri
256 257
      (fun i cst ->
        match cst with
bguillaum's avatar
bguillaum committed
258
          | Cst_out _ | Cst_in _ -> bprintf buff "  C_%d { word=\"*\"}\n" i
259
          | _ -> ()
260
      ) pos_basic.constraints;
261
    bprintf buff "}\n";
bguillaum's avatar
bguillaum committed
262

263
    bprintf buff "[EDGES] {\n";
bguillaum's avatar
bguillaum committed
264

265 266
    Pid_map.iter
      (fun id_src node ->
bguillaum's avatar
bguillaum committed
267
        Massoc_pid.iter
268
          (fun id_tar edge ->
bguillaum's avatar
bguillaum committed
269 270 271
            bprintf buff "  N_%s -> N_%s { label=\"%s\"}\n"
              (Pid.to_id id_src)
              (Pid.to_id id_tar)
272
              (P_edge.to_string domain edge)
273 274
          )
          (P_node.get_next node)
275
      ) pos_basic.graph;
276

277
    List.iteri
278 279
      (fun i cst ->
        match cst with
bguillaum's avatar
bguillaum committed
280
          | Cst_out (pid, label_cst) ->
bguillaum's avatar
bguillaum committed
281
            bprintf buff "  N_%s -> C_%d {label = \"%s\"; style=dot; bottom; color=green;}\n"
282
              (Pid.to_id pid) i (Label_cst.to_string domain label_cst)
bguillaum's avatar
bguillaum committed
283
          | Cst_in (pid, label_cst) ->
bguillaum's avatar
bguillaum committed
284
            bprintf buff "  C_%d -> N_%s {label = \"%s\"; style=dot; bottom; color=green;}\n"
285
              i (Pid.to_id pid) (Label_cst.to_string domain label_cst)
286
          | _ -> ()
287
      ) pos_basic.constraints;
288 289
    bprintf buff "}\n";
    Buffer.contents buff
bguillaum's avatar
bguillaum committed
290

291
  (* ====================================================================== *)
292
  let build_commands domain ?param ?(locals=[||]) suffixes pos pos_table ast_commands =
293
    let known_act_ids = List.map (fun x -> (Ast.No_sharp x)) (Array.to_list pos_table) in
294
    let known_edge_ids = get_edge_ids pos in
295

296
    let rec loop (kai,kei) = function
297 298
      | [] -> []
      | ast_command :: tail ->
299
          let (command, (new_kai, new_kei)) =
300
            Command.build
301
              domain
302
              domain
303
              ?param
304
              (kai,kei)
305 306
              pos_table
              locals
307
              suffixes
308
              ast_command in
309 310
          command :: (loop (new_kai,new_kei) tail) in
    loop (known_act_ids, known_edge_ids) ast_commands
311 312

  (* ====================================================================== *)
bguillaum's avatar
bguillaum committed
313 314 315 316 317 318 319 320 321 322 323 324
  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

325
  (* ====================================================================== *)
326
  let build domain ?(locals=[||]) suffixes dir rule_ast =
bguillaum's avatar
bguillaum committed
327 328

    let (param, pat_vars, cmd_vars) =
bguillaum's avatar
bguillaum committed
329 330
      match rule_ast.Ast.param with
      | None -> (None,[],[])
331
      | Some (files,vars) ->
bguillaum's avatar
bguillaum committed
332 333 334
          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
335 336 337 338 339 340

          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
341
            (fun acc file ->
bguillaum's avatar
bguillaum committed
342 343 344 345 346 347
              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
348

349
    let (pos, pos_table) = build_pos_basic domain ~pat_vars ~locals rule_ast.Ast.pos_basic in
bguillaum's avatar
bguillaum committed
350 351 352
    let (negs,_) =
      List.fold_left
      (fun (acc,pos) basic_ast ->
353
        try ((build_neg_basic domain ~pat_vars ~locals pos_table basic_ast) :: acc, pos+1)
bguillaum's avatar
bguillaum committed
354 355 356 357 358
        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)
      ) ([],1) rule_ast.Ast.neg_basics in
pj2m's avatar
pj2m committed
359
    {
bguillaum's avatar
bguillaum committed
360
      name = rule_ast.Ast.rule_id;
361
      pattern = (pos, negs);
362
      commands = build_commands domain ~param:(pat_vars,cmd_vars) ~locals suffixes pos pos_table rule_ast.Ast.commands;
bguillaum's avatar
bguillaum committed
363 364 365 366 367
      loc = rule_ast.Ast.rule_loc;
      param = param;
      param_names = (pat_vars,cmd_vars)
    }

368 369 370
  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
371 372
    (pos, negs)

373
  (* ====================================================================== *)
pj2m's avatar
pj2m committed
374
  type matching = {
375
      n_match: Gid.t Pid_map.t;                     (* partial fct: pattern nodes |--> graph nodes *)
376
      e_match: (string*(Gid.t*Label.t*Gid.t)) list; (* edge matching: edge ident  |--> (src,label,tar) *)
bguillaum's avatar
bguillaum committed
377
      a_match: (Gid.t*Label.t*Gid.t) list;          (* anonymous edge matched *)
378
      m_param: Lex_par.t option;
pj2m's avatar
pj2m committed
379
    }
380

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

pj2m's avatar
pj2m committed
383 384
  let e_comp (e1,_) (e2,_) = compare e1 e2

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

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

392
  let match_deco pattern matching =
393 394 395
    { G_deco.nodes =
        Pid_map.fold
          (fun pid gid acc ->
396
            let pnode = P_graph.find pid (fst pattern).graph in
397 398
            (gid, (P_node.get_name pnode, P_fs.feat_list (P_node.get_fs pnode))) ::acc
          ) matching.n_match [];
399
      G_deco.edges = List.fold_left (fun acc (_,edge) -> edge::acc) matching.a_match matching.e_match;
pj2m's avatar
pj2m committed
400 401
    }

bguillaum's avatar
bguillaum committed
402
  let find cnode ?loc (matching, (created_nodes,activated_nodes)) =
pj2m's avatar
pj2m committed
403
    match cnode with
404
    | Command.Pat pid ->
405
        (try Pid_map.find pid matching.n_match
bguillaum's avatar
bguillaum committed
406 407
        with Not_found -> Error.bug ?loc "Inconsistent matching pid '%s' not found" (Pid.to_string pid))
    | Command.New name ->
bguillaum's avatar
bguillaum committed
408 409
        (try List.assoc name created_nodes
        with Not_found -> Error.run ?loc "Identifier '%s' not found" name)
bguillaum's avatar
bguillaum committed
410 411 412 413
    | 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
414

pj2m's avatar
pj2m committed
415 416

  let down_deco (matching,created_nodes) commands =
417 418 419 420 421 422 423 424 425 426
    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
427
    {
428
     G_deco.nodes = List.map (fun (gid,feat_list) -> (gid, ("",feat_list))) (Gid_map.bindings feat_to_highlight);
429
     G_deco.edges = List.fold_left
bguillaum's avatar
bguillaum committed
430 431
       (fun acc -> function
         | (Command.ADD_EDGE (src_cn,tar_cn,edge),loc) ->
432
             (find src_cn (matching, created_nodes), edge, find tar_cn (matching, created_nodes)) :: acc
433
         | _ -> acc
pj2m's avatar
pj2m committed
434 435 436 437 438
       ) [] commands
   }

  exception Fail
  type partial = {
bguillaum's avatar
bguillaum committed
439
      sub: matching;
440 441 442
      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
443
      check: const list (* constraints to verify at the end of the matching *)
bguillaum's avatar
bguillaum committed
444 445 446 447
    }

        (* PREREQUISITES:
           - all partial matching have the same domain
448 449
           - the domain of the pattern P is the disjoint union of domain([sub]) and [unmatched_nodes]
         *)
bguillaum's avatar
bguillaum committed
450
  (*  ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
451 452
  let init param basic =
    let roots = P_graph.roots basic.graph in
pj2m's avatar
pj2m committed
453

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

    (* put all roots in the front of the list to speed up the algo *)
bguillaum's avatar
bguillaum committed
457
    let sorted_node_list =
pj2m's avatar
pj2m committed
458
      List.sort
459 460 461 462
        (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
463

bguillaum's avatar
bguillaum committed
464
    { sub = empty_matching param;
pj2m's avatar
pj2m committed
465 466 467
      unmatched_nodes = sorted_node_list;
      unmatched_edges = [];
      already_matched_gids = [];
bguillaum's avatar
bguillaum committed
468
      check = basic.constraints;
pj2m's avatar
pj2m committed
469 470
    }

bguillaum's avatar
bguillaum committed
471
  (*  ---------------------------------------------------------------------- *)
472
  let apply_cst domain graph matching cst =
bguillaum's avatar
bguillaum committed
473
    let get_node pid = G_graph.find (Pid_map.find pid matching.n_match) graph in
474 475 476 477 478 479
    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
480 481

    match cst with
bguillaum's avatar
bguillaum committed
482
      | Cst_out (pid,label_cst) ->
483
        let gid = Pid_map.find pid matching.n_match in
484
        if G_graph.edge_out domain graph gid label_cst
bguillaum's avatar
bguillaum committed
485 486
        then matching
        else raise Fail
bguillaum's avatar
bguillaum committed
487
      | Cst_in (pid,label_cst) ->
488
        let gid = Pid_map.find pid matching.n_match in
bguillaum's avatar
bguillaum committed
489
        if G_graph.node_exists
490
          (fun node ->
491
            List.exists (fun e -> Label_cst.match_ domain e label_cst) (Massoc_gid.assoc gid (G_node.get_next node))
492
          ) graph
bguillaum's avatar
bguillaum committed
493 494
        then matching
        else raise Fail
bguillaum's avatar
bguillaum committed
495
      | Filter (pid, fs) ->
bguillaum's avatar
bguillaum committed
496 497 498 499 500 501 502 503
        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
504 505 506
      | 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
507 508
            | Some fv1, Some fv2 when fv1 = fv2 -> matching
            | _ -> raise Fail
bguillaum's avatar
bguillaum committed
509 510 511 512
        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
513 514
            | Some fv1, Some fv2 when fv1 <> fv2 -> matching
            | _ -> raise Fail
bguillaum's avatar
bguillaum committed
515 516
        end
      | Feature_ineq (ineq, pid1, feat_name1, pid2, feat_name2) ->
517 518
        begin
          match (ineq, get_float_feat pid1 feat_name1, get_float_feat pid2 feat_name2) with
bguillaum's avatar
bguillaum committed
519 520 521 522 523
            | (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
524 525 526 527 528 529 530 531 532 533
          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
pj2m's avatar
pj2m committed
534

bguillaum's avatar
bguillaum committed
535
  (*  ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
536
  (* returns all extension of the partial input matching *)
537
  let rec extend_matching domain (positive,neg) (graph:G_graph.t) (partial:partial) =
pj2m's avatar
pj2m committed
538
    match (partial.unmatched_edges, partial.unmatched_nodes) with
bguillaum's avatar
bguillaum committed
539
    | [], [] ->
bguillaum's avatar
bguillaum committed
540 541 542 543 544
      begin
        try
          let new_matching =
            List.fold_left
              (fun acc const ->
545
                apply_cst domain graph acc const
bguillaum's avatar
bguillaum committed
546 547 548 549
              ) partial.sub partial.check in
          [new_matching, partial.already_matched_gids]
        with Fail -> []
      end
pj2m's avatar
pj2m committed
550
    | (src_pid, p_edge, tar_pid)::tail_ue, _ ->
551 552
        begin
          try (* is the tar already found in the matching ? *)
bguillaum's avatar
bguillaum committed
553
            let new_partials =
554 555 556
              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
557
              let g_edges = Massoc_gid.assoc tar_gid (G_node.get_next src_gnode) in
bguillaum's avatar
bguillaum committed
558

559
              match P_edge.match_list domain p_edge g_edges with
560
              | P_edge.Fail -> (* no good edge in graph for this pattern edge -> stop here *)
561
                  []
562
              | P_edge.Ok label -> (* at least an edge in the graph fits the p_edge "constraint" -> go on *)
bguillaum's avatar
bguillaum committed
563
                  [ {partial with unmatched_edges = tail_ue; sub = a_match_add (src_gid,label,tar_gid) partial.sub} ]
564
              | 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
565
                  List.map
566 567
                    (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
568
                    ) labels
569
            in List_.flat_map (extend_matching domain (positive,neg) graph) new_partials
570 571
          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
572
              let (src_gid : Gid.t) = Pid_map.find src_pid partial.sub.n_match in
573
              let src_gnode = G_graph.find src_gid graph in
574
              Massoc_gid.fold
575
                (fun acc gid_next g_edge ->
576
                  match P_edge.match_ domain p_edge g_edge with
577
                  | P_edge.Fail -> (* g_edge does not fit, no new candidate *)
578
                      acc
579
                  | P_edge.Ok label -> (* g_edge fits with the same matching *)
bguillaum's avatar
bguillaum committed
580
                      (gid_next, a_match_add (src_gid, label, gid_next) partial.sub) :: acc
581
                  | P_edge.Binds (id,[label]) -> (* g_edge fits with an extended matching *)
582
                      (gid_next, e_match_add (id, (src_gid, label, gid_next)) partial.sub) :: acc
583 584
                  | _ -> Error.bug "P_edge.match_ must return exactly one label"
                ) [] (G_node.get_next src_gnode) in
585
            List_.flat_map
bguillaum's avatar
bguillaum committed
586
              (fun (gid_next, matching) ->
587
                extend_matching_from domain (positive,neg) graph tar_pid gid_next
588 589 590
                  {partial with sub=matching; unmatched_edges = tail_ue}
              ) candidates
        end
bguillaum's avatar
bguillaum committed
591
    | [], pid :: _ ->
592 593
        G_graph.fold_gid
          (fun gid acc ->
594
            (extend_matching_from domain (positive,neg) graph pid gid partial) @ acc
595
          ) graph []
bguillaum's avatar
bguillaum committed
596

bguillaum's avatar
bguillaum committed
597
  (*  ---------------------------------------------------------------------- *)
598
  and extend_matching_from domain (positive,neg) (graph:G_graph.t) pid (gid : Gid.t) partial =
pj2m's avatar
pj2m committed
599 600 601
    if List.mem gid partial.already_matched_gids
    then [] (* the required association pid -> gid is not injective *)
    else
bguillaum's avatar
bguillaum committed
602 603 604 605 606 607 608 609 610 611
      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 *)
612
      let g_node = try G_graph.find gid graph with Not_found -> failwith "INS" in
bguillaum's avatar
bguillaum committed
613

bguillaum's avatar
bguillaum committed
614
      try
615
        let new_param = P_node.match_ ?param: partial.sub.m_param p_node g_node in
616
        (* add all out-edges from pid in pattern *)
bguillaum's avatar
bguillaum committed
617 618
        let new_unmatched_edges =
          Massoc_pid.fold
619
            (fun acc pid_next p_edge -> (pid, p_edge, pid_next) :: acc
620
            ) partial.unmatched_edges (P_node.get_next p_node) in
bguillaum's avatar
bguillaum committed
621 622

        let new_partial =
bguillaum's avatar
bguillaum committed
623
          { partial with
bguillaum's avatar
bguillaum committed
624
            unmatched_nodes = (try List_.rm pid partial.unmatched_nodes with Not_found -> failwith "List_.rm");
bguillaum's avatar
bguillaum committed
625 626 627 628
            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
629
        extend_matching domain (positive,neg) graph new_partial
630
      with P_fs.Fail -> []
pj2m's avatar
pj2m committed
631

bguillaum's avatar
bguillaum committed
632 633
  (*  ---------------------------------------------------------------------- *)
  (* the exception below is added to handle unification failure in merge!! *)
634
  exception Command_execution_fail
pj2m's avatar
pj2m committed
635

bguillaum's avatar
bguillaum committed
636 637
  (*  ---------------------------------------------------------------------- *)
  (** [apply_command instance matching created_nodes command] returns [(new_instance, new_created_nodes)] *)
638
  let apply_command domain (command,loc) instance matching (created_nodes, (activated_nodes:((Pid.t * string) * Gid.t) list)) =
bguillaum's avatar
bguillaum committed
639
    let node_find cnode = find ~loc cnode (matching, (created_nodes, activated_nodes)) in
640 641

    match command with
bguillaum's avatar
bguillaum committed
642
    | Command.ADD_EDGE (src_cn,tar_cn,edge) ->
643 644 645
        let src_gid = node_find src_cn in
        let tar_gid = node_find tar_cn in
        begin
646
          match G_graph.add_edge instance.Instance.graph src_gid edge tar_gid with
bguillaum's avatar
bguillaum committed
647
          | Some new_graph ->
648
              (
bguillaum's avatar
bguillaum committed
649 650
               {instance with
                Instance.graph = new_graph;
651
                history = List_.sort_insert (Command.H_ADD_EDGE (src_gid,tar_gid,edge)) instance.Instance.history
652
              },
bguillaum's avatar
bguillaum committed
653
               (created_nodes, activated_nodes)
654
              )
bguillaum's avatar
bguillaum committed
655
          | None ->
656
              Error.run "ADD_EDGE: the edge '%s' already exists %s" (G_edge.to_string domain edge) (Loc.to_string loc)
657 658
        end

bguillaum's avatar
bguillaum committed
659
    | Command.DEL_EDGE_EXPL (src_cn,tar_cn,edge) ->
660 661 662
        let src_gid = node_find src_cn in
        let tar_gid = node_find tar_cn in
        (
bguillaum's avatar
bguillaum committed
663
         {instance with
664
          Instance.graph = G_graph.del_edge domain loc instance.Instance.graph src_gid edge tar_gid;
665
           history = List_.sort_insert (Command.H_DEL_EDGE_EXPL (src_gid,tar_gid,edge)) instance.Instance.history
666
        },
bguillaum's avatar
bguillaum committed
667
         (created_nodes, activated_nodes)
668 669 670
        )

    | Command.DEL_EDGE_NAME edge_ident ->
bguillaum's avatar
bguillaum committed
671 672
        let (src_gid,edge,tar_gid) =
          try List.assoc edge_ident matching.e_match
673 674
          with Not_found -> Error.bug "The edge identifier '%s' is undefined %s" edge_ident (Loc.to_string loc) in
        (
bguillaum's avatar
bguillaum committed
675
         {instance with
676
          Instance.graph = G_graph.del_edge domain ~edge_ident loc instance.Instance.graph src_gid edge tar_gid;
677
          history = List_.sort_insert (Command.H_DEL_EDGE_EXPL (src_gid,tar_gid,edge)) instance.Instance.history
678
        },
bguillaum's avatar
bguillaum committed
679
         (created_nodes, activated_nodes)
bguillaum's avatar
bguillaum committed
680
        )
681

bguillaum's avatar
bguillaum committed
682
    | Command.DEL_NODE node_cn ->
683 684
        let node_gid = node_find node_cn in
        (
bguillaum's avatar
bguillaum committed
685
         {instance with
686
          Instance.graph = G_graph.del_node instance.Instance.graph node_gid;
687
          history = List_.sort_insert (Command.H_DEL_NODE node_gid) instance.Instance.history
688
        },
bguillaum's avatar
bguillaum committed
689
         (created_nodes, activated_nodes)
690 691 692 693 694
        )

    | Command.MERGE_NODE (src_cn, tar_cn) ->
        let src_gid = node_find src_cn in
        let tar_gid = node_find tar_cn in
695
        (match G_graph.merge_node loc domain instance.Instance.graph src_gid tar_gid with
bguillaum's avatar
bguillaum committed
696
        | Some new_graph ->
697
            (
bguillaum's avatar
bguillaum committed
698
             {instance with
699
              Instance.graph = new_graph;
700
              history = List_.sort_insert (Command.H_MERGE_NODE (src_gid,tar_gid)) instance.Instance.history
701
            },
bguillaum's avatar
bguillaum committed
702
             (created_nodes, activated_nodes)
703 704 705
            )
        | None -> raise Command_execution_fail
        )
bguillaum's avatar
bguillaum committed
706

707
    | Command.UPDATE_FEAT (tar_cn,tar_feat_name, item_list) ->
bguillaum's avatar
bguillaum committed
708
        let tar_gid = node_find tar_cn in
709 710
        let rule_items = List.map
            (function
bguillaum's avatar
bguillaum committed
711 712
              | 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
713
              | Command.Param_out index ->
bguillaum's avatar
bguillaum committed
714 715
                  (match matching.m_param with
                  | None -> Error.bug "Cannot apply a UPDATE_FEAT command without parameter"
bguillaum's avatar
bguillaum committed
716
                  | Some param -> Concat_item.String (Lex_par.get_command_value index param))
bguillaum's avatar
bguillaum committed
717
              | Command.Param_in index ->
bguillaum's avatar
bguillaum committed
718
                  (match matching.m_param with
719
                  | None -> Error.bug "Cannot apply a UPDATE_FEAT command without parameter"
bguillaum's avatar
bguillaum committed
720
                  | Some param -> Concat_item.String (Lex_par.get_param_value index param))
721
            ) item_list in
722

bguillaum's avatar
bguillaum committed
723
        let (new_graph, new_feature_value) =
724
          G_graph.update_feat ~loc domain instance.Instance.graph tar_gid tar_feat_name rule_items in
bguillaum's avatar
bguillaum committed
725
        (
726 727
         {instance with
          Instance.graph = new_graph;
728
          history = List_.sort_insert (Command.H_UPDATE_FEAT (tar_gid,tar_feat_name,new_feature_value)) instance.Instance.history
bguillaum's avatar
bguillaum committed
729
        },
bguillaum's avatar
bguillaum committed
730
         (created_nodes, activated_nodes)
731
        )
732 733 734 735

    | Command.DEL_FEAT (tar_cn,feat_name) ->
        let tar_gid = node_find tar_cn in
        (
bguillaum's avatar
bguillaum committed
736
         {instance with
737
          Instance.graph = G_graph.del_feat instance.Instance.graph tar_gid feat_name;
738
          history = List_.sort_insert (Command.H_DEL_FEAT (tar_gid,feat_name)) instance.Instance.history
739
        },
bguillaum's avatar
bguillaum committed
740
         (created_nodes, activated_nodes)
bguillaum's avatar
bguillaum committed
741
        )
742 743

    | Command.NEW_NEIGHBOUR (created_name,edge,base_pid) ->
744
        let base_gid = Pid_map.find base_pid matching.n_match in
745
        let (new_gid,new_graph) = G_graph.add_neighbour loc domain instance.Instance.graph base_gid edge in
746
        (
bguillaum's avatar
bguillaum committed
747
         {instance with
748
          Instance.graph = new_graph;
749 750
          history = List_.sort_insert (Command.H_NEW_NEIGHBOUR (created_name,edge,new_gid)) instance.Instance.history;
          activated_node = new_gid :: instance.Instance.activated_node;
751
        },
bguillaum's avatar
bguillaum committed
752 753 754 755 756 757 758 759 760 761 762 763
         ((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)
764
        )
765
    | Command.ACT_NODE _ -> Error.bug "Try to activate a node without suffix" (Loc.to_string loc)
766

bguillaum's avatar
bguillaum committed
767
    | Command.SHIFT_IN (src_cn,tar_cn,label_cst) ->
768 769 770
        let src_gid = node_find src_cn in
        let tar_gid = node_find tar_cn in
        (
bguillaum's avatar
bguillaum committed
771
         {instance with
772
          Instance.graph = G_graph.shift_in loc domain src_gid tar_gid label_cst instance.Instance.graph;
773
          history = List_.sort_insert (Command.H_SHIFT_IN (src_gid,tar_gid)) instance.Instance.history
774
        },
bguillaum's avatar
bguillaum committed
775
         (created_nodes, activated_nodes)
776 777
        )