grew_command.ml 4.76 KB
Newer Older
pj2m's avatar
pj2m committed
1 2 3
open Printf
open Log

bguillaum's avatar
bguillaum committed
4 5
open Grew_utils
open Grew_ast
pj2m's avatar
pj2m committed
6
open Grew_edge
bguillaum's avatar
bguillaum committed
7
open Grew_fs
pj2m's avatar
pj2m committed
8 9

module Command  = struct 
10 11
  type pid = Pid.t
  type gid = Gid.t
pj2m's avatar
pj2m committed
12 13 14 15 16
	
  type cnode =       (* a command node is either: *)
    | Pid of pid     (* a node identified in the pattern *)
    | New of string  (* a node introduced by a new_neighbour *)

17 18 19
  type item =
    | Feat of (cnode * string)
    | String of string
bguillaum's avatar
bguillaum committed
20 21
    | Param_in of int
    | Param_out of int
22

pj2m's avatar
pj2m committed
23 24 25
  (* the command in pattern *)
  type p = 
    | DEL_NODE of cnode
26
    | DEL_EDGE_EXPL of (cnode * cnode * G_edge.t) 
pj2m's avatar
pj2m committed
27
    | DEL_EDGE_NAME of string
28
    | ADD_EDGE of (cnode * cnode * G_edge.t)
bguillaum's avatar
bguillaum committed
29
    | DEL_FEAT of (cnode * string)
30
    | UPDATE_FEAT of (cnode * string * item list)
31
    | NEW_NEIGHBOUR of (string * G_edge.t * pid)
pj2m's avatar
pj2m committed
32
    | SHIFT_EDGE of (cnode * cnode)
33 34
    | SHIFT_IN of (cnode * cnode)
    | SHIFT_OUT of (cnode * cnode)
pj2m's avatar
pj2m committed
35 36 37 38 39 40 41
    | MERGE_NODE of (cnode * cnode)

  type t = p * Loc.t  (* remember command location to be able to localize a command failure *)

  (* a item in the command history: command applied to a graph *)
  type h = 
    | H_DEL_NODE of gid
42
    | H_DEL_EDGE_EXPL of (gid * gid *G_edge.t) 
pj2m's avatar
pj2m committed
43
    | H_DEL_EDGE_NAME of string
44
    | H_ADD_EDGE of (gid * gid * G_edge.t)
pj2m's avatar
pj2m committed
45
    | H_DEL_FEAT of (gid *string)
46
    | H_UPDATE_FEAT of (gid * string * string)
47
    | H_NEW_NEIGHBOUR of (string * G_edge.t * gid)
pj2m's avatar
pj2m committed
48
    | H_SHIFT_EDGE of (gid * gid)
49 50
    | H_SHIFT_IN of (gid * gid)
    | H_SHIFT_OUT of (gid * gid)
pj2m's avatar
pj2m committed
51 52
    | H_MERGE_NODE of (gid * gid)

bguillaum's avatar
bguillaum committed
53
  let build ?param (kni, kei) table locals ast_command = 
pj2m's avatar
pj2m committed
54 55 56 57 58
    let get_pid node_name =
      match Id.build_opt node_name table with
      | Some id -> Pid id
      | None -> New node_name in

59 60 61 62 63 64 65 66
    let check_node loc node_id kni = 
      if not (List.mem node_id kni) 
      then Error.build ~loc "Unbound node identifier \"%s\"" node_id in

    let check_edge loc edge_id kei = 
      if not (List.mem edge_id kei) 
      then Error.build ~loc "Unbound edge identifier \"%s\"" edge_id in

pj2m's avatar
pj2m committed
67 68
    match ast_command with
    | (Ast.Del_edge_expl (i, j, lab), loc) ->
69
        check_node loc i kni; check_node loc j kni;
70
	let edge = G_edge.make ~locals lab in
71
	((DEL_EDGE_EXPL (get_pid i, get_pid j, edge), loc), (kni, kei))
pj2m's avatar
pj2m committed
72 73
	  
    | (Ast.Del_edge_name id, loc) -> 
74 75
        check_edge loc id kei;
        (DEL_EDGE_NAME id, loc), (kni, List_.rm id kei)
pj2m's avatar
pj2m committed
76 77
	  
    | (Ast.Add_edge (i, j, lab), loc) ->
78
        check_node loc i kni; check_node loc j kni;
79
	let edge = G_edge.make ~locals lab in
80
	((ADD_EDGE (get_pid i, get_pid j, edge), loc), (kni, kei))
pj2m's avatar
pj2m committed
81 82
	  
    | (Ast.Shift_edge (i, j), loc) ->
83 84
        check_node loc i kni; check_node loc j kni;
	((SHIFT_EDGE (get_pid i, get_pid j), loc), (kni, kei))
pj2m's avatar
pj2m committed
85

86 87 88 89 90 91 92 93
    | (Ast.Shift_in (i, j), loc) ->
        check_node loc i kni; check_node loc j kni;
	((SHIFT_IN (get_pid i, get_pid j), loc), (kni, kei))

    | (Ast.Shift_out (i, j), loc) ->
        check_node loc i kni; check_node loc j kni;
	((SHIFT_OUT (get_pid i, get_pid j), loc), (kni, kei))

pj2m's avatar
pj2m committed
94
    | (Ast.Merge_node (i, j), loc) ->
95 96
        check_node loc i kni; check_node loc j kni;
	((MERGE_NODE (get_pid i, get_pid j), loc), (List_.rm i kni, kei))
pj2m's avatar
pj2m committed
97 98
	  
    | (Ast.New_neighbour (name_created, ancestor, label), loc) -> 
99 100 101
        check_node loc ancestor kni;
        if List.mem name_created kni
        then Error.build ~loc "Node identifier \"%s\" is already used" name_created;
102
	let edge = G_edge.make ~locals label in
pj2m's avatar
pj2m committed
103
	begin
104
	  try ((NEW_NEIGHBOUR (name_created, edge, Id.build ~loc ancestor table), loc), (name_created::kni, kei))
pj2m's avatar
pj2m committed
105 106
	  with Not_found -> 
	    Log.fcritical "[GRS] tries to build a command New_neighbour (%s) on node %s which is not in the pattern %s"
107
	      (G_edge.to_string edge)
pj2m's avatar
pj2m committed
108 109 110 111
	      ancestor
	      (Loc.to_string loc)
	end
	  
112 113 114
    | (Ast.Del_node n, loc) ->
        check_node loc n kni;
	((DEL_NODE (get_pid n), loc), (List_.rm n kni, kei))
pj2m's avatar
pj2m committed
115
	  
116
    | (Ast.Del_feat (node,feat_name), loc) ->
117 118
        check_node loc node kni;
        ((DEL_FEAT (get_pid node, feat_name), loc), (kni, kei))
bguillaum's avatar
bguillaum committed
119

120
    | (Ast.Update_feat ((tar_node, tar_feat_name), ast_items), loc) ->
121
        check_node loc tar_node kni;
122 123
        let items = List.map 
            (function
124
              | Ast.Qfn_item (node,feat_name) -> check_node loc node kni; Feat (get_pid node, feat_name)
125 126
              | Ast.String_item s -> String s
              | Ast.Param_item var -> 
bguillaum's avatar
bguillaum committed
127
                  match param with
128
                  | None -> Error.build "Unknown command variable '%s'" var
bguillaum's avatar
bguillaum committed
129 130 131 132 133
                  | Some (par,cmd) -> 
                      match (List_.pos var par, List_.pos var cmd) with
                      | (_,Some index) -> Param_out index
                      | (Some index,_) -> Param_in index
                      | _ -> Error.build "Unknown command variable '%s'" var
134
            ) ast_items in
135
        ((UPDATE_FEAT (get_pid tar_node, tar_feat_name, items), loc), (kni, kei))
pj2m's avatar
pj2m committed
136
end